1. with Ada.Real_Time;                     use Ada.Real_Time; 
  2. with Ada.Streams;                       use Ada.Streams; 
  3. with Associations;                      use Associations; 
  4. with Directions;                        use Directions; 
  5. with Interfaces;                        use Interfaces; 
  6. with Objects;                           use Objects; 
  7. with Processes;                         use Processes; 
  8. with Values;                            use Values; 
  9.  
  10. limited with Worlds; 
  11.  
  12. private with Ada.Containers.Doubly_Linked_Lists; 
  13. private with Object_Factory; 
  14. private with Tiles.Libraries; 
  15.  
  16. pragma Elaborate_All( Object_Factory ); 
  17.  
  18. package Entities is 
  19.  
  20.     -- Uniquely identifies an Entity within a World. 
  21.     type Entity_Id is private; 
  22.  
  23.     -- Default value for no entity. 
  24.     INVALID_ID : constant Entity_Id; 
  25.  
  26.     -- Compares Entity_Id values to support ordering. 
  27.     function "<"( l, r : Entity_Id ) return Boolean; 
  28.  
  29.     -- Returns a string representation of 'id'. 
  30.     function Image( id : Entity_Id ) return String; 
  31.  
  32.     ---------------------------------------------------------------------------- 
  33.  
  34.     -- An Entity represents any distinct object with a location within a World, 
  35.     -- visible or invisible, physical or static. Each entity in the Game's World 
  36.     -- is updated by a call to Tick while the game is running. 
  37.     type Entity is abstract new Object with private; 
  38.     type A_Entity is access all Entity'Class; 
  39.  
  40.     -- Notifies the entity that it is being activated. To implement behavior to 
  41.     -- handle this event, override On_Activate. 
  42.     procedure Activate( this      : not null access Entity'Class; 
  43.                         activator : not null A_Entity ); 
  44.  
  45.     -- Notifies the entity that it has collided with 'e', updating the entity's 
  46.     -- touch list and calling On_Collide to invoke collision behavior. To add 
  47.     -- entity behavior to handle a collision event, override On_Collide. 
  48.     procedure Collided( this : not null access Entity'Class; e : not null A_Entity ); 
  49.  
  50.     -- This procedure is called to change the direction the entity is facing. 
  51.     -- The default implementation is a null procedure so it must be overridden 
  52.     -- to provide some specific behavior. 
  53.     procedure Face( this : access Entity; dir : Direction_Type ) is null; 
  54.  
  55.     -- Returns a reference to the entity's internal attributes. The reference 
  56.     -- belongs to the entity, do not delete it! 
  57.     function Get_Attributes( this : not null access Entity'Class ) return A_Association; 
  58.     pragma Postcondition( Get_Attributes'Result /= null ); 
  59.  
  60.     -- Returns the direction that the entity is currently facing. 
  61.     function Get_Direction( this : not null access Entity'Class ) return Direction_Type; 
  62.  
  63.     -- Returns the entity's frame as a tile id in the entity's tile library. 
  64.     function Get_Frame( this : not null access Entity'Class ) return Integer; 
  65.  
  66.     -- Returns the entity's physical height in world units. 
  67.     function Get_Height( this : not null access Entity'Class ) return Integer; 
  68.  
  69.     -- Returns the entity's unique id. 
  70.     function Get_Id( this : not null access Entity'Class ) return Entity_Id; 
  71.  
  72.     -- Returns the name of the entity's tile library. This does not change over 
  73.     -- the lifetime of the object. 
  74.     function Get_Lib_Name( this : not null access Entity'Class ) return String; 
  75.  
  76.     -- Returns the entity's physical width in world units. 
  77.     function Get_Width( this : not null access Entity'Class ) return Integer; 
  78.  
  79.     -- Returns the X location of the center of the entity in world coordinates. 
  80.     function Get_X( this : not null access Entity'Class ) return Float; 
  81.  
  82.     -- Returns the X velocity of the entity in world units. 
  83.     function Get_XV( this : not null access Entity'Class ) return Float; 
  84.  
  85.     -- Returns the Y location of the center of the entity in world coordinates. 
  86.     function Get_Y( this : not null access Entity'Class ) return Float; 
  87.  
  88.     -- Returns the Y velocity of the entity in world units. 
  89.     function Get_YV( this : not null access Entity'Class ) return Float; 
  90.  
  91.     -- Notifies the entity that it hit a wall. To implement behavior to handle 
  92.     -- this event, override On_Hit_Wall. 
  93.     procedure Hit_Wall( this         : not null access Entity'Class; 
  94.                         dir          : Cardinal_Direction; 
  95.                         firstContact : Boolean ); 
  96.  
  97.     -- Returns True if the entity is clipped to the walls in the world. 
  98.     function Is_Clipped( this : not null access Entity'Class ) return Boolean; 
  99.  
  100.     -- Returns True if this entity is a permanent part of the world and isn't 
  101.     -- allowed to be deleted. The player, for example, is permanent. 
  102.     function Is_Permanent( this : not null access Entity'Class ) return Boolean; 
  103.  
  104.     -- Returns True if the entity is invisible, existing metaphysically. 
  105.     function Is_Metaphysical( this : not null access Entity'Class ) return Boolean; 
  106.  
  107.     -- Returns True if the entity is subject to the laws of physics. 
  108.     function Is_Physical( this : not null access Entity'Class ) return Boolean; 
  109.  
  110.     -- Reads an entity object from a stream and returns it. All concrete Entity 
  111.     -- subclasses must implement this function. 
  112.     function Object_Input( stream : access Root_Stream_Type'Class ) return Entity is abstract; 
  113.  
  114.     -- Override this procedure to implement behavior for when the entity's world 
  115.     -- is loaded from disk. On_Load is invoked once over the life of the object 
  116.     -- and before its logic is executed. The overriding implementation should 
  117.     -- call this first. 
  118.     procedure On_Load( this : access Entity ); 
  119.  
  120.     -- Notifies the entity that it has separated with 'e', updating the entity's 
  121.     -- touch list and calling On_Separate to invoke separation behavior. To 
  122.     -- implement behavior to handle this event, override On_Separate. 
  123.     procedure Separated( this : not null access Entity'Class; e : not null A_Entity ); 
  124.  
  125.     -- Sets an attribute of this entity. An Entity_Attribute_Changed event will 
  126.     -- be queued. 
  127.     procedure Set_Attribute( this : access Entity; 
  128.                              name : String; 
  129.                              val  : in out A_Value ); 
  130.     pragma Precondition( name'Length > 0 ); 
  131.     pragma Postcondition( val = null ); 
  132.  
  133.     -- Sets the grounded state of the entity. If 'grounded' is True, the entity 
  134.     -- is resting on the ground. The entity's frame will be updated. 
  135.     procedure Set_Grounded( this : not null access Entity'Class; grounded : Boolean ); 
  136.  
  137.     -- Sets the entity's location without sending an event. 
  138.     procedure Set_Location( this : not null access Entity'Class; x, y : Float ); 
  139.  
  140.     -- Sets the entity's physical size without sending an event. 
  141.     procedure Set_Size( this   : not null access Entity'Class; 
  142.                         width, 
  143.                         height : Natural ); 
  144.  
  145.     -- Sets the entity's reference to the world in which it exists. An exception 
  146.     -- will be raised if the entity already has a world reference because it 
  147.     -- cannot be transplanted between worlds. 
  148.     procedure Set_World( this  : not null access Entity'Class; 
  149.                          world : not null access Worlds.World_Object'Class ); 
  150.  
  151.     -- Sets the entity's X velocity in world units without sending an event. The 
  152.     -- entity's frame will be updated. 
  153.     procedure Set_Velocity_X( this : not null access Entity'Class; xv : Float ); 
  154.  
  155.     -- Sets the entity's Y velocity in world units without sending an event. The 
  156.     -- entity's frame will be updated. 
  157.     procedure Set_Velocity_Y( this : not null access Entity'Class; yv : Float ); 
  158.  
  159.     -- Runs the entity logic for one execution frame. An overriding 
  160.     -- implementation should call this first. 
  161.     procedure Tick( this : access Entity; time : Tick_Time ); 
  162.  
  163.     ---------------------------------------------------------------------------- 
  164.  
  165.     -- Allocates and returns a new Entity instance by class id. 
  166.     function Allocate( id : String ) return A_Entity; 
  167.     pragma Precondition( id'Length > 0 ); 
  168.  
  169.     -- Entities can't be copied; Raises COPY_NOT_ALLOWED. 
  170.     function Copy( src : A_Entity ) return A_Entity; 
  171.     pragma Postcondition( Copy'Result /= src or else src = null ); 
  172.  
  173.     -- Deletes an entity. 
  174.     procedure Delete( this : in out A_Entity ); 
  175.     pragma Postcondition( this = null ); 
  176.  
  177.     -- Returns True if class 'id' is a class id that matches the regular 
  178.     -- expression 'pattern' (case insensitive). For example, to determine if 
  179.     -- 'Entities.Enemies.Cat' is an enemy entity class, you can check if it 
  180.     -- is in the class pattern 'Entities.Enemies.*'. 
  181.     function In_Class( id : String; pattern : String ) return Boolean; 
  182.  
  183.     -- Iterates across the registered entity class ids, matching against a 
  184.     -- regular expression pattern. If 'pattern' is empty, all classes will be 
  185.     -- iterated. 
  186.     procedure Iterate_Classes( pattern : String := ""; 
  187.                                examine : access procedure( id : String ) ); 
  188.  
  189.     -- Returns a reference to a template Entity instance for the given class id 
  190.     -- or null, if 'id' is not a registered class. Do not modify the object! 
  191.     function Template( id : String ) return A_Entity; 
  192.     pragma Precondition( id'Length > 0 ); 
  193.  
  194.     ---------------------------------------------------------------------------- 
  195.  
  196.     -- Initializes the Entity factory. 
  197.     procedure Initialize; 
  198.  
  199.     -- Finalizes the Entity factory. 
  200.     procedure Finalize; 
  201.  
  202. private 
  203.  
  204.     use Tiles.Libraries; 
  205.  
  206.     type Entity_Id is new Unsigned_64; 
  207.  
  208.     INVALID_ID   : constant Entity_Id := Entity_Id'First; 
  209.     DUPLICATE_ID : exception; 
  210.  
  211.     function A_Entity_Input( stream : access Root_Stream_Type'Class ) return A_Entity; 
  212.     for A_Entity'Input use A_Entity_Input; 
  213.  
  214.     procedure A_Entity_Output( stream : access Root_Stream_Type'Class; obj : A_Entity ); 
  215.     for A_Entity'Output use A_Entity_Output; 
  216.  
  217.     procedure A_Entity_Read( stream : access Root_Stream_Type'Class; obj : out A_Entity ); 
  218.     for A_Entity'Read use A_Entity_Read; 
  219.  
  220.     procedure A_Entity_Write( stream : access Root_Stream_Type'Class; obj : A_Entity ); 
  221.     for A_Entity'Write use A_Entity_Write; 
  222.  
  223.     package Entity_Lists is new Ada.Containers.Doubly_Linked_Lists( A_Entity, "=" ); 
  224.     use Entity_Lists; 
  225.  
  226.     ---------------------------------------------------------------------------- 
  227.  
  228.     type Entity is abstract new Object with 
  229.         record 
  230.             -- ** this field is streamed ** 
  231.             id : Entity_Id := INVALID_ID;      -- unique id 
  232.  
  233.             -- ** these fields are identical for instances of the same class ** 
  234.             permanent    : Boolean := False; 
  235.             physical     : Boolean := True; 
  236.             metaphysical : Boolean := False; 
  237.             clipped      : Boolean := True; 
  238.             lib          : A_Tile_Library := null; 
  239.  
  240.             -- ** these fields are unique to the instance ** 
  241.  
  242.             -- age of the entity, incremented each Tick 
  243.             age : Time_Span := Time_Span_Zero; 
  244.  
  245.             -- size of the entity in world units (for collision detection) 
  246.             width, 
  247.             height : Natural := 0; 
  248.  
  249.             -- entity's location in world coordinates 
  250.             x, 
  251.             y : Float := 0.0; 
  252.  
  253.             -- entity's velocity in world units per second 
  254.             xv, 
  255.             yv : Float := 0.0; 
  256.  
  257.             -- the direction the entity is facing or acting 
  258.             dir : Direction_Type := Dir_Left; 
  259.  
  260.             frame : Natural := 0; 
  261.             attrs : A_Association := null;     -- entity attributes 
  262.  
  263.             -- begin fields not streamed 
  264.             world       : access Worlds.World_Object'Class := null; 
  265.             grounded    : Boolean := False; 
  266.             touching    : Entity_Lists.List; 
  267.             editingMode : Boolean := False;   -- set to True on construction if the 
  268.                                               -- entity is in an editing environment 
  269.             -- end fields not streamed 
  270.  
  271.         end record; 
  272.  
  273.     -- Constructs the Entity. 'width' and 'height' are the physical height in 
  274.     -- world units. 'libName' is the name of the tile library containing the 
  275.     -- sprites for the entity. 
  276.     procedure Construct( this    : access Entity; 
  277.                          width, 
  278.                          height  : Natural; 
  279.                          libName : String ); 
  280.  
  281.     -- Raises COPY_NOT_ALLOWED. 
  282.     procedure Adjust( this : access Entity ); 
  283.  
  284.     procedure Delete( this : in out Entity ); 
  285.  
  286.     -- Iterates over all entities that this entity is currently touching, calling 
  287.     -- the examine procedure for each. Null will never be passed to 'examine'. 
  288.     procedure Iterate_Touching( this    : not null access Entity'Class; 
  289.                                 examine : not null access procedure( e : A_Entity ) ); 
  290.  
  291.     -- Override this procedure to implement behavior for when this entity is 
  292.     -- activated by another entity, 'activator'. 
  293.     procedure On_Activate( this : access Entity; activator : not null A_Entity ) is null; 
  294.  
  295.     -- Override this procedure to implement behavior for when this entity 
  296.     -- collides with another entity, 'e'. 
  297.     procedure On_Collide( this : access Entity; e : not null A_Entity ) is null; 
  298.  
  299.     -- Override this procedure to implement behavior for when this entity runs 
  300.     -- into a wall. 
  301.     procedure On_Hit_Wall( this         : access Entity; 
  302.                            dir          : Cardinal_Direction; 
  303.                            firstContact : Boolean ) is null; 
  304.  
  305.     -- Override this procedure to implement behavior for when this entity 
  306.     -- separates from another entity, 'e'. 
  307.     procedure On_Separate( this : access Entity; e : not null A_Entity ) is null; 
  308.  
  309.     -- Sets the entity's current frame. If 'notify' is True, a Frame_Changed 
  310.     -- event will be queued if the new frame is different. 
  311.     procedure Set_Frame( this   : not null access Entity'Class; 
  312.                          frame  : Natural; 
  313.                          notify : Boolean := True ); 
  314.  
  315.     -- Returns a string representation of the Entity for debugging purposes. 
  316.     function To_String( this : access Entity ) return String; 
  317.  
  318.     -- Determines the entity's current frame using its current state. If 
  319.     -- 'notify' is True, a Frame_Changed event will be queued if the frame 
  320.     -- changes. 
  321.     procedure Update_Frame( this : access Entity; notify : Boolean := True ); 
  322.  
  323.     procedure Object_Read( stream : access Root_Stream_Type'Class; obj : out Entity ); 
  324.     for Entity'Read use Object_Read; 
  325.  
  326.     procedure Object_Write( stream : access Root_Stream_Type'Class; obj : Entity ); 
  327.     for Entity'Write use Object_Write; 
  328.  
  329.     ---------------------------------------------------------------------------- 
  330.  
  331.     package Factory is new Object_Factory( Entity, A_Entity, Delete ); 
  332.  
  333. end Entities;