File: full_test.adb

package info (click to toggle)
libgtkada2 2.8.1-6lenny3
  • links: PTS, VCS
  • area: main
  • in suites: lenny
  • size: 13,496 kB
  • ctags: 3,886
  • sloc: ada: 103,189; ansic: 45,411; perl: 5,500; sh: 2,812; makefile: 1,169; xml: 19
file content (340 lines) | stat: -rw-r--r-- 11,537 bytes parent folder | download | duplicates (5)
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

with Glib;                use Glib;
with Gdk.Color;           use Gdk.Color;
with Gdk.GC;              use Gdk.GC;
with Gdk.Drawable;        use Gdk.Drawable;
with Gtk.Adjustment;      use Gtk.Adjustment;
with Gtk.Window;          use Gtk.Window;
with Gtk.Enums;           use Gtk.Enums;
with Gtk.Handlers;        use Gtk.Handlers;
with Gtk.Button;          use Gtk.Button;
with Gtk.Box;             use Gtk.Box;
with Gtk.Label;           use Gtk.Label;
with Gtk.Widget;          use Gtk.Widget;
with Double_Buffer;       use Double_Buffer;
with Gtk.Toggle_Button;   use Gtk.Toggle_Button;
with Gtk.Main;            use Gtk.Main;
with Gtk.Text_Buffer;     use Gtk.Text_Buffer;
with Gtk.Text_View;       use Gtk.Text_View;
with Gtk.Scrolled_Window; use Gtk.Scrolled_Window;

with Gtk.Type_Conversion;
pragma Warnings (Off, Gtk.Type_Conversion);
--  So that we can get the child of a button (a Gtk_Label) even if it
--  was created at the C level

pragma Elaborate_All (Gtk.Handlers);

with Ada.Numerics.Discrete_Random;

package body Full_Test is
   package Void_Cb is new Gtk.Handlers.User_Callback
     (Widget_Type => Gtk_Toggle_Button_Record,
      User_Type   => Gtk_Double_Buffer);
   package Button_Cb is new Gtk.Handlers.Callback
     (Widget_Type => Gtk_Double_Buffer_Record);
   package Quit_Cb is new Gtk.Handlers.Callback
     (Widget_Type => Gtk_Window_Record);

   Pixmap_Width : constant Gint := 400;
   Pixmap_Height : constant Gint := 250;

   subtype My_Gint is Gint range 0 .. Gint'Min (Pixmap_Width, Pixmap_Height);
   package Gint_Random is new Ada.Numerics.Discrete_Random (My_Gint);
   Gen : Gint_Random.Generator;

   subtype Color_Index is Natural range 1 .. 5;
   Colors : Gdk_Color_Array (Color_Index'Range);
   package Color_Random is new Ada.Numerics.Discrete_Random (Color_Index);
   Gen_Color : Color_Random.Generator;

   White_Gc : Gdk.GC.Gdk_GC;
   Black_Gc : Gdk.GC.Gdk_GC;

   -----------------------
   -- Toggle_Back_Store --
   -----------------------

   procedure Toggle_Back_Store (Button : access Gtk_Toggle_Button_Record'Class;
                                Buffer : Gtk_Double_Buffer) is
   begin
      Set_Back_Store (Buffer, Get_Active (Button));
   end Toggle_Back_Store;

   -------------------
   -- Toggle_Triple --
   -------------------

   procedure Toggle_Triple (Button : access Gtk_Toggle_Button_Record'Class;
                            Buffer : Gtk_Double_Buffer) is
   begin
      Set_Triple_Buffer (Buffer, Get_Active (Button));
   end Toggle_Triple;

   -------------------
   -- Toggle_Freeze --
   -------------------

   procedure Toggle_Freeze (Button : access Gtk_Toggle_Button_Record'Class;
                            Buffer : Gtk_Double_Buffer)
   is
      Label : Gtk_Label;
   begin
      --  The following call only works thanks to
      --  the 'with Gtk.Type_Conversion', since the label is created in C
      --  and not in Ada.

      Label := Gtk_Label (Widget_List.Get_Data (Children (Button)));

      if Get_Active (Button) then
         Freeze (Buffer);
         Set_Text (Label, "Thaw");

      else
         Thaw (Buffer);
         Set_Text (Gtk_Label (Widget_List.Get_Data (Children (Button))),
                   "Freeze");
      end if;
   end Toggle_Freeze;

   ----------
   -- Draw --
   ----------

   procedure Draw (Buffer : access Gtk_Double_Buffer_Record'Class) is
      X : Gint := Gint (Gint_Random.Random (Gen));
      Y : Gint := Gint (Gint_Random.Random (Gen));

   begin
      Gdk.GC.Set_Foreground (Black_Gc,
                             Colors (Color_Random.Random (Gen_Color)));
      Draw_Rectangle (Get_Pixmap (Buffer),
                      Black_Gc, False,
                      X, Y, 50, 30);
   end Draw;

   -----------
   -- Reset --
   -----------

   procedure Reset (Buffer : access Gtk_Double_Buffer_Record'Class) is
   begin
      Draw_Rectangle (Get_Pixmap (Buffer),
                      White_Gc, True, 0, 0,
                      Gint (Get_Allocation_Width (Buffer)),
                      Gint (Get_Allocation_Height (Buffer)));
   end Reset;

   ----------------
   -- Force_Draw --
   ----------------

   procedure Force_Draw (Buffer : access Gtk_Double_Buffer_Record'Class) is
   begin
      Double_Buffer.Draw (Buffer);
   end Force_Draw;

   ----------
   -- Quit --
   ----------

   procedure Quit (Win : access Gtk_Window_Record'Class) is
      pragma Warnings (Off, Win);
   begin
      Gtk.Main.Gtk_Exit (0);
   end Quit;

   ----------
   -- Help --
   ----------

   function Help return String is
      LF : constant Character := ASCII.LF;
   begin
      return "This demo shows how the double_buffer works:"
         & LF
         & "You can draw random rectangles on the off-screen pixmap thanks"
         & LF & " to the DRAW button."
         & LF & LF
         & "The rectangles will not appear on the screen before you explictly"
         & LF
         & " call Gtk.Widget.Draw (button GTK.WIDGET.DRAW). This copies the"
         & LF
         & " off-screen pixmap both to the screen and to the triple buffer if"
         & LF
         & " you are using it."
         & LF & LF
         & "You should also examine how the double_buffer behaves with regards"
         & LF
         & " to expose event. The simplest way to test that is to hide part or"
         & LF
         & " all of the window, and show it again."
         & LF & LF
         & "The following scenarii are worth examining:"
         & LF & LF
         & "  - If no Triple_Buffer is used and the window not frozen."
         & LF & LF
         & "    The screen is updated from the off-screen pixmap whenever you"
         & LF
         & "    click on DRAW or force an expose event. If you are in the" & LF
         & "    process of doing a long draw operation (multiple DRAW clicks)"
         & LF
         & "    the screen is updated anyway with whatever is displayed on"
         & LF & "    the off-screen buffer at the time."
         & LF & LF
         & "  - If no Triple_Buffer is used and the window is frozen."
         & LF & LF &
         "    The screen is not updated when an expose event happens, and the"
         & LF
         & "    update is delayed until the widget is thawed." & LF
         & "    Likewise, the screen is not updated even when you call" & LF
         & "    Gtk.Widget.Draw."
         & LF & LF
         & "  - If a Triple_Buffer is used and the window is not frozen."
         & LF & LF &
         "    The screen is updated from the triple buffer. Thus you can draw"
         & LF
         & "    anything on the double-buffer, it won't be visible on the"
         & LF
         & "    screen until you call Gtk.Widget.Draw, even if some expose"
         & LF
         & "    event happens during a long draw operation."
         & LF & LF
         & "  - If a Triple_Buffer is used and the window is frozen."
         & LF & LF
         & "    The screen is still updated from the triple buffer. However,"
         & LF
         & "    the double buffer is never copied to the triple buffer, even"
         & LF
         & "    when you call Gtk.Widget.Draw. When the widget is thawed, the"
         & LF
         & "    double buffer is copied to the triple buffer if required."
         & LF & LF
         & "The value of Back_Store is used when the widget is resized. If its"
         & LF
         & " value is False, then the content of the pixmap is not saved when"
         & LF
         & " widget is resized, and the new content of the pixmap is random."
         & LF &
         "If its value is True, then the content is restored, and if required"
         & LF
         & " is completed by an solid color (chosen from the Gtk_Style of the"
         & LF
         & " widget).";
   end Help;

   ----------
   -- Init --
   ----------

   procedure Init is
      Win    : Gtk_Window;
      Vbox,
      Hbox,
      Box    : Gtk_Box;
      Buffer : Gtk_Double_Buffer;
      Button : Gtk_Button;
      Toggle : Gtk_Toggle_Button;
      Text   : Gtk_Text_View;
      Text_Buffer : Gtk_Text_Buffer;
      Scrolled : Gtk_Scrolled_Window;
      Color   : Gdk.Color.Gdk_Color;
      Result  : Gint;
      Success : Boolean_Array (Color_Index'Range);

   begin
      Gtk_New (Win, Window_Toplevel);
      Set_Title (Win, "Double_Buffer tests");
      Quit_Cb.Connect (Win, "destroy", Quit_Cb.To_Marshaller (Quit'Access));

      Gtk_New_Vbox (Vbox, Homogeneous => False);
      Add (Win, Vbox);

      Gtk_New_Hbox (Hbox, Homogeneous => False, Spacing => 5);
      Pack_Start (Vbox, Hbox);

      Gtk_New_Vbox (Box, Homogeneous => False, Spacing => 5);
      Pack_Start (Hbox, Box, Expand => False, Fill => False);

      Gtk_New (Buffer);
      Set_Back_Store (Buffer, True);
      Set_Triple_Buffer (Buffer, False);
      Set_USize (Buffer, Pixmap_Width, Pixmap_Height);
      Pack_Start (Hbox, Buffer, Expand => True);

      Gtk_New (Button, "Rectangle");
      Pack_Start (Box, Button, Expand => False);
      Button_Cb.Object_Connect (Button, "clicked",
                                Button_Cb.To_Marshaller (Draw'Access),
                                Buffer);

      Gtk_New (Button, "Gtk.Widget.Draw");
      Pack_Start (Box, Button, Expand => False);
      Button_Cb.Object_Connect (Button, "clicked",
                                Button_Cb.To_Marshaller (Force_Draw'Access),
                                Buffer);

      Gtk_New (Button, "Reset");
      Pack_Start (Box, Button, Expand => False);
      Button_Cb.Object_Connect (Button, "clicked",
                                Button_Cb.To_Marshaller (Reset'Access),
                                Buffer);

      Gtk_New (Toggle, "Freeze");
      Pack_End (Box, Toggle, Expand => False);
      Void_Cb.Connect (Toggle, "clicked",
                       Void_Cb.To_Marshaller (Toggle_Freeze'Access),
                       Buffer);

      Gtk_New (Toggle, "Back Store");
      Set_Active (Toggle, True);
      Pack_End (Box, Toggle, Expand => False);
      Void_Cb.Connect (Toggle, "clicked",
                       Void_Cb.To_Marshaller (Toggle_Back_Store'Access),
                       Buffer);

      Gtk_New (Toggle, "Use Triple Buffer");
      Pack_End (Box, Toggle, Expand => False);
      Void_Cb.Connect (Toggle, "clicked",
                       Void_Cb.To_Marshaller (Toggle_Triple'Access),
                       Buffer);

      Gtk_New (Scrolled);
      Set_Policy (Scrolled, Policy_Automatic, Policy_Automatic);
      Pack_Start (Vbox, Scrolled);

      Gtk_New (Text_Buffer);
      Gtk_New (Text, Text_Buffer);
      Set_Editable (Text, False);
      Set_USize (Text, Pixmap_Width, 250);
      Add (Scrolled, Text);

      Set_Text (Text_Buffer, Help);

      Show_All (Win);

      Gdk.GC.Gdk_New (White_Gc, Get_Window (Buffer));
      Color := Gdk.Color.Parse ("black");
      Gdk.Color.Alloc (Get_Default_Colormap, Color);
      Gdk.GC.Set_Foreground (White_Gc, Color);

      Reset (Buffer);
      Double_Buffer.Draw (Buffer);

      Colors (1) := Gdk.Color.Parse ("blue");
      Colors (2) := Gdk.Color.Parse ("red");
      Colors (3) := Gdk.Color.Parse ("green");
      Colors (4) := Gdk.Color.Parse ("yellow");
      Colors (5) := Gdk.Color.Parse ("orange");

      Alloc_Colors (Get_Default_Colormap,
                    Colors,
                    Writeable  => False,
                    Best_Match => True,
                    Success    => Success,
                    Result     => Result);

      Gdk.GC.Gdk_New (Black_Gc, Get_Window (Buffer));
   end Init;

end Full_Test;