1159 lines
32 KiB
Ada
1159 lines
32 KiB
Ada
with
|
|
gel.hinge_Joint,
|
|
gel. any_Joint,
|
|
gel.World,
|
|
|
|
ada.Tags,
|
|
ada.unchecked_Deallocation,
|
|
ada.unchecked_Conversion;
|
|
|
|
package body gel.Sprite
|
|
is
|
|
use ada.Tags,
|
|
linear_Algebra_3D;
|
|
|
|
|
|
procedure log (Message : in String)
|
|
-- renames ada.text_IO.put_Line;
|
|
is null;
|
|
|
|
|
|
------------------
|
|
--- Initialisation
|
|
--
|
|
|
|
procedure rebuild_Shape (Self : in out Item)
|
|
is
|
|
use type physics.Model.shape_Kind,
|
|
physics.Model.View;
|
|
|
|
the_Scale : aliased Vector_3;
|
|
|
|
begin
|
|
-- Self.Shape := Self.World.Space.new_Shape (Self.physics_Model);
|
|
|
|
-- Old
|
|
if Self.physics_Model = null then
|
|
return;
|
|
end if;
|
|
|
|
the_Scale := Self.physics_Model.Scale;
|
|
|
|
case Self.physics_Model.shape_Info.Kind
|
|
is
|
|
when physics.Model.Cube =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space. new_box_Shape (Self.physics_Model.shape_Info.half_Extents));
|
|
|
|
when physics.Model.a_Sphere =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space. new_sphere_Shape (Self.physics_Model.shape_Info.sphere_Radius));
|
|
|
|
when physics.Model.multi_Sphere =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space.new_multisphere_Shape (Self.physics_Model.shape_Info.Sites.all,
|
|
Self.physics_Model.shape_Info.Radii.all));
|
|
when physics.Model.Cone =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space. new_cone_Shape (Radius => Real (Self.physics_Model.Scale (1) / 2.0),
|
|
Height => Real (Self.physics_Model.Scale (2))));
|
|
when physics.Model.a_Capsule =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space. new_capsule_Shape (Self.physics_Model.shape_Info.lower_Radius,
|
|
Self.physics_Model.shape_Info.Height));
|
|
when physics.Model.Cylinder =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space. new_cylinder_Shape (Self.physics_Model.shape_Info.half_Extents));
|
|
|
|
when physics.Model.Hull =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space.new_convex_hull_Shape (Self.physics_Model.shape_Info.Points.all));
|
|
|
|
when physics.Model.Mesh =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space .new_mesh_Shape (Self.physics_Model.shape_Info.Model));
|
|
|
|
when physics.Model.Plane =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space. new_plane_Shape (Self.physics_Model.Shape_Info.plane_Normal,
|
|
Self.physics_Model.Shape_Info.plane_Offset));
|
|
when physics.Model.Heightfield =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space.new_heightfield_Shape (Self.physics_Model.shape_Info.Heights.all,
|
|
Self.physics_Model.Scale));
|
|
when physics.Model.Circle =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space. new_circle_Shape (Self.physics_Model.shape_Info.circle_Radius));
|
|
|
|
when physics.Model.Polygon =>
|
|
Self.Shape := physics_Shape_view (Self.World.Space. new_polygon_Shape (physics.space.polygon_Vertices (Self.physics_Model.shape_Info.Vertices (1 .. Self.physics_Model.shape_Info.vertex_Count))));
|
|
end case;
|
|
|
|
end rebuild_Shape;
|
|
|
|
|
|
|
|
procedure rebuild_Solid (Self : in out Item; at_Site : Vector_3)
|
|
is
|
|
use Physics.Object;
|
|
begin
|
|
if Self.Solid /= null
|
|
then
|
|
raise Program_Error;
|
|
end if;
|
|
|
|
Self.Solid := physics_Object_view (Self.World.Space.new_Object (physics.Shape.view (Self.Shape),
|
|
Self.physics_Model.Mass,
|
|
Self.physics_Model.Friction,
|
|
Self.physics_Model.Restitution,
|
|
at_Site,
|
|
Self.is_Kinematic));
|
|
end rebuild_Solid;
|
|
|
|
|
|
|
|
procedure define (Self : access Item; World : in World_view;
|
|
at_Site : in Vector_3;
|
|
graphics_Model : access openGL. Model.item'Class;
|
|
physics_Model : access physics.Model.item'Class;
|
|
owns_Graphics : in Boolean;
|
|
owns_Physics : in Boolean;
|
|
is_Kinematic : in Boolean := False;
|
|
user_Data : in any_user_Data_view := null)
|
|
is
|
|
use type physics.Model.view;
|
|
begin
|
|
Self.Id := World.new_sprite_Id;
|
|
Self.World := World;
|
|
|
|
Self.Visual.Model_is (graphics_Model.all'unchecked_Access);
|
|
Self.physics_Model := physics.Model.view (physics_Model);
|
|
Self.owns_Graphics := owns_Graphics;
|
|
Self.owns_Physics := owns_Physics;
|
|
|
|
Self.is_Kinematic := is_Kinematic;
|
|
Self.user_Data := user_Data;
|
|
|
|
-- set_Translation (Self.Transform, To => physics_Model.Site);
|
|
|
|
-- Physics
|
|
--
|
|
if Self.physics_Model /= null
|
|
then
|
|
Self.rebuild_Shape;
|
|
Self.rebuild_Solid (at_Site);
|
|
end if;
|
|
end define;
|
|
|
|
|
|
|
|
procedure destroy (Self : access Item; and_Children : in Boolean)
|
|
is
|
|
use gel.Joint;
|
|
begin
|
|
if Self.is_Destroyed
|
|
then
|
|
raise Error with "Sprite is already destroyed.";
|
|
end if;
|
|
|
|
-- Detach parent, if any.
|
|
--
|
|
if Self.parent_Joint /= null then
|
|
Self.parent_Joint.Sprite_A.detach (Sprite.view (Self));
|
|
end if;
|
|
|
|
-- Detach children, if any.
|
|
--
|
|
while not Self.child_Joints.is_Empty
|
|
loop
|
|
declare
|
|
child_Sprite : constant Sprite.view := Self.child_Joints.last_Element.Sprite_B;
|
|
begin
|
|
Self.detach (child_Sprite);
|
|
|
|
if and_Children
|
|
then
|
|
destroy (child_Sprite, and_Children); -- Recurse.
|
|
end if;
|
|
end;
|
|
end loop;
|
|
|
|
Self.is_Destroyed := True;
|
|
Self.World.destroy (Sprite.view (Self));
|
|
|
|
lace.Subject_and_deferred_Observer.item (Self.all).destroy; -- Destroy base class.
|
|
end destroy;
|
|
|
|
|
|
|
|
function is_Destroyed (Self : in Item) return Boolean
|
|
is
|
|
begin
|
|
return Self.is_Destroyed;
|
|
end is_Destroyed;
|
|
|
|
|
|
|
|
procedure free (Self : in out View)
|
|
is
|
|
pragma assert (Self.is_Destroyed);
|
|
|
|
use gel.Joint,
|
|
physics.Model,
|
|
physics.Object,
|
|
physics.Shape;
|
|
|
|
procedure deallocate is new ada.unchecked_Deallocation (Sprite.item'Class, Sprite.view);
|
|
procedure deallocate is new ada.unchecked_Deallocation (Joint.views, access_Joint_views);
|
|
pragma Unreferenced (deallocate);
|
|
|
|
child_Joint : Joint.view;
|
|
|
|
begin
|
|
for Each in 1 .. Integer (Self.child_Joints.Length)
|
|
loop
|
|
child_Joint := Self.child_Joints.Element (Each);
|
|
free (child_Joint);
|
|
end loop;
|
|
|
|
if Self.owns_Physics
|
|
then
|
|
free (Self.physics_Model);
|
|
end if;
|
|
|
|
free (Self.Shape);
|
|
free (Self.Solid);
|
|
|
|
deallocate (Self);
|
|
end free;
|
|
|
|
|
|
----------
|
|
--- Forge
|
|
--
|
|
package body Forge
|
|
is
|
|
|
|
function to_Sprite (Name : in String;
|
|
World : in World_view;
|
|
at_Site : in Vector_3;
|
|
graphics_Model : access openGL. Model.item'Class;
|
|
physics_Model : access physics.Model.item'Class;
|
|
owns_Graphics : in Boolean;
|
|
owns_Physics : in Boolean;
|
|
is_Kinematic : in Boolean := False;
|
|
user_Data : in any_user_Data_view := null) return Item
|
|
is
|
|
begin
|
|
return Self : Item := (lace.Subject_and_deferred_Observer.forge.to_Subject_and_Observer (Name)
|
|
with others => <>)
|
|
do
|
|
Self.define (World, at_Site, graphics_Model, physics_Model, owns_Graphics, owns_Physics, is_Kinematic, user_Data);
|
|
end return;
|
|
end to_Sprite;
|
|
|
|
|
|
|
|
function new_Sprite (Name : in String;
|
|
World : in World_view;
|
|
at_Site : in Vector_3;
|
|
graphics_Model : access openGL. Model.item'Class;
|
|
physics_Model : access physics.Model.item'Class;
|
|
owns_Graphics : in Boolean := True;
|
|
owns_Physics : in Boolean := True;
|
|
is_Kinematic : in Boolean := False;
|
|
user_Data : in any_user_Data_view := null) return View
|
|
is
|
|
Self : constant View := new Item' (to_Sprite (Name,
|
|
World,
|
|
at_Site,
|
|
graphics_Model,
|
|
physics_Model,
|
|
owns_Graphics,
|
|
owns_Physics,
|
|
is_Kinematic,
|
|
user_Data => user_Data));
|
|
begin
|
|
|
|
return Self;
|
|
end new_Sprite;
|
|
|
|
end Forge;
|
|
|
|
|
|
--------------
|
|
--- Attributes
|
|
--
|
|
|
|
function World (Self : in Item) return access gel.World.item'Class
|
|
is
|
|
begin
|
|
return Self.World;
|
|
end World;
|
|
|
|
|
|
|
|
function Id (Self : in Item) return gel.sprite_Id
|
|
is
|
|
begin
|
|
return Self.Id;
|
|
end Id;
|
|
|
|
|
|
|
|
procedure Id_is (Self : in out Item; Now : in gel.sprite_Id)
|
|
is
|
|
begin
|
|
Self.Id := Now;
|
|
end Id_is;
|
|
|
|
|
|
|
|
function Depth_in_camera_space (Self : in Item) return Real
|
|
is
|
|
begin
|
|
return Self.Depth_in_camera_space;
|
|
end Depth_in_camera_space;
|
|
|
|
|
|
|
|
function Mass (Self : in Item) return Real
|
|
is
|
|
begin
|
|
return Self.physics_Model.Mass;
|
|
end Mass;
|
|
|
|
|
|
|
|
function is_Static (Self : in Item) return Boolean
|
|
is
|
|
begin
|
|
return Self.Mass = 0.0;
|
|
end is_Static;
|
|
|
|
|
|
|
|
function is_Kinematic (Self : in Item) return Boolean
|
|
is
|
|
begin
|
|
return Self.is_Kinematic;
|
|
end is_Kinematic;
|
|
|
|
|
|
|
|
procedure mvp_Matrix_is (Self : in out Item; Now : in Matrix_4x4)
|
|
is
|
|
begin
|
|
Self.Visual.mvp_Transform_is (Now);
|
|
Self.Depth_in_camera_space := Now (4, 3);
|
|
end mvp_Matrix_is;
|
|
|
|
|
|
|
|
function mvp_Matrix (Self : in Item) return Matrix_4x4
|
|
is
|
|
begin
|
|
return Self.Visual.mvp_Transform;
|
|
end mvp_Matrix;
|
|
|
|
|
|
|
|
procedure is_Visible (Self : in out Item; Now : in Boolean)
|
|
is
|
|
begin
|
|
Self.is_Visible := Now;
|
|
end is_Visible;
|
|
|
|
|
|
|
|
function is_Visible (Self : in Item) return Boolean
|
|
is
|
|
begin
|
|
return Self.is_Visible;
|
|
end is_Visible;
|
|
|
|
|
|
|
|
procedure key_Response_is (Self : in out Item; Now : in lace.Response.view)
|
|
is
|
|
begin
|
|
Self.key_Response := Now;
|
|
end key_Response_is;
|
|
|
|
|
|
|
|
function key_Response (Self : in Item) return lace.Response.view
|
|
is
|
|
begin
|
|
return Self.key_Response;
|
|
end key_Response;
|
|
|
|
|
|
|
|
function Visual (Self : access Item) return openGL.Visual.view
|
|
is
|
|
begin
|
|
return Self.Visual;
|
|
end Visual;
|
|
|
|
|
|
|
|
function graphics_Model (Self : in Item) return openGL.Model.view
|
|
is
|
|
begin
|
|
return Self.visual.Model;
|
|
end graphics_Model;
|
|
|
|
|
|
|
|
procedure Model_is (Self : in out Item; Now : in openGL.Model.view)
|
|
is
|
|
begin
|
|
Self.Visual.Model_is (Now);
|
|
end Model_is;
|
|
|
|
|
|
|
|
function owns_Graphics (Self : in Item) return Boolean
|
|
is
|
|
begin
|
|
return Self.owns_Graphics;
|
|
end owns_Graphics;
|
|
|
|
|
|
|
|
function physics_Model (Self : in Item) return access physics.Model.item'class
|
|
is
|
|
begin
|
|
return Self.physics_Model;
|
|
end physics_Model;
|
|
|
|
|
|
|
|
procedure physics_Model_is (Self : in out Item; Now : in physics.Model.view)
|
|
is
|
|
begin
|
|
Self.physics_Model := Now;
|
|
end physics_Model_is;
|
|
|
|
|
|
|
|
procedure Scale_is (Self : in out Item; Now : in math.Vector_3)
|
|
is
|
|
begin
|
|
Self.physics_Model.Scale_is (Now);
|
|
Self.World .update_Scale (Self'unchecked_Access, +Now);
|
|
end Scale_is;
|
|
|
|
|
|
|
|
function Scale (Self : in Item) return Vector_3
|
|
is
|
|
begin
|
|
return Self.physics_Model.Scale;
|
|
end Scale;
|
|
|
|
|
|
|
|
function Solid (Self : in Item) return physics_Object_view
|
|
is
|
|
begin
|
|
return Self.Solid;
|
|
end Solid;
|
|
|
|
|
|
|
|
procedure Solid_is (Self : in out Item; Now : in physics_Object_view)
|
|
is
|
|
begin
|
|
Self.Solid := Now;
|
|
end Solid_is;
|
|
|
|
|
|
|
|
function to_GEL (the_Solid : in physics_Object_view) return gel.Sprite.view
|
|
is
|
|
begin
|
|
return gel.Sprite.view (the_Solid.user_Data);
|
|
end to_GEL;
|
|
|
|
|
|
|
|
function Shape (Self : in Item) return physics_Shape_view
|
|
is
|
|
begin
|
|
return Self.Shape;
|
|
end Shape;
|
|
|
|
|
|
|
|
function user_Data (Self : in Item) return any_user_Data_view
|
|
is
|
|
begin
|
|
return Self.user_Data;
|
|
end user_Data;
|
|
|
|
|
|
|
|
procedure user_Data_is (Self : in out Item; Now : in any_user_Data_view)
|
|
is
|
|
begin
|
|
Self.user_Data := Now;
|
|
end user_Data_is;
|
|
|
|
|
|
|
|
|
|
-------------
|
|
--- Dynamics
|
|
--
|
|
|
|
--- Bounds
|
|
--
|
|
|
|
function Bounds (Self : in Item) return Geometry_3d.bounding_Box
|
|
is
|
|
use Geometry_3d;
|
|
begin
|
|
return Self.graphics_Model.Bounds.Box + Self.Site;
|
|
end Bounds;
|
|
|
|
|
|
--- Site
|
|
--
|
|
|
|
function Site (Self : in Item) return Vector_3
|
|
is
|
|
begin
|
|
return Self.Solid.Site;
|
|
end Site;
|
|
|
|
|
|
|
|
procedure Site_is (Self : in out Item; Now : in Vector_3)
|
|
is
|
|
begin
|
|
Self.Solid.Site_is (Now);
|
|
end Site_is;
|
|
|
|
|
|
|
|
procedure move (Self : in out Item; to_Site : in Vector_3)
|
|
is
|
|
the_Offset : constant Vector_3 := to_Site - Self.Site;
|
|
child_Sprite : Sprite.view;
|
|
begin
|
|
-- Do children.
|
|
--
|
|
for i in 1 .. Integer (Self.child_Joints.Length)
|
|
loop
|
|
child_Sprite := Self.child_Joints.Element (i).Sprite_B;
|
|
child_Sprite.move (to_site => child_Sprite.Site + the_Offset); -- Recurse.
|
|
end loop;
|
|
|
|
Self.Site_is (to_Site);
|
|
end move;
|
|
|
|
|
|
|
|
procedure set_Speed (Self : in out Item; to_Speed : in Vector_3)
|
|
is
|
|
child_Sprite : Sprite.view;
|
|
begin
|
|
-- Do children.
|
|
--
|
|
for i in 1 .. Integer (Self.child_Joints.Length)
|
|
loop
|
|
child_Sprite := Self.child_Joints.Element (i).Sprite_B;
|
|
child_Sprite.set_Speed (to_Speed);
|
|
end loop;
|
|
|
|
Self.Speed_is (to_Speed);
|
|
end set_Speed;
|
|
|
|
|
|
|
|
function Spin (Self : in Item) return Matrix_3x3
|
|
is
|
|
begin
|
|
return Self.Solid.Spin;
|
|
end Spin;
|
|
|
|
|
|
|
|
procedure Spin_is (Self : in out Item; Now : in Matrix_3x3)
|
|
is
|
|
use type Physics.Object.view;
|
|
-- Transform : Matrix_4x4 := Self.Transform.Value;
|
|
begin
|
|
-- set_Rotation (Self.Transform, Now);
|
|
-- Self.Transform_is (Transform);
|
|
|
|
-- if Self.Solid /= null then
|
|
Self.Solid.Spin_is (Now);
|
|
-- end if;
|
|
end Spin_is;
|
|
|
|
|
|
|
|
function xy_Spin (Self : in Item) return Radians
|
|
is
|
|
begin
|
|
return Self.Solid.xy_Spin;
|
|
end xy_Spin;
|
|
|
|
|
|
|
|
procedure xy_Spin_is (Self : in out Item; Now : in Radians)
|
|
is
|
|
begin
|
|
Self.World.set_xy_Spin (Self'unchecked_Access, Now);
|
|
end xy_Spin_is;
|
|
|
|
|
|
|
|
procedure rotate (Self : in out Item; to_Spin : in Matrix_3x3)
|
|
is
|
|
the_spin_Delta : constant Matrix_3x3 := to_Spin * Inverse (Self.Spin); -- The rotation matrix describing the amount by which Self has rotated.
|
|
|
|
procedure spin_Children (the_Sprite : in Sprite.item'class)
|
|
is
|
|
begin
|
|
if the_Sprite.child_Joints.Is_Empty then
|
|
return;
|
|
end if;
|
|
|
|
declare
|
|
child_Sprite : Sprite.view;
|
|
the_site_Offset : Vector_3;
|
|
begin
|
|
for i in 1 .. Integer (the_Sprite.child_Joints.Length)
|
|
loop
|
|
child_Sprite := the_Sprite.child_Joints.Element (i).Sprite_B;
|
|
the_site_Offset := the_spin_Delta * (child_Sprite.Site - Self.Site) ;
|
|
|
|
child_Sprite.Site_is (Self.Site + the_site_Offset);
|
|
child_Sprite.Spin_is (the_spin_Delta * child_Sprite.Spin);
|
|
|
|
spin_Children (child_Sprite.all); -- Recurse.
|
|
end loop;
|
|
end;
|
|
end spin_Children;
|
|
|
|
begin
|
|
spin_Children (Self); -- Do children.
|
|
Self.Spin_is (to_Spin);
|
|
end rotate;
|
|
|
|
|
|
|
|
function Transform (Self : in Item) return Matrix_4x4
|
|
is
|
|
begin
|
|
-- return Self.Transform.Value;
|
|
return Self.Solid.Transform;
|
|
end Transform;
|
|
|
|
|
|
|
|
procedure Transform_is (Self : in out Item; Now : in Matrix_4x4)
|
|
is
|
|
begin
|
|
-- Self.Transform.Value_is (Now);
|
|
Self.Solid.Transform_is (Now);
|
|
end Transform_is;
|
|
|
|
|
|
|
|
function Speed (Self : in Item) return Vector_3
|
|
is
|
|
begin
|
|
return Self.Solid.Speed;
|
|
end Speed;
|
|
|
|
|
|
|
|
procedure Speed_is (Self : in out Item; Now : in Vector_3)
|
|
is
|
|
begin
|
|
Self.World.set_Speed (Self'unchecked_Access, Now);
|
|
end Speed_is;
|
|
|
|
|
|
|
|
function Gyre (Self : in Item) return Vector_3
|
|
is
|
|
begin
|
|
return Self.Solid.Gyre;
|
|
end Gyre;
|
|
|
|
|
|
|
|
procedure Gyre_is (Self : in out Item; Now : in Vector_3)
|
|
is
|
|
begin
|
|
Self.Solid.Gyre_is (Now);
|
|
end Gyre_is;
|
|
|
|
|
|
|
|
procedure set_Gyre (Self : in out Item; to_Gyre : in Vector_3)
|
|
is
|
|
child_Sprite : Sprite.view;
|
|
begin
|
|
-- Do children.
|
|
--
|
|
for i in 1 .. Integer (Self.child_Joints.Length)
|
|
loop
|
|
child_Sprite := Self.child_Joints.Element (i).Sprite_B;
|
|
child_Sprite.set_Gyre (to_Gyre);
|
|
end loop;
|
|
|
|
Self.Gyre_is (to_Gyre);
|
|
end set_Gyre;
|
|
|
|
|
|
--- Forces
|
|
--
|
|
|
|
procedure apply_Force (Self : in out Item; Force : in Vector_3)
|
|
is
|
|
the_Force : aliased constant Vector_3 := Force;
|
|
begin
|
|
Self.Solid.apply_Force (Force);
|
|
-- Self.World.apply_Force (Self'unchecked_Access, the_Force);
|
|
end apply_Force;
|
|
|
|
|
|
|
|
procedure apply_Torque (Self : in out Item; Torque : in Vector_3)
|
|
is
|
|
the_Torque : constant Vector_3 := Torque;
|
|
begin
|
|
Self.Solid.apply_Torque (the_Torque);
|
|
end apply_Torque;
|
|
|
|
|
|
|
|
procedure apply_Torque_impulse (Self : in out Item; Torque : in Vector_3)
|
|
is
|
|
the_Torque : constant Vector_3 := Torque;
|
|
begin
|
|
Self.Solid.apply_Torque_impulse (the_Torque);
|
|
end apply_Torque_impulse;
|
|
|
|
|
|
-- Mirrored Dynamics
|
|
--
|
|
|
|
protected
|
|
body safe_Interpolation
|
|
is
|
|
procedure set (desired_Site : in Vector_3;
|
|
desired_Spin : in Quaternion)
|
|
is
|
|
begin
|
|
Safe.Site.initial := Safe.Site.desired;
|
|
Safe.Site.desired := desired_Site;
|
|
|
|
Safe.Spin.initial := Safe.Spin.desired;
|
|
Safe.Spin.desired := desired_Spin;
|
|
|
|
Safe.Percent := 0.0;
|
|
end set;
|
|
|
|
|
|
procedure get (Site : out Vector_3;
|
|
Spin : out Quaternion)
|
|
is
|
|
begin
|
|
Site := Interpolated (Safe.Site.initial,
|
|
Safe.Site.desired,
|
|
Safe.Percent);
|
|
|
|
Spin := Interpolated (Safe.Spin.initial,
|
|
Safe.Spin.desired,
|
|
Safe.Percent);
|
|
|
|
if gel.World.interpolation_Steps = 0
|
|
then
|
|
Safe.Percent := 100.0;
|
|
else
|
|
Safe.Percent := Percentage'Min ( Safe.Percent
|
|
+ to_Percentage (1.0 / Real (gel.World.interpolation_Steps + 1)),
|
|
unit_Percentage'Last);
|
|
end if;
|
|
end get;
|
|
|
|
end safe_Interpolation;
|
|
|
|
|
|
|
|
procedure desired_Dynamics_are (Self : in out Item; Site : in Vector_3;
|
|
Spin : in Quaternion)
|
|
is
|
|
begin
|
|
Self.Interpolation.set (desired_Site => Site,
|
|
desired_Spin => Spin);
|
|
end desired_Dynamics_are;
|
|
|
|
|
|
|
|
procedure interpolate_Motion (Self : in out Item)
|
|
is
|
|
begin
|
|
if Self.is_Static then
|
|
return;
|
|
end if;
|
|
|
|
declare
|
|
new_Site : Vector_3;
|
|
new_Spin : Quaternion;
|
|
begin
|
|
Self.Interpolation.get (new_Site,
|
|
new_Spin);
|
|
Self.Site_is (new_Site);
|
|
Self.Spin_is (Transpose (to_Matrix (new_Spin)));
|
|
end;
|
|
end interpolate_Motion;
|
|
|
|
|
|
|
|
--------------
|
|
--- Operations
|
|
--
|
|
|
|
--- Hierachy
|
|
--
|
|
|
|
function parent_Joint (Self : in Item) return gel.Joint.view
|
|
is
|
|
begin
|
|
return Self.parent_Joint;
|
|
end parent_Joint;
|
|
|
|
|
|
|
|
function child_Joints (Self : in Item) return gel.Joint.views
|
|
is
|
|
the_Joints : Joint.views (1 .. Integer (Self.child_Joints.Length));
|
|
begin
|
|
for i in the_Joints'Range
|
|
loop
|
|
the_Joints (i) := Self.child_Joints.Element (i);
|
|
end loop;
|
|
|
|
return the_Joints;
|
|
end child_Joints;
|
|
|
|
|
|
|
|
function top_Parent (Self : access Item) return gel.Sprite.view
|
|
is
|
|
begin
|
|
if Self.parent_Joint = null
|
|
then return gel.Sprite.view (Self);
|
|
else return Self.parent_Joint.Sprite_A.top_Parent; -- Recurse.
|
|
end if;
|
|
end top_Parent;
|
|
|
|
|
|
|
|
function Parent (Self : in Item) return gel.Sprite.view
|
|
is
|
|
begin
|
|
if Self.parent_Joint = null
|
|
then return null;
|
|
else return Self.parent_Joint.Sprite_A;
|
|
end if;
|
|
end Parent;
|
|
|
|
|
|
|
|
function tree_Depth (Self : in Item) return Natural
|
|
is
|
|
Parent : Sprite.view := Self.Parent;
|
|
Depth : Natural := 0;
|
|
begin
|
|
while Parent /= null
|
|
loop
|
|
Depth := Depth + 1;
|
|
Parent := Parent.Parent;
|
|
end loop;
|
|
|
|
return Depth;
|
|
end tree_Depth;
|
|
|
|
|
|
|
|
procedure apply (Self : in out Item; do_Action : Action)
|
|
is
|
|
begin
|
|
do_Action (Self);
|
|
|
|
for i in 1 .. Integer (Self.child_Joints.Length)
|
|
loop
|
|
Self.child_Joints.Element (i).Sprite_B.apply (do_Action);
|
|
end loop;
|
|
end apply;
|
|
|
|
|
|
|
|
procedure attach (Self : access Item; the_Child : in Sprite.view;
|
|
the_Joint : in gel.Joint.view)
|
|
is
|
|
begin
|
|
log ("Attaching " & the_Child.Id'Image & " to " & Self.Id'Image);
|
|
|
|
Self.child_Joints.append (the_Joint);
|
|
|
|
the_Child.parent_Joint := the_Joint;
|
|
the_Child.relay_responseless_Events (To => Self);
|
|
end attach;
|
|
|
|
|
|
|
|
procedure detach (Self : in out Item; the_Child : gel.Sprite.view)
|
|
is
|
|
childs_Joint : Joint.view;
|
|
begin
|
|
log ("Detaching " & the_Child.Id'Image & " from " & Self.Id'Image);
|
|
|
|
for i in 1 .. Integer (Self.child_Joints.Length)
|
|
loop
|
|
if Self.child_Joints.Element (i).Sprite_B = the_Child
|
|
then
|
|
childs_Joint := Self.child_Joints.Element (i);
|
|
|
|
Self.child_Joints.delete (i);
|
|
the_Child.parent_Joint := null;
|
|
Self.World.destroy (childs_Joint);
|
|
|
|
return;
|
|
end if;
|
|
end loop;
|
|
|
|
raise no_such_Child;
|
|
end detach;
|
|
|
|
|
|
|
|
-- Hinge
|
|
--
|
|
procedure attach_via_Hinge (Self : access Item; the_Child : in Sprite.view;
|
|
pivot_Axis : in Vector_3;
|
|
Anchor : in Vector_3;
|
|
child_Anchor : in Vector_3;
|
|
low_Limit : in Real;
|
|
high_Limit : in Real;
|
|
collide_Connected : in Boolean;
|
|
new_joint : out gel.Joint.view)
|
|
is
|
|
the_Joint : constant gel.hinge_Joint.view := new gel.hinge_Joint.item;
|
|
begin
|
|
the_Joint.define (Self.World.Space,
|
|
Self, the_Child,
|
|
pivot_Axis,
|
|
Anchor, child_Anchor,
|
|
low_Limit, high_Limit,
|
|
collide_Connected);
|
|
|
|
the_Joint.Limits_are (low_Limit, high_Limit);
|
|
|
|
Self.attach (the_Child, the_Joint.all'Access);
|
|
|
|
new_Joint := the_Joint.all'Access;
|
|
end attach_via_Hinge;
|
|
|
|
|
|
|
|
procedure attach_via_Hinge (Self : access Item; the_Child : in Sprite.view;
|
|
pivot_Axis : in Vector_3;
|
|
pivot_Anchor : in Vector_3;
|
|
low_Limit : in Real;
|
|
high_Limit : in Real;
|
|
new_joint : out gel.Joint.view)
|
|
is
|
|
the_Joint : constant gel.hinge_Joint.view := new gel.hinge_Joint.item;
|
|
begin
|
|
the_Joint.define (in_Space => Self.World.Space,
|
|
Sprite_A => Self,
|
|
Sprite_B => the_Child,
|
|
pivot_Axis => pivot_Axis,
|
|
pivot_Anchor => pivot_Anchor);
|
|
|
|
the_Joint.Limits_are (low_Limit, high_Limit);
|
|
|
|
Self.attach (the_Child, the_Joint.all'Access);
|
|
|
|
new_Joint := the_Joint.all'Access;
|
|
end attach_via_Hinge;
|
|
|
|
|
|
|
|
procedure attach_via_Hinge (Self : access Item; the_Child : in Sprite.view;
|
|
pivot_Axis : in Vector_3;
|
|
low_Limit : in Real;
|
|
high_Limit : in Real;
|
|
new_joint : out gel.Joint.view)
|
|
is
|
|
the_Joint : constant gel.hinge_Joint.view := new gel.hinge_Joint.item;
|
|
begin
|
|
the_Joint.define (in_Space => Self.World.Space,
|
|
Sprite_A => Self,
|
|
Sprite_B => the_Child,
|
|
pivot_Axis => pivot_Axis);
|
|
|
|
the_Joint.Limits_are (low_Limit, high_Limit);
|
|
|
|
Self.attach (the_Child, the_Joint.all'Access);
|
|
|
|
new_Joint := the_Joint.all'Access;
|
|
end attach_via_Hinge;
|
|
|
|
|
|
|
|
procedure attach_via_Hinge (Self : access Item; the_Child : in Sprite.view;
|
|
Frame_in_parent : in Matrix_4x4;
|
|
Frame_in_child : in Matrix_4x4;
|
|
Limits : in DoF_Limits;
|
|
collide_Connected : in Boolean;
|
|
new_joint : out gel.Joint.view)
|
|
is
|
|
the_Joint : constant gel.hinge_Joint.view := new gel.hinge_Joint.item;
|
|
begin
|
|
the_Joint.define (Self.World.Space,
|
|
Self, the_Child,
|
|
Frame_in_parent, Frame_in_child,
|
|
Limits.Low, Limits.High,
|
|
collide_Connected);
|
|
|
|
the_Joint.Limits_are (limits.Low, limits.High);
|
|
|
|
Self.attach (the_Child, the_Joint.all'Access);
|
|
|
|
new_Joint := the_Joint.all'Access;
|
|
end attach_via_Hinge;
|
|
|
|
|
|
-- Ball/Socket
|
|
--
|
|
|
|
procedure internal_attach_via_ball_Socket (Self : access Item; the_Child : in Sprite.view;
|
|
pitch_Limits : in DoF_Limits;
|
|
yaw_Limits : in DoF_Limits;
|
|
roll_Limits : in DoF_Limits;
|
|
the_Joint : in gel.any_Joint.view)
|
|
is
|
|
use gel.any_Joint;
|
|
begin
|
|
the_Joint.low_Bound_is (Pitch, pitch_Limits.Low);
|
|
the_Joint.low_Bound_is (Yaw, yaw_Limits .Low);
|
|
the_Joint.low_Bound_is (Roll, roll_Limits .Low);
|
|
|
|
the_Joint.high_Bound_is (Pitch, pitch_Limits.High);
|
|
the_Joint.high_Bound_is (Yaw, yaw_Limits .High);
|
|
the_Joint.high_Bound_is (Roll, roll_Limits .High);
|
|
|
|
Self.attach (the_Child, the_Joint.all'Access);
|
|
end internal_attach_via_ball_Socket;
|
|
|
|
|
|
|
|
procedure attach_via_ball_Socket (Self : access Item; the_Child : in Sprite.view;
|
|
pivot_Anchor : in Vector_3;
|
|
pivot_Axis : in Matrix_3x3;
|
|
pitch_Limits : in DoF_Limits;
|
|
yaw_Limits : in DoF_Limits;
|
|
roll_Limits : in DoF_Limits;
|
|
new_joint : out gel.Joint.view)
|
|
is
|
|
the_Joint : constant gel.any_Joint.view := new gel.any_Joint.item;
|
|
begin
|
|
the_Joint.define (Self.World.Space,
|
|
Self, the_Child,
|
|
pivot_Anchor, pivot_Axis);
|
|
|
|
Self.internal_attach_via_ball_Socket (the_Child,
|
|
pitch_Limits,
|
|
yaw_Limits,
|
|
roll_Limits,
|
|
the_joint);
|
|
new_Joint := the_Joint.all'Access;
|
|
end attach_via_ball_Socket;
|
|
|
|
|
|
|
|
procedure attach_via_ball_Socket (Self : access Item; the_Child : in Sprite.view;
|
|
Frame_in_parent : in Matrix_4x4;
|
|
Frame_in_child : in Matrix_4x4;
|
|
pitch_Limits : in DoF_Limits;
|
|
yaw_Limits : in DoF_Limits;
|
|
roll_Limits : in DoF_Limits;
|
|
new_joint : out gel.Joint.view)
|
|
is
|
|
the_Joint : constant gel.any_Joint.view := new gel.any_Joint.item;
|
|
begin
|
|
the_Joint.define (Self.World.Space,
|
|
Self, the_Child,
|
|
Frame_in_parent, Frame_in_child);
|
|
|
|
Self.internal_attach_via_ball_Socket (the_Child,
|
|
pitch_Limits,
|
|
yaw_Limits,
|
|
roll_Limits,
|
|
the_joint);
|
|
new_Joint := the_Joint.all'Access;
|
|
end attach_via_ball_Socket;
|
|
|
|
|
|
|
|
------------
|
|
--- Graphics
|
|
--
|
|
|
|
procedure program_Parameters_are (Self : in out Item; Now : in opengl.Program.Parameters_view)
|
|
is
|
|
begin
|
|
Self.program_Parameters := Now;
|
|
end program_Parameters_are;
|
|
|
|
|
|
|
|
function program_Parameters (Self : in Item) return opengl.Program.Parameters_view
|
|
is
|
|
begin
|
|
return Self.program_Parameters;
|
|
end program_Parameters;
|
|
|
|
|
|
-----------
|
|
--- Utility
|
|
--
|
|
|
|
function to_Hash (Self : in ada.Tags.Tag) return ada.Containers.Hash_type
|
|
is
|
|
function Converted is new ada.unchecked_Conversion (ada.Tags.Tag, ada.Containers.Hash_type);
|
|
begin
|
|
return Converted (Self);
|
|
end to_Hash;
|
|
pragma Unreferenced (to_Hash);
|
|
|
|
|
|
|
|
-- protected
|
|
-- body safe_Matrix_4x4
|
|
-- is
|
|
-- function Value return Matrix_4x4
|
|
-- is
|
|
-- begin
|
|
-- return the_Value;
|
|
-- end Value;
|
|
--
|
|
-- procedure Value_is (Now : in Matrix_4x4)
|
|
-- is
|
|
-- begin
|
|
-- the_Value := Now;
|
|
-- end Value_is;
|
|
--
|
|
-- procedure Site_is (Now : in Vector_3)
|
|
-- is
|
|
-- begin
|
|
-- the_Value (4, 1) := Now (1);
|
|
-- the_Value (4, 2) := Now (2);
|
|
-- the_Value (4, 3) := Now (3);
|
|
-- end Site_is;
|
|
-- end safe_Matrix_4x4;
|
|
|
|
|
|
end gel.Sprite;
|