1. with Ada.Unchecked_Deallocation; 
  2. with Allegro.Bitmaps;                   use Allegro.Bitmaps; 
  3. with Ada.Real_Time;                     use Ada.Real_Time; 
  4. with Ada.Streams;                       use Ada.Streams; 
  5. with Objects;                           use Objects; 
  6. with Physics;                           use Physics; 
  7.  
  8. private with Ada.Containers.Doubly_Linked_Lists; 
  9. private with Ada.Strings.Unbounded; 
  10. private with Archives; 
  11. private with Locking_Objects; 
  12. private with Resources; 
  13.  
  14. package Tiles is 
  15.  
  16.     procedure Initialize; 
  17.  
  18.     procedure Finalize; 
  19.  
  20.     ---------------------------------------------------------------------------- 
  21.  
  22.     type Tile_Id_Array is array (Integer range <>) of Natural; 
  23.     type A_Tile_Id_Array is access all Tile_Id_Array; 
  24.  
  25.     function A_Tile_Id_Array_Input( stream : access Root_Stream_Type'Class ) return A_Tile_Id_Array; 
  26.     for A_Tile_Id_Array'Input use A_Tile_Id_Array_Input; 
  27.  
  28.     procedure A_Tile_Id_Array_Output( stream : access Root_Stream_Type'Class; tia : A_Tile_Id_Array ); 
  29.     for A_Tile_Id_Array'Output use A_Tile_Id_Array_Output; 
  30.  
  31.     function Copy( src : A_Tile_Id_Array ) return A_Tile_Id_Array; 
  32.     pragma Postcondition( Copy'Result /= src or else src = null ); 
  33.  
  34.     procedure Delete is new Ada.Unchecked_Deallocation( Tile_Id_Array, A_Tile_Id_Array ); 
  35.  
  36.     ---------------------------------------------------------------------------- 
  37.  
  38.     type Tile_Object is abstract new Object with private; 
  39.     type A_Tile is access all Tile_Object'Class; 
  40.  
  41.     -- Creates a new tile using register allocator. Returns null if no allocator 
  42.     -- has been registered. 
  43.     function Create_Tile return A_Tile; 
  44.  
  45.     -- Returns the animation frame delay for the tile. 
  46.     function Get_Anm_Delay( this : not null access Tile_Object'Class ) return Time_Span; 
  47.  
  48.     -- Returns the id of the tile within its library. 
  49.     function Get_Id( this : not null access Tile_Object'Class ) return Natural; 
  50.  
  51.     -- Returns the name of the tile within its library. 
  52.     function Get_Name( this : not null access Tile_Object'Class ) return String; 
  53.  
  54.     -- Returns the id of the next frame in the tile's animation if it's a frame 
  55.     -- in a single shot animation. 
  56.     function Get_Next_Frame( this : not null access Tile_Object'Class ) return Natural; 
  57.  
  58.     -- Returns a reference to the tile's looped animation frame list, or null if 
  59.     -- the tile does not have a looping animation. Do not delete the array, it 
  60.     -- belongs to the tile. 
  61.     function Get_Frame_List( this : not null access Tile_Object'Class ) return A_Tile_Id_Array; 
  62.  
  63.     -- Returns True if the file is animated. 
  64.     function Is_Animated( this : not null access Tile_Object'Class ) return Boolean; 
  65.  
  66.     function Object_Input( stream : access Root_Stream_Type'Class ) return Tile_Object is abstract; 
  67.  
  68.     procedure Object_Output( stream : access Root_Stream_Type'Class; obj : Tile_Object ) is abstract; 
  69.  
  70.     -- Sets an attribute on the tile by name. Only certain attribute names are 
  71.     -- supported and each has its own value constraints. False is returned in 
  72.     -- 'found' if the attribute name is not recognized. An exception is raised 
  73.     -- if the value is invalid or if there is a semantic error caused by setting 
  74.     -- the attribute. 
  75.     procedure Set_Attribute( this  : in out Tile_Object; 
  76.                              found : out Boolean; 
  77.                              name  : String; 
  78.                              val   : String := "" ); 
  79.  
  80.     -- Sets the id of the tile. 
  81.     procedure Set_Id( this : access Tile_Object; id : Natural ); 
  82.  
  83.     -- Sets the name of the tile. 
  84.     procedure Set_Name( this : access Tile_Object; name : String ); 
  85.     pragma Precondition( name'Length > 0 ); 
  86.  
  87.     -- Deletes the tile. 
  88.     procedure Delete( this : in out A_Tile ); 
  89.     pragma Postcondition( this = null ); 
  90.  
  91.     ATTRIBUTE_ERROR : exception; 
  92.  
  93. private 
  94.  
  95.     use Ada.Strings.Unbounded; 
  96.     use Archives; 
  97.     use Locking_Objects; 
  98.     use Resources; 
  99.  
  100.     ---------------------------------------------------------------------------- 
  101.  
  102.     type Tile_Object is abstract new Object with 
  103.         record 
  104.             id        : Natural := 0; 
  105.             name      : Unbounded_String; 
  106.  
  107.             lock      : A_Locking_Object := null;    -- protects bmp, priority 
  108.             bmp       : A_Bitmap := null; 
  109.             priority  : Integer := 0; 
  110.  
  111.             loadState : A_Async_Operation := null; 
  112.             clipping  : Clip_Type := Passive; 
  113.             anmDelay  : Time_Span := Time_Span_Zero; -- animation frame delay in ms 
  114.             nextFrame : Natural := 0;                -- tile id of next frame in one-shot animation 
  115.             frames    : A_Tile_Id_Array := null;     -- tile id list in looping animation 
  116.         end record; 
  117.  
  118.     -- Raises COPY_NOT_ALLOWED. 
  119.     procedure Adjust( this : access Tile_Object ); 
  120.  
  121.     procedure Construct( this : access Tile_Object ); 
  122.  
  123.     procedure Delete( this : in out Tile_Object ); 
  124.  
  125.     -- Returns null if the tile's bitmap file isn't found or hasn't loaded yet. 
  126.     function Get_Bitmap( this : not null access Tile_Object'Class ) return A_Bitmap; 
  127.  
  128.     -- Returns the physics clipping type that the tile represents. 
  129.     function Get_Clipping( this : not null access Tile_Object'Class ) return Clip_Type; 
  130.  
  131.     -- Returns True if the tile's bitmap has been loaded, successfully or otherwise. 
  132.     function Is_Loaded( this : not null access Tile_Object'Class ) return Boolean; 
  133.  
  134.     -- Loads the tile's bitmap from an archive. 
  135.     procedure Load_Bitmap( this    : not null access Tile_Object'Class; 
  136.                            archive : not null A_Archive ); 
  137.  
  138.     -- Blocks the caller until the tile's bitmap has been loaded. 
  139.     procedure Wait_For_Load( this : not null access Tile_Object'Class ); 
  140.  
  141.     procedure Object_Read( stream : access Root_Stream_Type'Class; obj : out Tile_Object ); 
  142.     for Tile_Object'Read use Object_Read; 
  143.  
  144.     procedure Object_Write( stream : access Root_Stream_Type'Class; obj : Tile_Object ); 
  145.     for Tile_Object'Write use Object_Write; 
  146.  
  147.     ---------------------------------------------------------------------------- 
  148.  
  149.     function A_Tile_Input( stream : access Root_Stream_Type'Class ) return A_Tile; 
  150.     for A_Tile'Input use A_Tile_Input; 
  151.  
  152.     procedure A_Tile_Output( stream : access Root_Stream_Type'Class; tile : A_Tile ); 
  153.     for A_Tile'Output use A_Tile_Output; 
  154.  
  155.     procedure A_Tile_Read( stream : access Root_Stream_Type'Class; tile : out A_Tile ); 
  156.     for A_Tile'Read use A_Tile_Read; 
  157.  
  158.     procedure A_Tile_Write( stream : access Root_Stream_Type'Class; tile : A_Tile ); 
  159.     for A_Tile'Write use A_Tile_Write; 
  160.  
  161.     ---------------------------------------------------------------------------- 
  162.  
  163.     package Tile_Lists is new Ada.Containers.Doubly_Linked_Lists( A_Tile, "=" ); 
  164.     use Tile_Lists; 
  165.  
  166.     ---------------------------------------------------------------------------- 
  167.  
  168.     type Allocator is access function return A_Tile; 
  169.  
  170.     function Tile_Identifier return String; 
  171.     pragma Postcondition( Tile_Identifier'Result'Length > 0 ); 
  172.  
  173.     -- Returns 0 if a tile version has not yet been registered. 
  174.     function Tile_Version return Natural; 
  175.  
  176.     procedure Register_Allocator( allocate : not null Allocator ); 
  177.  
  178.     procedure Register_Identifier( identifier : String ); 
  179.     pragma Precondition( identifier'Length > 0 ); 
  180.  
  181.     procedure Register_Version( version : Positive ); 
  182.  
  183. end Tiles;