Thread: [Gtkada-wrapper-devel] SF.net SVN: gtkada-wrapper: [6] trunk/src
Brought to you by:
bechir_zalila
From: <bec...@us...> - 2006-11-25 01:58:11
|
Revision: 6 http://svn.sourceforge.net/gtkada-wrapper/?rev=6&view=rev Author: bechir_zalila Date: 2006-11-24 17:58:11 -0800 (Fri, 24 Nov 2006) Log Message: ----------- * Now the stub compiles. Added athe action a dn command types that list the possible user commands. Modified Paths: -------------- trunk/src/Makefile.am trunk/src/gtkada_wrapper.adb trunk/src/gtkada_wrapper.ads Added Paths: ----------- trunk/src/libs/ trunk/src/objects/ Modified: trunk/src/Makefile.am =================================================================== --- trunk/src/Makefile.am 2006-11-25 00:18:45 UTC (rev 5) +++ trunk/src/Makefile.am 2006-11-25 01:58:11 UTC (rev 6) @@ -14,6 +14,9 @@ all-local: $(GNATMAKE) -P $(PROJECT_FILE) $(GNATFLAGS) +clean-local: + $(GNATCLEAN) -P $(PROJECT_FILE) $(GNATFLAGS) + install-data-local: $(INSTALL) -d $(DESTDIR)$(headers_dir) $(INSTALL) -d $(DESTDIR)$(ali_dir) @@ -25,4 +28,4 @@ done for f in $(srcdir)/libs/lib*; do \ $(INSTALL) -m 444 $$f $(DESTDIR)$(libdir); \ - done \ No newline at end of file + done Modified: trunk/src/gtkada_wrapper.adb =================================================================== --- trunk/src/gtkada_wrapper.adb 2006-11-25 00:18:45 UTC (rev 5) +++ trunk/src/gtkada_wrapper.adb 2006-11-25 01:58:11 UTC (rev 6) @@ -1,24 +1,156 @@ +with Unchecked_Deallocation; + package body Gtkada_Wrapper is - ----------------------- - -- Clear_Main_Window -- - ----------------------- + -- The actions the user can do - procedure Clear_Main_Window is + type Action_Kind is + (A_None, + A_Clear_Drawing_Area, + A_Line_Color, + A_Fill_Color, + A_Thickness, + A_Angle, + A_Rotate, + A_Jump_With_Length, + A_Jump_With_End, + A_Line_With_Length, + A_Line_With_End, + A_Line_With_Start_Length, + A_Line_With_Start_End, + A_Spot, + A_Image, + A_Text, + A_Rafresh, + A_Get_Mouse_Pointer, + A_Clear_Text_Area, + A_Put_String, + A_Put_Character, + A_New_Line, + A_Put_Line_String, + A_Put_Line_Character, + A_Get_String, + A_Get_Line_String, + A_Get_Immediate_Character); + + type String_Ptr is access all String; + procedure Free is new Unchecked_Deallocation (String, String_Ptr); + pragma Unreferenced (Free); + + -- The command data + + type Command (Action : Action_Kind) is record + case Action is + when A_None + | A_Clear_Drawing_Area + | A_Rafresh + | A_Clear_Text_Area + | A_Get_String + | A_Get_Line_String + | A_Get_Immediate_Character => + null; + + when A_Line_Color | A_Fill_Color => + Color : Color_Type; + + when A_Thickness => + Thickness : Float; + + when A_Angle | A_Rotate => + Angle : Float; + + when A_Jump_With_End + | A_Line_With_End + | A_Line_With_Start_End + | A_Jump_With_Length + | A_Line_With_Length + | A_Line_With_Start_Length => + + X_Start : Float; + Y_Start : Float; + + case Action is + when A_Jump_With_End + | A_Line_With_End + | A_Line_With_Start_End => + X_End : Float; + Y_End : Float; + + when A_Jump_With_Length + | A_Line_With_Length + | A_Line_With_Start_Length => + Distance : Float; + + when others => + null; + end case; + + when A_Spot => + Diameter : Float; + + when A_Image | A_Text => + X_Justify : X_Justification_Type; + Y_Justify : Y_Justification_Type; + + case Action is + when A_Image => + File_Name : String_Ptr; + Scale : Float; + + when A_Text => + Text : String_Ptr; + Size : Float; + + when others => + null; + end case; + + when A_Get_Mouse_Pointer => + X : Float; + Y : Float; + Button : Natural; + + when A_New_Line => + N_Lines : Positive; + + when A_Put_String | A_Put_Line_String => + Str : String_Ptr; + + when A_Put_Character | A_Put_Line_Character => + Char : Character; + end case; + end record; + pragma Unreferenced (Command); + + ------------------------ + -- Clear_Drawing_Area -- + ------------------------ + + procedure Clear_Drawing_Area is begin null; - end Clear_Main_Window; + end Clear_Drawing_Area; + --------------------- + -- Clear_Text_Area -- + --------------------- + + procedure Clear_Text_Area is + begin + null; + end Clear_Text_Area; + ------------------------ -- Create_Main_Window -- ------------------------ procedure Create_Main_Window - (X_Max : Float := 512.0; - Y_Max : Float := 512.0; - Text_Area : Boolean := False; + (X_Max : Float := 512.0; + Y_Max : Float := 512.0; + Text_Area : Boolean := False; Drawing_Area : Boolean := True) is + pragma Unreferenced (X_Max, Y_Max, Text_Area, Drawing_Area); begin null; end Create_Main_Window; @@ -38,7 +170,7 @@ function Get return String is begin - return Get; + return ""; end Get; --------------- @@ -47,7 +179,7 @@ function Get_Angle return Float is begin - return Get_Angle; + return 0.0; end Get_Angle; -------------------- @@ -56,7 +188,7 @@ function Get_Fill_Color return Color_Type is begin - return Get_Fill_Color; + return Black; end Get_Fill_Color; ------------------- @@ -64,6 +196,7 @@ ------------------- procedure Get_Immediate (Item : out Character) is + pragma Unreferenced (Item); begin null; end Get_Immediate; @@ -74,7 +207,7 @@ function Get_Line return String is begin - return Get_Line; + return ""; end Get_Line; -------------------- @@ -83,7 +216,7 @@ function Get_Line_Color return Color_Type is begin - return Get_Line_Color; + return Black; end Get_Line_Color; ----------------------- @@ -95,6 +228,7 @@ Y : out Float; Button : out Natural) is + pragma Unreferenced (X, Y, Button); begin null; end Get_Mouse_Pointer; @@ -104,6 +238,7 @@ ------------------ procedure Get_Position (X : out Float; Y : out Float) is + pragma Unreferenced (X, Y); begin null; end Get_Position; @@ -114,7 +249,7 @@ function Get_Thickness return Float is begin - return Get_Thickness; + return 0.0; end Get_Thickness; ------------------ @@ -127,6 +262,7 @@ X_Justification : X_Justification_Type := Center; Y_Justification : Y_Justification_Type := Center) is + pragma Unreferenced (File_Name, Scale, X_Justification, Y_Justification); begin null; end Insert_Image; @@ -141,6 +277,7 @@ X_Justification : X_Justification_Type := Center; Y_Justification : Y_Justification_Type := Center) is + pragma Unreferenced (Text, Size, X_Justification, Y_Justification); begin null; end Insert_Text; @@ -150,6 +287,7 @@ ---------- procedure Jump (Distance : Float) is + pragma Unreferenced (Distance); begin null; end Jump; @@ -159,6 +297,7 @@ ---------- procedure Jump (X : Float; Y : Float) is + pragma Unreferenced (X, Y); begin null; end Jump; @@ -168,6 +307,7 @@ ---------- procedure Line (Distance : Float) is + pragma Unreferenced (Distance); begin null; end Line; @@ -177,6 +317,7 @@ ---------- procedure Line (X : Float; Y : Float) is + pragma Unreferenced (X, Y); begin null; end Line; @@ -190,6 +331,7 @@ Y_Start : Float; Distance : Float) is + pragma Unreferenced (X_Start, Y_Start, Distance); begin null; end Line; @@ -204,6 +346,7 @@ X_End : Float; Y_End : Float) is + pragma Unreferenced (X_Start, Y_Start, X_End, Y_End); begin null; end Line; @@ -213,6 +356,7 @@ -------------- procedure New_Line (Spacing : Positive := 1) is + pragma Unreferenced (Spacing); begin null; end New_Line; @@ -222,6 +366,7 @@ --------- procedure Put (Item : String) is + pragma Unreferenced (Item); begin null; end Put; @@ -231,6 +376,7 @@ --------- procedure Put (Item : Character) is + pragma Unreferenced (Item); begin null; end Put; @@ -240,6 +386,7 @@ -------------- procedure Put_Line (Item : String) is + pragma Unreferenced (Item); begin null; end Put_Line; @@ -249,6 +396,7 @@ -------------- procedure Put_Line (Item : Character) is + pragma Unreferenced (Item); begin null; end Put_Line; @@ -268,7 +416,9 @@ function RGB (R : Integer; G : Integer; B : Integer) return Color_Type is begin - return RGB (R, G, B); + return Color_Type'(R => Single_Color (R mod 256), + G => Single_Color (G mod 256), + B => Single_Color (B mod 256)); end RGB; ------------ @@ -276,6 +426,7 @@ ------------ procedure Rotate (Angle : Float) is + pragma Unreferenced (Angle); begin null; end Rotate; @@ -285,6 +436,7 @@ --------------- procedure Set_Angle (Angle : Float) is + pragma Unreferenced (Angle); begin null; end Set_Angle; @@ -294,6 +446,7 @@ -------------------- procedure Set_Fill_Color (C : Color_Type) is + pragma Unreferenced (C); begin null; end Set_Fill_Color; @@ -303,6 +456,7 @@ -------------------- procedure Set_Line_Color (C : Color_Type) is + pragma Unreferenced (C); begin null; end Set_Line_Color; @@ -312,6 +466,7 @@ ------------------ procedure Set_Position (X : Float; Y : Float) is + pragma Unreferenced (X, Y); begin null; end Set_Position; @@ -321,6 +476,7 @@ ------------------- procedure Set_Thickness (T : Float) is + pragma Unreferenced (T); begin null; end Set_Thickness; @@ -330,6 +486,7 @@ ---------- procedure Spot (Radius : Float := 4.0) is + pragma Unreferenced (Radius); begin null; end Spot; Modified: trunk/src/gtkada_wrapper.ads =================================================================== --- trunk/src/gtkada_wrapper.ads 2006-11-25 00:18:45 UTC (rev 5) +++ trunk/src/gtkada_wrapper.ads 2006-11-25 01:58:11 UTC (rev 6) @@ -12,9 +12,9 @@ package Gtkada_Wrapper is procedure Create_Main_Window - (X_Max : Float := 512.0; - Y_Max : Float := 512.0; - Text_Area : Boolean := False; + (X_Max : Float := 512.0; + Y_Max : Float := 512.0; + Text_Area : Boolean := False; Drawing_Area : Boolean := True); -- Creates the main window of the application. X_Max and Y_Max -- represent respectively the width and the height of each one of @@ -23,11 +23,6 @@ -- parts. Note that at least one of these two flags has to be set -- to true. - procedure Clear_Main_Window; - -- Clear the main window. If the drwing area exists, then it will - -- be ``blanked''. If the text area exist then all text will be - -- erased. - procedure Destroy_Main_Window; -- Close and destroy the main window @@ -72,6 +67,9 @@ White : constant Color_Type; -- Predefined colors + procedure Clear_Drawing_Area; + -- If the drwing area exists, then it will be ``blanked'' + procedure Set_Line_Color (C : Color_Type); -- Set the line color of the virtual brush to C @@ -183,6 +181,9 @@ -- Text Area Specific Routines -- --------------------------------- + procedure Clear_Text_Area; + -- If the text area exist then all text will be erased. + procedure Put (Item : String); -- Type the given text on the current cursor position of the text -- area. This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bec...@us...> - 2006-11-25 17:18:52
|
Revision: 8 http://svn.sourceforge.net/gtkada-wrapper/?rev=8&view=rev Author: bechir_zalila Date: 2006-11-25 09:18:47 -0800 (Sat, 25 Nov 2006) Log Message: ----------- * (protected_queue.ad?): Added a generic package for protected queues * (gtkada_wrapper.ad?): Added a reponse record type and instantiated a command queue and a response queue Modified Paths: -------------- trunk/src/gtkada_wrapper.adb trunk/src/gtkada_wrapper.ads trunk/src/gtkada_wrapper.gpr Added Paths: ----------- trunk/src/protected_queue.adb trunk/src/protected_queue.ads Modified: trunk/src/gtkada_wrapper.adb =================================================================== --- trunk/src/gtkada_wrapper.adb 2006-11-25 01:59:33 UTC (rev 7) +++ trunk/src/gtkada_wrapper.adb 2006-11-25 17:18:47 UTC (rev 8) @@ -1,11 +1,20 @@ +-- $Id$ +-- Copyright (C) 2006 Bechir Zalila <bec...@en...> +-- See COPYING file for license + with Unchecked_Deallocation; +with Gdk.Types; use Gdk.Types; + +with Protected_Queue; + package body Gtkada_Wrapper is -- The actions the user can do type Action_Kind is (A_None, + A_Destroy, A_Clear_Drawing_Area, A_Line_Color, A_Fill_Color, @@ -39,14 +48,16 @@ -- The command data - type Command (Action : Action_Kind) is record + type Command (Action : Action_Kind := A_None) is record case Action is when A_None + | A_Destroy | A_Clear_Drawing_Area | A_Rafresh | A_Clear_Text_Area | A_Get_String | A_Get_Line_String + | A_Get_Mouse_Pointer | A_Get_Immediate_Character => null; @@ -105,11 +116,6 @@ null; end case; - when A_Get_Mouse_Pointer => - X : Float; - Y : Float; - Button : Natural; - when A_New_Line => N_Lines : Positive; @@ -120,8 +126,45 @@ Char : Character; end case; end record; - pragma Unreferenced (Command); + -- The user command queue + + package Command_Queue is new Protected_Queue (Command, 10000); + pragma Unreferenced (Command_Queue); + + -- The response kind + + type Response_Kind is + (R_None, + R_Mouse, + R_Console, + R_Immediate); + + -- The response data + + type Response (Rsp_Kind : Response_Kind := R_None) is record + case Rsp_Kind is + when R_None => + null; + + when R_Mouse => + X : Float; + Y : Float; + Button : Natural; + + when R_Console => + Text : String_Ptr; + + when R_Immediate => + Key : Gdk_Key_Type; + end case; + end record; + + -- Response queue + + package Response_Queue is new Protected_Queue (Response, 10000); + pragma Unreferenced (Response_Queue); + ------------------------ -- Clear_Drawing_Area -- ------------------------ Modified: trunk/src/gtkada_wrapper.ads =================================================================== --- trunk/src/gtkada_wrapper.ads 2006-11-25 01:59:33 UTC (rev 7) +++ trunk/src/gtkada_wrapper.ads 2006-11-25 17:18:47 UTC (rev 8) @@ -1,5 +1,6 @@ -- $Id$ --- AUTHOR: Bechir Zalila <bec...@en...> +-- Copyright (C) 2006 Bechir Zalila <bec...@en...> +-- See COPYING file for license -- This package provides a simplified api to build graphic Ada -- applications. Its purpose is to encapsulate the complexity of GTK Modified: trunk/src/gtkada_wrapper.gpr =================================================================== --- trunk/src/gtkada_wrapper.gpr 2006-11-25 01:59:33 UTC (rev 7) +++ trunk/src/gtkada_wrapper.gpr 2006-11-25 17:18:47 UTC (rev 8) @@ -1,3 +1,5 @@ +with "gtkada"; + project GTKAda_Wrapper is for Library_Kind use "static"; for Source_Dirs use ("."); Added: trunk/src/protected_queue.adb =================================================================== --- trunk/src/protected_queue.adb (rev 0) +++ trunk/src/protected_queue.adb 2006-11-25 17:18:47 UTC (rev 8) @@ -0,0 +1,140 @@ +-- $Id$ +-- Copyright (C) 2006 Bechir Zalila <bec...@en...> +-- See COPYING file for license + +with GNAT.Table; + +package body Protected_Queue is + + type Waiting_Type is (To_Enqueue, To_Dequeue, To_Enqueue_Plus_Dequeue); + -- To choose which number of waiting task we want to get + + package The_Queue is new GNAT.Table + (Element_Type, Natural, 1, 100, 10); + + -- The protected object that ensure concurrency safety + + protected The_Protected_Queue is + entry Enqueue (Element : Element_Type); + entry Dequeue (Element : out Element_Type); + + function Number_Waiting + (To : Waiting_Type := To_Dequeue) + return Natural; + + function Length return Natural; + procedure Clear; + end The_Protected_Queue; + + protected body The_Protected_Queue is + + ------------- + -- Enqueue -- + ------------- + + entry Enqueue (Element : Element_Type) + when The_Queue.Last < Max_Length is + begin + The_Queue.Append (Element); + end Enqueue; + + ------------- + -- Dequeue -- + ------------- + + entry Dequeue (Element : out Element_Type) + when The_Queue.Last > 0 is + begin + Element := The_Queue.Table (The_Queue.Last); + The_Queue.Decrement_Last; + end Dequeue; + + -------------------- + -- Number_Waiting -- + -------------------- + + function Number_Waiting + (To : Waiting_Type := To_Dequeue) + return Natural + is + Result : Natural := 0; + begin + if To = To_Enqueue or To = To_Enqueue_Plus_Dequeue then + Result := Result + The_Protected_Queue.Enqueue'Count; + end if; + + if To = To_Dequeue or To = To_Enqueue_Plus_Dequeue then + Result := Result + The_Protected_Queue.Dequeue'Count; + end if; + + return Result; + end Number_Waiting; + + ------------ + -- Length -- + ------------ + + function Length return Natural is + begin + return The_Queue.Last; + end Length; + + ----------- + -- Clear -- + ----------- + + procedure Clear is + begin + The_Queue.Free; + The_Queue.Init; + end Clear; + end The_Protected_Queue; + + ------------- + -- Enqueue -- + ------------- + + procedure Enqueue (Element : Element_Type) is + begin + The_Protected_Queue.Enqueue (Element); + end Enqueue; + + ------------- + -- Dequeue -- + ------------- + + function Dequeue return Element_Type is + Result : Element_Type; + begin + The_Protected_Queue.Dequeue (Result); + return Result; + end Dequeue; + + ------------ + -- Length -- + ------------ + + function Length return Natural is + begin + return The_Protected_Queue.Length; + end Length; + + ----------- + -- Clear -- + ----------- + + procedure Clear is + begin + The_Protected_Queue.Clear; + end Clear; + + -------------------- + -- Number_Waiting -- + -------------------- + + function Number_Waiting return Natural is + begin + return The_Protected_Queue.Number_Waiting; + end Number_Waiting; + +end Protected_Queue; Property changes on: trunk/src/protected_queue.adb ___________________________________________________________________ Name: svn:keywords + Id Name: svn:eol-style + native Added: trunk/src/protected_queue.ads =================================================================== --- trunk/src/protected_queue.ads (rev 0) +++ trunk/src/protected_queue.ads 2006-11-25 17:18:47 UTC (rev 8) @@ -0,0 +1,36 @@ +-- $Id$ +-- Copyright (C) 2006 Bechir Zalila <bec...@en...> +-- See COPYING file for license + +-- This generic package implements a protected queue. It has to be +-- instantiated with the queue element type and a maximal length of +-- the queue. Each instantiation of the package creates one single +-- queue. + +generic + type Element_Type is private; + + Max_Length : Natural := 100; +package Protected_Queue is + -- All the routines below are concurrency safe + + procedure Enqueue (Element : Element_Type); + -- Put an element at the end of the queue. If the queue is full, + -- block until a place is freed. + + function Dequeue return Element_Type; + -- Return the first element of the queue and remove it from the + -- head of the queue. If the queue is empty, bolock until an + -- element is put. + + function Length return Natural; + -- Return the number of elements present in the queue + + procedure Clear; + -- Delete all the elements of the queue + + function Number_Waiting return Natural; + -- Return the number of tasks waiting on the queue entries + -- (enqueuing and dequeuing). + +end Protected_Queue; Property changes on: trunk/src/protected_queue.ads ___________________________________________________________________ Name: svn:keywords + Id Name: svn:eol-style + native This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bec...@us...> - 2006-11-26 23:58:44
|
Revision: 16 http://svn.sourceforge.net/gtkada-wrapper/?rev=16&view=rev Author: bechir_zalila Date: 2006-11-26 15:58:45 -0800 (Sun, 26 Nov 2006) Log Message: ----------- * Disable debug by default. Minor reformatting Modified Paths: -------------- trunk/src/gtkada_wrapper.adb trunk/src/gtkada_wrapper.ads Modified: trunk/src/gtkada_wrapper.adb =================================================================== --- trunk/src/gtkada_wrapper.adb 2006-11-26 23:48:18 UTC (rev 15) +++ trunk/src/gtkada_wrapper.adb 2006-11-26 23:58:45 UTC (rev 16) @@ -31,11 +31,12 @@ with Protected_Queue; -pragma Debug_Policy (Check); -- 'Ignore' Or 'Check' +pragma Debug_Policy (Ignore); +-- To control the debug message display: 'Ignore' Or 'Check' package body Gtkada_Wrapper is - procedure O (Message : String) renames Ada.Text_IO.Put_Line; + procedure O (Message : String); -- For debugging purpose procedure Quit (Window : access Gtk.Window.Gtk_Window_Record'Class); @@ -856,7 +857,7 @@ procedure Do_Jump_With_Length (Cmd : Command) is begin - pragma Debug (O ("")); + pragma Debug (O ("Do_Jump_With_Length: begin")); Brush_X := Brush_X + Cmd.Distance * Cos (Angle, 360.0); Brush_X := Brush_Y + Cmd.Distance * Sin (Angle, 360.0); @@ -864,7 +865,7 @@ pragma Debug (O ("Changed the virtual brush position to (" & Brush_X'Img & ", " & Brush_Y'Img & ")")); - pragma Debug (O ("")); + pragma Debug (O ("Do_Jump_With_Length: done")); end Do_Jump_With_Length; ------------------- @@ -1101,7 +1102,7 @@ Height - Gint (Y_End)); pragma Debug (O ("Line drawn between" - & "(" & X_Start'Img & ", " & Y_Start'Img & ") and" + & "(" & X_Start'Img & ", " & Y_Start'Img & ") and " & "(" & X_End'Img & ", " & Y_End'Img & ")")); pragma Debug (O ("Draw_Line: done")); end Draw_Line; @@ -1461,9 +1462,9 @@ Cmd := Command_Queue.Dequeue; if Dispatch_Table (Cmd.Action) /= null then - pragma Debug (O ("")); + pragma Debug (O ("Main_Loop: executing command")); Dispatch_Table (Cmd.Action).all (Cmd); - pragma Debug (O ("")); + pragma Debug (O ("Main_Loop: done")); end if; end if; @@ -1487,6 +1488,16 @@ pragma Debug (O ("New_Line : enqueued")); end New_Line; + ------- + -- O -- + ------- + + procedure O (Message : String) is + begin + Ada.Text_IO.Put ("DEBUG: "); + Ada.Text_IO.Put_Line (Message); + end O; + --------- -- Put -- --------- @@ -1547,7 +1558,7 @@ pragma Unreferenced (Window); begin Gtk.Main.Main_Quit; - pragma Debug (O ("")); + pragma Debug (O ("Quit: done")); end Quit; ------------- Modified: trunk/src/gtkada_wrapper.ads =================================================================== --- trunk/src/gtkada_wrapper.ads 2006-11-26 23:48:18 UTC (rev 15) +++ trunk/src/gtkada_wrapper.ads 2006-11-26 23:58:45 UTC (rev 16) @@ -2,7 +2,7 @@ -- Copyright (C) 2006 Bechir Zalila <bec...@en...> -- See COPYING file for license --- This package provides a simplified api to build graphic Ada +-- This package provides a simplified API to build graphic Ada -- applications. Its purpose is to encapsulate the complexity of GTK -- (and GTKAda) and provide a simple way to build graphical Ada -- application for beginner programmers. @@ -59,8 +59,8 @@ -- Create an RGB (Red Green Blue) color. All the given parameter -- are considered modulo 65536, the maximal value of a color -- composant. - -- IMPORTANT NOTE: All custom color must be declared *before* the - -- call to Create_Main_Window + -- IMPORTANT NOTE: All custom colors must be declared + -- *before* the call to Create_Main_Window Black : constant Color_Type; Red : constant Color_Type; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |