[Gtkada-wrapper-devel] SF.net SVN: gtkada-wrapper: [17] trunk
Brought to you by:
bechir_zalila
From: <bec...@us...> - 2006-11-27 21:05:54
|
Revision: 17 http://svn.sourceforge.net/gtkada-wrapper/?rev=17&view=rev Author: bechir_zalila Date: 2006-11-27 13:05:51 -0800 (Mon, 27 Nov 2006) Log Message: ----------- * (configure.ac, examples/Makefile.am, examples/fractal/*): Added a new example "fractal" to test the drawing speed. * (TODO): Removed some resolve item and added some new ones. * (gtkada_wrapper.ad?): Got rid of the Idle main loop mechanisme which, when it has time delays is very slow and when not consumes 100% of CPU. Replaced the old mechanisme by and event handler task which guarantees tha thread safety of th drawing. Used terminate to control task termination. Default fill color is black. Defaul spot radius is 1.0. * (gtkada_wrapper.gpr): Compile with -O3 in release mode. Modified Paths: -------------- trunk/TODO trunk/configure.ac trunk/examples/Makefile.am trunk/src/gtkada_wrapper.adb trunk/src/gtkada_wrapper.ads trunk/src/gtkada_wrapper.gpr Added Paths: ----------- trunk/examples/fractal/ trunk/examples/fractal/Makefile.am trunk/examples/fractal/README trunk/examples/fractal/fractal.adb trunk/examples/fractal/fractal.gpr Modified: trunk/TODO =================================================================== --- trunk/TODO 2006-11-26 23:58:45 UTC (rev 16) +++ trunk/TODO 2006-11-27 21:05:51 UTC (rev 17) @@ -2,7 +2,7 @@ * Implement fill color * Implement forms * Implement Text area - * Remove the Idle loop + * Get_Mouse_Pointer will block forever if the user closes the window /doc: * Write the documentation Modified: trunk/configure.ac =================================================================== --- trunk/configure.ac 2006-11-26 23:58:45 UTC (rev 16) +++ trunk/configure.ac 2006-11-27 21:05:51 UTC (rev 17) @@ -89,6 +89,7 @@ examples/Makefile examples/empty_window/Makefile examples/basic_drawings/Makefile + examples/fractal/Makefile src/Makefile ]) Modified: trunk/examples/Makefile.am =================================================================== --- trunk/examples/Makefile.am 2006-11-26 23:58:45 UTC (rev 16) +++ trunk/examples/Makefile.am 2006-11-27 21:05:51 UTC (rev 17) @@ -1 +1 @@ -SUBDIRS = empty_window basic_drawings +SUBDIRS = empty_window basic_drawings fractal Added: trunk/examples/fractal/Makefile.am =================================================================== --- trunk/examples/fractal/Makefile.am (rev 0) +++ trunk/examples/fractal/Makefile.am 2006-11-27 21:05:51 UTC (rev 17) @@ -0,0 +1,5 @@ +include ../Makefile.common + +PROJECT_FILE = $(srcdir)/fractal.gpr +SOURCES = $(srcdir)/fractal.adb + Added: trunk/examples/fractal/README =================================================================== --- trunk/examples/fractal/README (rev 0) +++ trunk/examples/fractal/README 2006-11-27 21:05:51 UTC (rev 17) @@ -0,0 +1 @@ +This example test the speed of the drawing by building a fractal. Added: trunk/examples/fractal/fractal.adb =================================================================== --- trunk/examples/fractal/fractal.adb (rev 0) +++ trunk/examples/fractal/fractal.adb 2006-11-27 21:05:51 UTC (rev 17) @@ -0,0 +1,49 @@ +-- $Id$ +-- Copyright (C) 2006 Bechir Zalila <bec...@en...> +-- See COPYING file for license + +-- This example tests some basic drawings using GTKAda Wrapper + +with Gtkada_Wrapper; use Gtkada_Wrapper; + +with Ada.Text_IO; + +procedure Fractal is + + procedure Draw_Fractal (X1, Y1, X2, Y2 : in Float); + -- Draw a fractal recursively + + ------------------ + -- Draw_Fractal -- + ------------------ + + procedure Draw_Fractal (X1, Y1, X2, Y2 : in Float) is + X3 : constant Float := (X1 + X2) / 2.0 - (Y2 - Y1) / 3.0; + Y3 : constant Float := (Y1 + Y2) / 2.0 + (X2 - X1) / 3.0; + begin + if abs (X1 - X2) > 1.0 or abs (Y1 - Y2) > 1.0 then + Jump (X1, Y1); + Spot; + Draw_Fractal (X1, Y1, X3, Y3); + Draw_Fractal (X3, Y3, X2, Y2); + end if; + end Draw_Fractal; + + X : Float; + Y : Float; + Button : Natural; +begin + Create_Main_Window; + + Draw_Fractal (150.0, 100.0, 350.0, 400.0); + Draw_Fractal (350.0, 400.0, 150.0, 100.0); + + Rafresh; + + Get_Mouse_Pointer (X, Y, Button); + Ada.Text_IO.Put_Line ("Got Click:"); + Ada.Text_IO.Put_Line (" X = " & X'Img); + Ada.Text_IO.Put_Line (" Y = " & Y'Img); + Ada.Text_IO.Put_Line (" Button = " & Button'Img); + Destroy_Main_Window; +end Fractal; Property changes on: trunk/examples/fractal/fractal.adb ___________________________________________________________________ Name: svn:keywords + Id Name: svn:eol-style + native Added: trunk/examples/fractal/fractal.gpr =================================================================== --- trunk/examples/fractal/fractal.gpr (rev 0) +++ trunk/examples/fractal/fractal.gpr 2006-11-27 21:05:51 UTC (rev 17) @@ -0,0 +1,10 @@ +with "../../src/gtkada_wrapper.gpr"; + +project Fractal is + for main use ("fractal.adb"); + + Build : GTKAda_Wrapper.Build_Type := External ("BUILD", "debug"); + + package Compiler renames GTKAda_Wrapper.Compiler; + package Binder renames GTKAda_Wrapper.Binder; +end Fractal; Property changes on: trunk/examples/fractal/fractal.gpr ___________________________________________________________________ Name: svn:keywords + Id Name: svn:eol-style + native Modified: trunk/src/gtkada_wrapper.adb =================================================================== --- trunk/src/gtkada_wrapper.adb 2006-11-26 23:58:45 UTC (rev 16) +++ trunk/src/gtkada_wrapper.adb 2006-11-27 21:05:51 UTC (rev 17) @@ -39,7 +39,7 @@ procedure O (Message : String); -- For debugging purpose - procedure Quit (Window : access Gtk.Window.Gtk_Window_Record'Class); + procedure Quit (Win : access Gtk.Window.Gtk_Window_Record'Class); -- Quit the main loop when the user closes the window procedure Assert_Main_Window_Exits; @@ -62,10 +62,6 @@ return Boolean; -- Handler for the "button_press_event" signal of the drawing area - function Main_Loop return Boolean; - -- This is the main loop that handle the user commands. It is - -- registered as an "Idle" function of the main window - function To_Gdk_Color (C : Color_Type) return Gdk_Color; pragma Inline (To_Gdk_Color); -- Convert user colors to GDK colors @@ -92,10 +88,6 @@ Have_Text_Area : Boolean; -- Properties of the main window - Main_Loop_Id : Idle_Handler_Id; - pragma Unreferenced (Main_Loop_Id); - -- Id of the main loop function - Width : Gint; Height : Gint; -- Dimensions of the drawing and text areas @@ -104,7 +96,7 @@ Brush_Y : Float := 0.0; Angle : Float := 0.0; Thickness : Float := 1.0; - Line_Color : Color_Type := Red; + Line_Color : Color_Type := Black; Fill_Color : Color_Type := White; -- Properties of the virtual brush @@ -159,6 +151,7 @@ type Action_Kind is (A_None, + A_Reset_Handler, -- For internal use A_Destroy, A_Clear_Drawing_Area, A_Line_Color, @@ -196,6 +189,7 @@ type Command (Action : Action_Kind := A_None) is record case Action is when A_None + | A_Reset_Handler | A_Destroy | A_Clear_Drawing_Area | A_Rafresh @@ -307,6 +301,41 @@ procedure Do_Get_Line_String (Cmd : Command); procedure Do_Get_Immediate_Character (Cmd : Command); + -- Dispatch table + + type Command_Proc_Type is access procedure (Cmd : Command); + + Dispatch_Table : constant array (Action_Kind) of Command_Proc_Type := + (A_Angle => Do_Angle'Access, + A_Clear_Drawing_Area => Do_Clear_Drawing_Area'Access, + A_Clear_Text_Area => Do_Clear_Text_Area'Access, + A_Destroy => Do_Destroy'Access, + A_Fill_Color => Do_Fill_Color'Access, + A_Get_Immediate_Character => Do_Get_Immediate_Character'Access, + A_Get_Line_String => Do_Get_Line_String'Access, + A_Get_Mouse_Pointer => Do_Get_Mouse_Pointer'Access, + A_Get_String => Do_Get_String'Access, + A_Image => Do_Image'Access, + A_Jump_With_End => Do_Jump_With_End'Access, + A_Jump_With_Length => Do_Jump_With_Length'Access, + A_Line_Color => Do_Line_Color'Access, + A_Line_With_End => Do_Line_With_End'Access, + A_Line_With_Length => Do_Line_With_Length'Access, + A_Line_With_Start_End => Do_Line_With_Start_End'Access, + A_Line_With_Start_Length => Do_Line_With_Start_Length'Access, + A_New_Line => Do_New_Line'Access, + A_None => null, + A_Put_Character => Do_Put_Character'Access, + A_Put_Line_Character => Do_Put_Line_Character'Access, + A_Put_Line_String => Do_Put_Line_String'Access, + A_Put_String => Do_Put_String'Access, + A_Rafresh => Do_Rafresh'Access, + A_Reset_Handler => null, + A_Rotate => Do_Rotate'Access, + A_Spot => Do_Spot'Access, + A_Text => Do_Text'Access, + A_Thickness => Do_Thickness'Access); + -- The user command queue package Command_Queue is new Protected_Queue (Command, 10000); @@ -350,127 +379,202 @@ -- The main window is created by a task that is allocated on the -- user demand. - -- The main windows task type + Main_Window_Exists : Boolean := False; + -- Used to see whether the main exists or not - task type Main_Window_Type; - type Main_Window_Access is access all Main_Window_Type; + -- The main windows task - -- The Main windows + task Main_Window is + entry Init; + -- After the call to this entry, a main windows is created + end Main_Window; - Main_Window : Main_Window_Access; + -- The event handler task - ---------------------- - -- Main_Window_Type -- - ---------------------- + task Event_Handler is + entry Init; + -- After the call to this entry, the main venet handling loop + -- is started. + end Event_Handler; - task body Main_Window_Type is + ----------------- + -- Main_Window -- + ----------------- + + task body Main_Window is begin - -- Initialize GTK + loop + select + accept Init do + Main_Window_Exists := True; + pragma Debug (O ("Main_Task.Init: done")); + end Init; + or + terminate; + end select; - Gtk.Main.Init; + -- Initialize GTK - -- Setup the main windows + Gtk.Main.Init; - Gtk_New (Window, Window_Toplevel); - Set_Title (Window, "GTKAda Wrapper"); - Set_Border_Width (Window, Border_Width => 5); + -- Setup the main windows - -- When the window is destroyed, some work has to be done + Gtk_New (Window, Window_Toplevel); + Set_Title (Window, "GTKAda Wrapper"); + Set_Border_Width (Window, Border_Width => 5); - Main_Window_Handlers.Connect - (Window, - "destroy", - Main_Window_Handlers.To_Marshaller (Quit'Access)); + -- When the window is destroyed, some work has to be done - -- Create the immediate window vertical box and adding it to - -- the windows + Main_Window_Handlers.Connect + (Window, + "destroy", + Main_Window_Handlers.To_Marshaller (Quit'Access)); - Gtk_New_Vbox (VBox, Homogeneous => False, Spacing => 0); - Add (Window, VBox); + -- Create the immediate window vertical box and adding it to + -- the windows. - -- Create the horizontal paned and adding it to the box + Gtk_New_Vbox (VBox, Homogeneous => False, Spacing => 0); + Add (Window, VBox); - Gtk_New_Hpaned (HPaned); - Pack_Start (VBox, HPaned); + -- Create the horizontal paned and adding it to the box - -- If the user requested a drawing area, create it and append - -- it to the paned. + Gtk_New_Hpaned (HPaned); + Pack_Start (VBox, HPaned); - if Have_Drawing_Area then - Gtk_New (Drawing_Area); - Size (Drawing_Area, Width, Height); - Pack1 (HPaned, Drawing_Area, Resize => False, Shrink => False); + -- If the user requested a drawing area, create it and + -- append it to the paned. - -- The only user event that may trigger the drawing area are - -- mouse clicks and exposure evenets (to rafresh it). + if Have_Drawing_Area then + Gtk_New (Drawing_Area); + Size (Drawing_Area, Width, Height); + Pack1 (HPaned, Drawing_Area, Resize => False, Shrink => False); - Set_Events (Drawing_Area, Exposure_Mask or Button_Press_Mask); + -- The only user event that may trigger the drawing area + -- are mouse clicks and exposure evenets (to rafresh it). - Drawing_Area_Handlers.Connect - (Widget => Drawing_Area, - Name => "expose_event", - Marsh => Drawing_Area_Handlers.To_Marshaller - (Expose_Event'Access)); + Set_Events (Drawing_Area, Exposure_Mask or Button_Press_Mask); - Drawing_Area_Handlers.Connect - (Widget => Drawing_Area, - Name => "button_press_event", - Marsh => Drawing_Area_Handlers.To_Marshaller - (Button_Press_Event'Access)); + Drawing_Area_Handlers.Connect + (Widget => Drawing_Area, + Name => "expose_event", + Marsh => Drawing_Area_Handlers.To_Marshaller + (Expose_Event'Access)); - -- Configure event is called when the window configuration - -- is changed (moved, resized, became visible...) + Drawing_Area_Handlers.Connect + (Widget => Drawing_Area, + Name => "button_press_event", + Marsh => Drawing_Area_Handlers.To_Marshaller + (Button_Press_Event'Access)); - Drawing_Area_Handlers.Connect - (Widget => Drawing_Area, - Name => "configure_event", - Marsh => Drawing_Area_Handlers.To_Marshaller - (Configure_Event'Access)); - end if; + -- Configure event is called when the window + -- configuration is changed (moved, resized, became + -- visible...) - -- If the user requested a text area, create it and append - -- it to the paned. + Drawing_Area_Handlers.Connect + (Widget => Drawing_Area, + Name => "configure_event", + Marsh => Drawing_Area_Handlers.To_Marshaller + (Configure_Event'Access)); + end if; - if Have_Text_Area then - null; - end if; + -- If the user requested a text area, create it and append + -- it to the paned. - -- Set the main loop function as "Idle" + if Have_Text_Area then + -- FIXME: Create text area + null; + end if; - Main_Loop_Id := Idle_Add (Main_Loop'Access); + Show_All (Window); - Show_All (Window); + -- It is necessary to set the graphic context *after* + -- showing the main window. - -- It is necessary to set the graphic context *after* showing - -- the main window. + if Have_Drawing_Area then + -- Create the graohic context (color, line width...) - if Have_Drawing_Area then - -- Create the graohic context (color, line width...) + Gdk_New (Graphic_Context, Get_Window (Drawing_Area)); - Gdk_New (Graphic_Context, Get_Window (Drawing_Area)); + -- Initialize the current line styles - -- Initialize the current line styles + Set_Line_Attributes (GC => Graphic_Context, + Line_Width => Gint (Thickness), + Line_Style => Line_Solid, + Cap_Style => Cap_Round, + Join_Style => Join_Round); - Set_Line_Attributes (GC => Graphic_Context, - Line_Width => Gint (Thickness), - Line_Style => Line_Solid, - Cap_Style => Cap_Round, - Join_Style => Join_Round); + -- Allocate predefined colors - -- Allocate predefined colors + Allocate_Colors; - Allocate_Colors; + Set_Foreground (Graphic_Context, To_Gdk_Color (Line_Color)); + Set_Background (Graphic_Context, To_Gdk_Color (Fill_Color)); + end if; - Set_Foreground (Graphic_Context, To_Gdk_Color (Line_Color)); - Set_Background (Graphic_Context, To_Gdk_Color (Fill_Color)); - end if; + -- Initialize the event handler task - Gtk.Main.Main; + Event_Handler.Init; - -- FIXME: Handle exit + -- Run the GTK main loop - end Main_Window_Type; + Gtk.Main.Main; + -- The main loop ended, reset all the mechanism + + Main_Window_Exists := False; + + -- Reset the handler + + Command_Queue.Enqueue (Command'(Action => A_Reset_Handler)); + + pragma Debug (O ("Main windows task terminated")); + end loop; + end Main_Window; + + ------------------- + -- Event_Handler -- + ------------------- + + task body Event_Handler is + Cmd : Command; + begin + loop + select + accept Init do + -- Synchronize only + + pragma Debug (O ("Event_Handler.Init: done")); + null; + end Init; + or + terminate; + end select; + + -- Main local loop + + loop + -- Block waiting for a new command + + Cmd := Command_Queue.Dequeue; + + -- Run the command if it is valid + + if Cmd.Action = A_Reset_Handler then + exit; + elsif Dispatch_Table (Cmd.Action) /= null then + pragma Debug (O ("Main_Loop: executing command")); + Dispatch_Table (Cmd.Action).all (Cmd); + pragma Debug (O ("Main_Loop: done")); + end if; + end loop; + + pragma Debug (O ("Resetting the event handler: emptying queues")); + Command_Queue.Clear; + Response_Queue.Clear; + pragma Debug (O ("Resetting the event handler: done")); + end loop; + end Event_Handler; + --------------------- -- Allocate_Colors -- --------------------- @@ -535,7 +639,7 @@ procedure Assert_Main_Window_Exits is begin - if Main_Window = null then + if not Main_Window_Exists then raise Lost_Main_Window with "The main window does not exist"; end if; end Assert_Main_Window_Exits; @@ -673,11 +777,11 @@ Drawing_Area : Boolean := True) is begin - if Main_Window /= null then + if Main_Window_Exists then raise Program_Error with "The main windows already exists"; end if; - pragma Debug (O ("Creating main window task")); + pragma Debug (O ("Initializing main window task")); Width := Gint (X_Max); Height := Gint (Y_Max); @@ -688,9 +792,11 @@ Have_Drawing_Area := Drawing_Area; Have_Text_Area := Text_Area; - Main_Window := new Main_Window_Type; + -- Initialize main window task - pragma Debug (O ("Main window task created")); + Main_Window.Init; + + pragma Debug (O ("Main window task initialized")); end Create_Main_Window; ------------------------- @@ -1417,64 +1523,6 @@ pragma Debug (O ("Line with start and end : enqueued")); end Line; - -- Dispatch table - - type Command_Proc_Type is access procedure (Cmd : Command); - - Dispatch_Table : constant array (Action_Kind) of Command_Proc_Type := - (A_Angle => Do_Angle'Access, - A_Clear_Drawing_Area => Do_Clear_Drawing_Area'Access, - A_Clear_Text_Area => Do_Clear_Text_Area'Access, - A_Destroy => Do_Destroy'Access, - A_Fill_Color => Do_Fill_Color'Access, - A_Get_Immediate_Character => Do_Get_Immediate_Character'Access, - A_Get_Line_String => Do_Get_Line_String'Access, - A_Get_Mouse_Pointer => Do_Get_Mouse_Pointer'Access, - A_Get_String => Do_Get_String'Access, - A_Image => Do_Image'Access, - A_Jump_With_End => Do_Jump_With_End'Access, - A_Jump_With_Length => Do_Jump_With_Length'Access, - A_Line_Color => Do_Line_Color'Access, - A_Line_With_End => Do_Line_With_End'Access, - A_Line_With_Length => Do_Line_With_Length'Access, - A_Line_With_Start_End => Do_Line_With_Start_End'Access, - A_Line_With_Start_Length => Do_Line_With_Start_Length'Access, - A_New_Line => Do_New_Line'Access, - A_None => null, - A_Put_Character => Do_Put_Character'Access, - A_Put_Line_Character => Do_Put_Line_Character'Access, - A_Put_Line_String => Do_Put_Line_String'Access, - A_Put_String => Do_Put_String'Access, - A_Rafresh => Do_Rafresh'Access, - A_Rotate => Do_Rotate'Access, - A_Spot => Do_Spot'Access, - A_Text => Do_Text'Access, - A_Thickness => Do_Thickness'Access); - - --------------- - -- Main_Loop -- - --------------- - - function Main_Loop return Boolean is - Cmd : Command; - begin - if Command_Queue.Length > 0 then - Cmd := Command_Queue.Dequeue; - - if Dispatch_Table (Cmd.Action) /= null then - pragma Debug (O ("Main_Loop: executing command")); - Dispatch_Table (Cmd.Action).all (Cmd); - pragma Debug (O ("Main_Loop: done")); - end if; - end if; - - -- Mark a small delay to not have 100% of CPU occupied - - delay 0.001; - - return True; - end Main_Loop; - -------------- -- New_Line -- -------------- @@ -1554,8 +1602,8 @@ -- Quit -- ---------- - procedure Quit (Window : access Gtk.Window.Gtk_Window_Record'Class) is - pragma Unreferenced (Window); + procedure Quit (Win : access Gtk.Window.Gtk_Window_Record'Class) is + pragma Unreferenced (Win); begin Gtk.Main.Main_Quit; pragma Debug (O ("Quit: done")); @@ -1583,7 +1631,7 @@ Gdk_Col : Gdk_Color; Position : Color_Type; begin - if Main_Window /= null then + if Main_Window_Exists then raise Program_Error with "RGB must be calle BEFORE the" & " creation of the main window"; end if; @@ -1694,7 +1742,7 @@ -- Spot -- ---------- - procedure Spot (Radius : Float := 4.0) is + procedure Spot (Radius : Float := 1.0) is begin Assert_Main_Window_Exits; pragma Debug (O ("Spot : begin")); Modified: trunk/src/gtkada_wrapper.ads =================================================================== --- trunk/src/gtkada_wrapper.ads 2006-11-26 23:58:45 UTC (rev 16) +++ trunk/src/gtkada_wrapper.ads 2006-11-27 21:05:51 UTC (rev 17) @@ -151,7 +151,7 @@ Y_End : Float); -- Same as above, but with the Cartesian destination. - procedure Spot (Radius : Float := 4.0); + procedure Spot (Radius : Float := 1.0); -- Draw a spot in the current position with the given radius type X_Justification_Type is (Left, Center, Right); Modified: trunk/src/gtkada_wrapper.gpr =================================================================== --- trunk/src/gtkada_wrapper.gpr 2006-11-26 23:58:45 UTC (rev 16) +++ trunk/src/gtkada_wrapper.gpr 2006-11-27 21:05:51 UTC (rev 17) @@ -23,7 +23,7 @@ "-fstack-check", "-gnatg"); when "release" => for Default_Switches ("Ada") use - ("-g", "-O2", "-gnat05", "-gnatfy", "-gnatwae", "-gnatpn", + ("-g", "-O3", "-gnat05", "-gnatfy", "-gnatwae", "-gnatpn", "-gnatg"); end case; end Compiler; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |