with Ada.Real_Time; use Ada.Real_Time;
with Ada.Streams; use Ada.Streams;
with Associations; use Associations;
with Directions; use Directions;
with Interfaces; use Interfaces;
with Objects; use Objects;
with Processes; use Processes;
with Values; use Values;
limited with Worlds;
private with Ada.Containers.Doubly_Linked_Lists;
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 new Unsigned_32;
-- Default value for no entity.
INVALID_ID : constant Entity_Id;
----------------------------------------------------------------------------
-- 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 );
-- 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 );
-- This procedure is called to change the direction the entity is facing.
-- The default implementation is a null procedure so it must be overridden
-- to provide some specific behavior.
procedure Face( this : access Entity; dir : Direction_Type ) is null;
-- 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 A_Association;
pragma Postcondition( Get_Attributes'Result /= null );
-- 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 );
-- 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 this entity is a permanent part of the world and isn't
-- allowed to be deleted. The player, for example, is permanent.
function Is_Permanent( 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.
procedure On_Load( this : access Entity ) is null;
-- 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 : in out A_Value );
pragma Precondition( name'Length > 0 );
pragma Postcondition( val = null );
-- 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 logic for one execution frame. An overriding
-- implementation should call this first.
procedure Tick( this : access Entity; time : Tick_Time );
----------------------------------------------------------------------------
-- Allocates and returns a new Entity instance by class id.
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 );
-- Iterates across the registered entity class ids, matching against a
-- regular expression pattern. If 'pattern' is empty, 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 Tiles.Libraries;
INVALID_ID : constant Entity_Id := Entity_Id'First;
DUPLICATE_ID : exception;
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, "=" );
use Entity_Lists;
----------------------------------------------------------------------------
type Entity is abstract new Object with
record
-- ** this field is assigned on creation **
id : Entity_Id := INVALID_ID;
-- ** these fields are identical for instances of the same class **
permanent : Boolean := False;
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 : A_Association := null; -- entity attributes
-- begin fields not streamed
world : access Worlds.World_Object'Class := null;
grounded : Boolean := False;
touching : Entity_Lists.List;
editingMode : Boolean := False; -- set to True on construction if the
-- entity is in an editing environment
-- end fields not streamed
end record;
-- 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 );
-- Raises COPY_NOT_ALLOWED.
procedure Adjust( this : access Entity );
procedure Delete( this : in out Entity );
-- 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 ) 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 );
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;