--
-- Copyright (c) 2012 Kevin Wellwood
-- All rights reserved.
--
-- This source code is distributed under the Modified BSD License. For terms and
-- conditions, see license.txt.
--
with Ada.Real_Time; use Ada.Real_Time;
with Ada.Streams; use Ada.Streams;
with Directions; use Directions;
with Hashed_Strings; use Hashed_Strings;
with Interfaces; use Interfaces;
with Objects; use Objects;
with Processes; use Processes;
with Values; use Values;
with Values.Associations; use Values.Associations;
with Values.Ids; use Values.Ids;
limited with Worlds;
private with Ada.Containers;
private with Ada.Containers.Doubly_Linked_Lists;
private with Ada.Containers.Hashed_Sets;
private with Object_Factory;
private with Tiles.Libraries;
pragma Elaborate_All( Object_Factory );
package Entities is
-- Uniquely identifies an Entity within a World.
type Entity_Id is private;
-- Default value for no entity.
INVALID_ID : constant Entity_Id;
-- Compares Entity_Id values to support ordering.
function "<"( l, r : Entity_Id ) return Boolean;
-- Returns a string representation of 'id'.
function Image( id : Entity_Id ) return String;
-- Casts an Id value class to an Entity_Id. If 'val' is a null pointer,
-- INVALID_ID will be returned.
function To_Entity_Id( val : Id_Ptr ) return Entity_Id;
-- Casts an Entity_Id to an Id value.
function To_Id_Value( id : Entity_Id ) return Id_Ptr;
pragma Postcondition( To_Id_Value'Result /= Ids.Nul );
----------------------------------------------------------------------------
-- The mode of a directive to the entity, to control behavior.
type Directive_Mode is (Once, Ongoing, Inactive);
type Directive_Type is
record
name : Hashed_String;
mode : Directive_Mode := Once;
end record;
----------------------------------------------------------------------------
-- An Entity represents any distinct object with a location within a World,
-- visible or invisible, physical or static. Each entity in the Game's World
-- is updated by a call to Tick while the game is running.
type Entity is abstract new Object with private;
type A_Entity is access all Entity'Class;
-- Notifies the entity that it is being activated. To implement behavior to
-- handle this event, override On_Activate.
procedure Activate( this : not null access Entity'Class;
activator : not null A_Entity );
-- Cancels all directives currently active for the entity.
procedure Cancel_Directives( this : not null access Entity'Class );
-- Notifies the entity that it has collided with 'e', updating the entity's
-- touch list and calling On_Collide to invoke collision behavior. To add
-- entity behavior to handle a collision event, override On_Collide.
procedure Collided( this : not null access Entity'Class; e : not null A_Entity );
-- Returns a reference to the entity's internal attributes. The reference
-- belongs to the entity, do not delete it!
function Get_Attributes( this : not null access Entity'Class ) return Assoc_Ptr;
pragma Postcondition( Get_Attributes'Result /= Associations.Nul );
-- Returns the direction that the entity is currently facing.
function Get_Direction( this : not null access Entity'Class ) return Direction_Type;
-- Returns the entity's frame as a tile id in the entity's tile library.
function Get_Frame( this : not null access Entity'Class ) return Integer;
-- Returns the entity's physical height in world units.
function Get_Height( this : not null access Entity'Class ) return Integer;
-- Returns the entity's unique id.
function Get_Id( this : not null access Entity'Class ) return Entity_Id;
-- Returns the name of the entity's tile library. This does not change over
-- the lifetime of the object.
function Get_Lib_Name( this : not null access Entity'Class ) return String;
-- Returns the entity's physical width in world units.
function Get_Width( this : not null access Entity'Class ) return Integer;
-- Returns the X location of the center of the entity in world coordinates.
function Get_X( this : not null access Entity'Class ) return Float;
-- Returns the X velocity of the entity in world units.
function Get_XV( this : not null access Entity'Class ) return Float;
-- Returns the Y location of the center of the entity in world coordinates.
function Get_Y( this : not null access Entity'Class ) return Float;
-- Returns the Y velocity of the entity in world units.
function Get_YV( this : not null access Entity'Class ) return Float;
-- Notifies the entity that it hit a wall. To implement behavior to handle
-- this event, override On_Hit_Wall.
procedure Hit_Wall( this : not null access Entity'Class;
dir : Cardinal_Direction;
firstContact : Boolean );
-- Returns True if the entity is clipped to the walls in the world.
function Is_Clipped( this : not null access Entity'Class ) return Boolean;
-- Returns True if the entity is invisible, existing metaphysically.
function Is_Metaphysical( this : not null access Entity'Class ) return Boolean;
-- Returns True if the entity is subject to the laws of physics.
function Is_Physical( this : not null access Entity'Class ) return Boolean;
-- Reads an entity object from a stream and returns it. All concrete Entity
-- subclasses must implement this function.
function Object_Input( stream : access Root_Stream_Type'Class ) return Entity is abstract;
-- Override this procedure to implement behavior for when the entity's world
-- is loaded from disk. On_Load is invoked once over the life of the object
-- and before its logic is executed. The overriding implementation should
-- call this first.
procedure On_Load( this : access Entity );
-- Notifies the entity that it has separated with 'e', updating the entity's
-- touch list and calling On_Separate to invoke separation behavior. To
-- implement behavior to handle this event, override On_Separate.
procedure Separated( this : not null access Entity'Class; e : not null A_Entity );
-- Sets an attribute of this entity. An Entity_Attribute_Changed event will
-- be queued.
procedure Set_Attribute( this : access Entity;
name : String;
val : Value_Ptr'Class );
pragma Precondition( name'Length > 0 );
pragma Precondition( Value_Ptr(val) /= Values.Nul );
-- Sets a directive (ex: from the player via input) to control the entity's
-- behavior. The entity can check the state of a directive during its Tick()
-- and act on it appropriately. If 'mode' is Ongoing, 'directive' will be
-- activate until 'directive' is set again, as Inactive. If 'mode' is 'Once'
-- then the directive will automatically become inactive after the next
-- Tick().
procedure Set_Directive( this : not null access Entity;
directive : Hashed_String;
mode : Directive_Mode );
-- Sets the grounded state of the entity. If 'grounded' is True, the entity
-- is resting on the ground. The entity's frame will be updated.
procedure Set_Grounded( this : not null access Entity'Class; grounded : Boolean );
-- Sets the entity's location without sending an event.
procedure Set_Location( this : not null access Entity'Class; x, y : Float );
-- Sets the entity's physical size without sending an event.
procedure Set_Size( this : not null access Entity'Class;
width,
height : Natural );
-- Sets the entity's reference to the world in which it exists. An exception
-- will be raised if the entity already has a world reference because it
-- cannot be transplanted between worlds.
procedure Set_World( this : not null access Entity'Class;
world : not null access Worlds.World_Object'Class );
-- Sets the entity's X velocity in world units without sending an event. The
-- entity's frame will be updated.
procedure Set_Velocity_X( this : not null access Entity'Class; xv : Float );
-- Sets the entity's Y velocity in world units without sending an event. The
-- entity's frame will be updated.
procedure Set_Velocity_Y( this : not null access Entity'Class; yv : Float );
-- Runs the entity for one execution frame. To implement the logic that
-- simulates behavior and responds to directives, override Update(). Do not
-- override this procedure.
procedure Tick( this : access Entity; time : Tick_Time );
-- Updates the entity, based on its directives and current state. This is
-- the procedure to override to implement entity behavior. 'time' is the
-- amount of time elapsed since the previous update.
procedure Update( this : access Entity; time : Tick_Time ) is null;
----------------------------------------------------------------------------
-- Allocates and returns a new Entity instance by class id. Null will be
-- returned if 'id' is not a recognized entity class.
function Allocate( id : String ) return A_Entity;
pragma Precondition( id'Length > 0 );
-- Entities can't be copied; Raises COPY_NOT_ALLOWED.
function Copy( src : A_Entity ) return A_Entity;
pragma Postcondition( Copy'Result /= src or else src = null );
-- Deletes an entity.
procedure Delete( this : in out A_Entity );
pragma Postcondition( this = null );
-- Returns True if class 'id' is a class id that matches the regular
-- expression 'pattern' (case insensitive). For example, to determine if
-- 'Entities.Enemies.Cat' is an enemy entity class, you can check if it
-- is in the class pattern 'Entities.Enemies.*'.
function In_Class( id : String; pattern : String ) return Boolean;
-- Iterates across the registered entity class ids, matching against a
-- globbing regular expression 'pattern'. If 'pattern' is an empty string,
-- all classes will be iterated.
procedure Iterate_Classes( pattern : String;
examine : access procedure( id : String ) );
-- Returns a reference to a template Entity instance for the given class id
-- or null, if 'id' is not a registered class. Do not modify the object!
function Template( id : String ) return A_Entity;
pragma Precondition( id'Length > 0 );
----------------------------------------------------------------------------
-- Initializes the Entity factory.
procedure Initialize;
-- Finalizes the Entity factory.
procedure Finalize;
private
use Ada.Containers;
use Tiles.Libraries;
type Entity_Id is new Unsigned_64;
INVALID_ID : constant Entity_Id := Entity_Id'First;
DUPLICATE_ID : exception;
----------------------------------------------------------------------------
function Eq( l : Directive_Type; r : Directive_Type ) return Boolean;
function Hash( d : Directive_Type ) return Hash_Type;
package Directive_Sets is new Ada.Containers.Hashed_Sets(Directive_Type, Hash, Eq);
----------------------------------------------------------------------------
function A_Entity_Input( stream : access Root_Stream_Type'Class ) return A_Entity;
for A_Entity'Input use A_Entity_Input;
procedure A_Entity_Output( stream : access Root_Stream_Type'Class; obj : A_Entity );
for A_Entity'Output use A_Entity_Output;
procedure A_Entity_Read( stream : access Root_Stream_Type'Class; obj : out A_Entity );
for A_Entity'Read use A_Entity_Read;
procedure A_Entity_Write( stream : access Root_Stream_Type'Class; obj : A_Entity );
for A_Entity'Write use A_Entity_Write;
package Entity_Lists is new Ada.Containers.Doubly_Linked_Lists( A_Entity, "=" );
----------------------------------------------------------------------------
type Entity is abstract new Object with
record
-- ** this field is streamed **
id : Entity_Id := INVALID_ID; -- unique id
-- ** these fields are identical for instances of the same class **
physical : Boolean := True;
metaphysical : Boolean := False;
clipped : Boolean := True;
lib : A_Tile_Library := null;
-- ** these fields are unique to the instance **
-- age of the entity, incremented each Tick
age : Time_Span := Time_Span_Zero;
-- size of the entity in world units (for collision detection)
width,
height : Natural := 0;
-- entity's location in world coordinates
x,
y : Float := 0.0;
-- entity's velocity in world units per second
xv,
yv : Float := 0.0;
-- the direction the entity is facing or acting
dir : Direction_Type := Dir_Left;
frame : Natural := 0;
attrs : Assoc_Ptr; -- entity attributes
-- begin fields not streamed
world : access Worlds.World_Object'Class := null;
grounded : Boolean := False;
touching : Entity_Lists.List;
directives : Directive_Sets.Set;
editingMode : Boolean := False; -- set to True on construction if the
-- entity is in an editing environment
-- end fields not streamed
end record;
-- Raises COPY_NOT_ALLOWED.
procedure Adjust( this : access Entity );
-- Constructs the Entity. 'width' and 'height' are the physical height in
-- world units. 'libName' is the name of the tile library containing the
-- sprites for the entity.
procedure Construct( this : access Entity;
width,
height : Natural;
libName : String );
procedure Delete( this : in out Entity );
-- Returns True if directive 'name' is currently active.
function Directive( this : not null access Entity'Class;
name : Hashed_String ) return Boolean;
-- Iterates over all entities that this entity is currently touching, calling
-- the examine procedure for each. Null will never be passed to 'examine'.
procedure Iterate_Touching( this : not null access Entity'Class;
examine : not null access procedure( e : A_Entity ) );
-- Override this procedure to implement behavior for when this entity is
-- activated by another entity, 'activator'.
procedure On_Activate( this : access Entity; activator : not null A_Entity ) is null;
-- Override this procedure to implement behavior for when this entity
-- collides with another entity, 'e'.
procedure On_Collide( this : access Entity; e : not null A_Entity ) is null;
-- Override this procedure to implement behavior for when this entity runs
-- into a wall.
procedure On_Hit_Wall( this : access Entity;
dir : Cardinal_Direction;
firstContact : Boolean ) is null;
-- Override this procedure to implement behavior for when this entity
-- separates from another entity, 'e'.
procedure On_Separate( this : access Entity; e : not null A_Entity ) is null;
-- Sets the entity's current frame. If 'notify' is True, a Frame_Changed
-- event will be queued if the new frame is different.
procedure Set_Frame( this : not null access Entity'Class;
frame : Natural;
notify : Boolean := True );
-- Returns a string representation of the Entity for debugging purposes.
function To_String( this : access Entity ) return String;
-- Determines the entity's current frame using its current state. If
-- 'notify' is True, a Frame_Changed event will be queued if the frame
-- changes.
procedure Update_Frame( this : access Entity; notify : Boolean := True ) is null;
procedure Object_Read( stream : access Root_Stream_Type'Class; obj : out Entity );
for Entity'Read use Object_Read;
procedure Object_Write( stream : access Root_Stream_Type'Class; obj : Entity );
for Entity'Write use Object_Write;
----------------------------------------------------------------------------
package Factory is new Object_Factory( Entity, A_Entity, Delete );
end Entities;