[Gtkada-wrapper-devel] SF.net SVN: gtkada-wrapper: [22] trunk
Brought to you by:
bechir_zalila
Menu
▾
▴
[Gtkada-wrapper-devel] SF.net SVN: gtkada-wrapper: [22] trunk
|
From: <bec...@us...> - 2006-11-29 22:48:54
|
Revision: 22
http://svn.sourceforge.net/gtkada-wrapper/?rev=22&view=rev
Author: bechir_zalila
Date: 2006-11-29 14:48:53 -0800 (Wed, 29 Nov 2006)
Log Message:
-----------
* (configure.ac): Prepared the future use of static compiled GTKAda.
Removed obsolete warning.
* (TODO): Update
* (gtkada_wrapper.ad?): Replaced Line_Color and Fill_Color by a unique
variable The_Color since draw functions are different from fill
functions. Added some routine to draw/fill some popular forms:
circles, rectangles and polygons.
* (basic_drawings.adb): Test the new added routines.
Modified Paths:
--------------
trunk/TODO
trunk/configure.ac
trunk/examples/basic_drawings/basic_drawings.adb
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-28 20:50:50 UTC (rev 21)
+++ trunk/TODO 2006-11-29 22:48:53 UTC (rev 22)
@@ -1,6 +1,7 @@
/src:
- * Implement fill color
- * Implement forms
+ * Implement text display on the drawing area
+ * Implement a custom 'Spot'
+ * Implement image insertion
* Implement Text area
/doc:
Modified: trunk/configure.ac
===================================================================
--- trunk/configure.ac 2006-11-28 20:50:50 UTC (rev 21)
+++ trunk/configure.ac 2006-11-29 22:48:53 UTC (rev 22)
@@ -32,13 +32,15 @@
GTKADA_INCS=""
GTKADA_LIBS=""
GTKADA_FLAGS=""
+GTKADA_PROJECT=""
has_gtkada=no
AC_MSG_CHECKING([GTKAda])
if gtkada-config --help 2>&1 | ${GREP} '^Usage.*gtkada-config' > /dev/null 2>&1; then
GTKADA_INCS="`gtkada-config --cflags`"
GTKADA_LIBS="`gtkada-config --libs`"
- GTKADA_FLAGS=`gtkada-config`
+ GTKADA_FLAGS="`gtkada-config`"
+ GTKADA_PROJECT="`gtkada-config --prefix`/lib/gnat/gtkada.gpr"
has_gtkada=yes
else
has_gtkada=no
@@ -49,6 +51,7 @@
AC_SUBST(GTKADA_INCS)
AC_SUBST(GTKADA_LIBS)
AC_SUBST(GTKADA_FLAGS)
+AC_SUBST(GTKADA_PROJECT)
##########################################
# Check for maintainer (debug) mode.
@@ -79,10 +82,6 @@
# Output generated files
##########################################
-dnl Important! One file per line, nothing before
-dnl or after except whitespace! This section
-dnl is edited automatically by make_distrib.
-
AC_OUTPUT([
Makefile
doc/Makefile
Modified: trunk/examples/basic_drawings/basic_drawings.adb
===================================================================
--- trunk/examples/basic_drawings/basic_drawings.adb 2006-11-28 20:50:50 UTC (rev 21)
+++ trunk/examples/basic_drawings/basic_drawings.adb 2006-11-29 22:48:53 UTC (rev 22)
@@ -32,13 +32,12 @@
Set_Angle (0.0);
for I in Color_Array'Range loop
- Set_Line_Color (Color_Array (I));
+ Set_Color (Color_Array (I));
Line (100.0 + 10.0 * Float (I));
Rotate (45.0);
- Get_Mouse_Pointer (X, Y, Button);
end loop;
- Set_Line_Color (My_Color_1);
+ Set_Color (My_Color_1);
Jump (50.0, 50.0);
Spot (20.0);
@@ -47,20 +46,66 @@
Jump (100.0, 100.0);
Spot (10.0);
- Get_Mouse_Pointer (X, Y, Button);
-
- Set_Line_Color (My_Color_2);
+ Set_Color (My_Color_2);
Jump (100.0, 400.0);
Spot (10.0);
- Get_Mouse_Pointer (X, Y, Button);
-
- Set_Line_Color (My_Color_2);
+ Set_Color (My_Color_2);
Set_Thickness (8.0);
Line (100.0, 100.0, 200.0, 400.0);
Line (100.0, 100.0, 100.0, 400.0);
+ Set_Thickness (5.0);
+
Get_Mouse_Pointer (X, Y, Button);
+ Set_Color (Orange);
+ Draw_Circle (100.0);
+
+ Set_Color (Yellow);
+ Fill_Circle (100.0);
+
+ Set_Color (Orange);
+ Draw_Circle (300.0, 300.0, 100.0);
+
+ Set_Color (Red);
+ Fill_Circle (300.0, 300.0, 100.0);
+
+ Set_Color (Blue);
+ Draw_Rectangle (100.0, 100.0, 200.0, 50.0);
+
+ Set_Color (Magenta);
+ Fill_Rectangle (100.0, 100.0, 200.0, 50.0);
+
+ Set_Thickness (2.0);
+ Set_Color (Black);
+ Draw_Polygon ((0.0, 0.0,
+ 100.0, 100.0,
+ 200.0, 100.0,
+ 200.0, 200.0,
+ 100.0, 200.0));
+
+ Set_Color (White);
+ Fill_Polygon ((0.0, 0.0,
+ 100.0, 100.0,
+ 200.0, 100.0,
+ 200.0, 200.0,
+ 100.0, 200.0));
+
+ Set_Color (Cyan);
+ Draw_Polygon ((50.0, 300.0,
+ 300.0, 300.0,
+ 60.0, 60.0,
+ 175.0, 400.0,
+ 290.0, 60.0));
+
+ Set_Color (Green);
+ Fill_Polygon ((50.0, 300.0,
+ 300.0, 300.0,
+ 60.0, 60.0,
+ 175.0, 400.0,
+ 290.0, 60.0));
+
+ 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);
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-28 20:50:50 UTC (rev 21)
+++ trunk/src/gtkada_wrapper.adb 2006-11-29 22:48:53 UTC (rev 22)
@@ -96,8 +96,7 @@
Brush_Y : Float := 0.0;
Angle : Float := 0.0;
Thickness : Float := 1.0;
- Line_Color : Color_Type := Black;
- Fill_Color : Color_Type := White;
+ The_Color : Color_Type := Black;
-- Properties of the virtual brush
VBox : Gtk_Vbox;
@@ -154,8 +153,7 @@
A_Reset_Handler, -- For internal use
A_Destroy,
A_Clear_Drawing_Area,
- A_Line_Color,
- A_Fill_Color,
+ A_Color,
A_Thickness,
A_Angle,
A_Rotate,
@@ -165,6 +163,14 @@
A_Line_With_End,
A_Line_With_Start_Length,
A_Line_With_Start_End,
+ A_Draw_Circle_From_Current,
+ A_Draw_Circle_From_Custom,
+ A_Fill_Circle_From_Current,
+ A_Fill_Circle_From_Custom,
+ A_Draw_Rectangle,
+ A_Fill_Rectangle,
+ A_Draw_Polygon,
+ A_Fill_Polygon,
A_Spot,
A_Image,
A_Text,
@@ -184,6 +190,12 @@
procedure Free is new Unchecked_Deallocation (String, String_Ptr);
pragma Unreferenced (Free);
+ type Float_Array_Access is access all Float_Array;
+ -- To be able to have a record of unconstrained type
+
+ procedure Free is new Unchecked_Deallocation
+ (Float_Array, Float_Array_Access);
+
-- The command data
type Command (Action : Action_Kind := A_None) is record
@@ -200,7 +212,7 @@
| A_Get_Immediate_Character =>
null;
- when A_Line_Color | A_Fill_Color =>
+ when A_Color =>
Color : Color_Type;
when A_Thickness =>
@@ -240,9 +252,24 @@
null;
end case;
- when A_Spot =>
+ when A_Spot
+ | A_Draw_Circle_From_Current
+ | A_Draw_Circle_From_Custom
+ | A_Fill_Circle_From_Current
+ | A_Fill_Circle_From_Custom =>
+
Radius : Float;
+ case Action is
+ when A_Draw_Circle_From_Custom
+ | A_Fill_Circle_From_Custom =>
+ Center_X : Float;
+ Center_Y : Float;
+
+ when others =>
+ null;
+ end case;
+
when A_Image | A_Text =>
X_Justify : X_Justification_Type;
Y_Justify : Y_Justification_Type;
@@ -260,6 +287,18 @@
null;
end case;
+ when A_Draw_Rectangle
+ | A_Fill_Rectangle =>
+
+ First_X : Float;
+ First_Y : Float;
+ Width : Float;
+ Height : Float;
+
+ when A_Draw_Polygon
+ | A_Fill_Polygon =>
+ Edges : Float_Array_Access;
+
when A_New_Line =>
N_Lines : Positive;
@@ -273,68 +312,82 @@
-- For each action, we declare a subprogram that does the job
- procedure Do_Destroy (Cmd : Command);
- procedure Do_Clear_Drawing_Area (Cmd : Command);
- procedure Do_Line_Color (Cmd : Command);
- procedure Do_Fill_Color (Cmd : Command);
- procedure Do_Thickness (Cmd : Command);
- procedure Do_Angle (Cmd : Command);
- procedure Do_Rotate (Cmd : Command);
- procedure Do_Jump_With_Length (Cmd : Command);
- procedure Do_Jump_With_End (Cmd : Command);
- procedure Do_Line_With_Length (Cmd : Command);
- procedure Do_Line_With_End (Cmd : Command);
- procedure Do_Line_With_Start_Length (Cmd : Command);
- procedure Do_Line_With_Start_End (Cmd : Command);
- procedure Do_Spot (Cmd : Command);
- procedure Do_Image (Cmd : Command);
- procedure Do_Text (Cmd : Command);
- procedure Do_Rafresh (Cmd : Command);
- procedure Do_Get_Mouse_Pointer (Cmd : Command);
- procedure Do_Clear_Text_Area (Cmd : Command);
- procedure Do_Put_String (Cmd : Command);
- procedure Do_Put_Character (Cmd : Command);
- procedure Do_New_Line (Cmd : Command);
- procedure Do_Put_Line_String (Cmd : Command);
- procedure Do_Put_Line_Character (Cmd : Command);
- procedure Do_Get_String (Cmd : Command);
- procedure Do_Get_Line_String (Cmd : Command);
- procedure Do_Get_Immediate_Character (Cmd : Command);
+ procedure Do_Destroy (Cmd : in out Command);
+ procedure Do_Clear_Drawing_Area (Cmd : in out Command);
+ procedure Do_Color (Cmd : in out Command);
+ procedure Do_Thickness (Cmd : in out Command);
+ procedure Do_Angle (Cmd : in out Command);
+ procedure Do_Rotate (Cmd : in out Command);
+ procedure Do_Jump_With_Length (Cmd : in out Command);
+ procedure Do_Jump_With_End (Cmd : in out Command);
+ procedure Do_Line_With_Length (Cmd : in out Command);
+ procedure Do_Line_With_End (Cmd : in out Command);
+ procedure Do_Line_With_Start_Length (Cmd : in out Command);
+ procedure Do_Line_With_Start_End (Cmd : in out Command);
+ procedure Do_Draw_Circle_From_Current (Cmd : in out Command);
+ procedure Do_Draw_Circle_From_Custom (Cmd : in out Command);
+ procedure Do_Fill_Circle_From_Current (Cmd : in out Command);
+ procedure Do_Fill_Circle_From_Custom (Cmd : in out Command);
+ procedure Do_Draw_Rectangle (Cmd : in out Command);
+ procedure Do_Fill_Rectangle (Cmd : in out Command);
+ procedure Do_Draw_Polygon (Cmd : in out Command);
+ procedure Do_Fill_Polygon (Cmd : in out Command);
+ procedure Do_Spot (Cmd : in out Command);
+ procedure Do_Image (Cmd : in out Command);
+ procedure Do_Text (Cmd : in out Command);
+ procedure Do_Rafresh (Cmd : in out Command);
+ procedure Do_Get_Mouse_Pointer (Cmd : in out Command);
+ procedure Do_Clear_Text_Area (Cmd : in out Command);
+ procedure Do_Put_String (Cmd : in out Command);
+ procedure Do_Put_Character (Cmd : in out Command);
+ procedure Do_New_Line (Cmd : in out Command);
+ procedure Do_Put_Line_String (Cmd : in out Command);
+ procedure Do_Put_Line_Character (Cmd : in out Command);
+ procedure Do_Get_String (Cmd : in out Command);
+ procedure Do_Get_Line_String (Cmd : in out Command);
+ procedure Do_Get_Immediate_Character (Cmd : in out Command);
-- Dispatch table
- type Command_Proc_Type is access procedure (Cmd : Command);
+ type Command_Proc_Type is access procedure (Cmd : in out 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);
+ (A_Angle => Do_Angle'Access,
+ A_Clear_Drawing_Area => Do_Clear_Drawing_Area'Access,
+ A_Clear_Text_Area => Do_Clear_Text_Area'Access,
+ A_Color => Do_Color'Access,
+ A_Destroy => Do_Destroy'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_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_Draw_Circle_From_Current => Do_Draw_Circle_From_Current'Access,
+ A_Draw_Circle_From_Custom => Do_Draw_Circle_From_Custom'Access,
+ A_Fill_Circle_From_Current => Do_Fill_Circle_From_Current'Access,
+ A_Fill_Circle_From_Custom => Do_Fill_Circle_From_Custom'Access,
+ A_Draw_Rectangle => Do_Draw_Rectangle'Access,
+ A_Fill_Rectangle => Do_Fill_Rectangle'Access,
+ A_Draw_Polygon => Do_Draw_Polygon'Access,
+ A_Fill_Polygon => Do_Fill_Polygon'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
@@ -507,8 +560,9 @@
Allocate_Colors;
- Set_Foreground (Graphic_Context, To_Gdk_Color (Line_Color));
- Set_Background (Graphic_Context, To_Gdk_Color (Fill_Color));
+ -- Set the current color
+
+ Set_Foreground (Graphic_Context, To_Gdk_Color (The_Color));
end if;
-- Initialize the event handler task
@@ -826,7 +880,7 @@
-- Do_Angle --
--------------
- procedure Do_Angle (Cmd : Command) is
+ procedure Do_Angle (Cmd : in out Command) is
begin
pragma Debug (O ("Do_Angle : begin"));
Angle := Cmd.Angle;
@@ -837,7 +891,7 @@
-- Do_Clear_Drawing_Area --
---------------------------
- procedure Do_Clear_Drawing_Area (Cmd : Command) is
+ procedure Do_Clear_Drawing_Area (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Clear_Drawing_Area: begin"));
@@ -869,7 +923,7 @@
-- Do_Clear_Text_Area --
------------------------
- procedure Do_Clear_Text_Area (Cmd : Command) is
+ procedure Do_Clear_Text_Area (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Text_Drawing_Area: begin"));
@@ -877,11 +931,25 @@
pragma Debug (O ("Do_Text_Drawing_Area: done"));
end Do_Clear_Text_Area;
+ --------------
+ -- Do_Color --
+ --------------
+
+ procedure Do_Color (Cmd : in out Command) is
+ begin
+ pragma Debug (O ("Do_Color: begin"));
+ The_Color := Cmd.Color;
+ Set_Foreground (Graphic_Context, To_Gdk_Color (The_Color));
+ pragma Debug (O ("Color changed to "
+ & To_String (Color_Table.Table (The_Color))));
+ pragma Debug (O ("Do_Color: done"));
+ end Do_Color;
+
----------------
-- Do_Destroy --
----------------
- procedure Do_Destroy (Cmd : Command) is
+ procedure Do_Destroy (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Destroy: begin"));
@@ -889,25 +957,288 @@
pragma Debug (O ("Do_Destroy: done"));
end Do_Destroy;
- -------------------
- -- Do_Fill_Color --
- -------------------
+ ---------------------------------
+ -- Do_Draw_Circle_From_Current --
+ ---------------------------------
- procedure Do_Fill_Color (Cmd : Command) is
+ procedure Do_Draw_Circle_From_Current (Cmd : in out Command) is
begin
- 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" &
- To_String (Color_Table.Table (Fill_Color))));
- pragma Debug (O ("Do_Fill_Color: end"));
- end Do_Fill_Color;
+ pragma Debug (O ("Do_Draw_Circle_From_Current: begin"));
+ Draw_Arc
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ False,
+ Gint (Brush_X) - Gint (Cmd.Radius),
+ Height - Gint (Brush_Y) - Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 0,
+ 360 * 64);
+ -- Backup
+
+ Draw_Arc
+ (Pixmap,
+ Graphic_Context,
+ False,
+ 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 ("Do_Draw_Circle_From_Current: done"));
+ end Do_Draw_Circle_From_Current;
+
--------------------------------
+ -- Do_Draw_Circle_From_Custom --
+ --------------------------------
+
+ procedure Do_Draw_Circle_From_Custom (Cmd : in out Command) is
+ begin
+ pragma Debug (O ("Do_Draw_Circle_From_Custom: begin"));
+ Draw_Arc
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ False,
+ Gint (Cmd.Center_X) - Gint (Cmd.Radius),
+ Height - Gint (Cmd.Center_Y) - Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 0,
+ 360 * 64);
+
+ -- Backup
+
+ Draw_Arc
+ (Pixmap,
+ Graphic_Context,
+ False,
+ Gint (Cmd.Center_X) - Gint (Cmd.Radius),
+ Height - Gint (Cmd.Center_Y) - Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 0,
+ 360 * 64);
+ pragma Debug (O ("Do_Draw_Circle_From_Custom: done"));
+ end Do_Draw_Circle_From_Custom;
+
+ ---------------------
+ -- Do_Draw_Polygon --
+ ---------------------
+
+ procedure Do_Draw_Polygon (Cmd : in out Command) is
+ Points : Gdk_Points_Array (1 .. Cmd.Edges'Length / 2);
+ Index : Positive;
+ -- To be array index safe and to avoid multiplications
+ begin
+ pragma Debug (O ("Do_Draw_Polygon: begin"));
+ pragma Debug (O ("Do_Draw_Polygon: Number of edges = "
+ & Points'Length'Img));
+
+ -- Fill the polygon edges
+
+ Index := Cmd.Edges'First;
+
+ for I in Points'Range loop
+ Points (I) := (Gint (Cmd.Edges (Index)),
+ Height - Gint (Cmd.Edges (Index + 1)));
+ Index := Index + 2;
+ end loop;
+
+ Draw_Polygon
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ False,
+ Points);
+
+ -- Backup
+
+ Draw_Polygon
+ (Pixmap,
+ Graphic_Context,
+ False,
+ Points);
+
+ -- Deallocate the dynamic array
+
+ Free (Cmd.Edges);
+ pragma Debug (O ("Do_Draw_Polygon: done"));
+ end Do_Draw_Polygon;
+
+ -----------------------
+ -- Do_Draw_Rectangle --
+ -----------------------
+
+ procedure Do_Draw_Rectangle (Cmd : in out Command) is
+ begin
+ pragma Debug (O ("Do_Draw_Rectangle: begin"));
+ Draw_Rectangle
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ False,
+ Gint (Cmd.First_X),
+ Height - Gint (Cmd.First_Y + Cmd.Height),
+ Gint (Cmd.Width),
+ Gint (Cmd.Height));
+
+ -- Backup
+
+ Draw_Rectangle
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ False,
+ Gint (Cmd.First_X),
+ Height - Gint (Cmd.First_Y + Cmd.Height),
+ Gint (Cmd.Width),
+ Gint (Cmd.Height));
+ pragma Debug (O ("Do_Draw_Rectangle: done"));
+ end Do_Draw_Rectangle;
+
+ ---------------------------------
+ -- Do_Fill_Circle_From_Current --
+ ---------------------------------
+
+ procedure Do_Fill_Circle_From_Current (Cmd : in out Command) is
+ begin
+ pragma Debug (O ("Do_Fill_Circle_From_Current: begin"));
+ Draw_Arc
+ (Get_Window (Drawing_Area),
+ 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);
+
+ -- Backup
+
+ 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 ("Do_Fill_Circle_From_Current: done"));
+ end Do_Fill_Circle_From_Current;
+
+ --------------------------------
+ -- Do_Fill_Circle_From_Custom --
+ --------------------------------
+
+ procedure Do_Fill_Circle_From_Custom (Cmd : in out Command) is
+ begin
+ pragma Debug (O ("Do_Fill_Circle_From_Custom: begin"));
+ Draw_Arc
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ True,
+ Gint (Cmd.Center_X) - Gint (Cmd.Radius),
+ Height - Gint (Cmd.Center_Y) - Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 0,
+ 360 * 64);
+
+ -- Backup
+
+ Draw_Arc
+ (Pixmap,
+ Graphic_Context,
+ True,
+ Gint (Cmd.Center_X) - Gint (Cmd.Radius),
+ Height - Gint (Cmd.Center_Y) - Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 2 * Gint (Cmd.Radius),
+ 0,
+ 360 * 64);
+ pragma Debug (O ("Do_Fill_Circle_From_Custom: done"));
+ end Do_Fill_Circle_From_Custom;
+
+ ---------------------
+ -- Do_Fill_Polygon --
+ ---------------------
+
+ procedure Do_Fill_Polygon (Cmd : in out Command) is
+ Points : Gdk_Points_Array (1 .. Cmd.Edges'Length / 2);
+ Index : Positive;
+ -- To be array index safe and to avoid multiplications
+ begin
+ pragma Debug (O ("Do_Fill_Polygon: begin"));
+ pragma Debug (O ("Do_Draw_Polygon: Number of edges = "
+ & Points'Length'Img));
+
+ -- Fill the polygon edges
+
+ Index := Cmd.Edges'First;
+
+ for I in Points'Range loop
+ Points (I) := (Gint (Cmd.Edges (Index)),
+ Height - Gint (Cmd.Edges (Index + 1)));
+ Index := Index + 2;
+ end loop;
+
+ Draw_Polygon
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ True,
+ Points);
+
+ -- Backup
+
+ Draw_Polygon
+ (Pixmap,
+ Graphic_Context,
+ True,
+ Points);
+
+ -- Deallocate the dynamic array
+
+ Free (Cmd.Edges);
+ pragma Debug (O ("Do_Fill_Polygon: done"));
+ end Do_Fill_Polygon;
+
+ -----------------------
+ -- Do_Fill_Rectangle --
+ -----------------------
+
+ procedure Do_Fill_Rectangle (Cmd : in out Command) is
+ begin
+ pragma Debug (O ("Do_Fill_Rectangle: begin"));
+ Draw_Rectangle
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ True,
+ Gint (Cmd.First_X),
+ Height - Gint (Cmd.First_Y + Cmd.Height),
+ Gint (Cmd.Width),
+ Gint (Cmd.Height));
+
+ -- Backup
+
+ Draw_Rectangle
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ True,
+ Gint (Cmd.First_X),
+ Height - Gint (Cmd.First_Y + Cmd.Height),
+ Gint (Cmd.Width),
+ Gint (Cmd.Height));
+ pragma Debug (O ("Do_Draw_Rectangle: done"));
+ pragma Debug (O ("Do_Fill_Rectangle: done"));
+ end Do_Fill_Rectangle;
+
+ --------------------------------
-- Do_Get_Immediate_Character --
--------------------------------
- procedure Do_Get_Immediate_Character (Cmd : Command) is
+ procedure Do_Get_Immediate_Character (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Get_Immediate_Character: begin"));
@@ -919,7 +1250,7 @@
-- Do_Get_Line_String --
------------------------
- procedure Do_Get_Line_String (Cmd : Command) is
+ procedure Do_Get_Line_String (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Get_Line_String: begin"));
@@ -931,7 +1262,7 @@
-- Do_Get_Mouse_Pointer --
--------------------------
- procedure Do_Get_Mouse_Pointer (Cmd : Command) is
+ procedure Do_Get_Mouse_Pointer (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Get_Mouse_Pointer: begin"));
@@ -943,7 +1274,7 @@
-- Do_Get_String --
-------------------
- procedure Do_Get_String (Cmd : Command) is
+ procedure Do_Get_String (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Get_String: begin"));
@@ -955,7 +1286,7 @@
-- Do_Image --
--------------
- procedure Do_Image (Cmd : Command) is
+ procedure Do_Image (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Image: begin"));
@@ -967,7 +1298,7 @@
-- Do_Jump_With_End --
----------------------
- procedure Do_Jump_With_End (Cmd : Command) is
+ procedure Do_Jump_With_End (Cmd : in out Command) is
begin
pragma Debug (O ("Do_Jump_With_End: begin"));
Brush_X := Cmd.X_End;
@@ -982,7 +1313,7 @@
-- Do_Jump_With_Length --
-------------------------
- procedure Do_Jump_With_Length (Cmd : Command) is
+ procedure Do_Jump_With_Length (Cmd : in out Command) is
begin
pragma Debug (O ("Do_Jump_With_Length: begin"));
@@ -995,25 +1326,11 @@
pragma Debug (O ("Do_Jump_With_Length: done"));
end Do_Jump_With_Length;
- -------------------
- -- Do_Line_Color --
- -------------------
-
- procedure Do_Line_Color (Cmd : Command) is
- begin
- 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 "
- & To_String (Color_Table.Table (Line_Color))));
- pragma Debug (O ("Do_Line_Color: done"));
- end Do_Line_Color;
-
----------------------
-- Do_Line_With_End --
----------------------
- procedure Do_Line_With_End (Cmd : Command) is
+ procedure Do_Line_With_End (Cmd : in out Command) is
X_Start : constant Float := Brush_X;
Y_Start : constant Float := Brush_Y;
X_End : constant Float := Cmd.X_End;
@@ -1028,7 +1345,7 @@
-- Do_Line_With_Length --
-------------------------
- procedure Do_Line_With_Length (Cmd : Command) is
+ procedure Do_Line_With_Length (Cmd : in out Command) is
X_Start : constant Float := Brush_X;
Y_Start : constant Float := Brush_Y;
X_End : constant Float := Brush_X + Cmd.Distance * Cos (Angle, 360.0);
@@ -1043,7 +1360,7 @@
-- Do_Line_With_Start_End --
----------------------------
- procedure Do_Line_With_Start_End (Cmd : Command) is
+ procedure Do_Line_With_Start_End (Cmd : in out Command) is
X_Start : constant Float := Cmd.X_Start;
Y_Start : constant Float := Cmd.Y_Start;
X_End : constant Float := Cmd.X_End;
@@ -1058,7 +1375,7 @@
-- Do_Line_With_Start_Length --
-------------------------------
- procedure Do_Line_With_Start_Length (Cmd : Command) is
+ procedure Do_Line_With_Start_Length (Cmd : in out Command) is
X_Start : constant Float := Cmd.X_Start;
Y_Start : constant Float := Cmd.Y_Start;
X_End : constant Float := Cmd.X_Start
@@ -1075,7 +1392,7 @@
-- Do_New_Line --
-----------------
- procedure Do_New_Line (Cmd : Command) is
+ procedure Do_New_Line (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_New_Line: begin"));
@@ -1087,7 +1404,7 @@
-- Do_Put_Character --
----------------------
- procedure Do_Put_Character (Cmd : Command) is
+ procedure Do_Put_Character (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Put_Character: begin"));
@@ -1099,7 +1416,7 @@
-- Do_Put_Line_Character --
---------------------------
- procedure Do_Put_Line_Character (Cmd : Command) is
+ procedure Do_Put_Line_Character (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Put_Line_Character: begin"));
@@ -1111,7 +1428,7 @@
-- Do_Put_Line_String --
------------------------
- procedure Do_Put_Line_String (Cmd : Command) is
+ procedure Do_Put_Line_String (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Put_Line_String: begin"));
@@ -1123,7 +1440,7 @@
-- Do_Put_String --
-------------------
- procedure Do_Put_String (Cmd : Command) is
+ procedure Do_Put_String (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Put_String: begin"));
@@ -1135,7 +1452,7 @@
-- Do_Rafresh --
----------------
- procedure Do_Rafresh (Cmd : Command) is
+ procedure Do_Rafresh (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Rafresh: begin"));
@@ -1148,7 +1465,7 @@
-- Do_Rotate --
---------------
- procedure Do_Rotate (Cmd : Command) is
+ procedure Do_Rotate (Cmd : in out Command) is
begin
pragma Debug (O ("Do_Rotate"));
Angle := Angle + Cmd.Angle;
@@ -1160,7 +1477,7 @@
-- Do_Spot --
-------------
- procedure Do_Spot (Cmd : Command) is
+ procedure Do_Spot (Cmd : in out Command) is
begin
pragma Debug (O ("Do_Spot: begin"));
@@ -1197,7 +1514,7 @@
-- Do_Text --
-------------
- procedure Do_Text (Cmd : Command) is
+ procedure Do_Text (Cmd : in out Command) is
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Text: begin"));
@@ -1209,7 +1526,7 @@
-- Do_Thickness --
------------------
- procedure Do_Thickness (Cmd : Command) is
+ procedure Do_Thickness (Cmd : in out Command) is
begin
pragma Debug (O ("Do_Thickness: begin"));
Thickness := Cmd.Thickness;
@@ -1223,6 +1540,35 @@
pragma Debug (O ("Do_Thickness: done"));
end Do_Thickness;
+ -----------------
+ -- Draw_Circle --
+ -----------------
+
+ procedure Draw_Circle (Radius : Float) is
+ begin
+ pragma Debug (O ("Draw_Circle: begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Draw_Circle_From_Current,
+ Radius => Radius));
+ pragma Debug (O ("Draw_Circle: enqueued"));
+ end Draw_Circle;
+
+ -----------------
+ -- Draw_Circle --
+ -----------------
+
+ procedure Draw_Circle
+ (Center_X : Float;
+ Center_Y : Float;
+ Radius : Float) is
+ begin
+ pragma Debug (O ("Draw_Circle: begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Draw_Circle_From_Custom,
+ Radius => Radius,
+ Center_X => Center_X,
+ Center_Y => Center_Y));
+ pragma Debug (O ("Draw_Circle: enqueued"));
+ end Draw_Circle;
+
---------------
-- Draw_Line --
---------------
@@ -1259,6 +1605,44 @@
end Draw_Line;
------------------
+ -- Draw_Polygon --
+ ------------------
+
+ procedure Draw_Polygon (Edges : Float_Array) is
+ Given_Edges : Float_Array_Access := new Float_Array'(Edges);
+ begin
+ pragma Debug (O ("Draw_Polygon: begin"));
+
+ if Edges'Length mod 2 /= 0 then
+ Free (Given_Edges);
+ raise Constraint_Error with "You must give an even number of Float";
+ end if;
+
+ Command_Queue.Enqueue (Command'(Action => A_Draw_Polygon,
+ Edges => Given_Edges));
+ pragma Debug (O ("Draw_Polygon: enqueued"));
+ end Draw_Polygon;
+
+ --------------------
+ -- Draw_Rectangle --
+ --------------------
+
+ procedure Draw_Rectangle
+ (First_X : Float;
+ First_Y : Float;
+ Width : Float;
+ Height : Float) is
+ begin
+ pragma Debug (O ("Draw_Rectangle: begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Draw_Rectangle,
+ First_X => First_X,
+ First_Y => First_Y,
+ Width => Width,
+ Height => Height));
+ pragma Debug (O ("Draw_Rectangle: enqueued"));
+ end Draw_Rectangle;
+
+ ------------------
-- Expose_Event --
------------------
@@ -1286,6 +1670,73 @@
return True;
end Expose_Event;
+ -----------------
+ -- Fill_Circle --
+ -----------------
+
+ procedure Fill_Circle (Radius : Float) is
+ begin
+ pragma Debug (O ("Fill_Circle: begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Fill_Circle_From_Current,
+ Radius => Radius));
+ pragma Debug (O ("Fill_Circle: enqueued"));
+ end Fill_Circle;
+
+ -----------------
+ -- Fill_Circle --
+ -----------------
+
+ procedure Fill_Circle
+ (Center_X : Float;
+ Center_Y : Float;
+ Radius : Float) is
+ begin
+ pragma Debug (O ("Fill_Circle: begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Fill_Circle_From_Custom,
+ Radius => Radius,
+ Center_X => Center_X,
+ Center_Y => Center_Y));
+ pragma Debug (O ("Fill_Circle: enqueued"));
+ end Fill_Circle;
+
+ ------------------
+ -- Fill_Polygon --
+ ------------------
+
+ procedure Fill_Polygon (Edges : Float_Array) is
+ Given_Edges : Float_Array_Access := new Float_Array'(Edges);
+ begin
+ pragma Debug (O ("Fill_Polygon: begin"));
+
+ if Edges'Length mod 2 /= 0 then
+ Free (Given_Edges);
+ raise Constraint_Error with "You must give an even number of Float";
+ end if;
+
+ Command_Queue.Enqueue (Command'(Action => A_Fill_Polygon,
+ Edges => Given_Edges));
+ pragma Debug (O ("Fill_Polygon: enqueued"));
+ end Fill_Polygon;
+
+ --------------------
+ -- Fill_Rectangle --
+ --------------------
+
+ procedure Fill_Rectangle
+ (First_X : Float;
+ First_Y : Float;
+ Width : Float;
+ Height : Float) is
+ begin
+ pragma Debug (O ("Fill_Rectangle: begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Fill_Rectangle,
+ First_X => First_X,
+ First_Y => First_Y,
+ Width => Width,
+ Height => Height));
+ pragma Debug (O ("Fill_Rectangle: enqueued"));
+ end Fill_Rectangle;
+
---------
-- Get --
---------
@@ -1311,17 +1762,6 @@
return Angle;
end Get_Angle;
- --------------------
- -- Get_Fill_Color --
- --------------------
-
- function Get_Fill_Color return Color_Type is
- begin
- Assert_Main_Window_Exits;
- pragma Debug (O ("Get_Fill_Color : done"));
- return Fill_Color;
- end Get_Fill_Color;
-
-------------------
-- Get_Immediate --
-------------------
@@ -1350,16 +1790,16 @@
return "";
end Get_Line;
- --------------------
- -- Get_Line_Color --
- --------------------
+ ---------------
+ -- Get_Color --
+ ---------------
- function Get_Line_Color return Color_Type is
+ function Get_Color return Color_Type is
begin
Assert_Main_Window_Exits;
pragma Debug (O ("Get_Line_Color : done"));
- return Line_Color;
- end Get_Line_Color;
+ return The_Color;
+ end Get_Color;
-----------------------
-- Get_Mouse_Pointer --
@@ -1726,33 +2166,19 @@
pragma Debug (O ("Set_Angle : enqueued"));
end Set_Angle;
- --------------------
- -- Set_Fill_Color --
- --------------------
+ ---------------
+ -- Set_Color --
+ ---------------
- procedure Set_Fill_Color (C : Color_Type) is
+ procedure Set_Color (C : Color_Type) is
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;
-
- --------------------
- -- Set_Line_Color --
- --------------------
-
- procedure Set_Line_Color (C : Color_Type) is
- begin
- Assert_Main_Window_Exits;
pragma Debug (O ("Set_Line_Color : begin"));
Command_Queue.Enqueue (Command'
- (Action => A_Line_Color,
+ (Action => A_Color,
Color => C));
pragma Debug (O ("Set_Line_Color : enqueued"));
- end Set_Line_Color;
+ end Set_Color;
------------------
-- Set_Position --
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-28 20:50:50 UTC (rev 21)
+++ trunk/src/gtkada_wrapper.ads 2006-11-29 22:48:53 UTC (rev 22)
@@ -80,20 +80,12 @@
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
+ procedure Set_Color (C : Color_Type);
+ -- Set the color of the virtual brush to C
- function Get_Line_Color return Color_Type;
- -- Return the Current line color of the virtual brush
+ function Get_Color return Color_Type;
+ -- Return the Current color of the virtual brush
- procedure Set_Fill_Color (C : Color_Type);
- -- Set the fill color of the virtual brush to C. The fill
- -- color is the color of the inside part of closed drawn forms
- -- (circles, square...).
-
- function Get_Fill_Color return Color_Type;
- -- Return the Current fill color of the virtual brush
-
procedure Set_Thickness (T : Float);
-- Set the thickness of the virtual brush to T
@@ -174,8 +166,56 @@
-- Draw a text string justified at the virtual brush's current
-- location. The size is expressed in points.
- -- FIXME: Add routines for predefined forms (circle, square...)
+ procedure Draw_Circle (Radius : Float);
+ -- Draw a circle with radius 'Radius' and with the center at the
+ -- current position of the virtual brush.
+ procedure Draw_Circle
+ (Center_X : Float;
+ Center_Y : Float;
+ Radius : Float);
+ -- Same as above but the position of the center is given
+
+ procedure Fill_Circle (Radius : Float);
+ -- Fill a circle with radius 'Radius' and with the center at the
+ -- current position of the virtual brush. Note that the actual
+ -- radius of the filled circle is 'Radius' minus 1 pixel.
+
+ procedure Fill_Circle
+ (Center_X : Float;
+ Center_Y : Float;
+ Radius : Float);
+ -- Same as above but the position of the center is given
+
+ procedure Draw_Rectangle
+ (First_X : Float;
+ First_Y : Float;
+ Width : Float;
+ Height : Float);
+ -- Draw a rectangle having the specified bottom left edge
+
+ procedure Fill_Rectangle
+ (First_X : Float;
+ First_Y : Float;
+ Width : Float;
+ Height : Float);
+ -- Fill a rectangle having the specified bottom left edge
+ -- edges. Note that the actual sizes of the filled rectangle is
+ -- reduced by 1 pixel.
+
+ type Float_Array is array (Positive range <>) of Float;
+ -- An array of Float. Must be instantiated with tha actual size
+
+ procedure Draw_Polygon (Edges : Float_Array);
+ -- Draw a polygon by linking the given edges. The array must be in
+ -- the form (X1, Y1, X2, Y2..., Xn, Yn). There fore its length
+ -- must be even. If the length of 'Edges' is odd, raise
+ -- Constraint_Error.
+
+ procedure Fill_Polygon (Edges : Float_Array);
+ -- Fill a polygon as it would have been drawn by the subprogram
+ -- above.
+
procedure Rafresh;
-- Redraw the drawing area
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
