-
Notifications
You must be signed in to change notification settings - Fork 0
/
jewl-canvas_implementation.ads
374 lines (338 loc) · 14.8 KB
/
jewl-canvas_implementation.ads
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
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
------------------------------------------------------------------------------
-- --
-- J E W L . C A N V A S _ I M P L E M E N T A T I O N --
-- --
-- This is a private package containing the internal implementation --
-- details of the canvases, as defined in JEWL.Windows. --
-- --
-- Copyright (C) John English 2000. Contact address: je@brighton.ac.uk --
-- This software is released under the terms of the GNU General Public --
-- License and is intended primarily for educational use. Please contact --
-- the author to report bugs, suggestions and modifications. --
-- --
------------------------------------------------------------------------------
-- $Id: jewl-canvas_implementation.ads 1.7 2007/01/08 17:00:00 JE Exp $
------------------------------------------------------------------------------
--
-- $Log: jewl-canvas_implementation.ads $
-- Revision 1.7 2007/01/08 17:00:00 JE
-- * Fixed linker options in JEWL.Win32_Interface to accommodate changes to GNAT
-- GPL 2006 compiler (thanks to John McCormick for this)
-- * Added delay in message loop to avoid the appearance of hogging 100% of CPU
-- time
--
-- Revision 1.6 2001/11/02 16:00:00 JE
-- * Fixed canvas bug when saving an empty canvas
-- * Restore with no prior save now acts as erase
-- * Removed redundant variable declaration in Image function
--
-- Revision 1.5 2001/08/22 15:00:00 JE
-- * Minor bugfix to Get_Text for combo boxes
-- * Minor changes to documentation (including new example involving dialogs)
--
-- Revision 1.4 2001/01/25 09:00:00 je
-- Changes visible to the user:
--
-- * Added support for drawing bitmaps on canvases (Draw_Image operations
-- and new type Image_Type)
-- * Added Play_Sound
-- * Added several new operations on all windows: Get_Origin, Get_Width,
-- Get_Height, Set_Origin, Set_Size and Focus
-- * Added several functions giving screen and window dimensions: Screen_Width,
-- Screen_Height, Frame_Width, Frame_Height, Dialog_Width, Dialog_Height and
-- Menu_Height
-- * Canvases can now handle keyboard events: new constructor and Key_Code added
-- * Added procedure Play_Sound
-- * Operations "+" and "-" added for Point_Type
-- * Pens can now be zero pixels wide
-- * The absolute origin of a frame can now have be specified when the frame
-- is created
-- * Added new File_Dialog operations Add_Filter and Set_Directory
-- * Added Get_Line renames to JEWL.IO for compatibility with Ada.Text_IO
-- * Added all the Get(File,Item) operations mentioned in documentation but
-- unaccountably missing :-(
-- * Documentation updated to reflect the above changes
-- * HTML versions of public package specifications added with links from
-- main documentation pages
--
-- Other internal changes:
--
-- * Canvas fonts, pens etc. now use JEWL.Reference_Counted_Type rather than
-- reinventing this particular wheel, as do images
-- * Various minor code formatting changes: some code reordered for clarity,
-- some comments added or amended,
-- * Changes introduced in 1.2 to support GNAT 3.10 have been reversed, since
-- GNAT 3.10 still couldn't compile this code correctly... ;-(
--
-- Outstanding issues:
--
-- * Optimisation breaks the code (workaround: don't optimise)
--
-- Revision 1.3 2000/07/07 12:00:00 je
-- * JEWL.Simple_Windows added; JEWL.IO modified to use JEWL.Simple_Windows.
-- * JEWL.IO bug fix: Put_Line to file wrote newline to standard output
-- instead of to the file (thanks to Jeff Carter for pointing this out).
-- * Panels fixed so that mouse clicks are passed on correctly to subwindows.
-- * Memos fixed so that tabs are handled properly.
-- * Password feature added to editboxes.
-- * Minor typos fixed in comments within the package sources.
-- * Documentation corrected and updated following comments from Moti Ben-Ari
-- and Don Overheu.
--
-- Revision 1.2 2000/04/18 20:00:00 je
-- * Minor code changes to enable compilation by GNAT 3.10
-- * Minor documentation errors corrected
-- * Some redundant "with" clauses removed
--
-- Revision 1.1 2000/04/09 21:00:00 je
-- Initial revision
--
------------------------------------------------------------------------------
with Ada.Finalization;
with JEWL.Win32_Interface;
private package JEWL.Canvas_Implementation is
use JEWL.Win32_Interface;
type Point_List is array (Positive range <>) of aliased Win32_POINT;
----------------------------------------------------------------------------
-- Forward declarations (defined fully later).
----------------------------------------------------------------------------
type Canvas_Object_Type;
type Canvas_Object_Ptr is access Canvas_Object_Type'Class;
type Image_Internals;
type Image_Ptr is access all Image_Internals;
----------------------------------------------------------------------------
--
-- C A N V A S _ M O N I T O R
--
-- Every canvas contains one of these protected records to synchronise
-- drawing operations with accesses from the message loop task. The
-- canvas stores the objects which are drawn on it as a linked list
-- of drawing objects (defined in JEWL.Objects).
--
-- The private data of a Canvas_Monitor is as follows:
--
-- First_Object : pointer to the first object in the drawing list
-- Last_Object : pointer to the last object in the drawing list
-- Save_Pointer : pointer to the saved position in the drawing list
-- BG_Brush : the brush used to paint the background of the canvas
-- Start_X : the X position where the mouse button was pressed
-- Start_Y : the Y position where the mouse button was pressed
-- End_X : the most recent X position while the mouse is down
-- End_Y : the most recent Y position while the mouse is down
-- Button : true if the mouse is down
-- Moved : true is the mouse has moved while the button is down
-- Keycode : the key that was pressed (or NUL if none)
--
-- The operations on a Canvas_Monitor are as follows:
--
-- Clear : delete all objects in the drawing list
-- Save ; save a pointer to the current end of the drawing list
-- Restore : truncate the drawing list to a previously saved point
-- Draw : draw all objects in the drawing list (called from the
-- message loop task)
-- Add : add an object to the end of the drawing list
-- Set_Brush : set the background brush
-- Background : get the background brush (called from the message loop
-- task)
-- Set_Start : set the start position when the mouse button is pressed
-- (called from the message loop task)
-- Get_Start : get the start position when the mouse button is pressed
-- Set_End : set the current mouse position and the mouse-move flag
-- (called from the message loop task)
-- Get_End : get the current mouse position
-- Set_Button : set the mouse button state (called from the message loop
-- task)
-- Mouse_Down : return the mouse button state
-- Mouse_Moved : return the mouse-move flag and reset it
-- Set_Key : set the keycode for a key press
-- Get_Key : get and reset the current keycode
--
----------------------------------------------------------------------------
protected type Canvas_Monitor is
procedure Clear;
procedure Save;
procedure Restore;
procedure Draw (Handle : in Win32_HWND;
Font : in Win32_HFONT);
procedure Add (Object : in Canvas_Object_Ptr);
procedure Set_Brush (Brush : in Win32_HBRUSH);
function Background return Win32_HBRUSH;
procedure Set_Start (X, Y : in Integer);
procedure Get_Start (X, Y : out Integer);
procedure Set_End (X, Y : in Integer);
procedure Get_End (X, Y : out Integer);
procedure Set_Button (B : in Boolean);
function Mouse_Down return Boolean;
function Mouse_Moved return Boolean;
procedure Set_Key (C : in Character);
procedure Get_Key (C : out Character);
private
First_Object : Canvas_Object_Ptr;
Last_Object : Canvas_Object_Ptr;
Save_Pointer : Canvas_Object_Ptr;
BG_Brush : Win32_HBRUSH;
Start_X : Integer := 0;
Start_Y : Integer := 0;
End_X : Integer := 0;
End_Y : Integer := 0;
Button : Boolean := False;
Moved : Boolean := False;
Keycode : Character := ASCII.NUL;
end Canvas_Monitor;
----------------------------------------------------------------------------
--
-- C A N V A S _ O B J E C T _ T Y P E
--
-- Canvas_Object_Type is the base type from which all drawing objects
-- are derived, and Canvas_Object_Ptr is a class-wide pointer. Each
-- object contains a pointer so that a singly-linked list of objects
-- can be constructed. Every object must define a Draw procedure which
-- draws the object on a window (which is identified by a handle to a
-- Windows display context).
--
----------------------------------------------------------------------------
type Canvas_Object_Type is abstract tagged
record
Next : Canvas_Object_Ptr;
end record;
procedure Draw (Object : in out Canvas_Object_Type;
Window : in Win32_HDC) is abstract;
----------------------------------------------------------------------------
--
-- Text_Type: an object type containing a text string
--
type Text_Type (Length : Natural) is new Canvas_Object_Type with
record
Text : String (1..Length);
From, To : JEWL.Point_Type;
Align : Integer;
end record;
procedure Draw (Object : in out Text_Type;
Window : in Win32_HDC);
----------------------------------------------------------------------------
--
-- Line_Type: an object type which defines a line by a pair of endpoints.
--
type Line_Type is new Canvas_Object_Type with
record
From, To : JEWL.Point_Type;
end record;
procedure Draw (Object : in out Line_Type;
Window : in Win32_HDC);
----------------------------------------------------------------------------
--
-- Rectangle_Type: an object type which defines a rectangle as a pair
-- of coordinates for two opposite corners.
--
type Rectangle_Type is new Canvas_Object_Type with
record
From, To : JEWL.Point_Type;
end record;
procedure Draw (Object : in out Rectangle_Type;
Window : in Win32_HDC);
----------------------------------------------------------------------------
--
-- Rounded_Rectangle_Type: an object type which defines a rectangle with
-- rounded corners using a pair of coordinates
-- for two opposite corners and a point to define
-- the size of the arc used to round the corners.
--
type Rounded_Rectangle_Type is new Canvas_Object_Type with
record
From, To, Corner : Point_Type;
end record;
procedure Draw (Object : in out Rounded_Rectangle_Type;
Window : in Win32_HDC);
----------------------------------------------------------------------------
--
-- Ellipse_Type: an object type which defines an ellipse or circle using
-- a pair of coordinates for two opposite corners of the
-- bounding rectangle.
--
type Ellipse_Type is new Canvas_Object_Type with
record
From, To : JEWL.Point_Type;
end record;
procedure Draw (Object : in out Ellipse_Type;
Window : in Win32_HDC);
----------------------------------------------------------------------------
--
-- Polyline_Type: an object type which defines an open figure as a
-- sequence of lines.
--
type Polyline_Type (Count : Positive) is new Canvas_Object_Type with
record
Points : Point_List(1..Count);
end record;
procedure Draw (Object : in out PolyLine_Type;
Window : in Win32_HDC);
----------------------------------------------------------------------------
--
-- Polygon_Type: an object type which defines an open figure as a
-- sequence of lines.
--
type Polygon_Type (Count : Positive) is new Canvas_Object_Type with
record
Points : Point_List(1..Count);
end record;
procedure Draw (Object : in out Polygon_Type;
Window : in Win32_HDC);
----------------------------------------------------------------------------
--
-- Handle_Type: an object type which encapsulates a handle to a Windows
-- GDI object (e.g. a pen or a brush).
--
type Handle_Type is new Canvas_Object_Type with
record
Handle : JEWL.Controlled_Type;
end record;
procedure Draw (Object : in out Handle_Type;
Window : in Win32_HDC);
----------------------------------------------------------------------------
--
-- Bitmap_Type: an object type representing a bitmap image.
--
type Bitmap_Type is new Canvas_Object_Type with
record
From : JEWL.Point_Type;
Width : Natural;
Height : Natural;
Bitmap : JEWL.Controlled_Type;
end record;
procedure Draw (Object : in out Bitmap_Type;
Window : in Win32_HDC);
----------------------------------------------------------------------------
--
-- C O N T R O L L E D T Y P E S
--
-- Each type below is a reference counted type which contains a handle to
-- a Windows GDI object. The handle will be deleted automatically when the
-- last object which refers to it is destroyed.
--
----------------------------------------------------------------------------
--
-- Image_Internals: used to store bitmaps in drawings
--
type Image_Internals is new Reference_Counted_Type with
record
Image : Win32_HBITMAP;
Width : Natural;
Height : Natural;
end record;
procedure Cleanup (Object : in out Image_Internals);
----------------------------------------------------------------------------
--
-- Counted_Handle_Type: used to store pens, brushes etc. in drawings
--
type Counted_Handle_Type is new JEWL.Reference_Counted_Type with
record
Handle : Win32_HGDIOBJ;
end record;
procedure Cleanup (Object : in out Counted_Handle_Type);
----------------------------------------------------------------------------
--
-- Handle: a function to create a controlled type object which contains
-- a Counted_Handle_Type object.
--
function Handle (Object : Win32_HGDIOBJ) return JEWL.Controlled_Type;
end JEWL.Canvas_Implementation;