1. ------------------------------------------------------------------------- 
  2.  --  GL.Textures - GL Texture model 
  3.  -- 
  4.  --  Copyright (c) Rod Kay 2007 
  5.  --  AUSTRALIA 
  6.  --  Permission granted to use this software, without any warranty, 
  7.  --  for any purpose, provided this copyright note remains attached 
  8.  --  and unmodified if sources are distributed further. 
  9.  ------------------------------------------------------------------------- 
  10.  
  11. with GL.Geometry; 
  12.  
  13. with Ada.Unchecked_Deallocation; 
  14.  
  15. package GL.Textures is 
  16.  
  17.    -- core types 
  18.    -- 
  19.  
  20.    subtype texture_Name is GL.Uint;     -- an openGL texture 'name', which is a natural integer. 
  21.  
  22.    type texture_Transform is 
  23.      record 
  24.        Offset  : Double; 
  25.        Scale   : Double; 
  26.      end record; 
  27.  
  28.    -- texture co - ordinates 
  29.    -- 
  30.  
  31.    type Coordinate_1D is 
  32.       record 
  33.          S  : aliased GL.Double; 
  34.       end record; 
  35.  
  36.    type Coordinate_1D_array is array (Natural range <>) of Coordinate_1D; 
  37.  
  38.    type Coordinate_2D is 
  39.       record 
  40.          S, T  : aliased GL.Double; 
  41.       end record; 
  42.  
  43.    type   Coordinate_2D_array is array (GL.Geometry.Positive_Vertex_Id range <>) of aliased Coordinate_2D;   -- tbd : can the index be '1'- based ? 
  44.    type p_Coordinate_2D_array is access all Coordinate_2D_array; 
  45.  
  46.    procedure free is new Ada.Unchecked_Deallocation (Coordinate_2D_array, p_Coordinate_2D_array); 
  47.  
  48.    function To_Texture_Coordinates_xz (the_Points  : GL.Geometry.GL_Vertex_array; 
  49.                                        Transform_S : texture_Transform;          -- transforms point X ordinate. 
  50.                                        Transform_T : texture_Transform)          -- transforms point Z ordinate. 
  51.                                        return p_Coordinate_2D_array;                -- using heap to avoid storage_Error with large numbers of points. 
  52.  
  53.    type coordinate_Generator   is abstract tagged null record; 
  54.    type p_coordinate_Generator is access all coordinate_Generator'Class; 
  55.  
  56.    function To_Coordinates (Self : coordinate_Generator; the_Vertices : GL.Geometry.GL_Vertex_array) return GL.Textures.p_Coordinate_2D_array is abstract; 
  57.    function To_Coordinates (Self : coordinate_Generator; the_Vertices : GL.Geometry.GL_Vertex_array) return GL.Textures.Coordinate_2D_array is abstract; 
  58.  
  59.    type xz_Generator is new coordinate_Generator with 
  60.       record 
  61.          Transform_S  : texture_Transform;          -- transforms point X ordinate. 
  62.          Transform_T  : texture_Transform;          -- transforms point Z ordinate. 
  63.       end record; 
  64.  
  65.    overriding function To_Coordinates (Self : xz_Generator; the_Vertices : GL.Geometry.GL_Vertex_array) return GL.Textures.p_Coordinate_2D_array; 
  66.    overriding function to_Coordinates (Self : xz_Generator; the_Vertices : GL.Geometry.GL_Vertex_array) return GL.Textures.Coordinate_2D_array; 
  67.  
  68.    type Coordinate_3D is 
  69.       record 
  70.          S, T, R  : aliased GL.Double; 
  71.       end record; 
  72.  
  73.    type Coordinate_3D_array is array (Natural range <>) of Coordinate_3D; 
  74.  
  75.    type Coordinate_4D is 
  76.       record 
  77.          S, T, R, Q  : aliased GL.Double; 
  78.       end record; 
  79.  
  80.    type Coordinate_4D_array is array (Natural range <>) of Coordinate_4D; 
  81.  
  82.    type Size is (Unknown, s2, s4, s8, s16, s32, s64, s128, s256, s512, s1024, s2048); 
  83.  
  84.    function To_Size (From : Positive) return Size; 
  85.  
  86.    -- Object - an openGL texture 'object'. 
  87.    -- 
  88.  
  89.    type Object  is private; 
  90.    type Objects is array (Positive range <>) of Object; 
  91.  
  92.    function New_Texture (image_Filename : String) return Object; 
  93.  
  94.    unsupported_format_Error  : exception;    -- raised when image filename is not of 'bmp' or 'tga' format. 
  95.  
  96.    procedure Destroy (Self  : in out Object); 
  97.  
  98.    procedure Set_Name (Self : in out Object; To : texture_Name); 
  99.    function  Name     (Self :        Object) return texture_Name; 
  100.  
  101.    procedure Enable (Self : in out Object); 
  102.  
  103.    function Size_Width  (Self : Object) return Size; 
  104.    function Size_Height (Self : Object) return Size; 
  105.  
  106.    function  Is_Transparent (Self :  Object) return Boolean; 
  107.  
  108.    -- Pool - a pool for rapid allocation/deallocation of texture objects. 
  109.    -- 
  110.  
  111.    type Pool is private; 
  112.    type p_Pool is access all Pool; 
  113.  
  114.    function New_Texture (From       : access Pool; 
  115.                          min_Width  :        Positive; 
  116.                          min_Height :        Positive) return Object; 
  117.    -- 
  118.    -- returns a texture object, whose width and height are powers of two, sufficient to contain the requested minimums. 
  119.    -- tbd : add texture properties to construction parameters ! 
  120.  
  121.    procedure Free (Self : in out Pool; the_Texture : Object); 
  122.    -- 
  123.    -- free's a texture, for future use. 
  124.  
  125.    procedure Vacuum (Self : in out Pool); 
  126.    -- 
  127.    -- releases any allocated, but unused, texture objects. 
  128.  
  129.    -- support 
  130.    -- 
  131.  
  132.    function Power_of_2_Ceiling (From : Positive) return GL.Sizei; 
  133.  
  134. private 
  135.  
  136.    type Object is tagged 
  137.       record 
  138.          Name    : aliased texture_Name := 0; 
  139.          Width, 
  140.          Height  :         Size := Unknown; 
  141.  
  142.          is_Transparent  : Boolean; 
  143.  
  144.          Pool    : Textures.p_Pool; 
  145.       end record; 
  146.  
  147.    -- pool 
  148.    -- 
  149.    -- re - uses existing textures when possible for performance. 
  150.  
  151.    type pool_texture_List is 
  152.       record 
  153.          Textures  : Objects (1 .. 3000); 
  154.          Last      : Natural            := 0; 
  155.       end record; 
  156.  
  157.    type p_pool_texture_List is access all pool_texture_List; 
  158.  
  159.    type pool_texture_Lists_by_size is array (Size, Size) of p_pool_texture_List; 
  160.  
  161.    type Pool is 
  162.       record 
  163.          unused_Textures_for_size  : pool_texture_Lists_by_size; 
  164.       end record; 
  165.  
  166. end GL.Textures;