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
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257 | with
gel.remote.World,
gel.World,
gel.Camera,
gel.Keyboard,
gel.Mouse,
gel.Sprite,
gel.Dolly,
gel.Window,
openGL.Renderer.lean,
opengl.Font,
lace.Event,
lace.Response,
lace.Subject,
lace.Observer,
lace.Subject_and_deferred_Observer,
ada.Containers.Vectors;
package gel.Applet
--
-- Provides an application model, configured with a single window.
--
is
type Item is limited new lace.Subject_and_deferred_Observer.item with private;
type View is access all Item'Class;
----------
--- Forge
--
package Forge
is
function to_Applet (Name : in String;
use_Window : in gel.Window.view) return Item;
function new_Applet (Name : in String;
use_Window : in gel.Window.view) return View;
end Forge;
overriding
procedure destroy (Self : in out Item);
procedure free (Self : in out View);
---------------
--- Attributes
--
function is_Open (Self : in Item) return Boolean;
function Window (Self : in Item) return gel.Window.view;
function Renderer (Self : in Item) return openGL.Renderer.lean.view;
function Keyboard (Self : in Item) return access gel.Keyboard.item'Class;
function Mouse (Self : in Item) return access gel.Mouse .item'Class;
function Dolly (Self : access Item) return gel.Dolly.view;
function last_Keypress (Self : access Item) return gel.Keyboard.Key;
function world_Count (Self : in Item) return Natural;
function Worlds (Self : in Item) return gel.World.views;
function World (Self : in Item; Id : in world_Id := 1) return gel.World.view;
function World_as_iFace (Self : in Item; Id : in world_Id := 1) return gel.remote.World.view;
function Camera (Self : in Item; world_Id : in gel.world_Id := 1;
camera_Id : in gel.camera_Id := 1) return gel.Camera.view;
function Font (Self : in Item) return opengl.Font.font_Id;
function titles_Font (Self : in Item) return opengl.Font.font_Id;
---------------------------------
--- Add a new world and camera(s)
--
use type gel.Camera.view;
package camera_Vectors is new ada.Containers.Vectors (Positive, gel.Camera.view);
subtype camera_Vector is camera_Vectors.Vector;
type world_Info is
record
World : gel.World.view;
Cameras : camera_Vector;
end record;
type world_Info_view is access all world_Info;
procedure add (Self : in out Item; the_World : in world_Info_view);
procedure add_new_World (Self : in out Item; Name : in String;
space_Kind : in physics.space_Kind);
function new_World (Self : access Item; Name : in String;
space_Kind : in physics.space_Kind) return gel.World.view;
---------------
--- Operations
--
use Math;
procedure evolve_all_Worlds (Self : in out Item; By : in Duration);
procedure add (Self : in out Item; the_Sprite : in gel.Sprite.view);
procedure add (Self : in out Item; the_Sprite : in gel.Sprite.view;
at_site : in Vector_3);
procedure Dolly_is (Self : access Item; Now : in gel.Dolly.view);
procedure enable_simple_Dolly (Self : access Item; in_World : in world_Id);
procedure enable_following_Dolly (Self : access Item; Follow : in gel.Sprite.view);
procedure enable_Mouse (Self : access Item; detect_Motion : in Boolean);
procedure prepare (Self : access Item) is null;
procedure freshen (Self : in out Item);
--
-- processes window events and then redraws the window.
procedure take_Screenshot (Self : in out Item; Filename : in String);
procedure request_Quit (Self : in out Item);
----------
--- Events
--
function local_Subject_and_Observer
(Self : access Item) return lace.Subject_and_deferred_Observer.view;
function local_Subject (Self : access Item) return lace.Subject.view;
function local_Observer (Self : access Item) return lace.Observer.view;
private
use type Sprite.view;
package sprite_Vectors is new ada.containers.Vectors (Positive, Sprite.view);
-------------------
--- Event Responses
--
type applet_event_Response is abstract new lace.Response.item with
record
Applet : gel.Applet.view;
end record;
-- 'add_new_Sprite' Response
--
type add_new_Sprite is new applet_event_Response with null record;
overriding
function Name (Self : in add_new_Sprite) return String;
overriding
procedure respond (Self : in out add_new_Sprite; to_Event : in lace.Event.item'Class);
the_add_new_sprite_Response : aliased add_new_Sprite;
-- 'Keyboard' Responses
--
type key_press_Response is new applet_event_Response with null record;
overriding
procedure respond (Self : in out key_press_Response; to_Event : in lace.Event.item'Class);
type key_release_Response is new applet_event_Response with null record;
overriding
procedure respond (Self : in out key_release_Response; to_Event : in lace.Event.item'Class);
-- 'Mouse' Responses
--
type button_press_Response is new applet_event_Response with null record;
overriding
procedure respond (Self : in out button_press_Response; to_Event : in lace.Event.item'Class);
type button_release_Response is new applet_event_Response with null record;
overriding
procedure respond (Self : in out button_release_Response; to_Event : in lace.Event.item'Class);
type mouse_motion_Response is new applet_event_Response with null record;
overriding
procedure respond (Self : in out mouse_motion_Response; to_Event : in lace.Event.item'Class);
type mouse_click_raycast_Response is new lace.Response.item with
record
Applet : gel.Applet.view;
end record;
overriding
procedure respond (Self : in out mouse_click_raycast_Response; to_Event : in lace.Event.item'Class);
type mouse_click_raycast_Response_view is access all mouse_click_raycast_Response'Class;
-- 'Screen' Resize Response
--
type resize_event_Response is new applet_event_Response with null record;
overriding
procedure respond (Self : in out resize_event_Response; to_Event : in lace.Event.Item'Class);
----------------
--- world_Vector
--
use type gel.World.view;
package world_Vectors is new ada.Containers.Vectors (Positive, world_Info_view);
subtype world_Vector is world_Vectors.Vector;
--------------
-- Applet Item
--
type Item is limited new lace.Subject_and_deferred_Observer.item with
record
local_Subject_and_Observer : lace.Subject_and_deferred_Observer.view := new lace.Subject_and_deferred_Observer.item;
Worlds : World_Vector;
Window : gel.Window.view;
resize_Response : aliased applet.resize_event_Response;
Keyboard : access gel.Keyboard.item'Class;
key_press_Response : aliased applet.key_press_Response;
key_release_Response : aliased applet.key_release_Response;
Mouse : access gel.Mouse.item'Class;
button_press_Response : aliased applet.button_press_Response;
button_release_Response : aliased applet.button_release_Response;
mouse_motion_Response : aliased applet.mouse_motion_Response;
mouse_click_raycast_Response : aliased applet.mouse_click_raycast_Response;
Renderer : openGL.Renderer.lean.view;
Font : opengl.Font.font_Id := (openGL.to_Asset ("assets/opengl/font/LiberationMono-Regular.ttf"), 30);
titles_Font : opengl.Font.font_Id := (openGL.to_Asset ("assets/opengl/font/LiberationMono-Regular.ttf"), 40);
is_capturing_Video : Boolean := False;
Dolly : gel.Dolly.view;
last_pressed_Key : gel.Keyboard.Key := gel.Keyboard.Nil;
key_Focus : gel.Sprite.view;
quit_Requested : Boolean := False;
end record;
global_Window : gel.Window.view;
end gel.Applet;
|