File: view_gl.gpb

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 (375 lines) | stat: -rw-r--r-- 11,161 bytes parent folder | download | duplicates (2)
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
375
#if HAVE_GL then
with Ada.Text_IO;      use Ada.Text_IO;
with gl_h;             use gl_h;
with Gdk.Event;        use Gdk.Event;
with Gdk.GL;           use Gdk.GL;
with Gdk.Rectangle;    use Gdk.Rectangle;
with Gdk.Types;        use Gdk.Types;
with Gdk.Window;       use Gdk.Window;
with Glib;             use Glib;
with glu_h;            use glu_h;
with Gtk.GLArea;       use Gtk.GLArea;
with Gtk.Handlers;     use Gtk.Handlers;
with Lwobjects;        use Lwobjects;
with Trackball;        use Trackball;
#else
with Gtk.Label; use Gtk.Label;
#end if;

package body View_Gl is

#if HAVE_GL
   type Mesh_Info_Type is
      record
         Do_Init : Boolean := True;  --  True if not yet initialized
         Zoom    : Float;            --  Field of view in degrees
         Quat    : Quaternion;       -- orientation of object
         Beginx  : Float;            --  Position of mouse
         Beginy  : Float;
         Object  : Lwobject;         --  lightwave object mesh
      end record;

   type My_Glarea_Record is new Gtk_GLArea_Record with
      record
         Mesh_Info : Mesh_Info_Type;
      end record;
   type My_Glarea is access all My_Glarea_Record'Class;

   package Event_Cb is new Gtk.Handlers.Return_Callback
     (My_Glarea_Record, Boolean);
   package Void_Cb is new Gtk.Handlers.Callback (My_Glarea_Record);

   VIEW_ASPECT : constant Float := 1.3;

   -------------
   -- Init_GL --
   -------------

   procedure Init_GL is
      Light0_Pos   : constant GLfloat_Vec_4 := (-50.0, 50.0, 0.0, 0.0);
      Light0_Color : constant GLfloat_Vec_4 := (0.6, 0.6, 0.6, 1.0);
      Light1_Pos   : constant GLfloat_Vec_4 := (50.0, 50.0, 0.0, 0.0);
      Light1_Color : constant GLfloat_Vec_4 := (0.4, 0.4, 1.0, 1.0);

   begin

      --  Remove back faces

      glDisable (GL_CULL_FACE);
      glEnable (GL_DEPTH_TEST);

      --  Speedups

      glDisable (GL_DITHER);
      glShadeModel (GL_SMOOTH);
      glHint (GL_PERSPECTIVE_CORRECTION_HINT, GL_FASTEST);
      glHint (GL_POLYGON_SMOOTH_HINT, GL_FASTEST);

      --  Light

      glLightfv (GL_LIGHT0, GL_POSITION, Light0_Pos);
      glLightfv (GL_LIGHT0, GL_DIFFUSE,  Light0_Color);
      glLightfv (GL_LIGHT1, GL_POSITION, Light1_Pos);
      glLightfv (GL_LIGHT1, GL_DIFFUSE,  Light1_Color);
      glEnable (GL_LIGHT0);
      glEnable (GL_LIGHT1);
      glEnable (GL_LIGHTING);

      glColorMaterial (GL_FRONT_AND_BACK, GL_AMBIENT_AND_DIFFUSE);
      glEnable (GL_COLOR_MATERIAL);
   end Init_GL;

   -------------------
   -- Glarea_Expose --
   -------------------

   function Glarea_Expose (Area  : access My_Glarea_Record'Class;
                           Event : Gdk_Event)
                          return Boolean
   is
      --  Event is an Expose_Event, but no need to cast, this is tested
      --  automatically by GtkAda

      M : Trackball.Matrix;

#if WIN32 then
      Val : aliased GLfloat;
#end if;

   begin
      --  Draw only the last expose event

      if Get_Count (Event) > 0 then
         return True;
      end if;

      --  OpenGL calls can be done only if make_current returns true

      if Make_Current (Area) then

         --  Basic initialization
         if Area.Mesh_Info.Do_Init then
            Init_GL;
            Area.Mesh_Info.Do_Init := False;
         end if;

         --  View
         glMatrixMode (GL_PROJECTION);
         glLoadIdentity;

#if WIN32 then
         gluPerspective (GLdouble (Area.Mesh_Info.Zoom),
                         GLdouble (VIEW_ASPECT), 1.0, 100.0);
#else
         gluPerspective (Long_Float (Area.Mesh_Info.Zoom),
                         Long_Float (VIEW_ASPECT), 1.0, 100.0);
#end if;
         glMatrixMode (GL_MODELVIEW);

         --  Draw Object
         glClearColor (0.3, 0.4, 0.6, 1.0);
         glClear (GL_COLOR_BUFFER_BIT + GL_DEPTH_BUFFER_BIT);

         glLoadIdentity;
         glTranslatef (0.0, 0.0, -30.0);
         Build_Rotmatrix (M, Area.Mesh_Info.Quat);

#if WIN32 then
         Val := GLfloat (M (0, 0));
         glmultmatrixf (Val'Unchecked_Access);
#else
         glMultMatrixf (M (0, 0)'Access);
#end if;

         Lw_Object_Show (Area.Mesh_Info.Object);

         --  Swap backbuffer to front
         Swap_Buffers (Area);
      end if;
      return True;
   end Glarea_Expose;

   ---------------
   -- Configure --
   ---------------

   function Configure (Area : access My_Glarea_Record'Class;
                       Event : Gdk_Event)
                      return Boolean
   is
      pragma Warnings (Off, Event);
   begin
      if Make_Current (Area) then
#if WIN32 then
         glViewport (0, 0,
                     GLsizei (Get_Allocation_Width (Area)),
                     GLsizei (Get_Allocation_Height (Area)));
#else
         glViewport (0, 0,
                     Integer (Get_Allocation_Width (Area)),
                     Integer (Get_Allocation_Height (Area)));
#end if;
      end if;
      return True;
   end Configure;

   --------------------
   -- GlArea_Destroy --
   --------------------

   procedure GlArea_Destroy (Area : access My_Glarea_Record'Class)
   is
   begin
      Lw_Object_Free (Area.Mesh_Info.Object);
   end GlArea_Destroy;

   ------------------
   -- Button_Press --
   ------------------

   function Button_Press (Area : access My_Glarea_Record'Class;
                          Event : Gdk_Event)
                         return Boolean
   is
      --  Event is an Gdk_Event_Button, but no need to cast, this is tested
      --  automatically by GtkAda
   begin
      if Get_Button (Event) = 1 then
         Area.Mesh_Info.Beginx := Float (Get_X (Event));
         Area.Mesh_Info.Beginy := Float (Get_Y (Event));
         return True;
      end if;
      return False;
   end Button_Press;

   -------------------
   -- Motion_Notify --
   -------------------

   function Motion_Notify (Area : access My_Glarea_Record'Class;
                           Event : Gdk_Event)
                          return Boolean
   is
      --  Event is an Gdk_Event_Motion, but no need to cast, this is tested
      --  automatically by GtkAda
      X, Y : Gint;
      Win  : Gdk_Window;
      State : Gdk_Modifier_Type;
      Rect  : Gdk_Rectangle;

   begin
      if Get_Is_Hint (Event) then
         Get_Pointer (Get_Window (Event), X, Y, State, Win);
      else
         X := Gint (Get_X (Event));
         Y := Gint (Get_Y (Event));
         State := Get_State (Event);
      end if;
      Rect.X := 0;
      Rect.Y := 0;
      Rect.Width  := Gint (Get_Allocation_Width (Area));
      Rect.Height := Gint (Get_Allocation_Height (Area));

      if (State and Button1_Mask) /= 0 then
         --  Drag in progress, simulate trackball
         declare
            Spin_Quat : Trackball.Quaternion;
         begin
            Trackball.Trackball
              (Spin_Quat,
               (2.0 * Area.Mesh_Info.Beginx - Float (Rect.Width))
                  / Float (Rect.Width),
               (Float (Rect.Height) - 2.0 * Area.Mesh_Info.Beginy)
                  / Float (Rect.Height),
               (2.0 * Float (X) - Float (Rect.Width)) / Float (Rect.Width),
               (Float (Rect.Height) - 2.0 * Float (Y)) / Float (Rect.Height));
            Add_Quats (Spin_Quat, Area.Mesh_Info.Quat,
                       Dest => Area.Mesh_Info.Quat);

            --  orientation has changed, redraw mesh
            Draw (Area, Rect);
         end;
      end if;

      if (State and Button2_Mask) /= 0 then
         --  Zooming drag
         Area.Mesh_Info.Zoom := Area.Mesh_Info.Zoom +
           ((Float (Y) - Area.Mesh_Info.Beginy) / Float (Rect.Height)) * 40.0;
         if Area.Mesh_Info.Zoom < 5.0 then
            Area.Mesh_Info.Zoom := 5.0;
         end if;
         if Area.Mesh_Info.Zoom > 120.0 then
            Area.Mesh_Info.Zoom := 120.0;
         end if;

         --  Zoom has changed, redraw mesh
         Draw (Area, Rect);
      end if;

      Area.Mesh_Info.Beginx := Float (X);
      Area.Mesh_Info.Beginy := Float (Y);
      return True;
   end Motion_Notify;

   -------------------
   -- Show_Lwobject --
   -------------------

   procedure Show_Lwobject (Frame : access Gtk_Frame_Record'Class;
                            Lwobject_Name : String)
   is
      Object : Lwobject;
      Area   : My_Glarea;

   begin
      --  Read lightwave object
      if not Lw_Is_Lwobject (Lwobject_Name) then
         Put_Line (Lwobject_Name & " is not a lightwave 3D object");
         return;
      end if;

      Object := Lw_Object_Read (Lwobject_Name);
      if Object = Null_Lwobject then
         Put_Line ("can't read lightwave 3D object " & Lwobject_Name);
         return;
      end if;

      Lw_Object_Scale (Object, 10.0 / Lw_Object_Radius (Object));

      --  Create aspect frame
      --  Gtk_New (Frame, "", 0.5, 0.5, VIEW_ASPECT, False);

      --  Create new OpenGL widget
      Area := new My_Glarea_Record;
      Initialize (Area,
                  (Gdk_GL_Rgba,
                   Gdk_GL_Red_Size, GL_Configs (1),
                   Gdk_GL_Green_Size, GL_Configs (1),
                   Gdk_GL_Blue_Size, GL_Configs (1),
                   Gdk_GL_Doublebuffer,
                   Gdk_GL_Depth_Size, GL_Configs (1)));
      if Area = null then
         Put_Line ("Can't create Gtk_GLArea widget");
         return;
      end if;
      Queue_Draw (Area);

      --  Setup events and signals
      Set_Events (Area, Exposure_Mask or Button_Press_Mask
                  or Button_Release_Mask or Pointer_Motion_Mask
                  or Pointer_Motion_Hint_Mask);
      Event_Cb.Connect (Area, "expose_event",
                        Event_Cb.To_Marshaller (Glarea_Expose'Access));
      Event_Cb.Connect (Area, "motion_notify_event",
                        Event_Cb.To_Marshaller (Motion_Notify'Access));
      Event_Cb.Connect (Area, "button_press_event",
                        Event_Cb.To_Marshaller (Button_Press'Access));
      Event_Cb.Connect (Area, "configure_event",
                        Event_Cb.To_Marshaller (Configure'Access));
      Void_Cb.Connect (Area, "destroy",
                       Void_Cb.To_Marshaller (GlArea_Destroy'Access));

      Set_USize (Area, 200, Gint (200.0 / VIEW_ASPECT));

      --  Set up mesh info
      Area.Mesh_Info.Do_Init := True;
      Area.Mesh_Info.Object := Object;
      Area.Mesh_Info.Beginx := 0.0;
      Area.Mesh_Info.Beginy := 0.0;
      Area.Mesh_Info.Zoom   := 45.0;
      Trackball.Trackball (Area.Mesh_Info.Quat, 0.0, 0.0, 0.0, 0.0);

      --  gtk_quit_add_destroy(1, GTK_OBJECT(window));

      --  Put GlArea into Window and show it all
      Add (Frame, Area);
      Show_All (Frame);
   end Show_Lwobject;

   ---------
   -- Run --
   ---------

   procedure Run (Frame : access Gtk.Frame.Gtk_Frame_Record'Class) is
   begin
      if not Gdk.GL.Query then
         Put_Line ("OpenGL not supported");
         return;
      end if;

      Show_Lwobject (Frame, "penguin.lwo");
   end Run;

#else

   procedure Run (Frame : access Gtk.Frame.Gtk_Frame_Record'Class) is
      Label : Gtk_Label;
   begin
      Gtk_New (Label, "OpenGL has not been installed on this system");
      Add (Frame, Label);
      Show_All (Frame);
   end Run;

#end if;

end View_Gl;