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