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