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