Back to... GLOBE_3D

Source file : globe_3d-textures.adb


with GL, GL.IO, UnZip.Streams;

with Ada.Characters.Handling;           use Ada.Characters.Handling;
with Ada.Exceptions;                    use Ada.Exceptions;
with Ada.Strings.Fixed;                 use Ada.Strings, Ada.Strings.Fixed;
with Ada.Unchecked_Deallocation;
with Ada.Containers.Hashed_Maps;
with Ada.Streams.Stream_IO;
with Ada.Strings.Unbounded.Hash;

package body GLOBE_3D.Textures is

  ------------------------------------------------------------------
  -- 1) Fast access though the number (Image_ID -> Texture_info): --
  ------------------------------------------------------------------
  type Texture_info is record
    loaded       : Boolean:= False;
    blending_hint: Boolean:= False;
    name         : Ident:= empty;
  end record;

  type Texture_info_array is array( Image_ID range <>) of Texture_info;
  type p_Texture_info_array is access Texture_info_array;

  procedure Dispose is new Ada.Unchecked_Deallocation(Texture_info_array, p_Texture_info_array);

  -----------------------------------
  -- 2) Fast access through a name --
  -----------------------------------

  package Texture_Name_Mapping is new Ada.Containers.Hashed_Maps
     (Key_Type        => Ada.Strings.Unbounded.Unbounded_String,
      Element_Type    => Image_ID,
      Hash            => Ada.Strings.Unbounded.Hash,
      Equivalent_Keys => Ada.Strings.Unbounded."=");

  type Texture_2d_infos_type is record
    tex              : p_Texture_info_array;
    map              : Texture_Name_Mapping.Map;
    last_entry_in_use: Image_ID;
  end record;

  empty_texture_2d_infos: constant Texture_2d_infos_type:=
    ( null,
      Texture_Name_Mapping.Empty_Map,
      null_image
    );

  texture_2d_infos: Texture_2d_infos_type:= empty_texture_2d_infos;

  -----------------------------
  -- Load_texture (internal) --
  -----------------------------

  procedure Load_texture_2D (id: Image_ID; blending_hint: out Boolean) is
    tex_name: constant String:= Trim(texture_2d_infos.tex(id).name, Right);
    found: Boolean:= False;

    procedure Try_archive( zif: in out Zip.Zip_info; name: String ) is
      use UnZip.Streams;
      ftex: Zipped_File_Type;
      procedure Try_image_type(tex_name_ext: String) is
      begin
        Open( ftex, zif, tex_name_ext );
        GL.IO.Load(
          Ada.Streams.Stream_IO.Stream_Access(Stream(ftex)),
          Image_ID'Pos(id)+1, blending_hint
        );
        Close( ftex );
        found:= True;
      exception
        when Zip.File_name_not_found =>
          null;  --  Nothing bad, item just not found.
        when e: others =>
          Raise_Exception(
            Exception_Identity(e),
            Exception_Message(e) & " on texture: " & tex_name_ext
          );
      end Try_image_type;
    begin -- Try_archive
      Load_if_needed( zif, name );
      Try_image_type(tex_name & ".TGA");
      if found then
        return;
      end if;
      Try_image_type(tex_name & ".BMP");
      if found then
        return;
      end if;
      Try_image_type(tex_name & ".JPG");
      if found then
        return;
      end if;
      -- Tip: use rather the TGA format: single compression, better with LZMA in the Zip archive.
      Try_image_type(tex_name & ".PNG");
      if found then
        return;
      end if;
      -- Tip: use rather the TGA format: single, better compression in the Zip archive.
      Try_image_type(tex_name & ".GIF");
    exception
      when Zip.Zip_file_open_Error =>
        null;
    end Try_archive;
  begin
    Try_archive( zif_level, S(level_data_name) );
    if found then
      return;
    end if;
    Try_archive( zif_global, S(global_data_name) );
    if found then
      return;
    end if;
    -- Never found - neither in level, nor in global pack
    raise Missing_texture with "texture: " & tex_name;
  end Load_texture_2D;

  function Valid_texture_ID(id: Image_ID) return Boolean is
  begin
    return id in null_image+1 .. texture_2d_infos.last_entry_in_use;
  end Valid_texture_ID;

  procedure Check_2D_texture(id: Image_ID; blending_hint: out Boolean) is
  begin
    if not Valid_texture_ID(id) then
      raise Undefined_texture_ID with "ID =" & Image_ID'Image(id);
    end if;
    if texture_2d_infos.tex(id).loaded then
      --  Already loaded. We recall the information we had at loading time.
      blending_hint:= texture_2d_infos.tex(id).blending_hint;
    else
      Load_texture_2D(id, blending_hint);
      texture_2d_infos.tex(id).loaded:= True;
      texture_2d_infos.tex(id).blending_hint:= blending_hint;
    end if;
  end Check_2D_texture;

  procedure Check_2D_texture(id: Image_ID) is
    junk_blending_hint: Boolean;
    pragma Warnings(off, junk_blending_hint);
  begin
    Check_2D_texture(id,junk_blending_hint);
  end Check_2D_texture;

  procedure Check_all_textures is
  begin
    for i in null_image+1 .. texture_2d_infos.last_entry_in_use loop
      Check_2D_texture(i);
    end loop;
  end Check_all_textures;

  procedure Reset_textures is
  begin
    if texture_2d_infos.tex /= null then
      Dispose(texture_2d_infos.tex);
    end if;
    texture_2d_infos:= empty_texture_2d_infos;
  end Reset_textures;

  procedure Add_texture_name( name: String; id: out Image_ID ) is
    new_tab: p_Texture_info_array;
    up_name: constant String:= To_Upper(name);
    -- Convention: UPPER_CASE for identifiers
    n_id: Ident:= empty;
    pos: Texture_Name_Mapping.Cursor;
    success: Boolean;
  begin
    if texture_2d_infos.tex = null then
      texture_2d_infos.tex:= new Texture_info_array(0..100);
    end if;
    if texture_2d_infos.last_entry_in_use >= texture_2d_infos.tex'Last then
      -- We need to enlarge the table: we double it...
      new_tab:= new Texture_info_array(0..texture_2d_infos.tex'Last * 2);
      new_tab(texture_2d_infos.tex'Range):= texture_2d_infos.tex.all;
      Dispose(texture_2d_infos.tex);
      texture_2d_infos.tex:= new_tab;
    end if;
    id:= texture_2d_infos.last_entry_in_use + 1;
    for i in up_name'Range loop
      n_id(n_id'First + i - up_name'First):= up_name(i);
    end loop;
    texture_2d_infos.tex(id).name:= n_id;
    texture_2d_infos.last_entry_in_use:=
      Image_ID'Max(texture_2d_infos.last_entry_in_use, id);
    -- Feed the name dictionary with the new name:
    Texture_Name_Mapping.Insert(
      texture_2d_infos.map,
      U(up_name),
      id,
      pos,
      success
    );
    if not success then -- A.18.4. 45/2
      raise Duplicate_name with name & ", already stored as " & up_name;
    end if;
  end Add_texture_name;

  procedure Register_textures_from_resources is

    procedure Register( zif: in out Zip.Zip_info; name: String ) is
      --
      procedure Action( name: String ) is
        dummy: Image_ID;
        ext: constant String:= To_Upper(name(name'Last-3..name'Last));
      begin
        if ext = ".BMP" or else ext = ".TGA"
          or else ext = ".JPG" or else ext = "JPEG"
          or else ext = ".GIF" or else ext = ".PNG"
        then
          Add_texture_name(name(name'First..name'Last-4), dummy);
        end if;
      end Action;
      --
      procedure Traverse is new Zip.Traverse(Action);
    begin
      Load_if_needed( zif, name );
      Traverse(zif);
      -- That's it!
    exception
      when Zip.Zip_file_open_Error =>
        null;
    end Register;

  begin
    Register( zif_level,  S(level_data_name) );
    Register( zif_global, S(global_data_name) );
  end Register_textures_from_resources;

  procedure Associate_textures is
    dummy: Image_ID;
  begin
    Reset_textures;
    for t in Texture_enum loop
      Add_texture_name( Texture_enum'Image(t), dummy );
    end loop;
  end Associate_textures;

  function Texture_name( id: Image_ID; trim: Boolean ) return Ident is
    tn: Ident;
  begin
    if not Valid_texture_ID(id) then
      raise Undefined_texture_ID with "ID =" & Image_ID'Image(id);
    end if;
    tn:= texture_2d_infos.tex(id).name;
    if trim then
      return Ada.Strings.Fixed.Trim(tn,Right);
    else
      return tn;
    end if;
  end Texture_name;

  function Texture_ID( name: String ) return Image_ID is
    trimmed: constant String:= Trim(name,Both);
    up_name: constant String:= To_Upper(trimmed);
    use Texture_Name_Mapping;
    c: constant Cursor:= texture_2d_infos.map.Find(U(up_name));
  begin
    if c = No_Element then
      -- Key not found
      raise Texture_name_not_found with
        "Texture: " & trimmed & ", searched as " & up_name & "." &
        ASCII.CR & ASCII.LF &
        "Check data files:" &
        ASCII.CR & ASCII.LF &
        "  - " & S(global_data_name) &
        ASCII.CR & ASCII.LF &
        "  - " & S(level_data_name) & '.' &
        ASCII.CR & ASCII.LF &
        "Or, check calls to Add_texture_name or Associate_textures." &
        ASCII.CR & ASCII.LF &
        "Or look if Register_textures_from_resources has browsed the right file extensions.";
    else
      return Element(c);
    end if;
  end Texture_ID;

end GLOBE_3D.Textures;

GLOBE_3D: Ada library for real-time 3D rendering. Ada programming.