1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167 | with
physics.Space,
physics.Joint,
physics.Object,
lace.Observer,
lace.Any,
ada.Tags;
package physics.Engine
--
-- Provides a task which evolves a physical space.
--
is
type Item is tagged limited private;
type View is access all Item'Class;
-- procedure start (Self : access Item; space_Kind : in physics.space_Kind);
procedure start (Self : access Item; the_Space : in Space.view);
procedure stop (Self : access Item);
procedure add (Self : access Item; the_Object : in Object.view);
procedure rid (Self : in out Item; the_Object : in Object.view);
procedure add (Self : in out Item; the_Joint : in Joint.view);
procedure rid (Self : in out Item; the_Joint : in Joint.view);
procedure update_Scale (Self : in out Item; of_Object : in Object.view;
To : in math.Vector_3);
procedure apply_Force (Self : in out Item; to_Object : in Object.view;
Force : in math.Vector_3);
procedure update_Site (Self : in out Item; of_Object : in Object.view;
To : in math.Vector_3);
procedure set_Speed (Self : in out Item; of_Object : in Object.view;
To : in math.Vector_3);
procedure set_Gravity (Self : in out Item; To : in math.Vector_3);
procedure set_xy_Spin (Self : in out Item; of_Object : in Object.view;
To : in math.Radians);
procedure update_Bounds (Self : in out Item; of_Object : in Object.view);
procedure set_local_Anchor (Self : in out Item; for_Joint : in Joint.view;
To : in math.Vector_3;
is_Anchor_A : in Boolean);
private
task
type Evolver (Self : access Engine.item'Class)
is
-- entry start (space_Kind : in physics.space_Kind);
entry start (the_Space : in Space.view);
entry stop;
entry reset_Age;
pragma Storage_Size (20_000_000);
end Evolver;
-- Engine Commands
--
type Any_limited_view is access all lace.Any.limited_item'Class;
type command_Kind is (add_Object, rid_Object,
scale_Object, destroy_Object,
update_Bounds, update_Site,
set_Speed, apply_Force,
set_xy_Spin,
add_Joint, rid_Joint,
set_Joint_local_Anchor,
free_Joint,
cast_Ray,
-- new_impact_Response,
set_Gravity);
type Command (Kind : command_Kind := command_Kind'First) is
record
Object : physics.Object.view;
case Kind
is
when add_Object =>
add_Children : Boolean;
-- Model : physics.Model.view;
when rid_Object =>
rid_Children : Boolean;
when update_Site =>
Site : math.Vector_3;
when scale_Object =>
Scale : math.Vector_3;
when apply_Force =>
Force : math.Vector_3;
when set_Speed =>
Speed : math.Vector_3;
when set_Gravity =>
Gravity : math.Vector_3;
when set_xy_Spin =>
xy_Spin : math.Radians;
when add_Joint | rid_Joint | free_Joint =>
Joint : physics.Joint.view;
when set_Joint_local_Anchor =>
anchor_Joint : physics.Joint.view;
is_Anchor_A : Boolean; -- When false, is anchor B.
local_Anchor : math.Vector_3;
when cast_Ray =>
From, To : math.Vector_3;
Observer : lace.Observer.view;
Context : Any_limited_view;
event_Kind : ada.Tags.Tag;
-- when new_impact_Response =>
-- Filter : impact_Filter;
-- Response : impact_Response;
when others =>
null;
end case;
end record;
type Commands is array (Positive range 1 .. 200_000) of Command;
protected
type safe_command_Set
is
function is_Empty return Boolean;
procedure add (the_Command : in Command);
procedure Fetch (To : out Commands;
Count : out Natural);
private
Set : Commands;
the_Count : Natural := 0;
end safe_command_Set;
type safe_command_Set_view is access all safe_command_Set;
type Item is tagged limited
record
Age : Duration := 0.0;
Space : physics.Space.view;
Commands : safe_command_Set_view := new safe_command_Set;
Evolver : engine.Evolver (Item'Access);
end record;
end physics.Engine;
|