496 lines
13 KiB
Ada
496 lines
13 KiB
Ada
with
|
|
openGL.Errors,
|
|
openGL.Tasks,
|
|
openGL.IO,
|
|
|
|
GL.Binding,
|
|
GL.lean,
|
|
GL.Pointers,
|
|
|
|
ada.unchecked_Deallocation;
|
|
|
|
with ada.Text_IO;
|
|
|
|
|
|
package body openGL.Texture
|
|
is
|
|
use GL,
|
|
GL.lean,
|
|
GL.Pointers;
|
|
|
|
|
|
----------------
|
|
-- Texture Name
|
|
--
|
|
|
|
function new_texture_Name return texture_Name
|
|
is
|
|
use GL.Binding;
|
|
the_Name : aliased texture_Name;
|
|
begin
|
|
Tasks.check;
|
|
glGenTextures (1, the_Name'Access);
|
|
return the_Name;
|
|
end new_texture_Name;
|
|
|
|
|
|
|
|
procedure free (the_texture_Name : in texture_Name)
|
|
is
|
|
the_Name : aliased texture_Name := the_texture_Name;
|
|
begin
|
|
Tasks.check;
|
|
glDeleteTextures (1, the_Name'Access);
|
|
end free;
|
|
|
|
|
|
---------
|
|
-- Forge
|
|
--
|
|
|
|
package body Forge
|
|
is
|
|
|
|
function to_Texture (Name : in texture_Name) return Object
|
|
is
|
|
Self : Texture.Object;
|
|
begin
|
|
Self.Name := Name;
|
|
-- TODO: Fill in remaining fields by querying GL.
|
|
|
|
return Self;
|
|
end to_Texture;
|
|
|
|
|
|
function to_Texture (Dimensions : in Texture.Dimensions) return Object
|
|
is
|
|
use GL.Binding;
|
|
Self : aliased Texture.Object;
|
|
|
|
begin
|
|
Tasks.check;
|
|
|
|
Self.Dimensions := Dimensions;
|
|
Self.Name := new_texture_Name;
|
|
Self.enable;
|
|
|
|
glPixelStorei (GL_UNPACK_ALIGNMENT, 1);
|
|
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE);
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);
|
|
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
|
|
|
|
return Self;
|
|
end to_Texture;
|
|
|
|
|
|
function to_Texture (the_Image : in Image;
|
|
use_Mipmaps : in Boolean := True) return Object
|
|
is
|
|
Self : aliased Texture.Object;
|
|
begin
|
|
Self.Name := new_texture_Name;
|
|
Self.set_Image (the_Image, use_Mipmaps);
|
|
|
|
return Self;
|
|
end to_Texture;
|
|
|
|
|
|
function to_Texture (the_Image : in lucid_Image;
|
|
use_Mipmaps : in Boolean := True) return Object
|
|
is
|
|
Self : aliased Texture.Object;
|
|
begin
|
|
Self.Name := new_texture_Name;
|
|
Self.set_Image (the_Image, use_Mipmaps);
|
|
|
|
return Self;
|
|
end to_Texture;
|
|
|
|
end Forge;
|
|
|
|
|
|
|
|
procedure destroy (Self : in out Object)
|
|
is
|
|
begin
|
|
free (Self.Name); -- Release the GL texture name.
|
|
end destroy;
|
|
|
|
|
|
|
|
procedure free (Self : in out Object)
|
|
is
|
|
begin
|
|
free (Self.Pool.all, Self); -- Release 'Self' from it's pool for later re-use.
|
|
end free;
|
|
|
|
|
|
|
|
function is_Defined (Self : in Object) return Boolean
|
|
is
|
|
use type texture_Name;
|
|
begin
|
|
return Self.Name /= 0;
|
|
end is_Defined;
|
|
|
|
|
|
|
|
procedure set_Name (Self : in out Object; To : in texture_Name)
|
|
is
|
|
begin
|
|
Self.Name := To;
|
|
end set_Name;
|
|
|
|
|
|
function Name (Self : in Object) return texture_Name
|
|
is
|
|
begin
|
|
return Self.Name;
|
|
end Name;
|
|
|
|
|
|
|
|
procedure set_Image (Self : in out Object; To : in Image;
|
|
use_Mipmaps : in Boolean := True)
|
|
is
|
|
use GL.Binding,
|
|
ada.Text_IO;
|
|
|
|
the_Image : Image renames To;
|
|
min_Width : constant Positive := the_Image'Length (2);
|
|
min_Height : constant Positive := the_Image'Length (1);
|
|
begin
|
|
Tasks.check;
|
|
|
|
Self.is_Transparent := False;
|
|
Self.Dimensions.Width := min_Width;
|
|
Self.Dimensions.Height := min_Height;
|
|
|
|
-- new_Line (3);
|
|
-- put_Line ("openGL.Texture.set_Image ~ GLsizei (Self.Dimensions.Width) =>" & GLsizei (Self.Dimensions.Width) 'Image);
|
|
-- put_Line (" ~ GLsizei (Self.Dimensions.Height) =>" & GLsizei (Self.Dimensions.Height)'Image);
|
|
-- put_Line (" ~ the_Image =>");
|
|
-- put_Line (the_Image'Image);
|
|
-- new_Line (3);
|
|
|
|
Self.enable;
|
|
|
|
glPixelStorei (GL_UNPACK_ALIGNMENT, 1); Errors.log;
|
|
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); Errors.log;
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); Errors.log;
|
|
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); Errors.log;
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); Errors.log;
|
|
|
|
glTexImage2D (GL_TEXTURE_2D,
|
|
0,
|
|
GL_RGB,
|
|
GLsizei (Self.Dimensions.Width),
|
|
GLsizei (Self.Dimensions.Height),
|
|
0,
|
|
GL_RGB,
|
|
GL_UNSIGNED_BYTE,
|
|
+the_Image (1, 1).Red'Address);
|
|
Errors.log;
|
|
|
|
if use_Mipmaps
|
|
then
|
|
glGenerateMipmap (GL_TEXTURE_2D);
|
|
Errors.log;
|
|
end if;
|
|
end set_Image;
|
|
|
|
|
|
|
|
procedure set_Image (Self : in out Object; To : in lucid_Image;
|
|
use_Mipmaps : in Boolean := True)
|
|
is
|
|
use GL.Binding;
|
|
|
|
the_Image : lucid_Image renames To;
|
|
min_Width : constant Positive := the_Image'Length (2);
|
|
min_Height : constant Positive := the_Image'Length (1);
|
|
|
|
begin
|
|
Tasks.check;
|
|
|
|
Self.is_Transparent := True;
|
|
Self.Dimensions.Width := min_Width;
|
|
Self.Dimensions.Height := min_Height;
|
|
Self.enable;
|
|
|
|
glPixelStorei (GL_UNPACK_ALIGNMENT, 1); Errors.log;
|
|
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); Errors.log;
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); Errors.log;
|
|
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); Errors.log;
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); Errors.log;
|
|
|
|
glTexImage2D (GL_TEXTURE_2D,
|
|
0,
|
|
GL_RGBA,
|
|
GLsizei (Self.Dimensions.Width),
|
|
GLsizei (Self.Dimensions.Height),
|
|
0,
|
|
GL_RGBA,
|
|
GL_UNSIGNED_BYTE,
|
|
+the_Image (1, 1).Primary.Red'Address);
|
|
Errors.log;
|
|
|
|
if use_Mipmaps
|
|
then
|
|
glGenerateMipmap (GL_TEXTURE_2D);
|
|
Errors.log;
|
|
end if;
|
|
end set_Image;
|
|
|
|
|
|
|
|
function is_Transparent (Self : in Object) return Boolean
|
|
is
|
|
begin
|
|
return Self.is_Transparent;
|
|
end is_Transparent;
|
|
|
|
|
|
|
|
procedure enable (Self : in Object)
|
|
is
|
|
use GL.Binding;
|
|
use type GL.GLuint;
|
|
pragma Assert (Self.Name > 0);
|
|
begin
|
|
Tasks.check;
|
|
glBindTexture (GL.GL_TEXTURE_2D, Self.Name);
|
|
Errors.log;
|
|
end enable;
|
|
|
|
|
|
|
|
function Power_of_2_Ceiling (From : in Positive) return GL.GLsizei
|
|
is
|
|
use type GL.GLsizei;
|
|
begin
|
|
if From <= 2 then return 2;
|
|
elsif From <= 4 then return 4;
|
|
elsif From <= 8 then return 8;
|
|
elsif From <= 16 then return 16;
|
|
elsif From <= 32 then return 32;
|
|
elsif From <= 64 then return 64;
|
|
elsif From <= 128 then return 128;
|
|
elsif From <= 256 then return 256;
|
|
elsif From <= 512 then return 512;
|
|
elsif From <= 1024 then return 1024;
|
|
elsif From <= 2 * 1024 then return 2 * 1024;
|
|
elsif From <= 4 * 1024 then return 4 * 1024;
|
|
elsif From <= 8 * 1024 then return 8 * 1024;
|
|
elsif From <= 16 * 1024 then return 16 * 1024;
|
|
elsif From <= 32 * 1024 then return 32 * 1024;
|
|
end if;
|
|
|
|
raise Constraint_Error with "Texture size too large:" & From'Image;
|
|
end Power_of_2_Ceiling;
|
|
|
|
|
|
|
|
function Size (Self : in Object) return Texture.Dimensions
|
|
is
|
|
begin
|
|
return Self.Dimensions;
|
|
end Size;
|
|
|
|
|
|
|
|
-----------------------
|
|
-- Name Maps of Texture
|
|
--
|
|
|
|
function fetch (From : access name_Map_of_texture'Class; texture_Name : in asset_Name) return Object
|
|
is
|
|
Name : constant unbounded_String := to_unbounded_String (to_String (texture_Name));
|
|
begin
|
|
if From.Contains (Name)
|
|
then
|
|
return From.Element (Name);
|
|
else
|
|
declare
|
|
new_Texture : constant Object := IO.to_Texture (texture_Name);
|
|
begin
|
|
From.insert (Name, new_Texture);
|
|
return new_Texture;
|
|
end;
|
|
end if;
|
|
end fetch;
|
|
|
|
|
|
|
|
--------
|
|
-- Pool
|
|
--
|
|
|
|
procedure destroy (the_Pool : in out Pool)
|
|
is
|
|
procedure deallocate is new ada.unchecked_Deallocation (pool_texture_List,
|
|
pool_texture_List_view);
|
|
begin
|
|
for Each of the_Pool.Map
|
|
loop
|
|
for i in 1 .. Each.Last
|
|
loop
|
|
destroy (Each.Textures (i));
|
|
deallocate (Each);
|
|
end loop;
|
|
end loop;
|
|
end destroy;
|
|
|
|
|
|
|
|
function new_Texture (From : access Pool; Size : in Dimensions) return Object
|
|
is
|
|
use GL.Binding;
|
|
|
|
the_Pool : access Pool renames From;
|
|
the_Texture : aliased Object;
|
|
|
|
unused_List : pool_texture_List_view;
|
|
|
|
begin
|
|
Tasks.check;
|
|
|
|
if the_Pool.Map.contains (Size)
|
|
then
|
|
unused_List := the_Pool.Map.Element (Size);
|
|
else
|
|
unused_List := new pool_texture_List;
|
|
the_Pool.Map.insert (Size, unused_List);
|
|
end if;
|
|
|
|
-- Search for existing, but unused, object.
|
|
--
|
|
if unused_List.Last > 0
|
|
then -- An existing unused texture has been found.
|
|
the_Texture := unused_List.Textures (unused_List.Last);
|
|
unused_List.Last := unused_List.Last - 1;
|
|
|
|
the_Texture.enable;
|
|
|
|
gltexImage2D (GL_TEXTURE_2D, 0, GL_RGBA,
|
|
GLsizei (Size.Width),
|
|
GLsizei (Size.Height),
|
|
0,
|
|
GL_RGBA, GL_UNSIGNED_BYTE,
|
|
null); -- NB: Actual image is not initialised.
|
|
|
|
else -- No existing, unused texture found, so create a new one.
|
|
the_Texture.Pool := From.all'unchecked_Access;
|
|
the_Texture.Name := new_texture_Name;
|
|
the_Texture.enable;
|
|
|
|
glPixelStorei (GL_UNPACK_ALIGNMENT, 1);
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S,
|
|
GL_CLAMP_TO_EDGE);
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T,
|
|
GL_CLAMP_TO_EDGE);
|
|
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER,
|
|
GL_LINEAR);
|
|
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER,
|
|
GL_LINEAR);
|
|
|
|
gltexImage2D (gl_TEXTURE_2D, 0, gl_RGBA,
|
|
GLsizei (Size.Width),
|
|
GLsizei (Size.Height),
|
|
0,
|
|
GL_RGBA, GL_UNSIGNED_BYTE,
|
|
null); -- NB: Actual image is not initialised.
|
|
end if;
|
|
|
|
the_Texture.Dimensions := Size;
|
|
|
|
return the_Texture;
|
|
end new_Texture;
|
|
|
|
|
|
|
|
procedure free (From : in out Pool; the_Texture : in Object)
|
|
is
|
|
use type texture_Name;
|
|
begin
|
|
if the_Texture.Name = 0 then
|
|
return;
|
|
end if;
|
|
|
|
raise Program_Error with "TODO: free texture from pool";
|
|
-- declare
|
|
-- unused_texture_List : constant pool_texture_List_view
|
|
-- := Self.unused_Textures_for_size (the_Texture.Size_width,
|
|
-- the_Texture.Size_height);
|
|
-- begin
|
|
-- unused_texture_List.Last := unused_texture_List.Last + 1;
|
|
-- unused_texture_List.Textures (unused_texture_List.Last) := the_Texture;
|
|
-- end;
|
|
end free;
|
|
|
|
|
|
|
|
procedure vacuum (the_Pool : in out Pool)
|
|
is
|
|
begin
|
|
for Each of the_Pool.Map
|
|
loop
|
|
declare
|
|
unused_List : constant pool_texture_List_view := Each;
|
|
begin
|
|
if unused_List /= null
|
|
then
|
|
for Each in 1 .. unused_List.Last
|
|
loop
|
|
free (unused_List.Textures (Each).Name);
|
|
end loop;
|
|
|
|
unused_List.Last := 0;
|
|
end if;
|
|
end;
|
|
end loop;
|
|
|
|
-- TODO: Test this ~ old code follows ...
|
|
|
|
-- for each_Width in Self.unused_Textures_for_size'Range (1)
|
|
-- loop
|
|
-- for each_Height in self.unused_Textures_for_size'Range (2)
|
|
-- loop
|
|
-- declare
|
|
-- unused_texture_List : constant pool_texture_List_view
|
|
-- := Self.unused_Textures_for_size (each_Width, each_Height);
|
|
-- begin
|
|
-- if unused_texture_List /= null
|
|
-- then
|
|
-- for Each in 1 .. unused_texture_List.Last
|
|
-- loop
|
|
-- free (unused_texture_List.Textures (Each).Name);
|
|
-- end loop;
|
|
--
|
|
-- unused_texture_List.Last := 0;
|
|
-- end if;
|
|
-- end;
|
|
-- end loop;
|
|
-- end loop;
|
|
end vacuum;
|
|
|
|
|
|
|
|
function Hash (the_Dimensions : in Texture.Dimensions) return ada.Containers.Hash_Type
|
|
is
|
|
begin
|
|
return ada.Containers.Hash_type ( the_Dimensions.Width * 13
|
|
+ the_Dimensions.Height * 17);
|
|
end Hash;
|
|
|
|
|
|
end openGL.Texture;
|