diff --git a/.gitignore b/.gitignore index dfb3334..4550a8b 100644 --- a/.gitignore +++ b/.gitignore @@ -28,7 +28,7 @@ bin ## Copies # 3-mid/opengl (copy 1) - +4-high/gel (copy *) ## Source # diff --git a/3-mid/opengl/source/lean/renderer/opengl-renderer-lean.adb b/3-mid/opengl/source/lean/renderer/opengl-renderer-lean.adb index 468cca6..e9d5246 100644 --- a/3-mid/opengl/source/lean/renderer/opengl-renderer-lean.adb +++ b/3-mid/opengl/source/lean/renderer/opengl-renderer-lean.adb @@ -24,6 +24,9 @@ with ada.Task_Identification, ada.unchecked_Deallocation; +with GL.Binding; + -- gdk.GLContext; + package body openGL.Renderer.lean is @@ -91,6 +94,7 @@ is end Context_is; + procedure Context_Setter_is (Self : in out Item; Now : in context_Setter) is begin @@ -98,6 +102,15 @@ is end Context_Setter_is; + + procedure context_Clearer_is (Self : in out Item; Now : in context_Clearer) + is + begin + Self.context_Clearer := Now; + end context_Clearer_is; + + + procedure Swapper_is (Self : in out Item; Now : in Swapper) is begin @@ -211,9 +224,28 @@ is -- Engine -- + protected body gl_Lock + is + entry acquire when not Locked + is + begin + Locked := True; + end acquire; + + + entry release when Locked + is + begin + Locked := False; + end release; + + end gl_Lock; + + + task body Engine is - the_Context : Context.view with unreferenced; + the_Context : Context.view; -- with unreferenced; Done : Boolean := False; begin @@ -224,9 +256,10 @@ is end start; openGL.Tasks.Renderer_Task := ada.Task_Identification.current_Task; - Self.context_Setter.all; + -- Self.context_Setter.all; + Self.Context := the_Context; - put_Line ("openGL Server version: " & Server.Version); + -- put_Line ("openGL Server version: " & Server.Version); or accept Stop @@ -235,9 +268,17 @@ is end Stop; end select; + -- put_Line ("renderer CONTEXT 1 " & Self.Context'Image); + + gl_Lock.acquire; + Self.context_Setter.all; + openGL.Geometry. lit_textured_skinned.define_Program; openGL.Geometry.lit_colored_textured_skinned.define_Program; + Self.context_Clearer.all; + gl_Lock.release; + while not Done loop @@ -281,6 +322,23 @@ is exit when Done; + -- declare + -- use gl.Binding; + -- begin + -- gl_Lock.acquire; + -- --gl_Context.make_Current; + -- Self.context_Setter.all; + -- glClearColor (0.0, 1.0, 0.0, 0.0); + -- glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); + -- -- Gdk.GLContext.clear_Current; + -- Self.context_Clearer.all; + -- gl_Lock.release; + -- end; + + -- gl_Lock.acquire; + -- Self.context_Setter.all; + -- put_Line ("renderer CONTEXT 2 " & Self.Context'Image); + if new_font_Name /= null_Asset then Self.Fonts.insert ((new_font_Name, @@ -289,25 +347,43 @@ is elsif new_snapshot_Name /= null_Asset then + gl_Lock.acquire; + Self.context_Setter.all; + IO.Screenshot (Filename => to_String (new_snapshot_Name), with_Alpha => snapshot_has_Alpha); + + Self.context_Clearer.all; + gl_Lock.release; + else + gl_Lock.acquire; + Self.context_Setter.all; + Self.update_Impostors_and_draw_Visuals (all_Updates (1 .. Length)); - Self.free_old_Models; - Self.free_old_Impostors; - - Self.is_Busy := False; - if Self.Swapper /= null and Self.swap_Required then Self.Swapper.all; end if; + + Self.context_Clearer.all; + gl_Lock.release; + + Self.free_old_Models; + Self.free_old_Impostors; + + Self.is_Busy := False; + end if; + + -- Self.context_Clearer.all; + -- gl_Lock.release; end; end loop; + Self.free_old_Models; Self.free_old_Impostors; diff --git a/3-mid/opengl/source/lean/renderer/opengl-renderer-lean.ads b/3-mid/opengl/source/lean/renderer/opengl-renderer-lean.ads index 32fd8fe..a78f6de 100644 --- a/3-mid/opengl/source/lean/renderer/opengl-renderer-lean.ads +++ b/3-mid/opengl/source/lean/renderer/opengl-renderer-lean.ads @@ -48,12 +48,14 @@ is function Light (Self : in out Item; Id : in light.Id_t) return openGL.Light.item; function fetch (Self : in out Item) return openGL.Light.items; - type context_Setter is access procedure; - type Swapper is access procedure; + type context_Setter is access procedure; + type context_Clearer is access procedure; + type Swapper is access procedure; - procedure Context_is (Self : in out Item; Now : in Context.view); - procedure Context_Setter_is (Self : in out Item; Now : in context_Setter); - procedure Swapper_is (Self : in out Item; Now : in Swapper); + procedure Context_is (Self : in out Item; Now : in Context.view); + procedure Context_Setter_is (Self : in out Item; Now : in context_Setter); + procedure Context_Clearer_is (Self : in out Item; Now : in context_Clearer); + procedure Swapper_is (Self : in out Item; Now : in Swapper); -------------- @@ -88,9 +90,23 @@ is procedure queue_Visuals (Self : in out Item; the_Visuals : in Visual.views; the_Camera : access Camera.item'Class); + + + --- Engine + -- + protected gl_Lock + is + entry acquire; + entry release; + private + Locked : Boolean := False; + end gl_Lock; + procedure start_Engine (Self : in out Item); procedure stop_Engine (Self : in out Item); + + procedure render (Self : in out Item; to_Surface : in Surface.view := null); procedure add_Font (Self : in out Item; font_Id : in Font.font_Id); procedure Screenshot (Self : in out Item; Filename : in String; @@ -293,6 +309,7 @@ private Context : openGL.Context.view; context_Setter : lean.context_Setter; + context_Clearer : lean.context_Clearer; Swapper : lean.Swapper; swap_Required : Boolean; is_Busy : Boolean := False; diff --git a/3-mid/opengl/source/lean/shader/opengl-attribute.adb b/3-mid/opengl/source/lean/shader/opengl-attribute.adb index 973e19d..aff888c 100644 --- a/3-mid/opengl/source/lean/shader/opengl-attribute.adb +++ b/3-mid/opengl/source/lean/shader/opengl-attribute.adb @@ -1,9 +1,11 @@ with openGL.Tasks, + openGL.Errors, GL.lean, System, ada.unchecked_Conversion; + package body openGL.Attribute is use GL.lean; @@ -103,12 +105,15 @@ is Tasks.check; glEnableVertexAttribArray (Index => Self.gl_Location); + openGL.Errors.log; + glVertexAttribPointer (Index => Self.gl_Location, Size => Self.Size, the_Type => to_GL (Self.data_Kind), Normalized => Self.Normalized, Stride => Self.vertex_Stride, Ptr => to_GL (Self.Offset)); + openGL.Errors.log; end enable; diff --git a/4-high/gel/applet/demo/game/pong-gtk/launch_pong.adb b/4-high/gel/applet/demo/game/pong-gtk/launch_pong.adb new file mode 100644 index 0000000..316da54 --- /dev/null +++ b/4-high/gel/applet/demo/game/pong-gtk/launch_pong.adb @@ -0,0 +1,401 @@ +with + gel.Window.setup, + gel.Window.gtk, + gel.Applet.gui_world, + gel.Forge, + gel.Sprite, + gel.World, + gel.Camera, + gel.Keyboard, + + Physics, + + openGL.Palette, + openGL.Light, + openGL.Model.text, + openGL.Renderer.lean, + + float_Math.Random, + + lace.Event, + lace.Response, + lace.Event.utility, + + gtk.Box, + gtk.Label, + gtk.Main, + gtk.Window, + gtk.glArea, + + ada.Text_IO, + ada.Exceptions; + +pragma Unreferenced (gel.Window.setup); + + +procedure launch_Pong +-- +-- Basic pong game. +-- +is + use gel.Applet, + gel.Applet.gui_world, + gel.Keyboard, + gel.Math, + + openGL.Palette, + + gtk.Box, + gtk.Label, + gtk.Window, + + ada.Text_IO; + + + --- GtkAda objects. + -- + top_Window : Gtk_Window; + Label : Gtk_Label; + Box : Gtk_Vbox; + +begin + ----------------- + --- Setup GtkAda. + -- + + -- Initialize GtkAda. + -- + gtk.Main.init; + + -- Create a window with a size of 800 x 650. + -- + gtk_new (top_Window); + top_Window.set_default_Size (800, 650); + + -- Create a box to organize vertically the contents of the window. + -- + gtk_New_vBox (Box); + top_Window.add (Box); + + -- Add a label. + -- + gtk_new (Label, "Hello Pong."); + Box.pack_Start (Label, + Expand => False, + Fill => False, + Padding => 10); + + -- Show the window. + -- + top_Window.show_All; + + + declare + --- Applet + -- + the_Applet : gel.Applet.gui_world.view + := gel.Forge.new_gui_Applet (Named => "Pong", + window_Width => 800, + window_Height => 650, + space_Kind => physics.Box2d); + + --- Ball + -- + the_Ball : constant gel.Sprite.view + := gel.Forge.new_circle_Sprite (in_World => the_Applet.World, + Site => [0.0, 0.0], + Mass => 1.0, + Bounce => 1.0, + Friction => 0.0, + Radius => 0.5, + Color => Grey, + Texture => openGL.to_Asset ("assets/opengl/texture/Face1.bmp")); + + court_Width : constant := 30.0; + court_Height : constant := 20.0; + + + --- Players + -- + type Player is + record + Paddle : gel.Sprite.view; + moving_Up : Boolean := False; + moving_Down : Boolean := False; + + Score : Natural := 0; + score_Text : gel.Sprite.view; + score_Model : openGL.Model.text.view; + end record; + + type player_Id is range 1 .. 2; + type Players is array (player_Id) of Player; + + the_Players : Players; + + + procedure add_Player (Id : in player_Id; + Site : in Vector_2) + is + the_Player : Player renames the_Players (Id); + score_Site : constant Vector_2 := Site + [0.0, court_Height / 2.0 + 0.8]; + begin + the_Player.Paddle := gel.Forge.new_rectangle_Sprite (the_Applet.World, + Site => Site, + Mass => 0.0, + Bounce => 1.0, + Friction => 0.0, + Width => 0.7, + Height => 3.0, + Color => Red); + + the_Player.score_Text := gel.Forge.new_text_Sprite (the_Applet.World, + Origin_3D, + " 0", + the_Applet.Font, + Green); + the_Player.score_Model := openGL.Model.text.view (the_Player.score_Text.graphics_Model); + + the_Applet.World.add (the_Player.Paddle); + the_Applet.World.add (the_Player.score_Text); + + the_Player.score_Text.Site_is (Vector_3 (score_Site & 0.0)); + end add_Player; + + + --- Court Walls + -- + procedure add_Wall (Site : in Vector_2; + Width, + Height : in Real) + is + the_Wall : constant gel.Sprite.view + := gel.Forge.new_rectangle_Sprite (the_Applet.World, + Site => Site, + Mass => 0.0, + Bounce => 1.0, + Friction => 0.0, + Width => Width, + Height => Height, + Color => Blue); + begin + the_Applet.World.add (the_Wall); + end add_Wall; + + + --- Controls + -- + relaunch_Ball : Boolean := True; + + + --- Events + -- + type key_press_Response is new lace.Response.item with null record; + + overriding + procedure respond (Self : in out key_press_Response; to_Event : in lace.Event.item'Class) + is + pragma Unreferenced (Self); + the_Event : gel.Keyboard.key_press_Event renames gel.Keyboard.key_press_Event (to_Event); + the_Key : constant gel.keyboard.Key := the_Event.modified_Key.Key; + begin + case the_Key + is + when up => the_Players (2).moving_Up := True; + when down => the_Players (2).moving_Down := True; + when a => the_Players (1).moving_Up := True; + when z => the_Players (1).moving_Down := True; + + when SPACE => relaunch_Ball := True; + when others => null; + end case; + end respond; + + + + type key_release_Response is new lace.Response.item with null record; + + overriding + procedure respond (Self : in out key_release_Response; to_Event : in lace.Event.item'Class) + is + pragma Unreferenced (Self); + the_Event : gel.Keyboard.key_release_Event renames gel.Keyboard.key_release_Event (to_Event); + the_Key : constant gel.keyboard.Key := the_Event.modified_Key.Key; + begin + case the_Key + is + when up => the_Players (2).moving_Up := False; + when down => the_Players (2).moving_Down := False; + when a => the_Players (1).moving_Up := False; + when z => the_Players (1).moving_Down := False; + when others => null; + end case; + end respond; + + + + function window_gl_Area return gtk.glArea.gtk_glArea + is + begin + return gel.Window.gtk.view (the_Applet.Window).GL_Area; + end window_gl_Area; + + + use lace.Event.Utility; + + the_key_press_Response : aliased key_press_Response; + the_key_release_Response : aliased key_release_Response; + + begin + --- Setup the game. + -- + + Box.pack_Start (window_gl_Area); + + + -- Show the window and present it. + -- + top_Window.Show_All; + top_Window.Present; + + the_Applet.Camera. Site_is ([0.0, 0.0, 20.0]); + the_Applet.World.Gravity_is ([0.0, 0.0, 0.0]); + the_Applet.World.add (the_Ball); + + + -- Set the lights position. + -- + declare + Light : openGL.Light.item := the_Applet.Renderer.new_Light; + begin + Light.Site_is ([0.0, -1000.0, 0.0]); + the_Applet.Renderer.set (Light); + end; + + + --- Add the players. + -- + declare + paddle_X_Offset : constant := court_Width / 2.0 - 2.0; + begin + add_Player (1, Site => [-paddle_X_Offset, 0.0]); + add_Player (2, Site => [ paddle_X_Offset, 0.0]); + end; + + + --- Build the court. + -- + declare + Thickness : constant := 1.0; -- Thickness of the walls. + goal_Size : constant := 6.0; + + side_wall_Height : constant := (court_Height - goal_Size) / 2.0; + top_wall_Y_Offset : constant := (court_Height - Thickness) / 2.0; + side_wall_X_Offset : constant := court_Width / 2.0; + side_wall_Y_Offset : constant := (side_wall_Height + goal_Size) / 2.0; + begin + add_Wall (Site => [0.0, top_wall_Y_Offset], Width => court_Width, Height => Thickness); -- Top + add_Wall (Site => [0.0, -top_wall_Y_Offset], Width => court_Width, Height => Thickness); -- Bottom + + add_Wall (Site => [-side_wall_X_Offset, side_wall_Y_Offset], Width => Thickness, Height => side_wall_Height); -- upper Left + add_Wall (Site => [-side_wall_X_Offset, -side_wall_Y_Offset], Width => Thickness, Height => side_wall_Height); -- lower Left + + add_Wall (Site => [ side_wall_X_Offset, side_wall_Y_Offset], Width => Thickness, Height => side_wall_Height); -- upper Right + add_Wall (Site => [ side_wall_X_Offset, -side_wall_Y_Offset], Width => Thickness, Height => side_wall_Height); -- lower Right + end; + + + -- Connect events. + -- + connect ( the_Applet.local_Observer, + the_Applet.Keyboard, + the_key_press_Response'unchecked_Access, + +gel.Keyboard.key_press_Event'Tag); + + connect ( the_Applet.local_Observer, + the_Applet.Keyboard, + the_key_release_Response'unchecked_Access, + +gel.Keyboard.key_release_Event'Tag); + + + --- Main loop. + -- + while the_Applet.is_open + loop + the_Applet.World.evolve; -- Advance the world. + the_Applet.freshen; -- Handle any new events and update the screen. + + + --- Check goal scoring. + -- + declare + procedure award_Goal (Id : in player_Id) + is + the_Player : Player renames the_Players (Id); + new_Score : constant String := Natural'Image (the_Player.Score + 1); + begin + relaunch_Ball := True; + the_Player.Score := the_Player.Score + 1; + + the_Player.score_Model.Text_is (new_Score); + + the_Ball.Site_is (Origin_3d); + the_Ball.Speed_is ([0.0, 0.0, 0.0]); + end award_Goal; + + goal_X_Boundary : constant := court_Width / 2.0 + 1.0; + + begin + if the_Ball.Site (1) > goal_X_Boundary then award_Goal (Id => 1); + elsif the_Ball.Site (1) < -goal_X_Boundary then award_Goal (Id => 2); + end if; + end; + + + --- Relauch the ball after a goal has been scored. + -- + if relaunch_Ball + then + the_Ball.Site_is ([0.0, 0.0, 0.0]); + + declare + the_Force : Vector_3 := [gel.Math.Random.random_Real (50.0, 200.0), + gel.Math.Random.random_Real ( 5.0, 20.0), + 0.0]; + begin + if gel.Math.Random.random_Boolean + then + the_Force := -the_Force; + end if; + + the_Ball.apply_Force (the_Force); + end; + + relaunch_Ball := False; + end if; + + + --- Move the paddles. + -- + for the_Player of the_Players + loop + declare + paddle_Speed : constant Vector_3 := [0.0, 0.2, 0.0]; + begin + if the_Player.moving_Up then the_Player.Paddle.Site_is (the_Player.Paddle.Site + paddle_Speed); end if; + if the_Player.moving_Down then the_Player.Paddle.Site_is (the_Player.Paddle.Site - paddle_Speed); end if; + end; + end loop; + end loop; + + free (the_Applet); + end; + + +exception + when E : others => + new_Line; + put_Line ("Unhandled exception in main task !"); + put_Line (ada.Exceptions.exception_Information (E)); + new_Line; +end launch_Pong; diff --git a/4-high/gel/applet/demo/game/pong-gtk/pong.gpr b/4-high/gel/applet/demo/game/pong-gtk/pong.gpr new file mode 100644 index 0000000..934fd6b --- /dev/null +++ b/4-high/gel/applet/demo/game/pong-gtk/pong.gpr @@ -0,0 +1,18 @@ +with + "gel_gtk", + "lace_shared"; + + +project Pong +is + for Object_Dir use "build"; + for Exec_Dir use "."; + for Main use ("launch_pong.adb"); + for Languages use ("Ada"); + + package Ide renames Lace_shared.Ide; + package Builder renames Lace_shared.Builder; + package Compiler renames Lace_shared.Compiler; + package Binder renames Lace_shared.Binder; + +end Pong; diff --git a/4-high/gel/applet/demo/game/pong/pong.gpr b/4-high/gel/applet/demo/game/pong/pong.gpr index c3f1402..4039eec 100644 --- a/4-high/gel/applet/demo/game/pong/pong.gpr +++ b/4-high/gel/applet/demo/game/pong/pong.gpr @@ -1,5 +1,5 @@ with - "gel", + "gel_sdl", "lace_shared"; project Pong diff --git a/4-high/gel/library/gel.gpr b/4-high/gel/library/gel.gpr index de8ec73..1d0dc7e 100644 --- a/4-high/gel/library/gel.gpr +++ b/4-high/gel/library/gel.gpr @@ -3,7 +3,7 @@ with "opengl", "collada", "physics", - "sdlada", +-- "sdlada", "lace_shared"; --library @@ -25,7 +25,7 @@ is "../source/joint", "../source/applet", "../source/applet/distributed", - "../source/platform/sdl", + -- "../source/platform/sdl", "../source/terrain", "../source/world"); @@ -33,8 +33,8 @@ is package Builder renames Lace_shared.Builder; package Compiler renames Lace_shared.Compiler; - package Linker is - for Linker_Options use ("-g", "-lSDL2"); - end Linker; +-- package Linker is +-- for Linker_Options use ("-g", "-lSDL2"); +-- end Linker; end GEL; diff --git a/4-high/gel/library/gtk/gel_gtk.gpr b/4-high/gel/library/gtk/gel_gtk.gpr new file mode 100644 index 0000000..e07ebf8 --- /dev/null +++ b/4-high/gel/library/gtk/gel_gtk.gpr @@ -0,0 +1,21 @@ +with + "gel", + "gtkada", + "lace_shared"; + +--library +project GEL_gtk +is + for Create_Missing_Dirs use "True"; + + for Source_Dirs use ("../../source/platform/gtk"); + for Object_Dir use "build"; + for Library_Dir use "lib"; + for Library_Ali_Dir use "objects"; +-- for Library_Name use "GEL_gtk"; + + package Ide renames Lace_shared.Ide; + package Builder renames Lace_shared.Builder; + package Compiler renames Lace_shared.Compiler; + +end GEL_gtk; diff --git a/4-high/gel/library/sdl/gel_sdl.gpr b/4-high/gel/library/sdl/gel_sdl.gpr new file mode 100644 index 0000000..1e18312 --- /dev/null +++ b/4-high/gel/library/sdl/gel_sdl.gpr @@ -0,0 +1,25 @@ +with + "gel", + "sdlada", + "lace_shared"; + +--library +project GEL_sdl +is + for Create_Missing_Dirs use "True"; + + for Source_Dirs use ("../../source/platform/sdl"); + for Object_Dir use "build"; + for Library_Dir use "lib"; + for Library_Ali_Dir use "objects"; +-- for Library_Name use "GEL_sdl"; + + package Ide renames Lace_shared.Ide; + package Builder renames Lace_shared.Builder; + package Compiler renames Lace_shared.Compiler; + +-- package Linker is +-- for Linker_Options use ("-g", "-lSDL2"); +-- end Linker; + +end GEL_sdl; diff --git a/4-high/gel/source/applet/gel-applet.adb b/4-high/gel/source/applet/gel-applet.adb index a8589d3..50575a4 100644 --- a/4-high/gel/source/applet/gel-applet.adb +++ b/4-high/gel/source/applet/gel-applet.adb @@ -31,6 +31,14 @@ is + procedure my_context_Clearer + is + begin + global_Window.disable_GL; + end my_context_Clearer; + + + procedure my_Swapper is begin @@ -96,7 +104,8 @@ is Self.Window.disable_GL; - Self.Renderer.Context_Setter_is (my_context_Setter'unrestricted_Access); + Self.Renderer.Context_Setter_is (my_context_Setter 'unrestricted_Access); + Self.Renderer.Context_Clearer_is (my_context_Clearer'unrestricted_Access); Self.Renderer.start_Engine; Self.Renderer.add_Font (Self. Font); @@ -428,6 +437,7 @@ is begin Self.Window.emit_Events; + Self.Window.freshen; Self.Window.swap_GL; Self .respond; diff --git a/4-high/gel/source/gel-sprite.adb b/4-high/gel/source/gel-sprite.adb index ff09b8b..b3db017 100644 --- a/4-high/gel/source/gel-sprite.adb +++ b/4-high/gel/source/gel-sprite.adb @@ -1109,7 +1109,7 @@ is - function program_Parameters (Self : in Item) return opengl.Program.Parameters_view + function program_Parameters (Self : in Item) return opengl.Program.Parameters_view is begin return Self.program_Parameters; diff --git a/4-high/gel/source/gel-window.ads b/4-high/gel/source/gel-window.ads index ee29625..890b75e 100644 --- a/4-high/gel/source/gel-window.ads +++ b/4-high/gel/source/gel-window.ads @@ -62,10 +62,11 @@ is --- Operations -- - procedure emit_Events (Self : in out Item) is null; - procedure enable_GL (Self : in Item) is null; - procedure disable_GL (Self : in Item) is null; - procedure swap_GL (Self : in out Item) is null; + procedure emit_Events (Self : in out Item) is null; + procedure enable_GL (Self : in Item) is null; + procedure disable_GL (Self : in Item) is null; + procedure swap_GL (Self : in out Item) is null; + procedure freshen (Self : in Item) is null; ---------- diff --git a/4-high/gel/source/platform/gtk/gel-window-gtk.adb b/4-high/gel/source/platform/gtk/gel-window-gtk.adb new file mode 100644 index 0000000..4354cb2 --- /dev/null +++ b/4-high/gel/source/platform/gtk/gel-window-gtk.adb @@ -0,0 +1,660 @@ +with + openGL.Renderer.lean, + + gtk.Widget, + gtk.Main, + gtk.Window, + gtk.Handlers, + + gdk.Types.Keysyms, + gdk.Event, + + ada.Text_IO; + + +package body gel.Window.gtk +is + use gdk.Event, + std_gtk.Widget, + std_gtk.Window, + ada.Text_IO; + + function to_gel_Key (From : in gdk.Types.gdk_Key_Type) return gel.keyboard.Key; + + + ------------- + --- Callbacks + -- + + package Callbacks_with_gel_Window_user_Data is new std_gtk.Handlers.user_Callback (gtk_Widget_record, + User_type => gel.Window.gtk.view); + + package Callbacks_with_gel_Window_user_Data_and_return_Boolean is new std_Gtk.Handlers.User_Return_Callback (gtk_Widget_record, + Return_type => Boolean, + User_type => Window.gtk.view); + + function key_press_Event_Cb (Self : access gtk_Widget_record'Class; + Event : in gdk.Event.gdk_Event; + user_Data : in Window.gtk.view) return Boolean + is + pragma Unreferenced (Self); + + gel_Window : Window.gtk.item'Class renames user_Data.all; + begin + -- put_Line ("key_press_Event_Cb ~ " & Event.Key'Image); + + gel_Window.Keyboard.emit_key_press_Event (Key => to_gel_Key (Event.Key.keyVal), + key_Code => Integer (Event.Key.hardware_Keycode)); + + return True; + end key_press_Event_Cb; + + + + function key_release_Event_Cb (Self : access gtk_Widget_record'Class; + Event : in gdk.Event.gdk_Event; + user_Data : in Window.gtk.view) return Boolean + is + pragma Unreferenced (Self); + use type Gdk.Types.Gdk_key_type; + + gel_Window : Window.gtk.item'Class renames user_Data.all; + begin + -- put_Line ("key_release_Event_Cb ~ " & Event.Key'Image); + + gel_Window.Keyboard.emit_key_release_Event (Key => to_gel_Key (Event.Key.keyVal)); + + if Event.Key.keyVal = gdk.Types.keySyms.gdk_Escape -- TODO: Make this user-configurable. + then + gel_Window.is_Open := False; + end if; + + return True; + end key_release_Event_Cb; + + + + procedure realize_Event_Cb (Widget : access gtk_Widget_Record'Class; + user_Data : in Window.gtk.view) + is + gl_Area : constant std_gtk.glArea.gtk_glArea := std_gtk.glArea.gtk_glArea (Widget); + gel_Window : Window.gtk.item'Class renames user_Data.all; + top_Window : gtk_Window; + begin + -- put_Line ("realize_Event_Cb"); + + gel_Window.is_Open := True; + top_Window := gtk_Window (gl_Area.get_Toplevel); + + Callbacks_with_gel_Window_user_Data_and_return_Boolean.connect (top_Window, + "key_press_event", + Callbacks_with_gel_Window_user_Data_and_return_Boolean.to_Marshaller (key_press_Event_Cb'Access), + user_Data => user_Data); + + Callbacks_with_gel_Window_user_Data_and_return_Boolean.connect (top_Window, + "key_release_event", + Callbacks_with_gel_Window_user_Data_and_return_Boolean.to_Marshaller (key_release_Event_Cb'Access), + user_Data => user_Data); + end realize_Event_Cb; + + + + procedure gl_Area_resize_Event_Cb (Widget : access gtk_Widget_record'Class; + user_Data : in Window.gtk.view) + is + gel_Window : Window.gtk.item'Class renames user_Data.all; + + Width : constant Integer := Integer (Widget.get_allocated_Width); + Height : constant Integer := Integer (Widget.get_allocated_Height); + begin + -- put_Line ("gl_Area_resize_Event_Cb ~ Height =>" & Height'Image & " Width =>" & Width'Image); + + gel_Window.Size_is (Width, Height); + end gl_Area_resize_Event_Cb; + + + + procedure unrealize_Event_Cb (Self : access gtk_Widget_record'Class; + user_Data : in Window.gtk.view) + is + pragma Unreferenced (Self); + + gel_Window : Window.gtk.item'Class renames user_Data.all; + begin + -- put_Line ("unrealize_Event_Cb"); + + gel_Window.is_Open := False; + end unrealize_Event_Cb; + + + + function render_Event_Cb (Self : access std_gtk.glArea .gtk_glArea_record 'Class; + Context : not null access gdk.glContext.gdk_glContext_record'Class) return Boolean + is + pragma Unreferenced (Self, Context); + begin + return True; + end render_Event_Cb; + + + + function Button_press_Event_Cb (Self : access gtk_Widget_record'Class; + Event : in gdk.Event .gdk_Event; + user_Data : in gel.Window.gtk.view) return Boolean + is + pragma Unreferenced (Self); + + gel_Window : Window.gtk.item'Class renames user_Data.all; + begin + -- put_Line ("Button_press_Event_Cb ~ Button =>" + -- & Event.Button.Button'Image + -- & " X =>" & Integer (Event.Button.X)'Image + -- & " Y =>" & Integer (Event.Button.Y)'Image); + + gel_Window.Mouse.emit_button_press_Event (Button => gel.mouse.button_Id (Event.Button.Button), + Modifiers => gel_Window.Keyboard.Modifiers, + Site => [Integer (Event.Button.X), + Integer (Event.Button.Y)]); + return True; + end Button_press_Event_Cb; + + + + function Button_release_Event_Cb (Self : access gtk_Widget_record'Class; + Event : in gdk.Event .gdk_Event; + user_Data : in gel.Window.gtk.view) return Boolean + is + pragma Unreferenced (Self); + + gel_Window : Window.gtk.item'Class renames user_Data.all; + begin + -- put_Line ("Button_release_Event_Cb ~ Button =>" + -- & Event.Button.Button'Image + -- & " X =>" & Integer (Event.Button.X)'Image + -- & " Y =>" & Integer (Event.Button.Y)'Image); + + gel_Window.Mouse.emit_button_release_Event (Button => gel.mouse.button_Id (Event.Button.Button), + Modifiers => gel_Window.Keyboard.Modifiers, + Site => [Integer (Event.Button.X), + Integer (Event.Button.Y)]); + return True; + end Button_release_Event_Cb; + + + + function Pointer_motion_Event_Cb (Self : access gtk_Widget_record'Class; + Event : in gdk.Event .gdk_Event; + user_Data : in gel.Window.gtk.view) return Boolean + is + pragma Unreferenced (Self); + + gel_Window : Window.gtk.item'Class renames user_Data.all; + begin + -- put_Line ("Pointer_motion_Event_Cb ~ Button =>" + -- & Event.Button.Button'Image + -- & " X =>" & Integer (Event.Button.X)'Image + -- & " Y =>" & Integer (Event.Button.Y)'Image); + -- -- & " X_root =>" & Integer (Event.Button.X_root)'Image + -- -- & " Y_root =>" & Integer (Event.Button.Y_root)'Image); + + gel_Window.Mouse.emit_motion_Event (Site => [Integer (Event.Button.X), + Integer (Event.Button.Y)]); + return True; + end Pointer_motion_Event_Cb; + + + + --------- + --- Forge + -- + + procedure define (Self : access Item; Title : in String; + Width : in Natural; + Height : in Natural) + is + pragma Unreferenced (Title, Width, Height); + + use std_gtk.glArea, + gdk .glContext; + begin + Self.gl_Area := gtk_glArea_new; + Self.gl_Area.set_use_ES (True); + + Callbacks_with_gel_Window_user_Data.connect (Self.gl_Area, + "realize", + Callbacks_with_gel_Window_user_Data.to_Marshaller (realize_Event_Cb'Access), + user_Data => View (Self)); + + Callbacks_with_gel_Window_user_Data.connect (Self.gl_Area, + "resize", + Callbacks_with_gel_Window_user_Data.to_Marshaller (gl_Area_resize_Event_Cb'Access), + user_Data => View (Self)); + + Callbacks_with_gel_Window_user_Data.connect (Self.gl_Area, + "unrealize", + Callbacks_with_gel_Window_user_Data.to_Marshaller (unrealize_Event_Cb'Access), + user_Data => View (Self)); + + Self.gl_Area.on_Render (render_Event_Cb'Access); + + Self.gl_Area.add_Events (Button_press_Mask); + Callbacks_with_gel_Window_user_Data_and_return_Boolean.connect (Self.gl_Area, + "button-press-event", + Callbacks_with_gel_Window_user_Data_and_return_Boolean.to_Marshaller (Button_press_Event_Cb'Access), + user_Data => View (Self)); + Self.gl_Area.add_Events (Button_release_Mask); + Callbacks_with_gel_Window_user_Data_and_return_Boolean.connect (Self.gl_Area, + "button-release-event", + Callbacks_with_gel_Window_user_Data_and_return_Boolean.to_Marshaller (Button_release_Event_Cb'Access), + user_Data => View (Self)); + Self.gl_Area.add_Events (Pointer_Motion_Mask); + Callbacks_with_gel_Window_user_Data_and_return_Boolean.connect (Self.gl_Area, + "motion-notify-event", + Callbacks_with_gel_Window_user_Data_and_return_Boolean.to_Marshaller (Pointer_motion_Event_Cb'Access), + user_Data => View (Self)); + Self.gl_Context := Self.gl_Area.get_Context; + end define; + + + + overriding + procedure destroy (Self : in out Item) + is + begin + destroy (gel.Window.item (Self)); -- Destroy base class. + end destroy; + + + + package body Forge + is + function to_Window (Title : in String; + Width : in Natural; + Height : in Natural) return gel.Window.gtk.item + is + begin + return Self : gel.Window.gtk.item := (gel.Window.private_Forge.to_Window (Title, Width, Height) + with others => <>) + do + define (Self'unchecked_Access, Title, Width, Height); + end return; + end to_Window; + + + function new_Window (Title : in String; + Width : in Natural; + Height : in Natural) return Window.gtk.view + is + Self : constant gel.Window.gtk.view := new Window.gtk.item' (to_Window (Title, Width, Height)); + begin + return Self; + end new_Window; + end Forge; + + + + -------------- + --- Operations + -- + + use gel.Keyboard; + + + function gl_Area (Self : in Item) return std_gtk.GLArea.Gtk_GLArea + is + begin + return Self.gl_Area; + end gl_Area; + + + + -- procedure set_Context (Self : in out Item; To : in gdk.glContext.gdk_glContext) + -- is + -- begin + -- Self.gl_Context := To; + -- end set_Context; + + + + overriding + procedure enable_GL (Self : in Item) + is + use gdk.GLContext; + use type std_gtk.glArea.gtk_GLArea; + begin + -- ada.Text_IO.Put_Line ("gel.window.gtk.enble_GL: attempting to make context current"); + + if Self.is_Open + and then ( Self.gl_Area /= null + and then Self.gl_Area.get_Context /= null) + then + Self.gl_Area.make_Current; + end if; + end enable_GL; + + + + overriding + procedure disable_GL (Self : in Item) + is + begin + gdk.glContext.clear_Current; + end disable_GL; + + + + overriding + procedure swap_GL (Self : in out Item) + is + begin + null; + end swap_GL; + + + + overriding + procedure freshen (Self : in Item) + is + begin + while std_gtk.Main.Events_pending + loop + declare + Ignore : Boolean; + begin + openGL.Renderer.lean.gl_Lock.acquire; + Ignore := std_gtk.Main.main_Iteration; + openGL.Renderer.lean.gl_Lock.release; + end; + end loop; + + if Self.is_Open + then + Self.gl_Area.queue_Render; + end if; + end freshen; + + + + + function to_gel_Key (From : in gdk.Types.gdk_Key_Type) return gel.Keyboard.Key + is + package Key renames gdk.Types.keySyms; + begin + case From + is + when Key.GDK_Return => return gel.Keyboard.Enter; + when Key.GDK_Escape => return gel.Keyboard.Escape; + when Key.GDK_Backspace => return gel.Keyboard.BackSpace; + when Key.GDK_Tab => return gel.Keyboard.Tab; + when Key.GDK_Space => return gel.Keyboard.Space; + when Key.GDK_Exclam => return gel.Keyboard.Exclaim; + when Key.GDK_QuoteDbl => return gel.Keyboard.QuoteDbl; + when Key.GDK_NumberSign => return gel.Keyboard.Hash; + when Key.GDK_Percent => return gel.Keyboard.Percent; + when Key.GDK_Dollar => return gel.Keyboard.Dollar; + when Key.GDK_Ampersand => return gel.Keyboard.Ampersand; + when Key.GDK_QuoteRight => return gel.Keyboard.Quote; + when Key.GDK_ParenLeft => return gel.Keyboard.leftParen; + when Key.GDK_ParenRight => return gel.Keyboard.rightParen; + when Key.GDK_Asterisk => return gel.Keyboard.Asterisk; + when Key.GDK_Plus => return gel.Keyboard.Plus; + when Key.GDK_Comma => return gel.Keyboard.Comma; + when Key.GDK_Minus => return gel.Keyboard.Minus; + when Key.GDK_Period => return gel.Keyboard.Period; + when Key.GDK_Slash => return gel.Keyboard.Slash; + + when Key.GDK_0 => return gel.Keyboard.'0'; + when Key.GDK_1 => return gel.Keyboard.'1'; + when Key.GDK_2 => return gel.Keyboard.'2'; + when Key.GDK_3 => return gel.Keyboard.'3'; + when Key.GDK_4 => return gel.Keyboard.'4'; + when Key.GDK_5 => return gel.Keyboard.'5'; + when Key.GDK_6 => return gel.Keyboard.'6'; + when Key.GDK_7 => return gel.Keyboard.'7'; + when Key.GDK_8 => return gel.Keyboard.'8'; + when Key.GDK_9 => return gel.Keyboard.'9'; + + when Key.GDK_colon => return gel.Keyboard.Colon; + when Key.GDK_semicolon => return gel.Keyboard.semiColon; + when Key.GDK_less => return gel.Keyboard.Less; + when Key.GDK_equal => return gel.Keyboard.Equals; + when Key.GDK_greater => return gel.Keyboard.Greater; + when Key.GDK_question => return gel.Keyboard.Question; + when Key.GDK_at => return gel.Keyboard.At_key; + + when Key.GDK_bracketLeft => return gel.Keyboard.leftBracket; + when Key.GDK_backslash => return gel.Keyboard.backSlash; + when Key.GDK_bracketRight => return gel.Keyboard.rightBracket; + when Key.GDK_caret => return gel.Keyboard.Caret; + when Key.GDK_underscore => return gel.Keyboard.Underscore; + when Key.GDK_quoteleft => return gel.Keyboard.backQuote; + + when Key.GDK_a | Key.GDK_lc_a => return gel.Keyboard.A; + when Key.GDK_b | Key.GDK_lc_b => return gel.Keyboard.B; + when Key.GDK_c | Key.GDK_lc_c => return gel.Keyboard.C; + when Key.GDK_d | Key.GDK_lc_d => return gel.Keyboard.D; + when Key.GDK_e | Key.GDK_lc_e => return gel.Keyboard.E; + when Key.GDK_f | Key.GDK_lc_f => return gel.Keyboard.F; + when Key.GDK_g | Key.GDK_lc_g => return gel.Keyboard.G; + when Key.GDK_h | Key.GDK_lc_h => return gel.Keyboard.H; + when Key.GDK_i | Key.GDK_lc_i => return gel.Keyboard.I; + when Key.GDK_j | Key.GDK_lc_j => return gel.Keyboard.J; + when Key.GDK_k | Key.GDK_lc_k => return gel.Keyboard.K; + when Key.GDK_l | Key.GDK_lc_l => return gel.Keyboard.L; + when Key.GDK_m | Key.GDK_lc_m => return gel.Keyboard.M; + when Key.GDK_n | Key.GDK_lc_n => return gel.Keyboard.N; + when Key.GDK_o | Key.GDK_lc_o => return gel.Keyboard.O; + when Key.GDK_p | Key.GDK_lc_p => return gel.Keyboard.P; + when Key.GDK_q | Key.GDK_lc_q => return gel.Keyboard.Q; + when Key.GDK_r | Key.GDK_lc_r => return gel.Keyboard.R; + when Key.GDK_s | Key.GDK_lc_s => return gel.Keyboard.S; + when Key.GDK_t | Key.GDK_lc_t => return gel.Keyboard.T; + when Key.GDK_u | Key.GDK_lc_u => return gel.Keyboard.U; + when Key.GDK_v | Key.GDK_lc_v => return gel.Keyboard.V; + when Key.GDK_w | Key.GDK_lc_w => return gel.Keyboard.W; + when Key.GDK_x | Key.GDK_lc_x => return gel.Keyboard.X; + when Key.GDK_y | Key.GDK_lc_y => return gel.Keyboard.Y; + when Key.GDK_z | Key.GDK_lc_z => return gel.Keyboard.Z; + + when Key.GDK_caps_lock => return gel.Keyboard.CapsLock; + + when Key.GDK_F1 => return gel.Keyboard.F1; + when Key.GDK_F2 => return gel.Keyboard.F2; + when Key.GDK_F3 => return gel.Keyboard.F3; + when Key.GDK_F4 => return gel.Keyboard.F4; + when Key.GDK_F5 => return gel.Keyboard.F5; + when Key.GDK_F6 => return gel.Keyboard.F6; + when Key.GDK_F7 => return gel.Keyboard.F7; + when Key.GDK_F8 => return gel.Keyboard.F8; + when Key.GDK_F9 => return gel.Keyboard.F9; + when Key.GDK_F10 => return gel.Keyboard.F10; + when Key.GDK_F11 => return gel.Keyboard.F11; + when Key.GDK_F12 => return gel.Keyboard.F12; + + when Key.GDK_print => return gel.Keyboard.Print; + when Key.GDK_scroll_lock => return gel.Keyboard.ScrollLock; + when Key.GDK_pause => return gel.Keyboard.Pause; + when Key.GDK_insert => return gel.Keyboard.Insert; + when Key.GDK_home => return gel.Keyboard.Home; + when Key.GDK_page_up => return gel.Keyboard.PageUp; + when Key.GDK_delete => return gel.Keyboard.Delete; + when Key.GDK_end => return gel.Keyboard.End_key; + when Key.GDK_page_down => return gel.Keyboard.PageDown; + when Key.GDK_right => return gel.Keyboard.Right; + when Key.GDK_left => return gel.Keyboard.Left; + when Key.GDK_down => return gel.Keyboard.Down; + when Key.GDK_up => return gel.Keyboard.Up; + + when Key.GDK_num_lock => return gel.Keyboard.NumLock; + + when Key.GDK_KP_Divide => return gel.Keyboard.KP_Divide; + when Key.GDK_KP_Multiply => return gel.Keyboard.KP_Multiply; + when Key.GDK_KP_Subtract => return gel.Keyboard.KP_Minus; + when Key.GDK_KP_Add => return gel.Keyboard.KP_Plus; + when Key.GDK_KP_Enter => return gel.Keyboard.KP_Enter; + when Key.GDK_KP_1 => return gel.Keyboard.KP1; + when Key.GDK_KP_2 => return gel.Keyboard.KP2; + when Key.GDK_KP_3 => return gel.Keyboard.KP3; + when Key.GDK_KP_4 => return gel.Keyboard.KP4; + when Key.GDK_KP_5 => return gel.Keyboard.KP5; + when Key.GDK_KP_6 => return gel.Keyboard.KP6; + when Key.GDK_KP_7 => return gel.Keyboard.KP7; + when Key.GDK_KP_8 => return gel.Keyboard.KP8; + when Key.GDK_KP_9 => return gel.Keyboard.KP9; + when Key.GDK_KP_0 => return gel.Keyboard.KP0; + when Key.GDK_KP_Decimal => return gel.Keyboard.KP_Period; + + -- when Key.GDK_application => return gel.Keyboard.; + -- when Key.GDK_power => return gel.Keyboard.Power; + when Key.GDK_KP_equal => return gel.Keyboard.KP_Equals; + when Key.GDK_F13 => return gel.Keyboard.F13; + when Key.GDK_F14 => return gel.Keyboard.F14; + when Key.GDK_F15 => return gel.Keyboard.F15; + -- when Key.GDK_F16 => return gel.Keyboard.; + -- when Key.GDK_F17 => return gel.Keyboard.; + -- when Key.GDK_F18 => return gel.Keyboard.; + -- when Key.GDK_F19 => return gel.Keyboard.; + -- when Key.GDK_F20 => return gel.Keyboard.; + -- when Key.GDK_F21 => return gel.Keyboard.; + -- when Key.GDK_F22 => return gel.Keyboard.; + -- when Key.GDK_F23 => return gel.Keyboard.; + -- when Key.GDK_F24 => return gel.Keyboard.; + -- when Key.GDK_execute => return gel.Keyboard.; + when Key.GDK_help => return gel.Keyboard.Help; + when Key.GDK_menu => return gel.Keyboard.Menu; + -- when Key.GDK_select => return gel.Keyboard.; + -- when Key.GDK_stop => return gel.Keyboard.; + -- when Key.GDK_again => return gel.Keyboard.; + when Key.GDK_undo => return gel.Keyboard.Undo; + -- when Key.GDK_cut => return gel.Keyboard.; + -- when Key.GDK_copy => return gel.Keyboard.; + -- when Key.GDK_paste => return gel.Keyboard.; + -- when Key.GDK_find => return gel.Keyboard.; + -- when Key.GDK_mute => return gel.Keyboard.; + -- when Key.GDK_volume_up => return gel.Keyboard.; + -- when Key.GDK_volume_down => return gel.Keyboard.; + -- when Key.GDK_KP_comma => return gel.Keyboard.; + -- when Key.GDK_KP_equals_AS400 => return gel.Keyboard.; + + -- when Key.GDK_alt_erase => return gel.Keyboard.; + when Key.GDK_sys_req => return gel.Keyboard.SysReq; + -- when Key.GDK_cancel => return gel.Keyboard.; + when Key.GDK_clear => return gel.Keyboard.Clear; + -- when Key.GDK_prior => return gel.Keyboard.; + -- when Key.GDK_return_2 => return gel.Keyboard.; + -- when Key.GDK_separator => return gel.Keyboard.; + -- when Key.GDK_out => return gel.Keyboard.; + -- when Key.GDK_oper => return gel.Keyboard.; + -- when Key.GDK_clear_again => return gel.Keyboard.; + -- when Key.GDK_CR_sel => return gel.Keyboard.; + -- when Key.GDK_Ex_sel => return gel.Keyboard.; + + -- when Key.GDK_KP_00 => return gel.Keyboard.; + -- when Key.GDK_KP_000 => return gel.Keyboard.; + -- when Key.GDK_thousands_separator => return gel.Keyboard.; + -- when Key.GDK_decimal_separator => return gel.Keyboard.; + -- when Key.GDK_currency_unit => return gel.Keyboard.; + -- when Key.GDK_KP_left_parenthesis => return gel.Keyboard.; + -- when Key.GDK_KP_right_parentheesis => return gel.Keyboard.; + -- when Key.GDK_KP_left_brace => return gel.Keyboard.; + -- when Key.GDK_KP_right_brace => return gel.Keyboard.; + -- when Key.GDK_KP_tab => return gel.Keyboard.; + -- when Key.GDK_KP_backspace => return gel.Keyboard.; + -- when Key.GDK_KP_A => return gel.Keyboard.; + -- when Key.GDK_KP_B => return gel.Keyboard.; + -- when Key.GDK_KP_C => return gel.Keyboard.; + -- when Key.GDK_KP_D => return gel.Keyboard.; + -- when Key.GDK_KP_E => return gel.Keyboard.; + -- when Key.GDK_KP_F => return gel.Keyboard.; + -- when Key.GDK_KP_xor => return gel.Keyboard.; + -- when Key.GDK_KP_power => return gel.Keyboard.; + -- when Key.GDK_KP_percent => return gel.Keyboard.; + -- when Key.GDK_KP_less => return gel.Keyboard.; + -- when Key.GDK_KP_greater => return gel.Keyboard.; + -- when Key.GDK_KP_ampersand => return gel.Keyboard.; + -- when Key.GDK_KP_double_ampersand => return gel.Keyboard.; + -- when Key.GDK_KP_vertical_bar => return gel.Keyboard.; + -- when Key.GDK_KP_double_vertical_bar => return gel.Keyboard.; + -- when Key.GDK_KP_colon => return gel.Keyboard.; + -- when Key.GDK_KP_hash => return gel.Keyboard.; + -- when Key.GDK_KP_space => return gel.Keyboard.; + -- when Key.GDK_KP_at => return gel.Keyboard.; + -- when Key.GDK_KP_exclamation => return gel.Keyboard.; + -- when Key.GDK_KP_memory_store => return gel.Keyboard.; + -- when Key.GDK_KP_memory_recall => return gel.Keyboard.; + -- when Key.GDK_KP_memory_clear => return gel.Keyboard.; + -- when Key.GDK_KP_memory_add => return gel.Keyboard.; + -- when Key.GDK_KP_memory_subtract => return gel.Keyboard.; + -- when Key.GDK_KP_memory_multiply => return gel.Keyboard.; + -- when Key.GDK_KP_memory_divide => return gel.Keyboard.; + -- when Key.GDK_KP_plus_minus => return gel.Keyboard.; + -- when Key.GDK_KP_clear => return gel.Keyboard.; + -- when Key.GDK_KP_clear_entry => return gel.Keyboard.; + -- when Key.GDK_KP_binary => return gel.Keyboard.; + -- when Key.GDK_KP_octal => return gel.Keyboard.; + -- when Key.GDK_KP_decimal => return gel.Keyboard.; + -- when Key.GDK_KP_hexadecimal => return gel.Keyboard.; + + when Key.GDK_control_L => return gel.Keyboard.lCtrl; + when Key.GDK_shift_L => return gel.Keyboard.lShift; + when Key.GDK_alt_L => return gel.Keyboard.lAlt; + when Key.GDK_control_R => return gel.Keyboard.rCtrl; + when Key.GDK_shift_R => return gel.Keyboard.rShift; + when Key.GDK_alt_R => return gel.Keyboard.rAlt; + + -- when Key.GDK_left_gui => return gel.Keyboard.; + -- when Key.GDK_right_gui => return gel.Keyboard.; + -- when Key.GDK_mode => return gel.Keyboard.; + + -- when Key.GDK_audio_next => return gel.Keyboard.; + -- when Key.GDK_audio_previous => return gel.Keyboard.; + -- when Key.GDK_audio_stop => return gel.Keyboard.; + -- when Key.GDK_audio_play => return gel.Keyboard.; + -- when Key.GDK_audio_mute => return gel.Keyboard.; + -- when Key.GDK_media_select => return gel.Keyboard.; + -- when Key.GDK_www => return gel.Keyboard.; + -- when Key.GDK_mail => return gel.Keyboard.; + -- when Key.GDK_calculator => return gel.Keyboard.; + -- when Key.GDK_computer => return gel.Keyboard.; + -- when Key.GDK_AC_search => return gel.Keyboard.; + -- when Key.GDK_AC_home => return gel.Keyboard.; + -- when Key.GDK_AC_back => return gel.Keyboard.; + -- when Key.GDK_AC_forward => return gel.Keyboard.; + -- when Key.GDK_AC_stop => return gel.Keyboard.; + -- when Key.GDK_AC_refresh => return gel.Keyboard.; + -- when Key.GDK_AC_bookmarks => return gel.Keyboard.; + + -- when Key.GDK_brightness_down => return gel.Keyboard.; + -- when Key.GDK_brightness_up => return gel.Keyboard.; + -- when Key.GDK_display_switch => return gel.Keyboard.; + -- when Key.GDK_illumination_toggle => return gel.Keyboard.; + -- when Key.GDK_illumination_down => return gel.Keyboard.; + -- when Key.GDK_illumination_up => return gel.Keyboard.; + -- when Key.GDK_eject => return gel.Keyboard.; + -- when Key.GDK_sleep => return gel.Keyboard.; + + when others => + ada.Text_IO.put_Line ("Gtk window ~ unhandled key: " & From'Image); -- TODO: Remaining key codes. + end case; + + return gel.Keyboard.Key'First; + end to_gel_Key; + + + + ------------------- + --- Window Creator + -- + + function window_Creator (Name : in String; + Width, Height : in Positive) return gel.Window.view + is + begin + return gel.Window.view (Forge.new_Window (Name, Width, Height)); + end window_Creator; + + + +begin + gel.Window.use_create_Window (window_Creator'Access); +end gel.Window.gtk; diff --git a/4-high/gel/source/platform/gtk/gel-window-gtk.ads b/4-high/gel/source/platform/gtk/gel-window-gtk.ads new file mode 100644 index 0000000..4a14914 --- /dev/null +++ b/4-high/gel/source/platform/gtk/gel-window-gtk.ads @@ -0,0 +1,72 @@ +with + gtk.glArea; + +private +with + gdk.glContext; + + +package gel.Window.gtk +-- +-- Provides a GTK implementation of a window. +-- +is + type Item is new gel.Window.item with private; + type View is access all Item'Class; + + + + --------- + --- Forge + -- + + procedure define (Self : access Item; Title : in String; + Width : in Natural; + Height : in Natural); + overriding + procedure destroy (Self : in out Item); + + + package Forge + is + function new_Window (Title : in String; + Width : in Natural; + Height : in Natural) return Window.gtk.view; + end Forge; + + + + -------------- + --- Attributes + -- + + package std_gtk renames standard.GTK; + + function gl_Area (Self : in Item) return std_gtk.GLArea.Gtk_GLArea; + + + + -------------- + --- Operations + -- + + overriding + procedure enable_GL (Self : in Item); + overriding + procedure disable_GL (Self : in Item); + overriding + procedure swap_GL (Self : in out Item); + overriding + procedure freshen (Self : in Item); + + + +private + + type Item is new gel.Window.item with + record + gl_Area : std_gtk.glArea .gtk_glArea; + gl_Context : gdk.glContext.gdk_glContext; + end record; + +end gel.Window.gtk; diff --git a/4-high/gel/source/platform/gtk/gel-window-setup.ads b/4-high/gel/source/platform/gtk/gel-window-setup.ads new file mode 100644 index 0000000..f1b5913 --- /dev/null +++ b/4-high/gel/source/platform/gtk/gel-window-setup.ads @@ -0,0 +1,6 @@ +with + gel.Window.gtk; + +package gel.Window.setup + renames gel.Window.gtk; + diff --git a/lace-gpr_paths.sh b/lace-gpr_paths.sh index 5b76fed..cc75b8c 100755 --- a/lace-gpr_paths.sh +++ b/lace-gpr_paths.sh @@ -20,6 +20,8 @@ GPR_PROJECT_PATH=$LACE/3-mid/physics/implement/impact/library:$GPR_PROJECT_PATH GPR_PROJECT_PATH=$LACE/4-high/gel/library:$GPR_PROJECT_PATH +GPR_PROJECT_PATH=$LACE/4-high/gel/library/sdl:$GPR_PROJECT_PATH +GPR_PROJECT_PATH=$LACE/4-high/gel/library/gtk:$GPR_PROJECT_PATH export GPR_PROJECT_PATH