1. with GL, GL.IO, UnZip.Streams; 
  2.  
  3. with Ada.Characters.Handling;           use Ada.Characters.Handling; 
  4. with Ada.Exceptions;                    use Ada.Exceptions; 
  5. with Ada.Strings.Fixed;                 use Ada.Strings, Ada.Strings.Fixed; 
  6. with Ada.Strings.Unbounded;             use Ada.Strings.Unbounded; 
  7. with Ada.Unchecked_Deallocation; 
  8. with Ada.Containers.Hashed_Maps; 
  9. with Ada.Strings.Unbounded.Hash; 
  10.  
  11. package body GLOBE_3D.Textures is 
  12.  
  13.   ------------------------------------------------------------------ 
  14.   -- 1) Fast access though the number (Image_ID - > Texture_info) : -- 
  15.   ------------------------------------------------------------------ 
  16.   type Texture_info is record 
  17.     loaded        : Boolean := False; 
  18.     blending_hint : Boolean := False; 
  19.     name          : Ident := empty; 
  20.   end record; 
  21.  
  22.   type Texture_info_array is array (Image_ID range <>) of Texture_info; 
  23.   type p_Texture_info_array is access Texture_info_array; 
  24.  
  25.   procedure Dispose is new Ada.Unchecked_Deallocation (Texture_info_array, p_Texture_info_array); 
  26.  
  27.   ----------------------------------- 
  28.   -- 2) Fast access through a name -- 
  29.   ----------------------------------- 
  30.  
  31.   package Texture_Name_Mapping is new Ada.Containers.Hashed_Maps 
  32.      (Key_Type        => Ada.Strings.Unbounded.Unbounded_String, 
  33.       Element_Type    => Image_ID, 
  34.       Hash            => Ada.Strings.Unbounded.Hash, 
  35.       Equivalent_Keys => Ada.Strings.Unbounded."="); 
  36.  
  37.   type Texture_2d_infos_type is record 
  38.     tex               : p_Texture_info_array; 
  39.     map               : Texture_Name_Mapping.Map; 
  40.     last_entry_in_use : Image_ID; 
  41.   end record; 
  42.  
  43.   empty_texture_2d_infos : constant Texture_2d_infos_type := 
  44.     (null, 
  45.       Texture_Name_Mapping.Empty_Map, 
  46.       null_image 
  47. ); 
  48.  
  49.   Texture_2d_Infos : Texture_2d_infos_type := empty_texture_2d_infos; 
  50.  
  51.   ----------------------------- 
  52.   -- Load_texture (internal) -- 
  53.   ----------------------------- 
  54.  
  55.   procedure Load_texture_2D (id : Image_ID; blending_hint : out Boolean) is 
  56.     tex_name : constant String := Trim (Texture_2d_Infos.tex.all (id).name, Right); 
  57.  
  58.     procedure Try (zif : in out Zip.Zip_info; name : String) is 
  59.       use UnZip.Streams; 
  60.       ftex : Zipped_File_Type; 
  61.       procedure Try_a_type (tex_name_ext : String; format : GL.IO.Supported_format) is 
  62.       begin 
  63.         Open (ftex, zif, tex_name_ext); 
  64.         GL.IO.Load (Stream (ftex), format, Image_ID'Pos (id) + 1, blending_hint); 
  65.         Close (ftex); 
  66.       exception 
  67.         when Zip.File_name_not_found => 
  68.           raise; 
  69.         when e : others => 
  70.           Raise_Exception ( 
  71.             Exception_Identity (e), 
  72.             Exception_Message (e) & " on texture : " & tex_name_ext); 
  73.       end Try_a_type; 
  74.     begin -- Try 
  75.       Load_if_needed (zif, name); 
  76.       Try_a_type (tex_name & ".TGA", GL.IO.TGA); 
  77.     exception 
  78.       when Zip.File_name_not_found => 
  79.         Try_a_type (tex_name & ".BMP", GL.IO.BMP); 
  80.     end Try; 
  81.   begin 
  82.     begin 
  83.       Try (zif_level, To_String (level_data_name)); 
  84.     exception 
  85.       when Zip.File_name_not_found | 
  86.            Zip.Zip_file_open_Error => 
  87.         -- Not found in level - specific pack 
  88.         Try (zif_global, To_String (global_data_name)); 
  89.     end; 
  90.   exception 
  91.     when Zip.File_name_not_found | 
  92.          Zip.Zip_file_open_Error => 
  93.       -- Never found - neither in level, nor in global pack 
  94.       Raise_Exception (Missing_texture'Identity, "texture : " & tex_name); 
  95.   end Load_texture_2D; 
  96.  
  97.   function Valid_texture_ID (id : Image_ID) return Boolean is 
  98.   begin 
  99.     return id in null_image + 1 .. Texture_2d_Infos.last_entry_in_use; 
  100.   end Valid_texture_ID; 
  101.  
  102.   procedure Check_2D_texture (id : Image_ID; blending_hint : out Boolean) is 
  103.   begin 
  104.     if not Valid_texture_ID (id) then 
  105.       raise Undefined_texture_ID; 
  106.     end if; 
  107.     if Texture_2d_Infos.tex.all (id).loaded then 
  108.       blending_hint := Texture_2d_Infos.tex.all (id).blending_hint; 
  109.     else 
  110.       Load_texture_2D (id, blending_hint); 
  111.       Texture_2d_Infos.tex.all (id).loaded := True; 
  112.       Texture_2d_Infos.tex.all (id).blending_hint := blending_hint; 
  113.     end if; 
  114.   end Check_2D_texture; 
  115.  
  116.   procedure Check_2D_texture (id : Image_ID) is 
  117.     junk_blending_hint : Boolean; pragma Unreferenced (junk_blending_hint); 
  118.   begin 
  119.     Check_2D_texture (id, junk_blending_hint); 
  120.   end Check_2D_texture; 
  121.  
  122.   procedure Check_all_textures is 
  123.   begin 
  124.     for i in null_image + 1 .. Texture_2d_Infos.last_entry_in_use loop 
  125.       Check_2D_texture (i); 
  126.     end loop; 
  127.   end Check_all_textures; 
  128.  
  129.   procedure Reset_textures is 
  130.   begin 
  131.     if Texture_2d_Infos.tex /= null then 
  132.       Dispose (Texture_2d_Infos.tex); 
  133.     end if; 
  134.     Texture_2d_Infos := empty_texture_2d_infos; 
  135.   end Reset_textures; 
  136.  
  137.   procedure Add_texture_name (name : String; id : out Image_ID) is 
  138.     new_tab : p_Texture_info_array; 
  139.     up_name : constant String := To_Upper (name); 
  140.     -- Convention : UPPER_CASE for identifiers 
  141.     n_id : Ident := empty; 
  142.     pos : Texture_Name_Mapping.Cursor; 
  143.     success : Boolean; 
  144.   begin 
  145.     if Texture_2d_Infos.tex = null then 
  146.       Texture_2d_Infos.tex := new Texture_info_array (0 .. 100); 
  147.     end if; 
  148.     if Texture_2d_Infos.last_entry_in_use >= Texture_2d_Infos.tex'Last then 
  149.       -- We need to enlarge the table : we double it .. . 
  150.       new_tab := new Texture_info_array (0 .. Texture_2d_Infos.tex'Last * 2); 
  151.       new_tab.all (Texture_2d_Infos.tex'Range) := Texture_2d_Infos.tex.all; 
  152.       Dispose (Texture_2d_Infos.tex); 
  153.       Texture_2d_Infos.tex := new_tab; 
  154.     end if; 
  155.     id := Texture_2d_Infos.last_entry_in_use + 1; 
  156.     for i in up_name'Range loop 
  157.       n_id (n_id'First + i - up_name'First) := up_name (i); 
  158.     end loop; 
  159.     Texture_2d_Infos.tex.all (id).name := n_id; 
  160.     Texture_2d_Infos.last_entry_in_use := 
  161.       Image_ID'Max (Texture_2d_Infos.last_entry_in_use, id); 
  162.     -- Feed the name dictionary with the new name: 
  163.     Texture_Name_Mapping.Insert ( 
  164.       Texture_2d_Infos.map, 
  165.       Ada.Strings.Unbounded.To_Unbounded_String (up_name), 
  166.       id, 
  167.       pos, 
  168.       success 
  169. ); 
  170.     if not success then -- A.18.4. 45/2 
  171.       raise Duplicate_name with name & ", already stored as " & up_name; 
  172.     end if; 
  173.   end Add_texture_name; 
  174.  
  175.   procedure Register_textures_from_resources is 
  176.  
  177.     procedure Register (zif : in out Zip.Zip_info; name : String) is 
  178.       -- 
  179.       procedure Action (Name_String : String) is 
  180.         dummy : Image_ID; 
  181.         ext : constant String := To_Upper (Name_String (Name_String'Last - 3 .. Name_String'Last)); 
  182.       begin 
  183.         if ext = ".BMP" or else ext = ".TGA" then 
  184.           Add_texture_name (Name_String (Name_String'First .. Name_String'Last - 4), dummy); 
  185.         end if; 
  186.       end Action; 
  187.       -- 
  188.       procedure Traverse is new Zip.Traverse (Action); 
  189.     begin 
  190.       Load_if_needed (zif, name); 
  191.       Traverse (zif); 
  192.       -- That's it! 
  193.     exception 
  194.       when Zip.Zip_file_open_Error => 
  195.         null; 
  196.     end Register; 
  197.  
  198.   begin 
  199.     Register (zif_level,  To_String (level_data_name)); 
  200.     Register (zif_global, To_String (global_data_name)); 
  201.   end Register_textures_from_resources; 
  202.  
  203.   procedure Associate_textures is 
  204.     dummy : Image_ID; 
  205.   begin 
  206.     Reset_textures; 
  207.     for t in Texture_enum loop 
  208.       Add_texture_name (Texture_enum'Image (t), dummy); 
  209.     end loop; 
  210.   end Associate_textures; 
  211.  
  212.   function Texture_name (id : Image_ID; Trim_Flag : Boolean) return Ident is 
  213.     tn : Ident; 
  214.   begin 
  215.     if not Valid_texture_ID (id) then 
  216.       raise Undefined_texture_ID; 
  217.     end if; 
  218.     tn := Texture_2d_Infos.tex.all (id).name; 
  219.     if Trim_Flag then 
  220.       return Ada.Strings.Fixed.Trim (tn, Right); 
  221.     else 
  222.       return tn; 
  223.     end if; 
  224.   end Texture_name; 
  225.  
  226.   function Texture_ID (name : String) return Image_ID is 
  227.     trimmed : constant String := Trim (name, Both); 
  228.     up_name : constant String := To_Upper (trimmed); 
  229.   begin 
  230.     return Texture_Name_Mapping.Element ( 
  231.             Texture_2d_Infos.map, 
  232.             Ada.Strings.Unbounded.To_Unbounded_String (up_name)); 
  233.   exception 
  234.     when Constraint_Error => 
  235.       raise Undefined_texture_name with 
  236.         "Texture : " & trimmed & ", searched as " & up_name & "." & 
  237.         ASCII.CR & ASCII.LF & 
  238.         "Check data files:" & 
  239.         ASCII.CR & ASCII.LF & 
  240.         ' ' & To_String (global_data_name) & 
  241.         ASCII.CR & ASCII.LF & 
  242.         ' ' & To_String (level_data_name) & '.' & 
  243.         ASCII.CR & ASCII.LF & 
  244.         "Check calls of Add_texture_name or Associate_textures."; 
  245.   end Texture_ID; 
  246.  
  247. end GLOBE_3D.Textures;