1. ------------------------------------------------------------------------- 
  2. --  GL.Textures - GL Textures 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.IO; 
  12. with GL.Errors; 
  13.  
  14. -- with Ada.Directories; 
  15. with Ada.Characters.Handling; 
  16. with Ada.Text_IO; use Ada.Text_IO; 
  17.  
  18. package body GL.Textures is 
  19.  
  20.    -- names 
  21.  
  22.    function New_Texture_Name return texture_Name is 
  23.  
  24.       the_Name : aliased texture_Name; 
  25.  
  26.    begin 
  27.       GL.Gen_Textures (1, the_Name'Unchecked_Access); 
  28.       return the_Name; 
  29.    end New_Texture_Name; 
  30.  
  31.    procedure Free (the_texture_Name : texture_Name) is 
  32.  
  33.       the_Name : aliased texture_Name := the_texture_Name; 
  34.  
  35.    begin 
  36.       GL.Delete_Textures (1, the_Name'Unchecked_Access); 
  37.    end Free; 
  38.  
  39.    -- coordinates 
  40.    -- 
  41.  
  42.    function To_Texture_Coordinates_xz (the_Points  : GL.Geometry.GL_Vertex_array; 
  43.                                        Transform_S : texture_Transform;          -- transforms point X ordinate. 
  44.                                        Transform_T : texture_Transform)          -- transforms point Z ordinate. 
  45.                                        return p_Coordinate_2D_array is 
  46.  
  47.       the_Coords : constant p_Coordinate_2D_array := new Coordinate_2D_array (1 .. the_Points'Last); 
  48.  
  49.    begin 
  50.       for Each in the_Points'Range loop 
  51.          declare 
  52.             the_Vertex  : GL.Geometry.GL_Vertex renames the_Points (Each); 
  53.          begin 
  54.             the_Coords.all (Each).S :=         (the_Vertex (0) + Transform_S.Offset) * Transform_S.Scale; 
  55.             the_Coords.all (Each).T := 1.0  -  (the_Vertex (2) + Transform_T.Offset) * Transform_T.Scale; 
  56.          end; 
  57.       end loop; 
  58.  
  59.       return the_Coords; 
  60.    end To_Texture_Coordinates_xz; 
  61.  
  62.    function To_Texture_Coordinates_xz (the_Points  : GL.Geometry.GL_Vertex_array; 
  63.                                        Transform_S : texture_Transform;          -- transforms point X ordinate. 
  64.                                        Transform_T : texture_Transform)          -- transforms point Z ordinate. 
  65.                                        return Coordinate_2D_array is 
  66.  
  67.       the_Coords  : Coordinate_2D_array (1 .. the_Points'Last); 
  68.  
  69.    begin 
  70.       for Each in the_Points'Range loop 
  71.          declare 
  72.             the_Vertex  : GL.Geometry.GL_Vertex renames the_Points (Each); 
  73.          begin 
  74.             the_Coords (Each).S :=         (the_Vertex (0) + Transform_S.Offset) * Transform_S.Scale; 
  75.             the_Coords (Each).T := 1.0  -  (the_Vertex (2) + Transform_T.Offset) * Transform_T.Scale; 
  76.          end; 
  77.       end loop; 
  78.  
  79.       return the_Coords; 
  80.    end To_Texture_Coordinates_xz; 
  81.  
  82.    -- xz_Generator 
  83.  
  84.    overriding function To_Coordinates (Self : xz_Generator; the_Vertices : GL.Geometry.GL_Vertex_array) return GL.Textures.p_Coordinate_2D_array is 
  85.      (To_Texture_Coordinates_xz (the_Vertices, Self.Transform_S, Self.Transform_T)); 
  86.  
  87.    overriding function To_Coordinates (Self : xz_Generator; the_Vertices : GL.Geometry.GL_Vertex_array) return GL.Textures.Coordinate_2D_array is 
  88.      (To_Texture_Coordinates_xz (the_Vertices, Self.Transform_S, Self.Transform_T)); 
  89.  
  90.    -- texture objects 
  91.  
  92.    function New_Texture (image_Filename : String) return Object is 
  93.  
  94.       use Ada.Characters.Handling; 
  95.  
  96.       Extension   : constant String := image_Filename (image_Filename'Last - 2 .. image_Filename'Last); 
  97.       the_Texture :          Object; 
  98.  
  99.    begin 
  100.       the_Texture.Name := New_Texture_Name; 
  101.  
  102.       if To_Lower (Extension) = "bmp" then 
  103.          GL.IO.Load (image_Filename,  GL.IO.BMP,  Integer (the_Texture.Name),  blending_hint => the_Texture.is_Transparent); 
  104.  
  105.       elsif To_Lower (Extension) = "tga" then 
  106.          GL.IO.Load (image_Filename,  GL.IO.TGA,  Integer (the_Texture.Name),  blending_hint => the_Texture.is_Transparent); 
  107.       else 
  108.          raise unsupported_format_Error; 
  109.       end if; 
  110.  
  111.       -- tbd : if not found, look in 'global' and 'level' zip files also, ala gautiers 'globe_3d.textures'. 
  112.       return the_Texture; 
  113.    end New_Texture; 
  114.  
  115.    procedure Destroy (Self : in out Object) is 
  116.  
  117.    begin 
  118.       case Self.Pool = null is 
  119.          when True  => Free (Self.Name); 
  120.          when False => Free (Self.Pool.all, Self); 
  121.       end case; 
  122.    end Destroy; 
  123.  
  124.    procedure Set_Name (Self : in out Object; To : GL.Uint) is 
  125.  
  126.    begin 
  127.       Self.Name := To; 
  128.    end Set_Name; 
  129.  
  130.    function Name (Self : Object) return GL.Uint is (Self.Name); 
  131.  
  132.    function Is_Transparent (Self : Object) return Boolean is (Self.is_Transparent); 
  133.  
  134.    procedure Enable (Self : in out Object) is 
  135.  
  136.    begin 
  137.       pragma Assert (Self.Name > 0); 
  138.  
  139.       GL.Enable      (GL.TEXTURE_2D); 
  140.       GL.BindTexture (GL.TEXTURE_2D, Self.Name); 
  141.    end Enable; 
  142.  
  143.    -- Pool 
  144.    -- 
  145.  
  146.    Null_Image : array (1 .. 10_000_000) of aliased GL.Ubyte := (others => 0); 
  147.  
  148.    -- tbd : add texture properties as 'in' parameters to habdle different types of textures. 
  149.    -- 
  150.    function New_Texture (From       : access Pool; 
  151.                          min_Width  :        Positive; 
  152.                          min_Height :        Positive) return Object is 
  153.  
  154.       the_Texture  : aliased Object; 
  155.  
  156.       Size_Min_Width   : constant Size := To_Size (min_Width); 
  157.       Size_Min_Height  : constant Size := To_Size (min_Height); 
  158.  
  159.       unused_texture_List  : p_pool_texture_List := From.all.unused_Textures_for_size (Size_Min_Width, Size_Min_Height); 
  160.  
  161.    begin 
  162.       if unused_texture_List = null then 
  163.          unused_texture_List                                                 := new pool_texture_List; 
  164.          From.all.unused_Textures_for_size (Size_Min_Width, Size_Min_Height) := unused_texture_List; 
  165.       end if; 
  166.  
  167.       -- search for existing, but unused, object. 
  168.       -- 
  169.       if unused_texture_List.all.Last > 0 then -- an existing unused texture has been found 
  170.          the_Texture                  := unused_texture_List.all.Textures (unused_texture_List.all.Last); 
  171.          unused_texture_List.all.Last := unused_texture_List.all.Last - 1; 
  172.  
  173.          Enable (the_Texture); 
  174.  
  175.          GL.TexImage2D  (GL.TEXTURE_2D,  0,  GL.RGBA, 
  176.                          Power_of_2_Ceiling (min_Width), Power_of_2_Ceiling (min_Height), 
  177.                          0, 
  178.                          -- gl.RGBA, GL.GL_UNSIGNED_BYTE, null);    -- nb : actual image is not initialised. 
  179.                          GL.RGBA, GL.GL_UNSIGNED_BYTE, Null_Image (Null_Image'First)'Access);    -- nb : actual image is not initialised. 
  180.       else 
  181.          -- no existing, unused texture found, so create a new one. 
  182.          -- 
  183.          the_Texture.Width  := Size_Min_Width; 
  184.          the_Texture.Height := Size_Min_Height; 
  185.  
  186.          the_Texture.Pool := From.all'Access; 
  187.  
  188.          the_Texture.Name := New_Texture_Name; 
  189.          Enable (the_Texture); 
  190.  
  191.          PixelStore (UNPACK_ALIGNMENT, 1);                        -- tbd : these properties are tailored for impostors 
  192.          -- TexParameter (TEXTURE_2D, TEXTURE_WRAP_S, REPEAT);       --      make them user settable ! 
  193.          -- TexParameter (TEXTURE_2D, TEXTURE_WRAP_T, REPEAT); 
  194.           -- TexParameter (TEXTURE_2D, TEXTURE_WRAP_S, CLAMP);       --      make them user settable ! 
  195.           -- TexParameter (TEXTURE_2D, TEXTURE_WRAP_T, CLAMP); 
  196.        TexParameter (TEXTURE_2D, TEXTURE_WRAP_S, CLAMP_TO_EDGE);       --      make them user settable ! 
  197.        TexParameter (TEXTURE_2D, TEXTURE_WRAP_T, CLAMP_TO_EDGE); 
  198.  
  199.          -- TexParameter (TEXTURE_2D, TEXTURE_MAG_FILTER, NEAREST); 
  200.          -- TexParameter (TEXTURE_2D, TEXTURE_MIN_FILTER, NEAREST); 
  201.          TexParameter (TEXTURE_2D, TEXTURE_MAG_FILTER, LINEAR); 
  202.          TexParameter (TEXTURE_2D, TEXTURE_MIN_FILTER, LINEAR); 
  203.  
  204.          TexEnv (TEXTURE_ENV, TEXTURE_ENV_MODE, MODULATE); 
  205.          -- TexEnv (TEXTURE_ENV, TEXTURE_ENV_MODE, DECAL); 
  206.  
  207.          GL.TexImage2D  (GL.TEXTURE_2D,  0,  GL.RGBA, 
  208.                          Power_of_2_Ceiling (min_Width), Power_of_2_Ceiling (min_Height), 
  209.                          0, 
  210.                          -- gl.RGBA, GL.GL_UNSIGNED_BYTE, null);    -- nb : actual image is not initialised. 
  211.                          GL.RGBA, GL.GL_UNSIGNED_BYTE, Null_Image (Null_Image'First)'Access);    -- nb : actual image is not initialised. 
  212.  
  213.          GL.Errors.log;  -- tbd : only for debug. 
  214.       end if; 
  215.  
  216.       return the_Texture; 
  217.    end New_Texture; 
  218.  
  219.    procedure Free (Self : in out Pool; the_Texture : Object) is 
  220.  
  221.    begin 
  222.       if the_Texture.Name = 0 then 
  223.          return; 
  224.       end if; 
  225.  
  226.       declare 
  227.          unused_texture_List : constant p_pool_texture_List := Self.unused_Textures_for_size (the_Texture.Width, the_Texture.Height); 
  228.       begin 
  229.          unused_texture_List.all.Last                                    := unused_texture_List.all.Last + 1; 
  230.          unused_texture_List.all.Textures (unused_texture_List.all.Last) := the_Texture; 
  231.       end; 
  232.    end Free; 
  233.  
  234.    procedure Vacuum (Self : in out Pool) is 
  235.  
  236.    begin 
  237.  
  238.       for each_Width in Self.unused_Textures_for_size'Range (1) loop 
  239.          for each_Height in Self.unused_Textures_for_size'Range (2) loop 
  240.             declare 
  241.                unused_texture_List  : constant p_pool_texture_List := Self.unused_Textures_for_size (each_Width, each_Height); 
  242.             begin 
  243.                if unused_texture_List /= null then 
  244.  
  245.                   for Each in 1 .. unused_texture_List.all.Last loop 
  246.                      Free (unused_texture_List.all.Textures (Each).Name); 
  247.                   end loop; 
  248.  
  249.                   unused_texture_List.all.Last := 0; 
  250.                end if; 
  251.             end; 
  252.          end loop; 
  253.       end loop; 
  254.  
  255.    end Vacuum; 
  256.  
  257.    function To_Size (From : Positive) return Size is 
  258.  
  259.    begin 
  260.       if    From <= 2    then 
  261.          return s2; 
  262.       elsif From <= 4    then 
  263.          return s4; 
  264.       elsif From <= 8    then 
  265.          return s8; 
  266.       elsif From <= 16   then 
  267.          return s16; 
  268.       elsif From <= 32   then 
  269.          return s32; 
  270.       elsif From <= 64   then 
  271.          return s64; 
  272.       elsif From <= 128  then 
  273.          return s128; 
  274.       elsif From <= 256  then 
  275.          return s256; 
  276.       elsif From <= 512  then 
  277.          return s512; 
  278.       elsif From <= 1024 then 
  279.          return s1024; 
  280.       elsif From <= 2048 then 
  281.          return s2048; 
  282.       end if; 
  283.  
  284.       Put_Line ("to_Size : From : " & Positive'Image (From)); 
  285.  
  286.       raise Constraint_Error; 
  287.    end To_Size; 
  288.  
  289.    function Power_of_2_Ceiling (From : Positive) return GL.Sizei is 
  290.  
  291.    begin 
  292.       if    From <= 2    then 
  293.          return 2; 
  294.       elsif From <= 4    then 
  295.          return 4; 
  296.       elsif From <= 8    then 
  297.          return 8; 
  298.       elsif From <= 16   then 
  299.          return 16; 
  300.       elsif From <= 32   then 
  301.          return 32; 
  302.       elsif From <= 64   then 
  303.          return 64; 
  304.       elsif From <= 128  then 
  305.          return 128; 
  306.       elsif From <= 256  then 
  307.          return 256; 
  308.       elsif From <= 512  then 
  309.          return 512; 
  310.       elsif From <= 1024 then 
  311.          return 1024; 
  312.       elsif From <= 2048 then 
  313.          return 2048; 
  314.       end if; 
  315.  
  316.       raise Constraint_Error; 
  317.    end Power_of_2_Ceiling; 
  318.  
  319.    function Size_Width  (Self : Object) return Size is (Self.Width); 
  320.  
  321.    function Size_Height (Self : Object) return Size is (Self.Height); 
  322.  
  323. end GL.Textures;