[Gtkada-wrapper-devel] SF.net SVN: gtkada-wrapper: [13] trunk
Brought to you by:
bechir_zalila
Menu
▾
▴
[Gtkada-wrapper-devel] SF.net SVN: gtkada-wrapper: [13] trunk
|
From: <bec...@us...> - 2006-11-26 20:30:30
|
Revision: 13
http://svn.sourceforge.net/gtkada-wrapper/?rev=13&view=rev
Author: bechir_zalila
Date: 2006-11-26 12:30:23 -0800 (Sun, 26 Nov 2006)
Log Message:
-----------
* Advanced in the designe of the drawing area. Compeleted alkl the
user commands related to the drawing area.
* Added an example of basic drawing
* There still be a probleme concerning colors: The drawing color is
always black.
Modified Paths:
--------------
trunk/Makefile.am
trunk/TODO
trunk/configure.ac
trunk/examples/Makefile.am
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
trunk/src/protected_queue.adb
Added Paths:
-----------
trunk/examples/basic_drawings/
trunk/examples/basic_drawings/Makefile.am
trunk/examples/basic_drawings/README
trunk/examples/basic_drawings/basic_drawings.adb
trunk/examples/basic_drawings/basic_drawings.gpr
Modified: trunk/Makefile.am
===================================================================
--- trunk/Makefile.am 2006-11-26 02:02:56 UTC (rev 12)
+++ trunk/Makefile.am 2006-11-26 20:30:23 UTC (rev 13)
@@ -1,4 +1,4 @@
-SUBDIRS=doc src
+SUBDIRS=doc src examples
AUTOMAKE_OPTIONS = no-dependencies
ACLOCAL_AMFLAGS = -I support
CLEANFILES = config-stamp
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-26 02:02:56 UTC (rev 12)
+++ trunk/TODO 2006-11-26 20:30:23 UTC (rev 13)
@@ -1,5 +1,8 @@
/src:
- * Complete the code
+ * Solve the color problem
+ * Implement custom colors
+ * Implement Text area
+ * Remove the Idle loop
/doc:
* Write the documentation
Modified: trunk/configure.ac
===================================================================
--- trunk/configure.ac 2006-11-26 02:02:56 UTC (rev 12)
+++ trunk/configure.ac 2006-11-26 20:30:23 UTC (rev 13)
@@ -88,6 +88,7 @@
doc/Makefile
examples/Makefile
examples/empty_window/Makefile
+ examples/basic_drawings/Makefile
src/Makefile
])
Modified: trunk/examples/Makefile.am
===================================================================
--- trunk/examples/Makefile.am 2006-11-26 02:02:56 UTC (rev 12)
+++ trunk/examples/Makefile.am 2006-11-26 20:30:23 UTC (rev 13)
@@ -1 +1 @@
-SUBDIRS = empty_window
+SUBDIRS = empty_window basic_drawings
Added: trunk/examples/basic_drawings/Makefile.am
===================================================================
--- trunk/examples/basic_drawings/Makefile.am (rev 0)
+++ trunk/examples/basic_drawings/Makefile.am 2006-11-26 20:30:23 UTC (rev 13)
@@ -0,0 +1,5 @@
+include ../Makefile.common
+
+PROJECT_FILE = $(srcdir)/basic_drawings.gpr
+SOURCES = $(srcdir)/basic_drawings.adb
+
Added: trunk/examples/basic_drawings/README
===================================================================
--- trunk/examples/basic_drawings/README (rev 0)
+++ trunk/examples/basic_drawings/README 2006-11-26 20:30:23 UTC (rev 13)
@@ -0,0 +1,2 @@
+This example test some basic drawings. It performs some drawings on
+the main window and wait the user click to exit.
Added: trunk/examples/basic_drawings/basic_drawings.adb
===================================================================
--- trunk/examples/basic_drawings/basic_drawings.adb (rev 0)
+++ trunk/examples/basic_drawings/basic_drawings.adb 2006-11-26 20:30:23 UTC (rev 13)
@@ -0,0 +1,45 @@
+-- $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 Basic_Drawings is
+ X : Float;
+ Y : Float;
+ Button : Natural;
+
+ Color_Array : constant array (1 .. 8) of Color_Type :=
+ (Black,
+ Red,
+ Green,
+ Yellow,
+ Blue,
+ Magenta,
+ Cyan,
+ Orange);
+begin
+ Create_Main_Window;
+
+ Set_Thickness (15.0);
+ Set_Angle (0.0);
+
+ for I in Color_Array'Range loop
+ Set_Line_Color (Color_Array (I));
+ Line (100.0 + 10.0 * Float (I));
+ Rotate (45.0);
+ end loop;
+
+ 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 Basic_Drawings;
Property changes on: trunk/examples/basic_drawings/basic_drawings.adb
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/examples/basic_drawings/basic_drawings.gpr
===================================================================
--- trunk/examples/basic_drawings/basic_drawings.gpr (rev 0)
+++ trunk/examples/basic_drawings/basic_drawings.gpr 2006-11-26 20:30:23 UTC (rev 13)
@@ -0,0 +1,5 @@
+with "../../src/gtkada_wrapper.gpr";
+
+project Basic_Drawings is
+ for main use ("basic_drawings.adb");
+end Basic_Drawings;
Property changes on: trunk/examples/basic_drawings/basic_drawings.gpr
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-26 02:02:56 UTC (rev 12)
+++ trunk/src/gtkada_wrapper.adb 2006-11-26 20:30:23 UTC (rev 13)
@@ -3,16 +3,19 @@
-- See COPYING file for license
with Ada.Text_IO;
+with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;
with Unchecked_Deallocation;
with Glib; use Glib;
+with Gdk.Color; use Gdk.Color;
with Gdk.Types; use Gdk.Types;
with Gdk.Event; use Gdk.Event;
with Gdk.Pixmap; use Gdk.Pixmap;
with Gdk.Window; use Gdk.Window;
with Gdk.Drawable; use Gdk.Drawable;
with Gdk.Rectangle; use Gdk.Rectangle;
+with Gdk.GC; use Gdk.GC;
with Gtk.Drawing_Area; use Gtk.Drawing_Area;
with Gtk.Window; use Gtk.Window;
@@ -22,11 +25,15 @@
with Gtk.Main; use Gtk.Main;
with Gtk.Handlers; use Gtk.Handlers;
with Gtk.Style; use Gtk.Style;
+with Gtk.Widget;
with Protected_Queue;
package body Gtkada_Wrapper is
+ procedure O (Message : String) renames Ada.Text_IO.Put_Line;
+ -- For debugging purpose
+
procedure Quit (Window : access Gtk.Window.Gtk_Window_Record'Class);
-- Quit the main loop when the user closes the window
@@ -54,6 +61,20 @@
-- This is the main loop that handle the user commands. It is
-- registered as an "Idle" function of the main window
+ function Image (C : Color_Type) return String;
+ -- For debugging purpose
+
+ function To_Gdk_Color (C : Color_Type) return Gdk_Color;
+ pragma Inline (To_Gdk_Color);
+ -- Convert user colors to GDK colors
+
+ procedure Draw_Line
+ (X_Start : Float;
+ Y_Start : Float;
+ X_End : Float;
+ Y_End : Float);
+ -- Draw a line with the current graphic properties
+
----------------------
-- Global Variables --
----------------------
@@ -73,9 +94,12 @@
Height : Gint;
-- Dimensions of the drawing and text areas
- Brush_X : Float := 0.0;
- Brush_Y : Float := 0.0;
- Angle : Float := 0.0;
+ Brush_X : Float := 0.0;
+ Brush_Y : Float := 0.0;
+ Angle : Float := 0.0;
+ Thickness : Float := 1.0;
+ Line_Color : Color_Type := Red;
+ Fill_Color : Color_Type := White;
-- Properties of the virtual brush
pragma Warnings (Off, Brush_X);
@@ -89,12 +113,41 @@
-- The container of the window components (the drawing area and
-- the text area).
- Drawing_Area : Gtk_Drawing_Area;
+ Drawing_Area : Gtk_Drawing_Area;
+ Graphic_Context : Gdk_GC;
-- The drawing area of the main window
Pixmap : Gdk_Pixmap;
-- Pixmap usefult when rafreshing the drawing area
+ N_Colors : constant := 13;
+
+ Color_Table : Gdk_Color_Array (1 .. N_Colors);
+ -- FIXME: Why does colors have to be declared at library level and
+ -- allocated?
+
+ type RGB_Fields is record
+ R : Guint16;
+ G : Guint16;
+ B : Guint16;
+ end record;
+
+ RGB_Vals : constant array (Color_Type range 1 .. Color_Type (N_Colors))
+ of RGB_Fields :=
+ (Black => (0, 0, 0),
+ Red => (65535, 0, 0),
+ Green => (0, 65535, 0),
+ Yellow => (65535, 65535, 0),
+ Blue => (0, 0, 65535),
+ Magenta => (65535, 0, 65535),
+ Cyan => (0, 65535, 65535),
+ Dark_Gray => (19789, 19789, 19789),
+ Orange => (65535, 42405, 0),
+ Pink => (65535, 49344, 52171),
+ Gray => (32767, 32767, 32767),
+ Light_Gray => (46003, 46003, 46003),
+ White => (65535, 65535, 65535));
+
-- User_Task : Task_Id := Null_Task_ID; -- Task that sets up world.
-- Pixmap : Gdk_Pixmap; -- Pixmap used as backing store.
-- Pausing : Boolean := False;
@@ -188,6 +241,11 @@
X_Start : Float;
Y_Start : Float;
+ -- These 2 component are not necesary in the case of
+ -- A_Jump_With_End and A_Line_With_End. However we cannot
+ -- do finer because it is impossible de decalre them
+ -- twice (in the case of A_Line_With_Start_End and
+ -- A_Line_With_Start_Length.
case Action is
when A_Jump_With_End
@@ -206,7 +264,7 @@
end case;
when A_Spot =>
- Diameter : Float;
+ Radius : Float;
when A_Image | A_Text =>
X_Justify : X_Justification_Type;
@@ -399,6 +457,43 @@
Main_Loop_Id := Idle_Add (Main_Loop'Access);
Show_All (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...)
+
+ Gdk_New (Graphic_Context, Get_Window (Drawing_Area));
+
+ -- 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);
+
+ -- Allocate colors
+
+ declare
+ Success : Boolean_Array (1 .. N_Colors);
+ N_Failed : Gint;
+ begin
+ Alloc_Colors
+ (Colormap => Gtk.Widget.Get_Default_Colormap,
+ Colors => Color_Table,
+ Writeable => False,
+ Best_Match => True,
+ Success => Success,
+ Result => N_Failed);
+ pragma Assert (N_Failed = 0);
+ end;
+
+ Set_Foreground (Graphic_Context, To_Gdk_Color (Line_Color));
+ Set_Background (Graphic_Context, To_Gdk_Color (Fill_Color));
+ end if;
+
Gtk.Main.Main;
-- FIXME: Handle exit
@@ -427,11 +522,13 @@
is
pragma Unreferenced (Drawing_Area);
begin
+ pragma Debug (O ("Mouse button pressed"));
+
-- Do not take in consideration mouse clicks on ly if the user
-- asked explicitely for them
if Current_Waited_Response = R_Mouse then
- Ada.Text_IO.Put_Line ("button_press");
+ pragma Debug (O ("Mouse button pressed: handling"));
-- Restore the current waited response
@@ -456,6 +553,12 @@
procedure Clear_Drawing_Area is
begin
Assert_Main_Window_Exits;
+
+ pragma Assert (Drawing_Area /= null);
+
+ pragma Debug (O ("Clear_Drawing_Area : begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Clear_Drawing_Area));
+ pragma Debug (O ("Clear_Drawing_Area : enqueued"));
end Clear_Drawing_Area;
---------------------
@@ -465,6 +568,12 @@
procedure Clear_Text_Area is
begin
Assert_Main_Window_Exits;
+
+ -- FIXME: pragma Assert (Text_Area /= null);
+
+ pragma Debug (O ("Clear_Text_Area : begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Clear_Text_Area));
+ pragma Debug (O ("Clear_Text_Area : enqueued"));
end Clear_Text_Area;
---------------------
@@ -482,7 +591,7 @@
use type Gdk.Gdk_Drawable;
begin
- Ada.Text_IO.Put_Line ("configure");
+ pragma Debug (O ("Window configuration changed: handling"));
Win := Get_Window (Drawing_Area);
-- Allocate a new pixmap of the reconfigured size and clear it
@@ -539,6 +648,8 @@
raise Program_Error with "The main windows already exists";
end if;
+ pragma Debug (O ("Creating main window task"));
+
Width := Gint (X_Max);
Height := Gint (Y_Max);
@@ -549,6 +660,8 @@
Have_Text_Area := Text_Area;
Main_Window := new Main_Window_Type;
+
+ pragma Debug (O ("Main window task created"));
end Create_Main_Window;
-------------------------
@@ -558,7 +671,9 @@
procedure Destroy_Main_Window is
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Destroying the main window"));
Command_Queue.Enqueue (Command'(Action => A_Destroy));
+ pragma Debug (O ("Main window destruction scheduled"));
end Destroy_Main_Window;
--------------
@@ -566,9 +681,10 @@
--------------
procedure Do_Angle (Cmd : Command) is
- pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Angle : begin"));
+ Angle := Cmd.Angle;
+ pragma Debug (O ("Do_Angle : angle changed to" & Cmd.Angle'Img));
end Do_Angle;
---------------------------
@@ -578,7 +694,19 @@
procedure Do_Clear_Drawing_Area (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Clear_Drawing_Area: begin"));
+
+ -- Redraw a white rectangle on the drawing area
+
+ Draw_Rectangle (Pixmap,
+ Get_White (Get_Style (Drawing_Area)),
+ True,
+ 0,
+ 0,
+ Width,
+ Height);
+
+ pragma Debug (O ("Do_Clear_Drawing_Area: done"));
end Do_Clear_Drawing_Area;
------------------------
@@ -588,7 +716,9 @@
procedure Do_Clear_Text_Area (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Text_Drawing_Area: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Text_Drawing_Area: done"));
end Do_Clear_Text_Area;
----------------
@@ -598,7 +728,9 @@
procedure Do_Destroy (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
+ pragma Debug (O ("Do_Destroy: begin"));
Quit (Window);
+ pragma Debug (O ("Do_Destroy: done"));
end Do_Destroy;
-------------------
@@ -606,9 +738,12 @@
-------------------
procedure Do_Fill_Color (Cmd : Command) is
- pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Fill_Color: begin"));
+ Fill_Color := Cmd.Color;
+ -- Set_Background (Graphic_Context, To_Gdk_Color (Fill_Color));
+ pragma Debug (O ("Fill color changed to" & Image (Fill_Color)));
+ pragma Debug (O ("Do_Fill_Color: end"));
end Do_Fill_Color;
--------------------------------
@@ -618,7 +753,9 @@
procedure Do_Get_Immediate_Character (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Get_Immediate_Character: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Get_Immediate_Character: done"));
end Do_Get_Immediate_Character;
------------------------
@@ -628,7 +765,9 @@
procedure Do_Get_Line_String (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Get_Line_String: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Get_Line_String: done"));
end Do_Get_Line_String;
--------------------------
@@ -638,7 +777,9 @@
procedure Do_Get_Mouse_Pointer (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
+ pragma Debug (O ("Do_Get_Mouse_Pointer: begin"));
Current_Waited_Response := R_Mouse;
+ pragma Debug (O ("Do_Get_Mouse_Pointer: done"));
end Do_Get_Mouse_Pointer;
-------------------
@@ -648,7 +789,9 @@
procedure Do_Get_String (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Get_String: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Get_String: end"));
end Do_Get_String;
--------------
@@ -658,7 +801,9 @@
procedure Do_Image (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Image: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Image: done"));
end Do_Image;
----------------------
@@ -666,9 +811,14 @@
----------------------
procedure Do_Jump_With_End (Cmd : Command) is
- pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Jump_With_End: begin"));
+ Brush_X := Cmd.X_End;
+ Brush_Y := Cmd.Y_End;
+ pragma Debug (O ("Changed the virtual brush position to ("
+ & Brush_X'Img & ", "
+ & Brush_Y'Img & ")"));
+ pragma Debug (O ("Do_Jump_With_End: done"));
end Do_Jump_With_End;
-------------------------
@@ -676,9 +826,16 @@
-------------------------
procedure Do_Jump_With_Length (Cmd : Command) is
- pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O (""));
+
+ Brush_X := Brush_X + Cmd.Distance * Cos (Angle, 360.0);
+ Brush_X := Brush_Y + Cmd.Distance * Sin (Angle, 360.0);
+
+ pragma Debug (O ("Changed the virtual brush position to ("
+ & Brush_X'Img & ", "
+ & Brush_Y'Img & ")"));
+ pragma Debug (O (""));
end Do_Jump_With_Length;
-------------------
@@ -686,9 +843,12 @@
-------------------
procedure Do_Line_Color (Cmd : Command) is
- pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Line_Color: begin"));
+ Line_Color := Cmd.Color;
+ Set_Foreground (Graphic_Context, To_Gdk_Color (Line_Color));
+ pragma Debug (O ("Line color changed to " & Image (Line_Color)));
+ pragma Debug (O ("Do_Line_Color: done"));
end Do_Line_Color;
----------------------
@@ -696,9 +856,14 @@
----------------------
procedure Do_Line_With_End (Cmd : Command) is
- pragma Unreferenced (Cmd);
+ X_Start : constant Float := Brush_X;
+ Y_Start : constant Float := Brush_Y;
+ X_End : constant Float := Cmd.X_End;
+ Y_End : constant Float := Cmd.Y_End;
begin
- null;
+ pragma Debug (O ("Do_Line_With_End: begin"));
+ Draw_Line (X_Start, Y_Start, X_End, Y_End);
+ pragma Debug (O ("Do_Line_With_End: done"));
end Do_Line_With_End;
-------------------------
@@ -706,9 +871,14 @@
-------------------------
procedure Do_Line_With_Length (Cmd : Command) is
- pragma Unreferenced (Cmd);
+ X_Start : constant Float := Brush_X;
+ Y_Start : constant Float := Brush_Y;
+ X_End : constant Float := Brush_X + Cmd.Distance * Cos (Angle, 360.0);
+ Y_End : constant Float := Brush_Y + Cmd.Distance * Sin (Angle, 360.0);
begin
- null;
+ pragma Debug (O ("Do_Line_With_Length: begin"));
+ Draw_Line (X_Start, Y_Start, X_End, Y_End);
+ pragma Debug (O ("Do_Line_With_Length: done"));
end Do_Line_With_Length;
----------------------------
@@ -716,9 +886,14 @@
----------------------------
procedure Do_Line_With_Start_End (Cmd : Command) is
- pragma Unreferenced (Cmd);
+ X_Start : constant Float := Cmd.X_Start;
+ Y_Start : constant Float := Cmd.Y_Start;
+ X_End : constant Float := Cmd.X_End;
+ Y_End : constant Float := Cmd.X_End;
begin
- null;
+ pragma Debug (O ("Do_Line_With_Start_End: begin"));
+ Draw_Line (X_Start, Y_Start, X_End, Y_End);
+ pragma Debug (O ("Do_Line_With_Start_End: done"));
end Do_Line_With_Start_End;
-------------------------------
@@ -726,9 +901,16 @@
-------------------------------
procedure Do_Line_With_Start_Length (Cmd : Command) is
- pragma Unreferenced (Cmd);
+ X_Start : constant Float := Cmd.X_Start;
+ Y_Start : constant Float := Cmd.Y_Start;
+ X_End : constant Float := Cmd.X_Start
+ + Cmd.Distance * Cos (Angle, 360.0);
+ Y_End : constant Float := Cmd.Y_Start
+ + Cmd.Distance * Sin (Angle, 360.0);
begin
- null;
+ pragma Debug (O ("Do_Line_With_Start_End: begin"));
+ Draw_Line (X_Start, Y_Start, X_End, Y_End);
+ pragma Debug (O ("Do_Line_With_Start_End: done"));
end Do_Line_With_Start_Length;
-----------------
@@ -738,7 +920,9 @@
procedure Do_New_Line (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_New_Line: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_New_Line: done"));
end Do_New_Line;
----------------------
@@ -748,7 +932,9 @@
procedure Do_Put_Character (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Put_Character: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Put_Character: done"));
end Do_Put_Character;
---------------------------
@@ -758,7 +944,9 @@
procedure Do_Put_Line_Character (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Put_Line_Character: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Put_Line_Character: done"));
end Do_Put_Line_Character;
------------------------
@@ -768,7 +956,9 @@
procedure Do_Put_Line_String (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Put_Line_String: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Put_Line_String: done"));
end Do_Put_Line_String;
-------------------
@@ -778,7 +968,9 @@
procedure Do_Put_String (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Put_String: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Put_String: done"));
end Do_Put_String;
----------------
@@ -788,7 +980,10 @@
procedure Do_Rafresh (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Rafresh: begin"));
+ Draw (Drawing_Area);
+ -- FIXME: Rafresh text area?
+ pragma Debug (O ("Do_Rafresh: done"));
end Do_Rafresh;
---------------
@@ -796,9 +991,11 @@
---------------
procedure Do_Rotate (Cmd : Command) is
- pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Rotate"));
+ Angle := Angle + Cmd.Angle;
+ pragma Debug (O ("Modified the virtual brush angle to " & Angle'Img));
+ pragma Debug (O ("Do_Rotate"));
end Do_Rotate;
-------------
@@ -806,9 +1003,21 @@
-------------
procedure Do_Spot (Cmd : Command) is
- pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Spot: begin"));
+ Draw_Arc
+ (Pixmap,
+ Graphic_Context,
+ True,
+ Gint (Brush_X) - Gint (Cmd.Radius),
+ Height - Gint (Brush_Y) - Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 0,
+ 360 * 64);
+ pragma Debug (O ("Drawn a spot of radius" & Cmd.Radius'Img & " at "
+ & "(" & Brush_X'Img & ", " & Brush_Y'Img & ")"));
+ pragma Debug (O ("Do_Spot: done"));
end Do_Spot;
-------------
@@ -818,7 +1027,9 @@
procedure Do_Text (Cmd : Command) is
pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Text: begin"));
+ null; -- FIXME
+ pragma Debug (O ("Do_Text: done"));
end Do_Text;
------------------
@@ -826,11 +1037,45 @@
------------------
procedure Do_Thickness (Cmd : Command) is
- pragma Unreferenced (Cmd);
begin
- null;
+ pragma Debug (O ("Do_Thickness: begin"));
+ Thickness := Cmd.Thickness;
+ Set_Line_Attributes (GC => Graphic_Context,
+ Line_Width => Gint (Thickness),
+ Line_Style => Line_Solid, -- FIXME Factorize
+ Cap_Style => Cap_Round,
+ Join_Style => Join_Round);
+ pragma Debug (O ("Modified the virtual brush thickness to " &
+ Thickness'Img));
+ pragma Debug (O ("Do_Thickness: done"));
end Do_Thickness;
+ ---------------
+ -- Draw_Line --
+ ---------------
+
+ procedure Draw_Line
+ (X_Start : Float;
+ Y_Start : Float;
+ X_End : Float;
+ Y_End : Float)
+ is
+ begin
+ pragma Debug (O ("Draw_Line: begin"));
+
+ Draw_Line (Pixmap,
+ Graphic_Context,
+ Gint (X_Start),
+ Height - Gint (Y_Start),
+ Gint (X_End),
+ Height - Gint (Y_End));
+
+ pragma Debug (O ("Line drawn between"
+ & "(" & X_Start'Img & ", " & Y_Start'Img & ") and"
+ & "(" & X_End'Img & ", " & Y_End'Img & ")"));
+ pragma Debug (O ("Draw_Line: done"));
+ end Draw_Line;
+
------------------
-- Expose_Event --
------------------
@@ -842,7 +1087,7 @@
is
Area : constant Gdk_Rectangle := Get_Area (Event);
begin
- Ada.Text_IO.Put_Line ("expose");
+ pragma Debug (O ("Main window exposed: handling"));
-- Restore screen from backing store pixmap
@@ -865,6 +1110,10 @@
function Get return String is
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Get String : begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Get_String));
+ pragma Debug (O ("Get String : enqueued"));
+ -- FIXME Get response
return "";
end Get;
@@ -875,7 +1124,8 @@
function Get_Angle return Float is
begin
Assert_Main_Window_Exits;
- return 0.0;
+ pragma Debug (O ("Get_Angle : done"));
+ return Angle;
end Get_Angle;
--------------------
@@ -885,7 +1135,8 @@
function Get_Fill_Color return Color_Type is
begin
Assert_Main_Window_Exits;
- return Black;
+ pragma Debug (O ("Get_Fill_Color : done"));
+ return Fill_Color;
end Get_Fill_Color;
-------------------
@@ -896,6 +1147,10 @@
pragma Unreferenced (Item);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Get_Immediate : begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Get_Immediate_Character));
+ pragma Debug (O ("Get_Immediate : enqueued"));
+ -- FIXME Get response
end Get_Immediate;
--------------
@@ -905,6 +1160,10 @@
function Get_Line return String is
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Get_Line : begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Get_Line_String));
+ pragma Debug (O ("Get_Line : enqueued"));
+ -- FIXME Get response
return "";
end Get_Line;
@@ -915,7 +1174,8 @@
function Get_Line_Color return Color_Type is
begin
Assert_Main_Window_Exits;
- return Black;
+ pragma Debug (O ("Get_Line_Color : done"));
+ return Line_Color;
end Get_Line_Color;
-----------------------
@@ -930,7 +1190,9 @@
Rsp : Response;
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Get_Mouse_Pointer : begin"));
Command_Queue.Enqueue (Command'(Action => A_Get_Mouse_Pointer));
+ pragma Debug (O ("Get_Mouse_Pointer : enqueued, dequeueing response"));
Rsp := Response_Queue.Dequeue;
case Rsp.Rsp_Kind is
@@ -945,6 +1207,7 @@
when others =>
raise Program_Error;
end case;
+ pragma Debug (O ("Get_Mouse_Pointer : done"));
end Get_Mouse_Pointer;
------------------
@@ -952,9 +1215,12 @@
------------------
procedure Get_Position (X : out Float; Y : out Float) is
- pragma Unreferenced (X, Y);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Get_Position: begin"));
+ X := Brush_X;
+ Y := Brush_Y;
+ pragma Debug (O ("Get_Position: done"));
end Get_Position;
-------------------
@@ -964,9 +1230,41 @@
function Get_Thickness return Float is
begin
Assert_Main_Window_Exits;
- return 0.0;
+ pragma Debug (O ("Get_Thickness: done"));
+ return Thickness;
end Get_Thickness;
+ -----------
+ -- Image --
+ -----------
+
+ function Image (C : Color_Type) return String is
+ function Image (I : Guint16) return String;
+ -- Return the image of I without the heading space
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (I : Guint16) return String is
+ Img : constant String := Guint16'Image (I);
+ begin
+ if Img (Img'First) = ' ' then
+ return Img (Img'First + 1 .. Img'Last);
+ else
+ return Img;
+ end if;
+ end Image;
+
+ RGB_Col : constant RGB_Fields := RGB_Vals (C);
+
+ begin
+ return "("
+ & Image (RGB_Col.R) & ", "
+ & Image (RGB_Col.G) & ", "
+ & Image (RGB_Col.B) & ")";
+ end Image;
+
------------------
-- Insert_Image --
------------------
@@ -977,9 +1275,16 @@
X_Justification : X_Justification_Type := Center;
Y_Justification : Y_Justification_Type := Center)
is
- pragma Unreferenced (File_Name, Scale, X_Justification, Y_Justification);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Insert_Image : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Image,
+ X_Justify => X_Justification,
+ Y_Justify => Y_Justification,
+ File_Name => new String'(File_Name),
+ Scale => Scale));
+ pragma Debug (O ("Insert_Image : enqueued"));
end Insert_Image;
-----------------
@@ -992,9 +1297,16 @@
X_Justification : X_Justification_Type := Center;
Y_Justification : Y_Justification_Type := Center)
is
- pragma Unreferenced (Text, Size, X_Justification, Y_Justification);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Insert_Text : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Text,
+ X_Justify => X_Justification,
+ Y_Justify => Y_Justification,
+ Text => new String'(Text),
+ Size => Size));
+ pragma Debug (O ("Insert_Text : enqueued"));
end Insert_Text;
----------
@@ -1002,9 +1314,15 @@
----------
procedure Jump (Distance : Float) is
- pragma Unreferenced (Distance);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Jump with distance : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Jump_With_Length,
+ Distance => Distance,
+ X_Start => 0.0, -- Dummy
+ Y_Start => 0.0)); -- Dummy
+ pragma Debug (O ("Jump with distance : enqueued"));
end Jump;
----------
@@ -1012,9 +1330,16 @@
----------
procedure Jump (X : Float; Y : Float) is
- pragma Unreferenced (X, Y);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Jump with end : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Jump_With_End,
+ X_End => X,
+ Y_End => Y,
+ X_Start => 0.0, -- Dummy
+ Y_Start => 0.0)); -- Dummy
+ pragma Debug (O ("Jump with end : enqueued"));
end Jump;
----------
@@ -1022,9 +1347,15 @@
----------
procedure Line (Distance : Float) is
- pragma Unreferenced (Distance);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Line with length : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Line_With_Length,
+ Distance => Distance,
+ X_Start => 0.0, -- Dummy
+ Y_Start => 0.0)); -- Dummy
+ pragma Debug (O ("Line with length : enqueued"));
end Line;
----------
@@ -1032,9 +1363,16 @@
----------
procedure Line (X : Float; Y : Float) is
- pragma Unreferenced (X, Y);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Line with end : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Line_With_End,
+ X_End => X,
+ Y_End => Y,
+ X_Start => 0.0, -- Dummy
+ Y_Start => 0.0)); -- Dummy
+ pragma Debug (O ("Line with end : enqueued"));
end Line;
----------
@@ -1046,9 +1384,15 @@
Y_Start : Float;
Distance : Float)
is
- pragma Unreferenced (X_Start, Y_Start, Distance);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Line with start and length : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Line_With_Start_Length,
+ X_Start => X_Start,
+ Y_Start => Y_Start,
+ Distance => Distance));
+ pragma Debug (O ("Line with start and length : enqueued"));
end Line;
----------
@@ -1061,9 +1405,16 @@
X_End : Float;
Y_End : Float)
is
- pragma Unreferenced (X_Start, Y_Start, X_End, Y_End);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Line with start and end : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Line_With_Start_End,
+ X_Start => X_Start,
+ Y_Start => Y_Start,
+ X_End => X_End,
+ Y_End => Y_End));
+ pragma Debug (O ("Line with start and end : enqueued"));
end Line;
-- Dispatch table
@@ -1111,7 +1462,9 @@
Cmd := Command_Queue.Dequeue;
if Dispatch_Table (Cmd.Action) /= null then
+ pragma Debug (O (""));
Dispatch_Table (Cmd.Action).all (Cmd);
+ pragma Debug (O (""));
end if;
end if;
@@ -1130,6 +1483,9 @@
pragma Unreferenced (Spacing);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("New_Line : begin"));
+ -- FIXME
+ pragma Debug (O ("New_Line : enqueued"));
end New_Line;
---------
@@ -1140,6 +1496,9 @@
pragma Unreferenced (Item);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Put String : begin"));
+ -- FIXME
+ pragma Debug (O ("Put String : enqueued"));
end Put;
---------
@@ -1150,6 +1509,9 @@
pragma Unreferenced (Item);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Put Character : begin"));
+ -- FIXME
+ pragma Debug (O ("Put Character : enqueued"));
end Put;
--------------
@@ -1160,6 +1522,9 @@
pragma Unreferenced (Item);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Put_Line String : begin"));
+ -- FIXME
+ pragma Debug (O ("Put_Line String : enqueued"));
end Put_Line;
--------------
@@ -1170,6 +1535,9 @@
pragma Unreferenced (Item);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Put_Line Character : begin"));
+ -- FIXME
+ pragma Debug (O ("Put_Line Character : enqueued"));
end Put_Line;
----------
@@ -1180,6 +1548,7 @@
pragma Unreferenced (Window);
begin
Gtk.Main.Main_Quit;
+ pragma Debug (O (""));
end Quit;
-------------
@@ -1189,6 +1558,9 @@
procedure Rafresh is
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Rafresh : begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Rafresh));
+ pragma Debug (O ("Rafresh : enqueued"));
end Rafresh;
---------
@@ -1197,9 +1569,9 @@
function RGB (R : Integer; G : Integer; B : Integer) return Color_Type is
begin
- return Color_Type'(R => Single_Color (R mod 256),
- G => Single_Color (G mod 256),
- B => Single_Color (B mod 256));
+ -- FIXME
+ raise Program_Error with "Not Yet Implemented";
+ return 1;
end RGB;
------------
@@ -1207,9 +1579,13 @@
------------
procedure Rotate (Angle : Float) is
- pragma Unreferenced (Angle);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Rotate : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Rotate,
+ Angle => Angle));
+ pragma Debug (O ("Rotate : enqueued"));
end Rotate;
---------------
@@ -1217,9 +1593,13 @@
---------------
procedure Set_Angle (Angle : Float) is
- pragma Unreferenced (Angle);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Set_Angle : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Angle,
+ Angle => Angle));
+ pragma Debug (O ("Set_Angle : enqueued"));
end Set_Angle;
--------------------
@@ -1227,9 +1607,13 @@
--------------------
procedure Set_Fill_Color (C : Color_Type) is
- pragma Unreferenced (C);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Set_Fill_Color : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Fill_Color,
+ Color => C));
+ pragma Debug (O ("Set_Fill_Color : enqueued"));
end Set_Fill_Color;
--------------------
@@ -1237,9 +1621,13 @@
--------------------
procedure Set_Line_Color (C : Color_Type) is
- pragma Unreferenced (C);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Set_Line_Color : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Line_Color,
+ Color => C));
+ pragma Debug (O ("Set_Line_Color : enqueued"));
end Set_Line_Color;
------------------
@@ -1247,9 +1635,16 @@
------------------
procedure Set_Position (X : Float; Y : Float) is
- pragma Unreferenced (X, Y);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Set_Position : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Jump_With_End,
+ X_End => X,
+ Y_End => Y,
+ X_Start => 0.0, -- Dummy
+ Y_Start => 0.0)); -- Dummy
+ pragma Debug (O ("Set_Position : enqueued"));
end Set_Position;
-------------------
@@ -1257,9 +1652,13 @@
-------------------
procedure Set_Thickness (T : Float) is
- pragma Unreferenced (T);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Set_Thickness : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Thickness,
+ Thickness => T));
+ pragma Debug (O ("Set_Thickness : enqueued"));
end Set_Thickness;
----------
@@ -1267,9 +1666,22 @@
----------
procedure Spot (Radius : Float := 4.0) is
- pragma Unreferenced (Radius);
begin
Assert_Main_Window_Exits;
+ pragma Debug (O ("Spot : begin"));
+ Command_Queue.Enqueue (Command'
+ (Action => A_Spot,
+ Radius => Radius));
+ pragma Debug (O ("Spot : enqueued"));
end Spot;
+ ------------------
+ -- To_Gdk_Color --
+ ------------------
+
+ function To_Gdk_Color (C : Color_Type) return Gdk_Color is
+ begin
+ return Color_Table (Positive (C));
+ end To_Gdk_Color;
+
end Gtkada_Wrapper;
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-26 02:02:56 UTC (rev 12)
+++ trunk/src/gtkada_wrapper.ads 2006-11-26 20:30:23 UTC (rev 13)
@@ -216,30 +216,26 @@
-- Block until the user press a key. The value of the key is
-- stored in Item. The user does not need to press ENTER.
- -- FIXME: Maybe some I/O function for intergers, floats...
+ -- FIXME: Maybe some I/O function for integers, floats...
private
type Single_Color is mod 256;
- type Color_Type is record
- R : Single_Color;
- G : Single_Color;
- B : Single_Color;
- end record;
+ type Color_Type is new Positive;
- Black : constant Color_Type := (0, 0, 0);
- Red : constant Color_Type := (255, 0, 0);
- Green : constant Color_Type := (0, 255, 0);
- Yellow : constant Color_Type := (255, 255, 0);
- Blue : constant Color_Type := (0, 0, 255);
- Magenta : constant Color_Type := (255, 0, 255);
- Cyan : constant Color_Type := (0, 255, 255);
- Dark_Gray : constant Color_Type := (77, 77, 77);
- Orange : constant Color_Type := (255, 165, 0);
- Pink : constant Color_Type := (255, 192, 203);
- Gray : constant Color_Type := (127, 127, 127);
- Light_Gray : constant Color_Type := (179, 179, 179);
- White : constant Color_Type := (255, 255, 255);
+ Black : constant Color_Type := 1;
+ Red : constant Color_Type := 2;
+ Green : constant Color_Type := 3;
+ Yellow : constant Color_Type := 4;
+ Blue : constant Color_Type := 5;
+ Magenta : constant Color_Type := 6;
+ Cyan : constant Color_Type := 7;
+ Dark_Gray : constant Color_Type := 8;
+ Orange : constant Color_Type := 9;
+ Pink : constant Color_Type := 10;
+ Gray : constant Color_Type := 11;
+ Light_Gray : constant Color_Type := 12;
+ White : constant Color_Type := 13;
end Gtkada_Wrapper;
Modified: trunk/src/protected_queue.adb
===================================================================
--- trunk/src/protected_queue.adb 2006-11-26 02:02:56 UTC (rev 12)
+++ trunk/src/protected_queue.adb 2006-11-26 20:30:23 UTC (rev 13)
@@ -2,15 +2,12 @@
-- 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);
+ type Queue_Array_Type is array (1 .. Max_Length) of Element_Type;
-- The protected object that ensure concurrency safety
@@ -23,7 +20,18 @@
return Natural;
function Length return Natural;
+
procedure Clear;
+ private
+ -- The queue is coded as a circular array
+
+ The_Queue : Queue_Array_Type;
+
+ -- Circular array state
+
+ First : Natural := 1;
+ Last : Natural := 0;
+ N_Elements : Natural := 0;
end The_Protected_Queue;
protected body The_Protected_Queue is
@@ -33,9 +41,17 @@
-------------
entry Enqueue (Element : Element_Type)
- when The_Queue.Last < Max_Length is
+ when N_Elements < Max_Length is
begin
- The_Queue.Append (Element);
+ if Last = Max_Length then
+ Last := 1;
+ else
+ Last := Last + 1;
+ end if;
+
+ The_Queue (Last) := Element;
+
+ N_Elements := N_Elements + 1;
end Enqueue;
-------------
@@ -43,10 +59,17 @@
-------------
entry Dequeue (Element : out Element_Type)
- when The_Queue.Last > 0 is
+ when N_Elements > 0 is
begin
- Element := The_Queue.Table (The_Queue.Last);
- The_Queue.Decrement_Last;
+ Element := The_Queue (First);
+
+ if First = Max_Length then
+ First := 1;
+ else
+ First := First + 1;
+ end if;
+
+ N_Elements := N_Elements - 1;
end Dequeue;
--------------------
@@ -76,7 +99,7 @@
function Length return Natural is
begin
- return The_Queue.Last;
+ return N_Elements;
end Length;
-----------
@@ -85,8 +108,9 @@
procedure Clear is
begin
- The_Queue.Free;
- The_Queue.Init;
+ First := 1;
+ Last := 0;
+ N_Elements := 0;
end Clear;
end The_Protected_Queue;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
