gtkada-wrapper-devel Mailing List for GTK Ada Simplified Wrapper
Brought to you by:
bechir_zalila
Menu
▾
▴
gtkada-wrapper-devel — GTKAda Wrapper development list
You can subscribe to this list here.
| 2006 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(23) |
Dec
(7) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2007 |
Jan
(1) |
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: <bec...@us...> - 2007-01-11 15:02:52
|
Revision: 32
http://svn.sourceforge.net/gtkada-wrapper/?rev=32&view=rev
Author: bechir_zalila
Date: 2007-01-11 06:50:55 -0800 (Thu, 11 Jan 2007)
Log Message:
-----------
* Added missing Makefile.am
* Doc fix
Modified Paths:
--------------
trunk/doc/gtkada_wrapper.texi
trunk/src/gtkada_wrapper.ads
Added Paths:
-----------
trunk/support/Makefile.am
Modified: trunk/doc/gtkada_wrapper.texi
===================================================================
--- trunk/doc/gtkada_wrapper.texi 2006-12-02 15:23:25 UTC (rev 31)
+++ trunk/doc/gtkada_wrapper.texi 2007-01-11 14:50:55 UTC (rev 32)
@@ -798,8 +798,8 @@
@end example
This function blocks until the user press a key corresponding to a
-graphical character. The value of the key is stored in Item. The user
-does not need to press @i{ENTER}.
+graphical character. The value of the key is returned. The userdoes
+not need to press @i{ENTER}.
@c end
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-12-02 15:23:25 UTC (rev 31)
+++ trunk/src/gtkada_wrapper.ads 2007-01-11 14:50:55 UTC (rev 32)
@@ -263,8 +263,8 @@
function Get_Immediate return Character;
-- Block until the user press a key corresponding to a graphical
- -- character. The value of the key is stored in Item. The user
- -- does not need to press ENTER.
+ -- character. The value of the key is returned. The user does
+ -- not need to press ENTER.
-- FIXME: Maybe some I/O function for integers, floats...
Added: trunk/support/Makefile.am
===================================================================
--- trunk/support/Makefile.am (rev 0)
+++ trunk/support/Makefile.am 2007-01-11 14:50:55 UTC (rev 32)
@@ -0,0 +1 @@
+EXTRA_DIST=reconfig
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-12-02 15:23:24
|
Revision: 31
http://svn.sourceforge.net/gtkada-wrapper/?rev=31&view=rev
Author: bechir_zalila
Date: 2006-12-02 07:23:25 -0800 (Sat, 02 Dec 2006)
Log Message:
-----------
* Pump up version number
Modified Paths:
--------------
trunk/configure.ac
Modified: trunk/configure.ac
===================================================================
--- trunk/configure.ac 2006-12-02 15:20:39 UTC (rev 30)
+++ trunk/configure.ac 2006-12-02 15:23:25 UTC (rev 31)
@@ -1,5 +1,5 @@
AC_PREREQ(2.57)
-AC_INIT(GTKAda-Wrapper, 0.2, gtk...@li...)
+AC_INIT(GTKAda-Wrapper, 0.3, gtk...@li...)
AC_CONFIG_SRCDIR(src)
AC_CONFIG_AUX_DIR(support)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-12-02 15:20:39
|
Revision: 30
http://svn.sourceforge.net/gtkada-wrapper/?rev=30&view=rev
Author: bechir_zalila
Date: 2006-12-02 07:20:39 -0800 (Sat, 02 Dec 2006)
Log Message:
-----------
* version 0.2 released
Modified Paths:
--------------
trunk/NEWS
Modified: trunk/NEWS
===================================================================
--- trunk/NEWS 2006-12-02 15:17:34 UTC (rev 29)
+++ trunk/NEWS 2006-12-02 15:20:39 UTC (rev 30)
@@ -1,3 +1,10 @@
+GTKAda_Wrapper 0.2 (2006-12-03):
+================================
+
+- Several bug fixes in the packaging process
+- Added a documentation
+- Added an installable project file
+
GTKAda_Wrapper 0.1 (2006-12-02):
================================
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-12-02 15:17:37
|
Revision: 29
http://svn.sourceforge.net/gtkada-wrapper/?rev=29&view=rev
Author: bechir_zalila
Date: 2006-12-02 07:17:34 -0800 (Sat, 02 Dec 2006)
Log Message:
-----------
* (doc/gtkada_wrapper.texi, doc/Makefile.am): Added documentation.
* (src/gtkada_wrapper.ads): Typos
* (src/Makefile.am, src/gtkada_wrapper_i.gpr): Added an installable
project file and fixed some typos in the Makefile.
* (examples/Makefile.common): Minor reformatting
* (TODO): Updated todo list
Modified Paths:
--------------
trunk/TODO
trunk/doc/Makefile.am
trunk/examples/Makefile.common
trunk/src/Makefile.am
trunk/src/gtkada_wrapper.ads
Added Paths:
-----------
trunk/doc/gtkada_wrapper.texi
trunk/src/gtkada_wrapper_i.gpr
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-12-01 23:16:32 UTC (rev 28)
+++ trunk/TODO 2006-12-02 15:17:34 UTC (rev 29)
@@ -1,11 +1,8 @@
/src:
- * Fix Bug in text insertion
+ * Fix Bug in text insertion: somtimes the executable crash when
+ trying to load a font.
/doc:
- * Write the documentation
/:
- * Add a projects subdirectory that will contain the project
- files that will be installed.
/examples:
- * Install examples
\ No newline at end of file
Modified: trunk/doc/Makefile.am
===================================================================
--- trunk/doc/Makefile.am 2006-12-01 23:16:32 UTC (rev 28)
+++ trunk/doc/Makefile.am 2006-12-02 15:17:34 UTC (rev 29)
@@ -0,0 +1,28 @@
+info_TEXINFOS = gtkada_wrapper.texi
+gtkada_wrapper_TEXINFOS = gtkada_wrapper.texi
+
+EXTRA_DIST = gtkada_wrapper.texi
+
+all-local: gtkada_wrapper.html gtkada_wrapper.pdf
+
+gtkada_wrapper.html: gtkada_wrapper.texi
+ $(MAKEINFO) --html gtkada_wrapper.texi -o gtkada_wrapper.html
+
+gtkada_wrapper.pdf: gtkada_wrapper.texi
+ $(TEXI2PDF) gtkada_wrapper.texi
+
+clean-local:
+ rm -f *.aux *.log *.dvi *.info *.tmp
+ rm -f *.cp *.pg *.toc *.vr *.fn *.ky *.tp *~
+ rm -rf gtkada_wrapper.html gtkada_wrapper.pdf
+
+dist-hook: all
+ cp -r gtkada_wrapper.html gtkada_wrapper.pdf $(distdir)
+
+install-data-local: all
+ $(INSTALL) -d $(DESTDIR)$(datadir)/doc/gtkada_wrapper
+ $(INSTALL_DATA) $(srcdir)/gtkada_wrapper.pdf $(DESTDIR)$(datadir)/doc/gtkada_wrapper
+ $(INSTALL) -d $(DESTDIR)$(datadir)/doc/gtkada_wrapper/gtkada_wrapper.html
+ for f in $(srcdir)/gtkada_wrapper.html/*.html; do \
+ $(INSTALL_DATA) $$f $(DESTDIR)$(datadir)/doc/gtkada_wrapper/gtkada_wrapper.html; \
+ done
Added: trunk/doc/gtkada_wrapper.texi
===================================================================
--- trunk/doc/gtkada_wrapper.texi (rev 0)
+++ trunk/doc/gtkada_wrapper.texi 2006-12-02 15:17:34 UTC (rev 29)
@@ -0,0 +1,808 @@
+\input texinfo @c -*-texinfo-*-
+
+@include version.texi
+
+@setfilename gtkada_wrapper.info
+@settitle GTKAda Wrapper: A Simple Ada 2005 Graphic Library
+@afourpaper
+
+@documentlanguage en
+@documentencoding UTF-8
+
+@c description and copyright
+
+@copying
+Copyright @copyright{2006} @sc{Bechir Zalila}
+
+@quotation
+Permission is granted to make and distribute verbatim copies of this
+entire document without royality provided the copyright notice and
+this permission are preserved.
+@end quotation
+@end copying
+
+@c title page, contents, copyright
+
+@titlepage
+@title GTKAda Wrapper
+@subtitle A Simple Ada 2005 Graphic Library
+@subtitle for GTKAda Wrapper @value{EDITION}, @value{UPDATED}
+@author @sc{Bechir Zalila}
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@iftex
+@contents
+@end iftex
+
+@c top node
+
+@ifnottex
+@node Top, About This Guide, (dir), (dir)
+@top GTKAda Wrapper
+@insertcopying
+@end ifnottex
+
+@c Do not indent examples
+
+@exampleindent 0
+
+@menu
+* About This Guide::
+* Installation::
+* Using GTKAda Wrapper::
+* Library Description::
+@end menu
+
+@c -------------------------------------------------------------------
+@node About This Guide, Installation, Top, Top
+@unnumbered About This Guide
+@c -------------------------------------------------------------------
+
+@noindent
+This guide describes the use of GTKAda Wrapper, a simplified Ada 2005
+graphic library over GTKAda. This purpose of this library is to help
+beginner programmer (CS Students) to build graphical Ada application
+without having to address all the complexity of GTK+.
+
+@c -------------------------------------------------------------------
+@node Installation, Using GTKAda Wrapper, About This Guide, Top
+@chapter Installation
+@c -------------------------------------------------------------------
+
+@menu
+* Supported Platforms::
+* Build requirements::
+* Build instructions::
+* Building Options::
+@end menu
+
+@c -------------------------------------------------------------------
+@node Supported Platforms, Build requirements, Installation, Installation
+@section Supported Platforms
+@c -------------------------------------------------------------------
+
+This library is supported by all the platforms that can run GNAT and
+GTK Ada:
+
+@itemize @bullet
+@item Linux
+@item MacOS X
+@item Solaris
+@item Windows
+@item ...
+@end itemize
+
+@c -------------------------------------------------------------------
+@node Build requirements, Build instructions, Supported Platforms, Installation
+@section Build requirements
+@c -------------------------------------------------------------------
+
+@noindent
+An Ada compiler:
+@itemize @bullet
+@item GNAT GPL 2006 or later
+(@url{http://libre.adacore.com/dynamic/gnat_gpl_edition.html})
+@item FSF GCC 4.1.1 or later (@url{http://gcc.gnu.org/})
+@end itemize
+
+GNAT has to be properly installed and the @file{bin} directory of the
+GNAT installation directory have to be the first directory of your
+@code{PATH} environment variable.
+
+@noindent
+GTKAda library
+@itemize @bullet
+@item GTKAda 2.8.0 or later (@url{http://libre.adacore.com/GtkAda/})
+@end itemize
+
+GTKAda has to be compiled and installed in the same install directory
+of GNAT for the following reason:
+@itemize @bullet
+@item This avoid having to indicate the full path to the @file{gtkada.gpr}
+ project file.
+@end itemize
+
+Besides, we encourage you to compile GTKAda statically (option
+@code{--enable-static --disable-shared} of the @file{configure} script
+of GTKAda. This allows to build applications that can run on other
+platforms that do not have GTKAda installed (GTK+ remains necessary
+nevertheless).
+
+@c -------------------------------------------------------------------
+@node Build instructions, Building Options, Build requirements, Installation
+@section Build instructions
+@c -------------------------------------------------------------------
+
+@noindent
+To compile and install GTKAda Wrapper, execute:
+
+
+@example
+ % ./configure [some options]
+ % make (or gmake if your make is not GNU make)
+ % make install (ditto)
+@end example
+
+@noindent
+This will install files in standard locations. If you want to choose
+another prefix than @file{/usr/local}, give configure a
+@option{--prefix=whereveryouwant} argument.
+
+Here also, we encourage you to install GTKAda Wrapper in the same
+install directory of GNAT for the same reason given above.
+
+Note: at this time, you MUST use GNU make to compile this software.
+
+@c -------------------------------------------------------------------
+@node Building Options, , Build instructions, Installation
+@section Building Options
+@c -------------------------------------------------------------------
+
+@noindent
+Available options for the @file{configure} script include:
+
+@itemize @bullet
+
+@item @option{--enable-debug}: enable debugging information generation
+and supplementary runtime checks. Note that this option has a
+significant space and time cost, and is not recommended for production
+use.
+
+@end itemize
+
+@c -------------------------------------------------------------------
+@node Using GTKAda Wrapper, Library Description, Installation, Top
+@chapter Using GTKAda Wrapper
+@c -------------------------------------------------------------------
+
+@noindent
+To use GTKAda Wrapper, you must add a with clause to the
+@code{GTKAda_Wrapper} package.
+
+The following example gives the source code of an application that
+builds an empty windows, waits for a mouse click and then exits. The
+file name has to be necessarily @file{empty_window.adb}:
+
+@example
+-- This example, creates an empty default main window then exits
+
+with Gtkada_Wrapper; use Gtkada_Wrapper;
+
+with Ada.Text_IO;
+
+procedure Empty_Window is
+ X : Float;
+ Y : Float;
+ Button : Natural;
+begin
+ -- Create the graphic window
+
+ Create_Main_Window;
+
+ -- Wait for the mouse click
+
+ Get_Mouse_Pointer (X, Y, Button);
+
+ -- Display the properties of the given click
+
+ 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 the graphic window
+
+ Destroy_Main_Window;
+end Empty_Window;
+@end example
+
+You must also use the GNAT project files to compile your
+application. This makes the application build easy and encapsulates
+the complexity of the building process (fetching the necessary include
+files and libraries).
+
+The following example gives the code of the project file relative to
+the @file{empty_window.adb}. The file name can have a name different
+from the source name. But it must have necessarily the @file{.gpr}
+extension and mut be coherent with the package name givent in the
+file. In our case, the project file name is @code{empty.gpr}
+
+@example
+with "/full/or/relative/path/to/gtkada_wrapper.gpr";
+
+-- In the case you installed GTKAda Wrapper in the same path as GNAT,
+-- you can give simply:
+-- with "gtkada_wrapper";
+
+project Empty is
+ for main use ("empty_window.adb");
+end Empty;
+@end example
+
+As mentioned in the project file code. If you installed GTKAda Wrapper
+in a location different from the GNAT compiler location, you must
+indicate event the fill path to @file{gtkada_wrapper.gpr} or the path
+to this file relatively to the path of your project file. However, if
+you installed GTKAda Wrapper in the same location as the GNAT
+compiler, you can indicate simply the name (without even the suffix)
+of the GTKAda Wrapper project file.
+
+Finally, compile you example by issuing:
+@example
+ % gnatmake -P empty.gpr
+@end example
+
+If you followed all the steps given above you should obtain an
+executable named @file{empty_window} that you can run.
+
+@c -------------------------------------------------------------------
+@node Library Description, , Using GTKAda Wrapper, Top
+@chapter Library Description
+@c -------------------------------------------------------------------
+
+@noindent
+This chapter describes all the routines provided by the GTKAda Wrapper
+library.
+
+@menu
+* Common Routines::
+* Drawing Area::
+* Text Area::
+@end menu
+
+@c -------------------------------------------------------------------
+@node Common Routines, Drawing Area, Library Description, Library Description
+@section Common Routines
+@c -------------------------------------------------------------------
+
+@noindent
+We give here the routines that control the creation and destruction of
+the graphical window.
+
+@example
+@b{
+Lost_Main_Window : exception;
+}
+@end example
+
+This exception is raised if the user tries to manipulate the windows
+before creating it or after destroying it.
+
+@example
+@b{
+procedure Create_Main_Window
+ (X_Max : Float := 512.0;
+ Y_Max : Float := 512.0;
+ Text_Area : Boolean := False;
+ Drawing_Area : Boolean := True);
+}
+@end example
+
+This procedure creates the main window of the
+application. @code{X_Max} and @code{Y_Max} represent respectively the
+width and the height of each one of the windows parts: the drawing
+area and the text area. The flags @code{Text_Area} and
+@code{Drawing_Area} control the creation of these parts. Note that at
+least one of these two flags has to be set to @code{True}.
+
+@example
+@b{
+procedure Destroy_Main_Window;
+}
+@end example
+
+This procedure closes and destroys the main window.
+
+You may, during the execution of your application, create and destroy
+as many windows as you want. However, one single windows at most has
+to exist at a given time.
+
+@c -------------------------------------------------------------------
+@node Drawing Area, Text Area, Common Routines, Library Description
+@section Drawing Area
+@c -------------------------------------------------------------------
+
+@noindent
+All the drawing is performed using a virtual brush. the brush has the
+following intrinsic characteristics:
+
+@enumerate
+@item A position relatively to the lower left corner of the drawing
+area. This position can be got/set using the Cartesian coordinate
+system as we as the Polar coordinate system.
+
+@item An Orientation relatively to the horizontal orientation and
+counter clockwise. For the sake of simplicity, all the angles are
+expressed in ``Degree''.
+@end enumerate
+
+Its obvious that only one of these characteristics is sufficient to
+perform all kinds of drawing. However, combining both systems may
+simplify enormously some complex drawings.
+
+@example
+@b{
+type Color_Type is private;
+}
+@end example
+
+This is the color type used to perform all the drawings. The type is a
+private type since the user has not to know the internals of the type
+to use it.
+
+@example
+@b{
+function RGB (R : Integer; G : Integer; B : Integer) return Color_Type;
+}
+@end example
+
+This function cretes an RGB (Red Green Blue) color. All the given
+parameter are considered modulo 65536, the maximal value of a color
+composant.
+
+@b{IMPORTANT NOTE:} All custom colors must be declared
+@b{@i{before}} the call to @code{Create_Main_Window}.
+
+The library defines some predefined colors that may be used without
+calling @code{RGB}:
+
+@itemize @bullet
+@item Black
+@item Red
+@item Green
+@item Yello
+@item Blue
+@item Magenta
+@item Cyan
+@item Orange
+@item Pink
+@item Dark_Gray
+@item Gray
+@item Light_Gray
+@item White
+@end itemize
+
+All the routines below:
+@itemize @bullet
+@item are thread-safe, in the sence that the call to a routine is
+``atomic'' to avoid interference between different tasks calling
+different routines.
+
+@item verify the existence of the graphical window and the drawing
+area and raise an error if on of themhas not been created.
+@end itemize
+
+@example
+@b{
+procedure Clear_Drawing_Area;
+}
+@end example
+
+This procedure ``blanks' the drawing area.
+
+@example
+@b{
+procedure Set_Color (C : Color_Type);
+}
+@end example
+
+This procedure sets the color of the virtual brush to @code{C}.
+
+@example
+@b{
+function Get_Color return Color_Type;
+}
+@end example
+
+This function returns the current color of the virtual brush.
+
+@example
+@b{
+procedure Set_Thickness (T : Float);
+}
+@end example
+
+This procedure sets the thickness of the virtual brush to @code{T}.
+
+@example
+@b{
+function Get_Thickness return Float;
+}
+@end example
+
+This function returns the current thickness of the virtual brush.
+
+@example
+@b{
+procedure Set_Angle (Angle : Float);
+}
+@end example
+
+This procedure sets the angle between the horizontal and the virtual
+brush orientation to @code{Angle}
+
+@example
+@b{
+function Get_Angle return Float;
+}
+@end example
+
+This function returns the angle between the horizontal and the virtual
+brush orientation.
+
+@example
+@b{
+procedure Rotate (Angle : Float);
+}
+@end example
+
+This procedure modifies the virtual brush orientation to @code{Angle +
+Current_Orientation}.
+
+@example
+@b{
+procedure Set_Position (X : Float; Y : Float);
+}
+@end example
+
+This function sets the current Cartesian position of the virtual brush
+to @code{(X,Y)}.
+
+@example
+@b{
+procedure Get_Position (X : out Float; Y : out Float);
+}
+@end example
+
+This procedure gets the current Cartesian position of the virtual
+brush.
+
+@example
+@b{
+procedure Jump (Distance : Float);
+}
+@end example
+
+This procedure jumps straight forward the given distance in the
+direction the virtual brush without drawing any line.
+
+@example
+@b{
+procedure Jump (X : Float; Y : Float);
+}
+@end example
+
+Same as above but using the Cartesian coordinate.
+
+@example
+@b{
+procedure Line (Distance : Float);
+}
+@end example
+
+This procedure jumps straight forward the given distance in the
+direction the virtual brush and draws a line between the start and the
+end points. The color, style and thickness of the line are specified
+using the appropriate routines.
+
+@example
+@b{
+procedure Line (X : Float; Y : Float);
+}
+@end example
+
+Same as above but using the Cartesian coordinate.
+
+@example
+@b{
+procedure Line (X_Start : Float;
+ Y_Start : Float;
+ Distance : Float);
+}
+@end example
+
+Same as above but start from @code{(X_Start, Y_Start)}. At the end of
+execution, the virtual brush is located at the end of the drwn line.
+
+@example
+@b{
+procedure Line
+ (X_Start : Float;
+ Y_Start : Float;
+ X_End : Float;
+ Y_End : Float);
+}
+@end example
+
+Same as above, but with the Cartesian destination.
+
+@example
+@b{
+procedure Point;
+}
+@end example
+
+This procedure draws a point in the current position.
+
+@example
+@b{
+procedure Point (Center_X : Float; Center_Y : Float);
+}
+@end example
+
+Same as above but with a custom position.
+
+@example
+@b{
+type X_Justification_Type is (Left, Center, Right);
+type Y_Justification_Type is (Top, Center, Bottom);
+}
+@end example
+
+These two enumeration types are used to align horizontally and
+vertically inserted text and images (see below).
+
+@example
+@b{
+procedure Insert_Image
+ (File_Name : String;
+ Scale : Float := 1.0;
+ X_Justification : X_Justification_Type := Center;
+ Y_Justification : Y_Justification_Type := Center);
+}
+@end example
+
+This procedure draws a graphic justified at the virtual brush's
+current location. This will draw any graphic that Gtk understands,
+including JPEG, GIF, BMP, PNG, PBM, TIFF, and perhaps some others.
+
+@b{IMPORTANT NOTE:} If the given path to the image is a relative path,
+the image location is calculated relatively to the working directory.
+
+@example
+@b{
+procedure Insert_Text
+ (Text : String;
+ Size : Float := 10.0;
+ X_Justification : X_Justification_Type := Center;
+ Y_Justification : Y_Justification_Type := Center);
+}
+@end example
+
+This procedure draws a text string justified at the virtual brush's
+current location. The size is expressed in @i{Pixels}.
+
+@example
+@b{
+procedure Draw_Circle (Radius : Float);
+}
+@end example
+
+This procedure draws a circle with radius @code{Radius} and with the
+center at the current position of the virtual brush.
+
+@example
+@b{
+procedure Draw_Circle
+ (Center_X : Float;
+ Center_Y : Float;
+ Radius : Float);
+}
+@end example
+
+Same as above but the position of the center is given.
+
+@example
+@b{
+procedure Fill_Circle (Radius : Float);
+}
+@end example
+
+This procedure fills a circle with radius @code{Radius} and with the
+center at the current position of the virtual brush. Note that the
+actual radius of the filled circle is @code{Radius - 1} pixel.
+
+@example
+@b{
+procedure Fill_Circle
+ (Center_X : Float;
+ Center_Y : Float;
+ Radius : Float);
+}
+@end example
+
+Same as above but the position of the center is given.
+
+@example
+@b{
+procedure Draw_Rectangle
+ (First_X : Float;
+ First_Y : Float;
+ Width : Float;
+ Height : Float);
+}
+@end example
+
+This procedure draws a rectangle having the specified bottom left
+edge.
+
+@example
+@b{
+procedure Fill_Rectangle
+ (First_X : Float;
+ First_Y : Float;
+ Width : Float;
+ Height : Float);
+}
+@end example
+
+This procedure fills a rectangle having the specified bottom left edge
+edges. Note that the actual sizes of the filled rectangle is reduced
+by 1 pixel.
+
+@example
+@b{
+type Float_Array is array (Positive range <>) of Float;
+}
+@end example
+
+This type defines an array of Float. It must be instantiated with tha
+actual size.
+
+@example
+@b{
+procedure Draw_Polygon (Edges : Float_Array);
+}
+@end example
+
+This procedure draws a polygon by linking the given edges. The array
+must be in the form @code{(X1, Y1, X2, Y2..., Xn, Yn)}. There fore its
+length must be even. If the length of 'Edges' is odd, raise
+Constraint_Error.
+
+@example
+@b{
+procedure Fill_Polygon (Edges : Float_Array);
+}
+@end example
+
+This procedure fills a polygon as it would have been drawn by the
+subprogram above.
+
+@example
+@b{
+procedure Rafresh;
+}
+@end example
+
+This procedure redraws the drawing area.
+
+@example
+@b{
+procedure Get_Mouse_Pointer
+ (X : out Float;
+ Y : out Float;
+ Button : out Natural);
+}
+@end example
+
+This procedure waits for a mouse button action and stores the mouse
+pointer coordinate in @code{X} and @code{Y} and the mouse button used
+to do the action. If the user closes the windows before giving a mouse
+click, @code{Lost_Main_Window} will be raised.
+
+@c -------------------------------------------------------------------
+@node Text Area, , Drawing Area, Library Description
+@section Text Area
+@c -------------------------------------------------------------------
+
+@noindent
+We give here the routines that allow the user to interact wi the test area.
+
+All the routines below:
+@itemize @bullet
+@item are thread-safe, in the sence that the call to a routine is
+``atomic'' to avoid interference between different tasks calling
+different routines.
+
+@item verify the existence of the graphical window and the text area
+and raise an error if on of themhas not been created.
+@end itemize
+
+@example
+@b{
+procedure Clear_Text_Area;
+}
+@end example
+
+This procedure erases all the text of the text area.
+
+@example
+@b{
+procedure Put (Item : String);
+}
+@end example
+
+This procedure inserts the given text on the current cursor position
+of the text area.
+
+@example
+@b{
+procedure Put (Item : Character);
+}
+@end example
+
+Same as above but with a character
+
+@example
+@b{
+procedure New_Line (Spacing : Positive := 1);
+}
+@end example
+
+This procedure jumps to the beginning of the last line of the next
+@code{Spacing} lines.
+
+@example
+@b{
+procedure Put_Line (Item : String);
+}
+@end example
+
+This procedure is equivalent to @code{Put (Item); New_Line;}.
+
+@example
+@b{
+procedure Put_Line (Item : Character);
+}
+@end example
+
+This procedure is equivalent to @code{Put (Item); New_Line;}.
+
+@example
+@b{
+function Get_Line return String;
+}
+@end example
+
+This function blocks until the user types a string followed by
+pressing @i{ENTER}
+
+@example
+@b{
+function Get_Immediate return Character;
+}
+@end example
+
+This function blocks until the user press a key corresponding to a
+graphical character. The value of the key is stored in Item. The user
+does not need to press @i{ENTER}.
+
+@c end
+
+@bye
+
+
Modified: trunk/examples/Makefile.common
===================================================================
--- trunk/examples/Makefile.common 2006-12-01 23:16:32 UTC (rev 28)
+++ trunk/examples/Makefile.common 2006-12-02 15:17:34 UTC (rev 29)
@@ -5,4 +5,3 @@
clean-local:
$(GNATCLEAN) -P $(PROJECT_FILE) $(GNATFLAGS)
-
Modified: trunk/src/Makefile.am
===================================================================
--- trunk/src/Makefile.am 2006-12-01 23:16:32 UTC (rev 28)
+++ trunk/src/Makefile.am 2006-12-02 15:17:34 UTC (rev 29)
@@ -14,11 +14,12 @@
ADA_BODIES = $(ADA_SPECS_WITH_BODY:.ads=.adb)
PROJECT_FILE = gtkada_wrapper.gpr
+PROJECT_FILE_I = gtkada_wrapper_i.gpr
-EXTRA_DIST = $(PROJECT_FILE) $(ADA_SPECS) $(ADA_BODIES)
+EXTRA_DIST = $(PROJECT_FILE) $(PROJECT_FILE_I) $(ADA_SPECS) $(ADA_BODIES)
headers_dir = $(includedir)/gtkada_wrapper
-ali_dir = $(libdir)/gtkada_wrappe
+ali_dir = $(libdir)/gtkada_wrapper
all-local:
$(GNATMAKE) -P $(PROJECT_FILE) $(GNATFLAGS)
@@ -29,6 +30,8 @@
install-data-local:
$(INSTALL) -d $(DESTDIR)$(headers_dir)
$(INSTALL) -d $(DESTDIR)$(ali_dir)
+ $(INSTALL) -d $(DESTDIR)$(libdir)/gnat
+ $(INSTALL) -m 444 $(PROJECT_FILE_I) $(DESTDIR)$(libdir)/gnat/$(PROJECT_FILE)
for f in $(ADA_SPECS) $(ADA_BODIES); do \
$(INSTALL) -m 444 $$f $(DESTDIR)$(headers_dir); \
done; \
@@ -37,6 +40,7 @@
done
for f in $(srcdir)/libs/lib*; do \
$(INSTALL) -m 444 $$f $(DESTDIR)$(libdir); \
+ $(INSTALL) -m 444 $$f $(DESTDIR)$(ali_dir); \
done
dist-hook:
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-12-01 23:16:32 UTC (rev 28)
+++ trunk/src/gtkada_wrapper.ads 2006-12-02 15:17:34 UTC (rev 29)
@@ -25,13 +25,13 @@
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
- -- the windows parts: the drawing area and the typing area. The
+ -- the windows parts: the drawing area and the text area. The
-- flags Text_Area and Drawing_Area control the creation of these
-- parts. Note that at least one of these two flags has to be set
- -- to true.
+ -- to True.
procedure Destroy_Main_Window;
- -- Close and destroy the main window
+ -- Closes and destroys the main window
------------------------------------
-- Drawing Area Specific Routines --
@@ -41,7 +41,7 @@
-- has the following intrinsic characteristics:
-- 1 - A position relatively to the lower left corner of the
- -- drowing area. This position can be got/set using the Cartesian
+ -- drawing area. This position can be got/set using the Cartesian
-- coordinate system as we as the Polar coordinate system.
-- 2 - An Orientation relatively to the horizontal orientation and
@@ -78,7 +78,7 @@
-- Predefined colors
procedure Clear_Drawing_Area;
- -- If the drwing area exists, then it will be ``blanked''
+ -- If the drawing area exists, then it will be ``blanked''
procedure Set_Color (C : Color_Type);
-- Set the color of the virtual brush to C
@@ -229,7 +229,7 @@
(X : out Float;
Y : out Float;
Button : out Natural);
- -- Wait for a mous button action and stores the mouse pointer
+ -- Wait for a mouse button action and stores the mouse pointer
-- coordinate in X and Y and the mouse button used to do the
-- action. If the user closes the windows before giving a mouse
-- click, 'Lost_Main_Window' will be raised.
Added: trunk/src/gtkada_wrapper_i.gpr
===================================================================
--- trunk/src/gtkada_wrapper_i.gpr (rev 0)
+++ trunk/src/gtkada_wrapper_i.gpr 2006-12-02 15:17:34 UTC (rev 29)
@@ -0,0 +1,40 @@
+with "gtkada";
+
+project GTKAda_Wrapper is
+ for Library_Kind use "static";
+ for Source_Dirs use ("../../include/gtkada_wrapper");
+ for Library_Dir use "../gtkada_wrapper";
+ for Library_Kind use "static";
+ for Library_Name use "gtkada_wrapper";
+ for Externally_Built use "true";
+
+ type Build_Type is ("release", "debug");
+ Build : Build_Type := External ("BUILD", "debug");
+
+ -- Compiler flags
+
+ package Compiler is
+ case Build is
+ when "debug" =>
+ for Default_Switches ("Ada") use
+ ("-g", "-gnat05", "-gnatfy", "-gnatwae", "-gnatoa",
+ "-fstack-check", "-gnatg");
+ when "release" =>
+ for Default_Switches ("Ada") use
+ ("-g", "-O2", "-gnat05", "-gnatfy", "-gnatwae", "-gnatpn",
+ "-gnatg");
+ end case;
+ end Compiler;
+
+ -- Binder options
+
+ package Binder is
+ case Build is
+ when "debug" =>
+ for Default_Switches ("Ada") use
+ ("-E");
+ when "release" =>
+ null;
+ end case;
+ end Binder;
+end GTKAda_Wrapper;
Property changes on: trunk/src/gtkada_wrapper_i.gpr
___________________________________________________________________
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-12-01 23:16:32
|
Revision: 28
http://svn.sourceforge.net/gtkada-wrapper/?rev=28&view=rev
Author: bechir_zalila
Date: 2006-12-01 15:16:32 -0800 (Fri, 01 Dec 2006)
Log Message:
-----------
* pump up version number
Modified Paths:
--------------
trunk/configure.ac
Modified: trunk/configure.ac
===================================================================
--- trunk/configure.ac 2006-12-01 23:13:28 UTC (rev 27)
+++ trunk/configure.ac 2006-12-01 23:16:32 UTC (rev 28)
@@ -1,5 +1,5 @@
AC_PREREQ(2.57)
-AC_INIT(GTKAda-Wrapper, 0.1, gtk...@li...)
+AC_INIT(GTKAda-Wrapper, 0.2, gtk...@li...)
AC_CONFIG_SRCDIR(src)
AC_CONFIG_AUX_DIR(support)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-12-01 23:13:28
|
Revision: 27
http://svn.sourceforge.net/gtkada-wrapper/?rev=27&view=rev
Author: bechir_zalila
Date: 2006-12-01 15:13:28 -0800 (Fri, 01 Dec 2006)
Log Message:
-----------
* Realeased version 0.1
Modified Paths:
--------------
trunk/NEWS
Modified: trunk/NEWS
===================================================================
--- trunk/NEWS 2006-12-01 23:08:41 UTC (rev 26)
+++ trunk/NEWS 2006-12-01 23:13:28 UTC (rev 27)
@@ -1,2 +1,16 @@
-GTKAda_Wrapper 0.1 (2006-xx-xx):
+GTKAda_Wrapper 0.1 (2006-12-02):
================================
+
+- A drawing area with the following features
+
+ * Setup of the color, the thickness, the position and the angle of
+ the brush.
+ * Common drawings (point, line, circle, polygon, text, image
+ insertion...)
+ * Getting of the mouse pointer at a click
+
+- A text area withe the following feature
+
+ * Display of a text (put, put line)
+ * Getting of a text followed by ENETR
+ * Immediate getting of text (without hitting ENTER)
\ No newline at end of file
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-12-01 23:08:40
|
Revision: 26
http://svn.sourceforge.net/gtkada-wrapper/?rev=26&view=rev
Author: bechir_zalila
Date: 2006-12-01 15:08:41 -0800 (Fri, 01 Dec 2006)
Log Message:
-----------
* Finished the implementation of the text area
* Added two examples, one to text the single text area and another
to text the interaction between the text and the drawing areas.
* Now, all the distribution packages properly
Modified Paths:
--------------
trunk/Makefile.am
trunk/TODO
trunk/configure.ac
trunk/examples/Makefile.am
trunk/examples/Makefile.common
trunk/src/Makefile.am
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
trunk/src/gtkada_wrapper.gpr
Added Paths:
-----------
trunk/examples/both_areas/
trunk/examples/both_areas/Makefile.am
trunk/examples/both_areas/README
trunk/examples/both_areas/both_areas.adb
trunk/examples/both_areas/both_areas.gpr
trunk/examples/console/
trunk/examples/console/Makefile.am
trunk/examples/console/README
trunk/examples/console/console.adb
trunk/examples/console/console.gpr
trunk/src/basic_types.adb
trunk/src/basic_types.ads
trunk/src/generic_list.adb
trunk/src/generic_list.ads
trunk/src/gui_utils.adb
trunk/src/gui_utils.ads
trunk/src/interactive_consoles.adb
trunk/src/interactive_consoles.ads
trunk/src/list_utils.adb
trunk/src/list_utils.ads
trunk/src/string_list_utils.adb
trunk/src/string_list_utils.ads
trunk/src/string_utils.adb
trunk/src/string_utils.ads
trunk/src/traces.adb
trunk/src/traces.ads
Modified: trunk/Makefile.am
===================================================================
--- trunk/Makefile.am 2006-12-01 19:43:10 UTC (rev 25)
+++ trunk/Makefile.am 2006-12-01 23:08:41 UTC (rev 26)
@@ -1,4 +1,4 @@
-SUBDIRS=doc src examples
+SUBDIRS=doc support src examples
AUTOMAKE_OPTIONS = no-dependencies
ACLOCAL_AMFLAGS = -I support
CLEANFILES = config-stamp
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-12-01 19:43:10 UTC (rev 25)
+++ trunk/TODO 2006-12-01 23:08:41 UTC (rev 26)
@@ -1,6 +1,5 @@
/src:
- * Implement Text area
-
+ * Fix Bug in text insertion
/doc:
* Write the documentation
Modified: trunk/configure.ac
===================================================================
--- trunk/configure.ac 2006-12-01 19:43:10 UTC (rev 25)
+++ trunk/configure.ac 2006-12-01 23:08:41 UTC (rev 26)
@@ -85,11 +85,14 @@
AC_OUTPUT([
Makefile
doc/Makefile
+ support/Makefile
examples/Makefile
examples/empty_window/Makefile
examples/basic_drawings/Makefile
examples/fractal/Makefile
examples/image/Makefile
+ examples/console/Makefile
+ examples/both_areas/Makefile
src/Makefile
])
Modified: trunk/examples/Makefile.am
===================================================================
--- trunk/examples/Makefile.am 2006-12-01 19:43:10 UTC (rev 25)
+++ trunk/examples/Makefile.am 2006-12-01 23:08:41 UTC (rev 26)
@@ -1 +1 @@
-SUBDIRS = empty_window basic_drawings fractal image
+SUBDIRS = empty_window basic_drawings fractal image console both_areas
Modified: trunk/examples/Makefile.common
===================================================================
--- trunk/examples/Makefile.common 2006-12-01 19:43:10 UTC (rev 25)
+++ trunk/examples/Makefile.common 2006-12-01 23:08:41 UTC (rev 26)
@@ -1,4 +1,4 @@
-EXTRA_DIST = $(SOURCES) $(PROJECT_FILE);
+EXTRA_DIST = $(SOURCES) $(PROJECT_FILE)
all-local:
$(GNATMAKE) -P $(PROJECT_FILE) $(GNATFLAGS)
Added: trunk/examples/both_areas/Makefile.am
===================================================================
--- trunk/examples/both_areas/Makefile.am (rev 0)
+++ trunk/examples/both_areas/Makefile.am 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,5 @@
+include ../Makefile.common
+
+PROJECT_FILE = $(srcdir)/both_areas.gpr
+SOURCES = $(srcdir)/both_areas.adb
+
Added: trunk/examples/both_areas/README
===================================================================
--- trunk/examples/both_areas/README (rev 0)
+++ trunk/examples/both_areas/README 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,2 @@
+This example tests both the drawing and the text area by controling
+the drawings using blocking statements in the text area.
Added: trunk/examples/both_areas/both_areas.adb
===================================================================
--- trunk/examples/both_areas/both_areas.adb (rev 0)
+++ trunk/examples/both_areas/both_areas.adb 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,135 @@
+-- $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;
+
+procedure Both_Areas is
+
+ Color_Array : constant array (1 .. 8) of Color_Type :=
+ (Black,
+ Red,
+ Green,
+ Yellow,
+ Blue,
+ Magenta,
+ Cyan,
+ Orange);
+
+ My_Color_1 : constant Color_Type := RGB (30000, 30000, 30000);
+ My_Color_2 : constant Color_Type := RGB (50000, 50000, 0);
+ Key : Character;
+ pragma Unreferenced (Key); -- Never read
+begin
+ Create_Main_Window (Drawing_Area => True, Text_Area => True);
+
+ Put_Line ("This is an example using both the drawing and the text areas");
+
+ Put ("Press a key to advance");
+ Key := Get_Immediate;
+ New_Line;
+
+ Put ("Inserting some multicolor lines... ");
+
+ Jump (250.0, 250.0);
+ Set_Thickness (15.0);
+ Set_Angle (0.0);
+
+ for I in Color_Array'Range loop
+ Set_Color (Color_Array (I));
+ Line (100.0 + 10.0 * Float (I));
+ Rotate (45.0);
+ end loop;
+
+ Put_Line ("Done!");
+
+ Put ("Press a key to advance");
+ Key := Get_Immediate;
+ New_Line;
+
+ Put ("Drawing some circles... ");
+
+ Set_Color (My_Color_1);
+ Jump (50.0, 50.0);
+ Fill_Circle (20.0);
+
+ Jump (100.0, 100.0);
+ Fill_Circle (10.0);
+
+ Set_Color (My_Color_2);
+ Jump (100.0, 400.0);
+ Fill_Circle (10.0);
+ Point;
+ Point (500.0, 500.0);
+
+ 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);
+
+ 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);
+
+ Put_Line ("Done!");
+
+ Put ("Press a key to advance");
+ Key := Get_Immediate;
+ New_Line;
+
+ Put ("Drawing a reactange, a trinagle and a star... ");
+
+ 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));
+
+ Put_Line ("Done!");
+
+ Put ("Press a key to quit");
+ Key := Get_Immediate;
+
+ Destroy_Main_Window;
+end Both_Areas;
Property changes on: trunk/examples/both_areas/both_areas.adb
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/examples/both_areas/both_areas.gpr
===================================================================
--- trunk/examples/both_areas/both_areas.gpr (rev 0)
+++ trunk/examples/both_areas/both_areas.gpr 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,10 @@
+with "../../src/gtkada_wrapper.gpr";
+
+project Both_Areas is
+ for main use ("both_areas.adb");
+
+ Build : GTKAda_Wrapper.Build_Type := External ("BUILD", "debug");
+
+ package Compiler renames GTKAda_Wrapper.Compiler;
+ package Binder renames GTKAda_Wrapper.Binder;
+end Both_Areas;
Property changes on: trunk/examples/both_areas/both_areas.gpr
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/examples/console/Makefile.am
===================================================================
--- trunk/examples/console/Makefile.am (rev 0)
+++ trunk/examples/console/Makefile.am 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,5 @@
+include ../Makefile.common
+
+PROJECT_FILE = $(srcdir)/console.gpr
+SOURCES = $(srcdir)/console.adb
+
Added: trunk/examples/console/README
===================================================================
--- trunk/examples/console/README (rev 0)
+++ trunk/examples/console/README 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1 @@
+This example tests the routines of the text area
\ No newline at end of file
Added: trunk/examples/console/console.adb
===================================================================
--- trunk/examples/console/console.adb (rev 0)
+++ trunk/examples/console/console.adb 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,41 @@
+-- $Id$
+-- Copyright (C) 2006 Bechir Zalila <bec...@en...>
+-- See COPYING file for license
+
+-- This example, creates an empty default main window then exits
+
+with Gtkada_Wrapper; use Gtkada_Wrapper;
+
+procedure Console is
+ C : Character;
+begin
+ Create_Main_Window (Drawing_Area => False,
+ Text_Area => True);
+
+ Put ("Hello");
+ Put (' ');
+ Put_Line ("This is the text area speaking");
+
+ Put_Line ("Makning 5 new lines");
+ New_Line (5);
+
+ Put_Line ("Testing classic get");
+ Put ("Type a text and hit ENTER: ");
+
+ declare
+ Str : constant String := Get_Line;
+ begin
+ Put_Line ("You typed """ & Str & """");
+ end;
+
+ Put_Line ("Testing immediate get");
+ Put ("Press a key: ");
+
+ C := Get_Immediate;
+ Put_Line ("You hit: '" & C & "'");
+
+ Put ("Press another key to quit");
+ C := Get_Immediate;
+
+ Destroy_Main_Window;
+end Console;
Property changes on: trunk/examples/console/console.adb
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/examples/console/console.gpr
===================================================================
--- trunk/examples/console/console.gpr (rev 0)
+++ trunk/examples/console/console.gpr 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,10 @@
+with "../../src/gtkada_wrapper.gpr";
+
+project Console is
+ for main use ("console.adb");
+
+ Build : GTKAda_Wrapper.Build_Type := External ("BUILD", "debug");
+
+ package Compiler renames GTKAda_Wrapper.Compiler;
+ package Binder renames GTKAda_Wrapper.Binder;
+end Console;
Property changes on: trunk/examples/console/console.gpr
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Modified: trunk/src/Makefile.am
===================================================================
--- trunk/src/Makefile.am 2006-12-01 19:43:10 UTC (rev 25)
+++ trunk/src/Makefile.am 2006-12-01 23:08:41 UTC (rev 26)
@@ -1,4 +1,13 @@
-ADA_SPECS_WITH_BODY =
+ADA_SPECS_WITH_BODY = $(srcdir)/basic_types.ads \
+ $(srcdir)/generic_list.ads \
+ $(srcdir)/gtkada_wrapper.ads \
+ $(srcdir)/gui_utils.ads \
+ $(srcdir)/interactive_consoles.ads \
+ $(srcdir)/list_utils.ads \
+ $(srcdir)/protected_queue.ads \
+ $(srcdir)/string_list_utils.ads \
+ $(srcdir)/string_utils.ads \
+ $(srcdir)/traces.ads
ADA_SPECS = $(ADA_SPECS_WITH_BODY)
Added: trunk/src/basic_types.adb
===================================================================
--- trunk/src/basic_types.adb (rev 0)
+++ trunk/src/basic_types.adb 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,125 @@
+-- $Id$
+
+-- This file has been taken from the GVD (GNU Visual Debugger)
+-- sources. See the header below for Copyright
+
+-----------------------------------------------------------------------
+-- GVD - The GNU Visual Debugger --
+-- --
+-- Copyright (C) 2000-2003 --
+-- ACT-Europe --
+-- --
+-- GVD is free software; you can redistribute it and/or modify it --
+-- under the terms of the GNU General Public License as published by --
+-- the Free Software Foundation; either version 2 of the License, or --
+-- (at your option) any later version. --
+-- --
+-- This program is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of --
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
+-- General Public License for more details. You should have received --
+-- a copy of the GNU General Public License along with this library; --
+-- if not, write to the Free Software Foundation, Inc., 59 Temple --
+-- Place - Suite 330, Boston, MA 02111-1307, USA. --
+-----------------------------------------------------------------------
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+
+package body Basic_Types is
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Ar : in out String_Array) is
+ begin
+ for A in Ar'Range loop
+ Free (Ar (A));
+ end loop;
+ end Free;
+
+ procedure Free (Ar : in out Argument_List) is
+ begin
+ for A in Ar'Range loop
+ Free (Ar (A));
+ end loop;
+ end Free;
+
+ procedure Free (Ar : in out String_Array_Access) is
+ begin
+ if Ar /= null then
+ Free (Ar.all);
+ Unchecked_Free (Ar);
+ end if;
+ end Free;
+
+ --------------
+ -- Is_Equal --
+ --------------
+
+ function Is_Equal
+ (List1, List2 : Argument_List;
+ Case_Sensitive : Boolean := True) return Boolean is
+ begin
+ if List1'Length /= List2'Length then
+ return False;
+
+ else
+ declare
+ L1 : Argument_List := List1;
+ L2 : Argument_List := List2;
+ begin
+ for A in L1'Range loop
+ for B in L2'Range loop
+ if L2 (B) /= null and then
+ ((Case_Sensitive and then L1 (A).all = L2 (B).all)
+ or else
+ (not Case_Sensitive
+ and then To_Lower (L1 (A).all) =
+ To_Lower (L2 (B).all)))
+ then
+ L1 (A) := null;
+ L2 (B) := null;
+ exit;
+ end if;
+ end loop;
+ end loop;
+
+ return L1 = (L1'Range => null)
+ and then L2 = (L2'Range => null);
+ end;
+ end if;
+ end Is_Equal;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (List : GNAT.OS_Lib.Argument_List;
+ Str : String;
+ Case_Sensitive : Boolean := True) return Boolean is
+ begin
+ if not Case_Sensitive then
+ declare
+ S : constant String := To_Lower (Str);
+ begin
+ for L in List'Range loop
+ if To_Lower (List (L).all) = S then
+ return True;
+ end if;
+ end loop;
+ end;
+ else
+ for L in List'Range loop
+ if List (L).all = Str then
+ return True;
+ end if;
+ end loop;
+ end if;
+
+ return False;
+ end Contains;
+
+end Basic_Types;
Property changes on: trunk/src/basic_types.adb
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/src/basic_types.ads
===================================================================
--- trunk/src/basic_types.ads (rev 0)
+++ trunk/src/basic_types.ads 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,138 @@
+-- $Id$
+
+-- This file has been taken from the GVD (GNU Visual Debugger)
+-- sources. See the header below for Copyright
+
+-----------------------------------------------------------------------
+-- GVD - The GNU Visual Debugger --
+-- --
+-- Copyright (C) 2000-2004 --
+-- ACT-Europe --
+-- --
+-- GVD is free software; you can redistribute it and/or modify it --
+-- under the terms of the GNU General Public License as published by --
+-- the Free Software Foundation; either version 2 of the License, or --
+-- (at your option) any later version. --
+-- --
+-- This program is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of --
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
+-- General Public License for more details. You should have received --
+-- a copy of the GNU General Public License along with this library; --
+-- if not, write to the Free Software Foundation, Inc., 59 Temple --
+-- Place - Suite 330, Boston, MA 02111-1307, USA. --
+-----------------------------------------------------------------------
+
+with System;
+with Interfaces.C.Strings;
+with Ada.Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with GNAT.OS_Lib;
+
+package Basic_Types is
+
+ subtype Pixmap_Array is Interfaces.C.Strings.chars_ptr_array (0 .. 0);
+ type Pixmap_Access is access all Pixmap_Array;
+
+ type String_Access is access all String;
+ procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);
+
+ type String_Array is array (Natural range <>) of String_Access;
+
+ type String_Array_Access is access all String_Array;
+
+ procedure Free (Ar : in out String_Array);
+ -- Free all the strings in the array.
+
+ procedure Free (Ar : in out String_Array_Access);
+ -- Free all the strings in the array and the array itself.
+
+ procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ (String_Array, String_Array_Access);
+ -- Free the array, but not the strings it contains.
+
+ subtype Unchecked_String is String (Positive);
+ pragma Suppress (All_Checks, Unchecked_String);
+
+ type Unchecked_String_Access is access all Unchecked_String;
+ -- For efficiency reasons, use this type compatible with C char*,
+ -- so that C strings can be reused without making extra copies.
+
+ function To_Unchecked_String is new Ada.Unchecked_Conversion
+ (System.Address, Unchecked_String_Access);
+
+ function To_Unchecked_String is new Ada.Unchecked_Conversion
+ (Interfaces.C.Strings.chars_ptr, Unchecked_String_Access);
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Unchecked_String, Unchecked_String_Access);
+
+ type Position_Type is new Natural;
+ -- Indicates the position in a file.
+ -- Note that these positions are relative to the real contents of the
+ -- editor, not necessarily the positions visible to the user (which
+ -- might be different because of ASCII.HT handling)
+
+ procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ (GNAT.OS_Lib.Argument_List, GNAT.OS_Lib.Argument_List_Access);
+ -- Free the memory occupied by the parameter array, but not the strings
+ -- themselves.
+
+ procedure Free (Ar : in out GNAT.OS_Lib.Argument_List);
+ -- Free all the strings in the array.
+
+ function Is_Equal
+ (List1, List2 : GNAT.OS_Lib.Argument_List;
+ Case_Sensitive : Boolean := True) return Boolean;
+ -- Return True if List1 has the same contents of List2 (no matter the order
+ -- of the strings in both arrays).
+
+ function Contains
+ (List : GNAT.OS_Lib.Argument_List;
+ Str : String;
+ Case_Sensitive : Boolean := True) return Boolean;
+ -- Return True if List contains Str
+
+ -----------------
+ -- File caches --
+ -----------------
+
+ type Packed_Boolean_Array is array (Positive range <>) of Boolean;
+ pragma Pack (Packed_Boolean_Array);
+ type Packed_Boolean_Access is access Packed_Boolean_Array;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Packed_Boolean_Array, Packed_Boolean_Access);
+
+ type File_Cache;
+ type File_Cache_List is access File_Cache;
+ type File_Cache is record
+ File_Name : String_Access := null;
+ -- The full name (including directory) for the file associated with
+ -- this record.
+
+ Line_Has_Code : Packed_Boolean_Access := null;
+ Line_Parsed : Packed_Boolean_Access := null;
+
+ File_Contents : String_Access := null;
+ -- The contents of the file. To save some memory, this is not allocated
+ -- for files that can be found on the local disk. However, it is used
+ -- for files that had to be downloaded from a remote machine.
+
+ CR_Stripped : Boolean := False;
+ -- True if the carriage return characters were stripped when the file
+ -- was read.
+
+ Next : File_Cache_List := null;
+ -- Next file in the cache list
+ end record;
+ -- Data associated with each file, and that contain cached data for the
+ -- file.
+ -- Line_Parsed indicates whether the line at a given index has been parsed.
+ -- This array is freed once the parsing has been finished (and in the
+ -- case Current_Line points to the last line with a breakpoint.
+
+ procedure Free is new
+ Ada.Unchecked_Deallocation (File_Cache, File_Cache_List);
+
+end Basic_Types;
Property changes on: trunk/src/basic_types.ads
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/src/generic_list.adb
===================================================================
--- trunk/src/generic_list.adb (rev 0)
+++ trunk/src/generic_list.adb 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,530 @@
+-- $Id$
+
+-- This file has been taken from the GPS (GNAT Programming Studio)
+-- sources. See the header below for Copyright
+
+-----------------------------------------------------------------------
+-- G P S --
+-- --
+-- Copyright (C) 2001-2003 --
+-- ACT-Europe --
+-- --
+-- GPS is free software; you can redistribute it and/or modify it --
+-- under the terms of the GNU General Public License as published by --
+-- the Free Software Foundation; either version 2 of the License, or --
+-- (at your option) any later version. --
+-- --
+-- This program is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of --
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
+-- General Public License for more details. You should have received --
+-- a copy of the GNU General Public License along with this program; --
+-- if not, write to the Free Software Foundation, Inc., 59 Temple --
+-- Place - Suite 330, Boston, MA 02111-1307, USA. --
+-----------------------------------------------------------------------
+
+package body Generic_List is
+
+ -------------
+ -- Prepend --
+ -------------
+
+ procedure Prepend
+ (L : in out List;
+ Item : Data_Type)
+ is
+ L2 : List_Node;
+ begin
+ if L.First = null then
+ L.First := new List_Node'(Null_Node);
+ end if;
+
+ L2 := L.First.all;
+
+ if L.Last = null then
+ L.Last := new List_Node'(Null_Node);
+ end if;
+
+ L.First.all :=
+ new List_Node_Record'
+ (Element => new Data_Type'(Item),
+ Next => L2);
+
+ if L2 = null then
+ L.Last.all := L.First.all;
+ end if;
+ end Prepend;
+
+ procedure Prepend
+ (L : in out List;
+ Node : List_Node;
+ Item : Data_Type)
+ is
+ Current : List_Node;
+ begin
+ if L.First = null then
+ L.First := new List_Node'(Null_Node);
+ end if;
+
+ if L.Last = null then
+ L.Last := new List_Node'(Null_Node);
+ end if;
+
+ Current := L.First.all;
+
+ if Node = null then
+ Append (L, Item);
+ elsif Node = L.First.all then
+ Prepend (L, Item);
+ else
+ while Current /= null and then Current.Next /= Node loop
+ Current := Current.Next;
+ end loop;
+
+ if Current = null then
+ raise List_Empty;
+ end if;
+
+ Current.Next := new List_Node_Record'
+ (Element => new Data_Type'(Item),
+ Next => Current.Next);
+ end if;
+ end Prepend;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (L : in out List;
+ Item : Data_Type) is
+ begin
+ if L.Last = null then
+ L.Last := new List_Node'(Null_Node);
+ end if;
+
+ if L.First = null then
+ L.First := new List_Node'(Null_Node);
+ end if;
+
+ if L.Last.all = null then
+ L.First.all := new List_Node_Record'
+ (Element => new Data_Type'(Item),
+ Next => null);
+ L.Last.all := L.First.all;
+
+ else
+ L.Last.all.Next := new List_Node_Record'
+ (Element => new Data_Type'(Item),
+ Next => null);
+ L.Last.all := L.Last.all.Next;
+ end if;
+ end Append;
+
+ procedure Append
+ (L : in out List;
+ Node : List_Node;
+ Item : Data_Type) is
+ begin
+ if L.Last = null then
+ L.Last := new List_Node'(Null_Node);
+ end if;
+
+ if L.First = null then
+ L.First := new List_Node'(Null_Node);
+ end if;
+
+ if Node = null then
+ Prepend (L, Item);
+ elsif Node = L.Last.all then
+ Append (L, Item);
+ else
+ Node.Next := new List_Node_Record'
+ (Element => new Data_Type'(Item),
+ Next => Node.Next);
+ end if;
+ end Append;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (L : List) return Boolean is
+ begin
+ return L.First = null
+ or else L.First.all = null
+ or else L.First.all.Element = null;
+ end Is_Empty;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (L : List) return Natural is
+ L_Current : List_Node;
+ Result : Natural := 0;
+
+ begin
+ if L.First = null then
+ return 0;
+ end if;
+
+ L_Current := L.First.all;
+
+ while L_Current /= null loop
+ Result := Result + 1;
+ L_Current := L_Current.Next;
+ end loop;
+
+ return Result;
+ end Length;
+
+ ------------
+ -- Concat --
+ ------------
+
+ procedure Concat
+ (L1 : in out List;
+ L2 : List)
+ is
+ F1 : List_Node_Access := L2.First;
+ F2 : List_Node_Access := L2.Last;
+ begin
+ if Is_Empty (L2) then
+ return;
+ end if;
+
+ if L1.Last = null then
+ L1.Last := new List_Node'(Null_Node);
+ end if;
+
+ if L1.First = null then
+ L1.First := new List_Node'(Null_Node);
+ end if;
+
+ if Is_Empty (L1) then
+ L1.First.all := L2.First.all;
+ L1.Last.all := L2.Last.all;
+ else
+ L1.Last.all.Next := L2.First.all;
+ L1.Last.all := L2.Last.all;
+ end if;
+
+ Free_Node_Access (F1);
+ Free_Node_Access (F2);
+ end Concat;
+
+ ------------------
+ -- Remove_Nodes --
+ ------------------
+
+ procedure Remove_Nodes
+ (L1 : in out List;
+ Start_Node : List_Node;
+ End_Node : List_Node := Null_Node)
+ is
+ Current : List_Node;
+ Delete : List_Node;
+ Last : List_Node;
+
+ procedure Local_Free (Node : in out List_Node);
+ -- Free Node and its element.
+
+ procedure Local_Free (Node : in out List_Node) is
+ begin
+ if Node.Element /= null then
+ Free (Node.Element.all);
+ Free_Element (Node.Element);
+ end if;
+
+ Free_Node (Node);
+ end Local_Free;
+
+ begin
+ if Start_Node = End_Node then
+ return;
+ end if;
+
+ if Start_Node = Null_Node then
+ -- If Start_Node is null, delete all nodes from the beginning
+ -- of L1, until End_Node.
+
+ Current := First (L1);
+
+ while Current /= End_Node loop
+ Delete := Current;
+ Current := Next (Current);
+ Local_Free (Delete);
+ end loop;
+
+ -- Remove End_Node
+
+ if End_Node /= Null_Node then
+ Delete := End_Node;
+ Last := End_Node.Next;
+ Local_Free (Delete);
+ end if;
+
+ -- Set the boundaries.
+
+ if Last /= Null_Node then
+ L1.First.all := Last;
+ else
+ Free_Node_Access (L1.First);
+ Free_Node_Access (L1.Last);
+ end if;
+
+ return;
+ else
+ Current := Start_Node;
+ Current := Next (Current);
+
+ -- Remove all nodes between Last and End_Node.
+
+ while Current /= End_Node loop
+ Delete := Current;
+ Current := Next (Current);
+ Local_Free (Delete);
+ end loop;
+
+ -- Do not remove End_Node if End_Node = Start_Node.
+
+ if End_Node /= Null_Node then
+ Delete := End_Node;
+ Last := End_Node.Next;
+ Local_Free (Delete);
+ end if;
+
+ -- Set the boundaries.
+
+ if Last = Null_Node then
+ L1.Last.all := Start_Node;
+ Start_Node.Next := Null_Node;
+ else
+ Start_Node.Next := Last;
+ end if;
+ end if;
+ end Remove_Nodes;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (L1 : in out List;
+ Node : List_Node;
+ L2 : List)
+ is
+ begin
+ if Is_Empty (L2) then
+ return;
+
+ elsif Is_Empty (L1) or else Node = L1.Last.all then
+ L1.First.all := L2.First.all;
+ L1.Last.all := L2.Last.all;
+
+ elsif Node = null then
+ L2.Last.all.Next := L1.First.all;
+ L1.First.all := L2.First.all;
+
+ else
+ L2.Last.all.Next := Node.Next;
+ Node.Next := L2.First.all;
+ end if;
+ end Insert;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (L : in out List; Free_Data : Boolean := True) is
+ Current : List_Node;
+ Tmp : List_Node;
+
+ begin
+ if L.First = null or else L.Last.all = null then
+ return;
+ end if;
+
+ Current := L.First.all;
+ L.First.all := null;
+ L.Last.all := null;
+
+ while Current /= null loop
+ Tmp := Current;
+ Current := Current.Next;
+
+ if Free_Data and then Tmp.Element /= null then
+ Free (Tmp.Element.all);
+ end if;
+
+ Free_Element (Tmp.Element);
+ Free_Node (Tmp);
+ end loop;
+
+ Free_Node_Access (L.First);
+ Free_Node_Access (L.Last);
+ end Free;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (L : List) return List_Node is
+ begin
+ if L.First = null then
+ return Null_Node;
+ else
+ return L.First.all;
+ end if;
+ end First;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (L : List) return List_Node is
+ begin
+ if L.Last = null then
+ return Null_Node;
+ else
+ return L.Last.all;
+ end if;
+ end Last;
+
+ ----------
+ -- Prev --
+ ----------
+
+ function Prev (L : List; Node : List_Node) return List_Node is
+ Current : List_Node;
+ begin
+ if L.First = null then
+ raise List_Empty;
+ end if;
+
+ Current := L.First.all;
+
+ if Current = Node then
+ return null;
+ end if;
+
+ while Current /= null and then Current.Next /= Node loop
+ Current := Current.Next;
+ end loop;
+
+ if Current = null then
+ raise List_Empty;
+ else
+ return Current;
+ end if;
+ end Prev;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Node : List_Node) return List_Node is
+ begin
+ if Node = null then
+ raise List_Empty;
+ else
+ return Node.Next;
+ end if;
+ end Next;
+
+ procedure Next
+ (L : in out List;
+ Free_Data : Boolean := True)
+ is
+ First : List_Node;
+ begin
+ if L.First = null or else L.First.all = null then
+ raise List_Empty;
+ else
+ First := L.First.all;
+ L.First.all := L.First.all.Next;
+
+ if L.First.all = null then
+ L.Last.all := null;
+ end if;
+
+ if Free_Data
+ and then First.Element /= null
+ then
+ Free (First.Element.all);
+ end if;
+
+ Free_Element (First.Element);
+ Free_Node (First);
+
+ if L.First.all = null then
+ Free_Node_Access (L.First);
+ end if;
+
+ if L.Last.all = null then
+ Free_Node_Access (L.Last);
+ end if;
+ end if;
+ end Next;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head (L : List) return Data_Type is
+ begin
+ if L.First = null
+ or else L.First.all = null
+ or else L.First.all.Element = null
+ then
+ raise List_Empty;
+ else
+ return L.First.all.Element.all;
+ end if;
+ end Head;
+
+ ----------
+ -- Data --
+ ----------
+
+ function Data (Node : List_Node) return Data_Type is
+ begin
+ if Node = null or else Node.Element = null then
+ raise List_Empty;
+ else
+ return Node.Element.all;
+ end if;
+ end Data;
+
+ --------------
+ -- Data_Ref --
+ --------------
+
+ function Data_Ref (Node : List_Node) return Data_Access is
+ begin
+ if Node = null or else Node.Element = null then
+ raise List_Empty;
+ else
+ return Node.Element;
+ end if;
+ end Data_Ref;
+
+ --------------
+ -- Set_Data --
+ --------------
+
+ procedure Set_Data
+ (Node : List_Node;
+ D : Data_Type) is
+ begin
+ if Node = null or else Node.Element = null then
+ raise List_Empty;
+ else
+ Free (Node.Element.all);
+ Free_Element (Node.Element);
+ Node.Element := new Data_Type'(D);
+ end if;
+ end Set_Data;
+
+end Generic_List;
Property changes on: trunk/src/generic_list.adb
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/src/generic_list.ads
===================================================================
--- trunk/src/generic_list.ads (rev 0)
+++ trunk/src/generic_list.ads 2006-12-01 23:08:41 UTC (rev 26)
@@ -0,0 +1,185 @@
+-- $Id$
+
+-- This file has been taken from the GPS (GNAT Programming Studio)
+-- sources. See the header below for Copyright
+
+-----------------------------------------------------------------------
+-- G P S --
+-- --
+-- Copyright (C) 2001-2003 --
+-- ACT-Europe --
+-- --
+-- GPS is free software; you can redistribute it and/or modify it --
+-- under the terms of the GNU General Public License as published by --
+-- the Free Software Foundation; either version 2 of the License, or --
+-- (at your option) any later version. --
+-- --
+-- This program is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of --
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
+-- General Public License for more details. You should have received --
+-- a copy of the GNU General Public License along with this program; --
+-- if not, write to the Free Software Foundation, Inc., 59 Temple --
+-- Place - Suite 330, Boston, MA 02111-1307, USA. --
+-----------------------------------------------------------------------
+
+-- A generic simple linked list, with an efficient sorting function.
+
+with Unchecked_Deallocation;
+
+generic
+ type Data_Type (<>) is private;
+
+ with procedure Free (Data : in out Data_Type) is <>;
+ -- Free any dynamic memory associated with Data.
+
+package Generic_List is
+
+ type List is private;
+ type List_Node is private;
+
+ Null_List : constant List;
+ Null_Node : constant List_Node;
+
+ List_Empty : exception;
+
+ type Data_Access is access Data_Type;
+
+ procedure Prepend
+ (L : in out List;
+ Item : Data_Type);
+ -- Add an item at the beginning of a list. The cost is O(1).
+
+ procedure Prepend
+ (L : in out List;
+ Node : List_Node;
+ Item : Data_Type);
+ -- Prepend an item before Node in list L. The cost is O(n).
+ -- If Node is null, Item is appended at the end of the list.
+
+ procedure Append
+ (L : in out List;
+ Item : Data_Type);
+ -- Add an item at the end of a list. The cost is O(1).
+
+ procedure Append
+ (L : in out List;
+ Node : List_Node;
+ Item : Data_Type);
+ -- Add an item after Node in list L. The cost is O(1).
+ -- If Node is null, Item is inserted at the beginning of the list.
+
+ function Is_Empty (L : List) return Boolean;
+ -- True if L does not contain any element.
+
+ function Length (L : List) return Natural;
+ -- Return the number of elements in L. Cost is O(n).
+
+ procedure Concat
+ (L1 : in out List;
+ L2 : List);
+ -- Append L2 at the end of L1. Cost is O(1).
+ -- Note that no deep copy of L2 is done, which means that L1 and L2
+ -- will share the same nodes.
+
+ procedure Insert
+ (L1 : in out List;
+ Node : List_Node;
+ L2 : List);
+ -- Insert L2 after Node in L1. Cost is O(1).
+ -- Note that no deep copy of L2 is done, which means that L1 and L2
+ -- will share the same nodes.
+ -- If Node is Null_Node, L2 is inserted at the beginning of L1.
+
+ procedure Remove_Nodes
+ (L1 : in out List;
+ Start_Node : List_Node;
+ End_Node : List_Node := Null_Node);
+ -- Remove all the nodes in L1, from Start_Node (NOT included) to
+ -- End_Node (Included).
+ -- If End_Node is not a valid node or is before Start_Node,
+ -- all the nodes after Start_Node will be removed from the list.
+ -- If First_Node is Null_Node, then the nodes are removed from the
+ -- beginning of the list.
+
+ procedure Free (L : in out List; Free_Data : Boolean := True);
+ -- Free memory associated to L.
+ -- If Free_Data is true, then the data associated with each node is also
+ -- freed through a called to the formal parameter Free.
+
+ function First (L : List) return List_Node;
+ -- Return the first node contained in L.
+
+ function Last (L : List) return List_Node;
+ -- Return the last node contained in L.
+
+ function Prev (L : List; Node : List_Node) return List_Node;
+ -- Return the node before Node in L. The cost is O(n).
+ -- If Node is the first element, return null.
+ -- If Node cannot be found in L, raise List_Empty.
+
+ function Next (Node : List_Node) return List_Node;
+ -- Return the node following Node. The cost is O(1).
+
+ procedure Next
+ (L : in out List;
+ Free_Data : Boolean := True);
+ -- Return the list following the first element.
+ -- Raise List_Empty if L is empty.
+ -- If Free_Data is True, the first element is freed.
+
+ function Head (L : List) return Data_Type;
+ -- Return the first data associated with L.
+ -- Raise List_Empty if L is null.
+
+ function Data (Node : List_Node) return Data_Type;
+ -- Return the data associated with L.
+ -- Raise List_Empty if L is null.
+
+ function Data_Ref (Node : List_Node) return Data_Access;
+ -- Return a pointer to the data associated with L.
+ -- The returned pointer should not be freed and its contents should not
+ -- be modified.
+ -- Raise List_Empty if L is null.
+
+ procedure Set_Data
+ (Node : List_Node;
+ D : Data_Type);
+ -- Free the data associated with L and replace it by D.
+
+private
+
+ type List_Node_Record;
+ type List_Node is access List_Node_Record;
+ type List_Node_Access is access List_Node;
+
+ Null_Node : constant List_Node := null;
+ type List is record
+ First : List_Node_Access;
+ Last : List_Node_Access;
+ end record;
+
+ Null_List : constant List := List'(null, null);
+
+ type List_Node_Record is record
+ Element : Data_Access;
+ Next : List_Node;
+ end record;
+
+ procedure Free_Element is new
+ Unchecked_Deallocation (Data_Type, Data_Access);
+
+ procedure Free_Node is new
+ Unchecked_Deallocation (List_Node_Record, List_Node);
+
+ procedure Free_Node_Access is new
+ Unchecked_Deallocation (List_Node, List_Node_Access);
+
+ pragma Inline (First);
+ pragma Inline (Prepend);
+ pragma Inline (Is_Empty);
+ pragma Inline (Data);
+ pragma Inline (Next);
+ pragma Inline (Head);
+
+end Generic_List;
Property changes on: trunk/src/generic_list.ads
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-12-01 19:43:10 UTC (rev 25)
+++ trunk/src/gtkada_wrapper.adb 2006-12-01 23:08:41 UTC (rev 26)
@@ -5,6 +5,7 @@
with Ada.Text_IO;
with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;
with Unchecked_Deallocation;
+with System;
with GNAT.Table;
@@ -33,9 +34,13 @@
with Gtk.Style; use Gtk.Style;
with Gtk.Widget;
+with Pango.Font; use Pango.Font;
+
+with Interactive_Consoles; use Interactive_Consoles;
+
with Protected_Queue;
-pragma Debug_Policy (Check);
+pragma Debug_Policy (Ignore);
-- To control the debug message display: 'Ignore' Or 'Check'
package body Gtkada_Wrapper is
@@ -81,6 +86,21 @@
-- Allocate the predefined colors and the user colors. This is
-- necessary for them to be valid.
+ function Line_Handler
+ (Console : access Interactive_Console_Record'Class;
+ Input : String;
+ User_Data : System.Address)
+ return String;
+ -- Handler called during the classic 'get' mode each time the user
+ -- types a text on the text area and hits ENTER.
+
+ procedure Key_Handler
+ (Console : access Interactive_Console_Record'Class;
+ Input : Gdk_Key_Type;
+ User_Data : System.Address);
+ -- Handler called during the immediate get mode each time the user
+ -- presses a key.
+
----------------------
-- Global Variables --
----------------------
@@ -114,6 +134,9 @@
Graphic_Context : Gdk_GC;
-- The drawing area of the main window
+ Text_Area : Interactive_Console;
+ -- The text area of the main window
+
Pixmap : Gdk_Pixmap;
-- Pixmap useful when rafreshing the drawing area
@@ -123,20 +146,9 @@
-- beginning of the table. User colors are allocated after.
N_Predefined_Colors : constant Color_Type := 13;
- -- IMPRTANT: Youmust edit this variable each time the predefined
+ -- IMPRTANT: You must edit this variable each time the predefined
-- color set is modified.
- -- User_Task : Task_Id := Null_Task_ID; -- Task that sets up world.
- -- Pixmap : Gdk_Pixmap; -- Pixmap used as backing store.
- -- Pausing : Boolean := False;
- -- Drawing_Area : Gtk_Drawing_Area;
- -- Console : Interactive_Console;
- -- Idle_Function_Id : Idle_Handler_Id;
- -- Pause_Timeout_Function_Id : Timeout_Handler_Id;
- -- Draw_Timeout_Function_Id : Timeout_Handler_Id;
- -- Width, Height : Gint;
- -- Gc : Gdk_Gc;
-
--------------------
-- Event Handlers --
--------------------
@@ -187,7 +199,6 @@
A_New_Line,
A_Put_Line_String,
A_Put_Line_Character,
- A_Get_String,
A_Get_Line_String,
A_Get_Immediate_Character);
@@ -211,7 +222,6 @@
| A_Point_Current
| A_Rafresh
| A_Clear_Text_Area
- | A_Get_String
| A_Get_Line_String
| A_Get_Mouse_Pointer
| A_Get_Immediate_Character =>
@@ -351,7 +361,6 @@
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);
@@ -368,7 +377,6 @@
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,
@@ -543,8 +551,27 @@
-- it to the paned.
if Have_Text_Area then
- -- FIXME: Create text area
- null;
+ -- Create the text area
+
+ Gtk_New (Console => Text_Area,
+ Prompt => "",
+ Handler => Line_Handler'Access,
+ User_Data => System.Null_Address,
+ Font => To_Font_Description
+ (Family_Name => "courier",
+ Size => 9));
+
+ Set_Immediate_Handler (Text_Area, Key_Handler'Access);
+
+ -- Do not display the prompt only when the user request
+ -- it.
+
+ Enable_Prompt_Display (Text_Area, False);
+
+ -- Resize the text area and insert it in the pane
+
+ Set_Size_Request (Text_Area, Width, Height);
+ Pack2 (HPaned, Text_Area, Resize => True, Shrink => True);
end if;
Show_All (Window);
@@ -608,7 +635,8 @@
-- Synchronize only
pragma Debug (O ("Event_Handler.Init: done"));
- null;
+
+ null; -- For non debug mode
end Init;
or
terminate;
@@ -627,12 +655,16 @@
exit;
elsif Dispatch_Table (Cmd.Action) /= null then
pragma Debug (O ("Event_Handler: executing command"));
+
Dispatch_Table (Cmd.Action).all (Cmd);
+
pragma Debug (O ("Event_Handler: done"));
end if;
end loop;
+
pragma Debug (O ("Resetting the event handler: firing"
&" all waiters for response"));
+
N_Wait_Rsp := Response_Queue.Number_Waiting
(Response_Queue.To_Dequeue);
@@ -680,6 +712,8 @@
Color_Table.Set_Item (Col, Gdk_Col);
end Allocate_Predefined_Color;
begin
+ pragma Assert (Drawing_Area /= null);
+
-- Allocate predefined colors
-- IMPORTANT: Don't forget to update N_Predefined_Colors each
@@ -764,7 +798,9 @@
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;
@@ -776,10 +812,12 @@
begin
Assert_Main_Window_Exits;
- -- FIXME: pragma Assert (Text_Area /= null);
+ 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;
@@ -799,6 +837,7 @@
use type Gdk.Gdk_Drawable;
begin
pragma Debug (O ("Window configuration changed: handling"));
+
Win := Get_Window (Drawing_Area);
-- Allocate a new pixmap of the reconfigured size and clear it
@@ -880,8 +919,11 @@
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;
@@ -891,8 +933,12 @@
procedure Do_Angle (Cmd : in out Command) is
begin
+ pragma Assert (Drawing_Area /= null);
+
pragma Debug (O ("Do_Angle : begin"));
+
Angle := Cmd.Angle;
+
pragma Debug (O ("Do_Angle : angle changed to" & Cmd.Angle'Img));
end Do_Angle;
@@ -936,7 +982,9 @@
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Text_Drawing_Area: begin"));
- null; -- FIXME
+
+ Clear (Text_Area);
+
pragma Debug (O ("Do_Text_Drawing_Area: done"));
end Do_Clear_Text_Area;
@@ -947,8 +995,10 @@
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"));
@@ -962,7 +1012,9 @@
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Destroy: begin"));
+
Quit (Window);
+
pragma Debug (O ("Do_Destroy: done"));
end Do_Destroy;
@@ -973,6 +1025,7 @@
procedure Do_Draw_Circle_From_Current (Cmd : in out Command) is
begin
pragma Debug (O ("Do_Draw_Circle_From_Current: begin"));
+
Draw_Arc
(Get_Window (Drawing_Area),
Graphic_Context,
@@ -996,6 +1049,7 @@
2 * Gint (Cmd.Radius),
0,
360 * 64);
+
pragma Debug (O ("Do_Draw_Circle_From_Current: done"));
end Do_Draw_Circle_From_Current;
@@ -1006,6 +1060,7 @@
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,
@@ -1029,6 +1084,7 @@
2 * Gint (Cmd.Radius),
0,
360 * 64);
+
pragma Debug (O ("Do_Draw_Circle_From_Custom: done"));
end Do_Draw_Circle_From_Custom;
@@ -1072,6 +1128,7 @@
-- Deallocate the dynamic array
Free (Cmd.Edges);
+
pragma Debug (O ("Do_Draw_Polygon: done"));
end Do_Draw_Polygon;
@@ -1082,6 +1139,7 @@
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,
@@ -1101,6 +1159,7 @@
Height - Gint (Cmd.First_Y + Cmd.Height),
Gint (Cmd.Width),
Gint (Cmd.Height));
+
pragma Debug (O ("Do_Draw_Rectangle: done"));
end Do_Draw_Rectangle;
@@ -1111,6 +1170,7 @@
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,
@@ -1134,6 +1194,7 @@
2 * Gint (Cmd.Radius),
0,
360 * 64);
+
pragma Debug (O ("Do_Fill_Circle_From_Current: done"));
end Do_Fill_Circle_From_Current;
@@ -1144,6 +1205,7 @@
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,
@@ -1167,6 +1229,7 @@
2 * Gint (Cmd.Radius),
0,
360 * 64);
+
pragma Debug (O ("Do_Fill_Circle_From_Custom: done"));
end Do_Fill_Circle_From_Custom;
@@ -1180,7 +1243,7 @@
-- 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 = "
+ pragma Debug (O ("Do_Draw_Polygon: Number of edges = "
& Points'Length'Img));
-- Fill the polygon edges
@@ -1210,6 +1273,7 @@
-- Deallocate the dynamic array
Free (Cmd.Edges);
+
pragma Debug (O ("Do_Fill_Polygon: done"));
end Do_Fill_Polygon;
@@ -1220,6 +1284,7 @@
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,
@@ -1239,6 +1304,7 @@
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;
@@ -1251,8 +1317,12 @@
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Get_Immediate_Character: begin"));
- null; -- FIXME
- pragma Debug (O ("Do_Get_Immediate_Character: done"));
+
+ Enable_Prompt_Display (Text_Area, True);
+ Set_Immediate_Mode (Text_Area, True);
+ Current_Waited_Response := R_Immediate;
+
+ pragma Debug (O ("Do_Get_Immediate_Character: waiting..."));
end Do_Get_Immediate_Character;
------------------------
@@ -1263,7 +1333,10 @@
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Get_Line_String: begin"));
- null; -- FIXME
+
+ Enable_Prompt_Display (Text_Area, True);
+ Current_Waited_Response := R_Console;
+
pragma Debug (O ("Do_Get_Line_String: done"));
end Do_Get_Line_String;
@@ -1275,22 +1348,12 @@
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;
- -------------------
- -- Do_Get_String --
- -------------------
-
- procedure Do_Get_String (Cmd : in out Command) is
- pragma Unreferenced (Cmd);
- begin
- pragma Debug (O ("Do_Get_String: begin"));
- null; -- FIXME
- pragma Debug (O ("Do_Get_String: end"));
- end Do_Get_String;
-
--------------
-- Do_Image --
--------------
@@ -1439,8 +1502,10 @@
procedure Do_Jump_With_End (Cmd : in out Command) is
begin
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 & ")"));
@@ -1475,7 +1540,9 @@
Y_End : constant Float := Cmd.Y_End;
begin
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;
@@ -1490,7 +1557,9 @@
Y_End : constant Float := Brush_Y + Cmd.Distance * Sin (Angle, 360.0);
begin
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;
@@ -1505,7 +1574,9 @@
Y_End : constant Float := Cmd.Y_End;
begin
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;
@@ -1522,7 +1593,9 @@
+ Cmd.Distance * Sin (Angle, 360.0);
begin
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;
@@ -1531,10 +1604,11 @@
-----------------
procedure Do_New_Line (Cmd : in out Command) is
- pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_New_Line: begin"));
- null; -- FIXME
+
+ Insert (Text_Area, "", Cmd.N_Lines);
+
pragma Debug (O ("Do_New_Line: done"));
end Do_New_Line;
@@ -1560,6 +1634,7 @@
Graphic_Context,
Gint (Brush_X),
Height - Gint (Brush_Y));
+
pragma Debug (O ("Do_Point_Current: done"));
end Do_Point_Current;
@@ -1592,10 +1667,11 @@
----------------------
procedure Do_Put_Character (Cmd : in out Command) is
- pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Put_Character: begin"));
- null; -- FIXME
+
+ Insert (Text_Area, (1 => Cmd.Char), 0);
+
pragma Debug (O ("Do_Put_Character: done"));
end Do_Put_Character;
@@ -1604,10 +1680,11 @@
---------------------------
procedure Do_Put_Line_Character (Cmd : in out Command) is
- pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Put_Line_Character: begin"));
- null; -- FIXME
+
+ Insert (Text_Area, (1 => Cmd.Char), 1);
+
pragma Debug (O ("Do_Put_Line_Character: done"));
end Do_Put_Line_Character;
@@ -1616,10 +1693,15 @@
------------------------
procedure Do_Put_Line_String (Cmd : in out Command) is
- pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Put_Line_String: begin"));
- null; -- FIXME
+
+ Insert (Text_Area, Cmd.Str.all, 1);
+
+ -- Deallocate string
+
+ Free (Cmd.Str);
+
pragma Debug (O ("Do_Put_Line_String: done"));
end Do_Put_Line_String;
@@ -1628,10 +1710,15 @@
-------------------
procedure Do_Put_String (Cmd : in out Command) is
- pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Put_String: begin"));
- null; -- FIXME
+
+ Insert (Text_Area, Cmd.Str.all, 0);
+
+ -- Deallocate string
+
+ Free (Cmd.Str);
+
pragma Debug (O ("Do_Put_String: done"));
end Do_Put_String;
@@ -1643,8 +1730,9 @@
pragma Unreferenced (Cmd);
begin
pragma Debug (O ("Do_Rafresh: begin"));
+
Draw (Drawing_Area);
- -- FIXME: Rafresh text area?
+
pragma Debug (O ("Do_Rafresh: done"));
end Do_Rafresh;
@@ -1655,7 +1743,9 @@
procedure Do_Rotate (Cmd : in out Command) is
begin
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;
@@ -1683,13...
[truncated message content] |
|
From: <bec...@us...> - 2006-12-01 19:43:11
|
Revision: 25
http://svn.sourceforge.net/gtkada-wrapper/?rev=25&view=rev
Author: bechir_zalila
Date: 2006-12-01 11:43:10 -0800 (Fri, 01 Dec 2006)
Log Message:
-----------
* Implemented image insertion and added an example to test it
Modified Paths:
--------------
trunk/TODO
trunk/configure.ac
trunk/examples/Makefile.am
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
Added Paths:
-----------
trunk/examples/image/
trunk/examples/image/Kubuntu-edgy.png
trunk/examples/image/Makefile.am
trunk/examples/image/image.adb
trunk/examples/image/image.gpr
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-30 20:53:52 UTC (rev 24)
+++ trunk/TODO 2006-12-01 19:43:10 UTC (rev 25)
@@ -1,5 +1,4 @@
/src:
- * Implement image insertion
* Implement Text area
/doc:
Modified: trunk/configure.ac
===================================================================
--- trunk/configure.ac 2006-11-30 20:53:52 UTC (rev 24)
+++ trunk/configure.ac 2006-12-01 19:43:10 UTC (rev 25)
@@ -89,6 +89,7 @@
examples/empty_window/Makefile
examples/basic_drawings/Makefile
examples/fractal/Makefile
+ examples/image/Makefile
src/Makefile
])
Modified: trunk/examples/Makefile.am
===================================================================
--- trunk/examples/Makefile.am 2006-11-30 20:53:52 UTC (rev 24)
+++ trunk/examples/Makefile.am 2006-12-01 19:43:10 UTC (rev 25)
@@ -1 +1 @@
-SUBDIRS = empty_window basic_drawings fractal
+SUBDIRS = empty_window basic_drawings fractal image
Added: trunk/examples/image/Kubuntu-edgy.png
===================================================================
(Binary files differ)
Property changes on: trunk/examples/image/Kubuntu-edgy.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: trunk/examples/image/Makefile.am
===================================================================
--- trunk/examples/image/Makefile.am (rev 0)
+++ trunk/examples/image/Makefile.am 2006-12-01 19:43:10 UTC (rev 25)
@@ -0,0 +1,5 @@
+include ../Makefile.common
+
+PROJECT_FILE = $(srcdir)/image.gpr
+SOURCES = $(srcdir)/image.adb
+
Added: trunk/examples/image/image.adb
===================================================================
--- trunk/examples/image/image.adb (rev 0)
+++ trunk/examples/image/image.adb 2006-12-01 19:43:10 UTC (rev 25)
@@ -0,0 +1,39 @@
+-- $Id$
+-- Copyright (C) 2006 Bechir Zalila <bec...@en...>
+-- See COPYING file for license
+
+-- This example, creates an empty default main window then exits
+
+with Gtkada_Wrapper; use Gtkada_Wrapper;
+
+with Ada.Text_IO;
+
+procedure Image is
+ X : Float;
+ Y : Float;
+ Button : Natural;
+begin
+ Create_Main_Window (600.0, 600.0);
+
+ -- Insert a non scaled image
+
+ Jump (25.0, 500.0);
+ Insert_Image ("Kubuntu-edgy.png", 1.0, Left, Top);
+
+ -- Insert an increased image
+
+ Jump (25.0, 350.0);
+ Insert_Image ("Kubuntu-edgy.png", 1.2, Left, Top);
+
+ -- Insert a reduced image
+
+ Jump (25.0, 200.0);
+ Insert_Image ("Kubuntu-edgy.png", 0.75, Left, Top);
+
+ 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 Image;
Property changes on: trunk/examples/image/image.adb
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/examples/image/image.gpr
===================================================================
--- trunk/examples/image/image.gpr (rev 0)
+++ trunk/examples/image/image.gpr 2006-12-01 19:43:10 UTC (rev 25)
@@ -0,0 +1,10 @@
+with "../../src/gtkada_wrapper.gpr";
+
+project Image is
+ for main use ("image.adb");
+
+ Build : GTKAda_Wrapper.Build_Type := External ("BUILD", "debug");
+
+ package Compiler renames GTKAda_Wrapper.Compiler;
+ package Binder renames GTKAda_Wrapper.Binder;
+end Image;
Property changes on: trunk/examples/image/image.gpr
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-30 20:53:52 UTC (rev 24)
+++ trunk/src/gtkada_wrapper.adb 2006-12-01 19:43:10 UTC (rev 25)
@@ -9,14 +9,17 @@
with GNAT.Table;
with Glib; use Glib;
+with Glib.Error; use Glib.Error;
with Gdk.Color; use Gdk.Color;
with Gdk.Types; use Gdk.Types;
with Gdk.Event; use Gdk.Event;
with Gdk.Font; use Gdk.Font;
+with Gdk.Rgb; use Gdk.Rgb;
with Gdk.Pixmap; use Gdk.Pixmap;
with Gdk.Window; use Gdk.Window;
with Gdk.Drawable; use Gdk.Drawable;
+with Gdk.Pixbuf; use Gdk.Pixbuf;
with Gdk.Rectangle; use Gdk.Rectangle;
with Gdk.GC; use Gdk.GC;
@@ -32,7 +35,7 @@
with Protected_Queue;
-pragma Debug_Policy (Ignore);
+pragma Debug_Policy (Check);
-- To control the debug message display: 'Ignore' Or 'Check'
package body Gtkada_Wrapper is
@@ -1293,10 +1296,139 @@
--------------
procedure Do_Image (Cmd : in out Command) is
- pragma Unreferenced (Cmd);
+
+ procedure Read_Image (Pixbuf : in out Gdk_Pixbuf);
+ -- Loads an imge from the command file and allocate a
+ -- Gdk_Pixbuf.
+
+ function Scale (Dimension : Gint) return Gint;
+ -- Returns Dimension * Cmd.Scale
+
+ ----------------
+ -- Read_Image --
+ ----------------
+
+ procedure Read_Image (Pixbuf : in out Gdk_Pixbuf) is
+ Error : GError;
+ begin
+ pragma Debug (O ("Loading image " & Cmd.File_Name.all));
+
+ Gdk_New_From_File (Pixbuf, Cmd.File_Name.all, Error);
+
+ if Error /= null then
+ declare
+ Msg : constant String := Get_Message (Error);
+ begin
+ Error_Free (Error);
+ Unref (Pixbuf);
+
+ raise Program_Error with "Error in loading image: " & Msg;
+ end;
+ end if;
+
+ pragma Debug (O ("Loading image " & Cmd.File_Name.all & ": done"));
+ end Read_Image;
+
+ -----------
+ -- Scale --
+ -----------
+
+ function Scale (Dimension : Gint) return Gint is
+ begin
+ return Gint (Float (Dimension) * Cmd.Scale);
+ end Scale;
+
+ Scaled_Image_Pixbuf : Gdk_Pixbuf;
+ Original_Image_Pixbuf : Gdk_Pixbuf;
+ X_Pix : Gint;
+ Y_Pix : Gint;
begin
pragma Debug (O ("Do_Image: begin"));
- null; -- FIXME
+
+ -- Load the image and scale it if necessary
+
+ if Cmd.Scale = 1.0 then
+ Read_Image (Scaled_Image_Pixbuf);
+ else
+ Read_Image (Original_Image_Pixbuf);
+
+ -- Apply scale
+
+ Scaled_Image_Pixbuf := Scale_Simple
+ (Original_Image_Pixbuf,
+ Scale (Get_Width (Original_Image_Pixbuf)),
+ Scale (Get_Height (Original_Image_Pixbuf)));
+
+ -- Deallocate the original buffer
+
+ Unref (Original_Image_Pixbuf);
+ end if;
+
+ -- Handle justification
+
+ case Cmd.X_Justify is
+ when Left =>
+ X_Pix := Gint (Brush_X);
+
+ when Center =>
+ X_Pix := Gint (Brush_X) - Get_Width (Scaled_Image_Pixbuf) / 2;
+
+ when Right =>
+ X_Pix := Gint (Brush_X) - Get_Width (Scaled_Image_Pixbuf);
+ end case;
+
+ case Cmd.Y_Justify is
+ when Top =>
+ Y_Pix := Height - Gint (Brush_Y);
+
+ when Center =>
+ Y_Pix := Height -
+ Gint (Brush_Y) -
+ Get_Height (Scaled_Image_Pixbuf) / 2;
+
+ when Bottom =>
+ Y_Pix := Height -
+ Gint (Brush_Y) -
+ Get_Height (Scaled_Image_Pixbuf);
+ end case;
+
+ -- Drawing the image
+
+ Render_To_Drawable
+ (Scaled_Image_Pixbuf,
+ Get_Window (Drawing_Area),
+ Graphic_Context,
+ 0,
+ 0,
+ X_Pix,
+ Y_Pix,
+ Get_Width (Scaled_Image_Pixbuf),
+ Get_Height (Scaled_Image_Pixbuf),
+ Dither_Normal,
+ 0,
+ 0);
+
+ -- Backup
+
+ Render_To_Drawable
+ (Scaled_Image_Pixbuf,
+ Pixmap,
+ Graphic_Context,
+ 0,
+ 0,
+ X_Pix,
+ Y_Pix,
+ Get_Width (Scaled_Image_Pixbuf),
+ Get_Height (Scaled_Image_Pixbuf),
+ Dither_Normal,
+ 0,
+ 0);
+
+ -- Deallocate the scaled buffer and the file name
+
+ Unref (Scaled_Image_Pixbuf);
+ Free (Cmd.File_Name);
+
pragma Debug (O ("Do_Image: done"));
end Do_Image;
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-30 20:53:52 UTC (rev 24)
+++ trunk/src/gtkada_wrapper.ads 2006-12-01 19:43:10 UTC (rev 25)
@@ -160,6 +160,9 @@
-- location. This will draw any graphic that Gtk understands,
-- including JPEG, GIF, BMP, PNG, PBM, TIFF, and perhaps some
-- others.
+ -- IMPORTANT NOTE: If the given path to the image is a relative
+ -- path, the image location is calculated relatively to the
+ -- working directory.
procedure Insert_Text
(Text : String;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-11-30 20:53:52
|
Revision: 24
http://svn.sourceforge.net/gtkada-wrapper/?rev=24&view=rev
Author: bechir_zalila
Date: 2006-11-30 12:53:52 -0800 (Thu, 30 Nov 2006)
Log Message:
-----------
* Implementation of text insertion on the drawing area
Modified Paths:
--------------
trunk/TODO
trunk/examples/basic_drawings/basic_drawings.adb
trunk/examples/fractal/fractal.adb
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-30 18:50:56 UTC (rev 23)
+++ trunk/TODO 2006-11-30 20:53:52 UTC (rev 24)
@@ -1,5 +1,4 @@
/src:
- * Implement text display on the drawing area
* Implement image insertion
* Implement Text area
Modified: trunk/examples/basic_drawings/basic_drawings.adb
===================================================================
--- trunk/examples/basic_drawings/basic_drawings.adb 2006-11-30 18:50:56 UTC (rev 23)
+++ trunk/examples/basic_drawings/basic_drawings.adb 2006-11-30 20:53:52 UTC (rev 24)
@@ -28,6 +28,21 @@
begin
Create_Main_Window;
+ Set_Color (Red);
+ Jump (100.0, 400.0);
+
+ Set_Color (Red);
+ Insert_Text ("Basic Drawings", 10.0, Right, Center);
+
+ Jump (100.0, 350.0);
+ Set_Color (Pink);
+ Insert_Text ("Basic Drawings", 15.0, Center, Center);
+
+ Jump (100.0, 300.0);
+ Set_Color (Gray);
+ Insert_Text ("Basic Drawings", 20.0, Left, Center);
+
+ Jump (250.0, 250.0);
Set_Thickness (15.0);
Set_Angle (0.0);
Modified: trunk/examples/fractal/fractal.adb
===================================================================
--- trunk/examples/fractal/fractal.adb 2006-11-30 18:50:56 UTC (rev 23)
+++ trunk/examples/fractal/fractal.adb 2006-11-30 20:53:52 UTC (rev 24)
@@ -38,8 +38,11 @@
begin
Create_Main_Window;
- Set_Color (Red);
+ Set_Color (Orange);
+ Jump (250.0, 250.0);
+ Insert_Text ("Fractal", 30.0, Center, Center);
+ Set_Color (Blue);
Draw_Fractal (150.0, 100.0, 350.0, 400.0);
Draw_Fractal (350.0, 400.0, 150.0, 100.0);
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-30 18:50:56 UTC (rev 23)
+++ trunk/src/gtkada_wrapper.adb 2006-11-30 20:53:52 UTC (rev 24)
@@ -13,6 +13,7 @@
with Gdk.Color; use Gdk.Color;
with Gdk.Types; use Gdk.Types;
with Gdk.Event; use Gdk.Event;
+with Gdk.Font; use Gdk.Font;
with Gdk.Pixmap; use Gdk.Pixmap;
with Gdk.Window; use Gdk.Window;
with Gdk.Drawable; use Gdk.Drawable;
@@ -189,7 +190,6 @@
type String_Ptr is access all String;
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
@@ -1533,10 +1533,76 @@
-------------
procedure Do_Text (Cmd : in out Command) is
- pragma Unreferenced (Cmd);
+ Font : Gdk_Font;
+ Pt_Size_Str : constant String := Natural (Cmd.Size)'Img;
+ X_Pix : Gint;
+ Y_Pix : Gint;
+ Lb : Gint;
+ Rb : Gint;
+ Width : Gint;
+ Asc : Gint;
+ Desc : Gint;
+ Font_Name : constant String := "-*-helvetica-*-r-*-*-"
+ & Pt_Size_Str (2 .. Pt_Size_Str'Last)
+ & "-*-*-*-*-*-*-*";
begin
pragma Debug (O ("Do_Text: begin"));
- null; -- FIXME
+
+ -- Load a font with the given size
+
+ pragma Debug (O ("Loading font " & Font_Name));
+ Load (Font, Font_Name);
+ pragma Debug (O ("Font " & Font_Name & " loaded"));
+
+ -- Get the string metrics to align it properly
+
+ pragma Debug (O ("Get text metrics"));
+ String_Extents (Font, Cmd.Text.all, Lb, Rb, Width, Asc, Desc);
+ pragma Debug (O ("Text metrics Got"));
+
+ case Cmd.X_Justify is
+ when Left =>
+ X_Pix := Gint (Brush_X);
+
+ when Center =>
+ X_Pix := Gint (Brush_X) - Width / 2;
+
+ when Right =>
+ X_Pix := Gint (Brush_X) - Width;
+ end case;
+
+ case Cmd.Y_Justify is
+ when Bottom =>
+ Y_Pix := Height - Gint (Brush_Y) - Desc;
+
+ when Center =>
+ Y_Pix := Height - Gint (Brush_Y) + Asc / 2;
+
+ when Top =>
+ Y_Pix := Height - Gint (Brush_Y) + Asc;
+ end case;
+
+ -- Draw the aligned text
+
+ Draw_Text (Get_Window (Drawing_Area),
+ Font,
+ Graphic_Context,
+ X_Pix,
+ Y_Pix,
+ Cmd.Text.all);
+
+ -- Backup
+
+ Draw_Text (Pixmap,
+ Font,
+ Graphic_Context,
+ X_Pix,
+ Y_Pix,
+ Cmd.Text.all);
+
+ -- Deallocate the text
+
+ Free (Cmd.Text);
pragma Debug (O ("Do_Text: done"));
end Do_Text;
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-30 18:50:56 UTC (rev 23)
+++ trunk/src/gtkada_wrapper.ads 2006-11-30 20:53:52 UTC (rev 24)
@@ -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 colors 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;
@@ -167,7 +167,7 @@
X_Justification : X_Justification_Type := Center;
Y_Justification : Y_Justification_Type := Center);
-- Draw a text string justified at the virtual brush's current
- -- location. The size is expressed in points.
+ -- location. The size is expressed in pixels.
procedure Draw_Circle (Radius : Float);
-- Draw a circle with radius 'Radius' and with the center at the
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-11-30 18:50:56
|
Revision: 23
http://svn.sourceforge.net/gtkada-wrapper/?rev=23&view=rev
Author: bechir_zalila
Date: 2006-11-30 10:50:56 -0800 (Thu, 30 Nov 2006)
Log Message:
-----------
* Renamed Spot into Point, removed the radius from points since
Fill_Circle does this job now and addad a custom Point procedure
that draws a point at the position given as parameter.
Modified Paths:
--------------
trunk/TODO
trunk/examples/basic_drawings/basic_drawings.adb
trunk/examples/fractal/fractal.adb
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-29 22:48:53 UTC (rev 22)
+++ trunk/TODO 2006-11-30 18:50:56 UTC (rev 23)
@@ -1,6 +1,5 @@
/src:
* Implement text display on the drawing area
- * Implement a custom 'Spot'
* Implement image insertion
* Implement Text area
Modified: trunk/examples/basic_drawings/basic_drawings.adb
===================================================================
--- trunk/examples/basic_drawings/basic_drawings.adb 2006-11-29 22:48:53 UTC (rev 22)
+++ trunk/examples/basic_drawings/basic_drawings.adb 2006-11-30 18:50:56 UTC (rev 23)
@@ -39,16 +39,18 @@
Set_Color (My_Color_1);
Jump (50.0, 50.0);
- Spot (20.0);
+ Fill_Circle (20.0);
Get_Mouse_Pointer (X, Y, Button);
Jump (100.0, 100.0);
- Spot (10.0);
+ Fill_Circle (10.0);
Set_Color (My_Color_2);
Jump (100.0, 400.0);
- Spot (10.0);
+ Fill_Circle (10.0);
+ Point;
+ Point (500.0, 500.0);
Set_Color (My_Color_2);
Set_Thickness (8.0);
Modified: trunk/examples/fractal/fractal.adb
===================================================================
--- trunk/examples/fractal/fractal.adb 2006-11-29 22:48:53 UTC (rev 22)
+++ trunk/examples/fractal/fractal.adb 2006-11-30 18:50:56 UTC (rev 23)
@@ -10,6 +10,8 @@
procedure Fractal is
+ N_Points : Natural := 0;
+
procedure Draw_Fractal (X1, Y1, X2, Y2 : in Float);
-- Draw a fractal recursively
@@ -23,7 +25,8 @@
begin
if abs (X1 - X2) > 1.0 or abs (Y1 - Y2) > 1.0 then
Jump (X1, Y1);
- Spot;
+ Point;
+ N_Points := N_Points + 1;
Draw_Fractal (X1, Y1, X3, Y3);
Draw_Fractal (X3, Y3, X2, Y2);
end if;
@@ -35,9 +38,13 @@
begin
Create_Main_Window;
+ Set_Color (Red);
+
Draw_Fractal (150.0, 100.0, 350.0, 400.0);
Draw_Fractal (350.0, 400.0, 150.0, 100.0);
+ Ada.Text_IO.Put_Line ("Drawn" & N_Points'Img & " points.");
+
Get_Mouse_Pointer (X, Y, Button);
Ada.Text_IO.Put_Line ("Got Click:");
Ada.Text_IO.Put_Line (" X = " & X'Img);
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-29 22:48:53 UTC (rev 22)
+++ trunk/src/gtkada_wrapper.adb 2006-11-30 18:50:56 UTC (rev 23)
@@ -171,7 +171,8 @@
A_Fill_Rectangle,
A_Draw_Polygon,
A_Fill_Polygon,
- A_Spot,
+ A_Point_Current,
+ A_Point_Custom,
A_Image,
A_Text,
A_Rafresh,
@@ -204,6 +205,7 @@
| A_Reset_Handler
| A_Destroy
| A_Clear_Drawing_Area
+ | A_Point_Current
| A_Rafresh
| A_Clear_Text_Area
| A_Get_String
@@ -252,23 +254,25 @@
null;
end case;
- when A_Spot
+ when A_Point_Custom
| A_Draw_Circle_From_Current
| A_Draw_Circle_From_Custom
| A_Fill_Circle_From_Current
| A_Fill_Circle_From_Custom =>
-
Radius : Float;
+ -- This component is not necessary for A_Point_Custom,
+ -- but we cannot factorize more.
- case Action is
- when A_Draw_Circle_From_Custom
+ case Action is
+ when A_Point_Custom
+ | A_Draw_Circle_From_Custom
| A_Fill_Circle_From_Custom =>
Center_X : Float;
Center_Y : Float;
when others =>
null;
- end case;
+ end case;
when A_Image | A_Text =>
X_Justify : X_Justification_Type;
@@ -332,7 +336,8 @@
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_Point_Current (Cmd : in out Command);
+ procedure Do_Point_Custom (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);
@@ -385,7 +390,8 @@
A_Rafresh => Do_Rafresh'Access,
A_Reset_Handler => null,
A_Rotate => Do_Rotate'Access,
- A_Spot => Do_Spot'Access,
+ A_Point_Current => Do_Point_Current'Access,
+ A_Point_Custom => Do_Point_Custom'Access,
A_Text => Do_Text'Access,
A_Thickness => Do_Thickness'Access);
@@ -1401,6 +1407,55 @@
end Do_New_Line;
----------------------
+ -- Do_Point_Current --
+ ----------------------
+
+ procedure Do_Point_Current (Cmd : in out Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ pragma Debug (O ("Do_Point_Current: begin"));
+
+ Draw_Point
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ Gint (Brush_X),
+ Height - Gint (Brush_Y));
+
+ -- Backup
+
+ Draw_Point
+ (Pixmap,
+ Graphic_Context,
+ Gint (Brush_X),
+ Height - Gint (Brush_Y));
+ pragma Debug (O ("Do_Point_Current: done"));
+ end Do_Point_Current;
+
+ ---------------------
+ -- Do_Point_Custom --
+ ---------------------
+
+ procedure Do_Point_Custom (Cmd : in out Command) is
+ begin
+ pragma Debug (O ("Do_Point_Custom: begin"));
+
+ Draw_Point
+ (Get_Window (Drawing_Area),
+ Graphic_Context,
+ Gint (Cmd.Center_X),
+ Height - Gint (Cmd.Center_Y));
+
+ -- Backup
+
+ Draw_Point
+ (Pixmap,
+ Graphic_Context,
+ Gint (Cmd.Center_X),
+ Height - Gint (Cmd.Center_Y));
+ pragma Debug (O ("Do_Point_Custom: done"));
+ end Do_Point_Custom;
+
+ ----------------------
-- Do_Put_Character --
----------------------
@@ -1474,43 +1529,6 @@
end Do_Rotate;
-------------
- -- Do_Spot --
- -------------
-
- procedure Do_Spot (Cmd : in out Command) is
- begin
- pragma Debug (O ("Do_Spot: 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 ("Drawn a spot of radius" & Cmd.Radius'Img & " at "
- & "(" & Brush_X'Img & ", " & Brush_Y'Img & ")"));
- pragma Debug (O ("Do_Spot: done"));
- end Do_Spot;
-
- -------------
-- Do_Text --
-------------
@@ -2033,6 +2051,33 @@
Ada.Text_IO.Put_Line (Message);
end O;
+ -----------
+ -- Point --
+ -----------
+
+ procedure Point is
+ begin
+ Assert_Main_Window_Exits;
+ pragma Debug (O ("Point from current : begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Point_Current));
+ pragma Debug (O ("Point from current : enqueued"));
+ end Point;
+
+ -----------
+ -- Point --
+ -----------
+
+ procedure Point (Center_X : Float; Center_Y : Float) is
+ begin
+ Assert_Main_Window_Exits;
+ pragma Debug (O ("Point from custom : begin"));
+ Command_Queue.Enqueue (Command'(Action => A_Point_Custom,
+ Center_X => Center_X,
+ Center_Y => Center_Y,
+ Radius => 0.0)); -- Dummy
+ pragma Debug (O ("Point from custom : enqueued"));
+ end Point;
+
---------
-- Put --
---------
@@ -2211,20 +2256,6 @@
pragma Debug (O ("Set_Thickness : enqueued"));
end Set_Thickness;
- ----------
- -- Spot --
- ----------
-
- procedure Spot (Radius : Float := 1.0) is
- 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 --
------------------
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-29 22:48:53 UTC (rev 22)
+++ trunk/src/gtkada_wrapper.ads 2006-11-30 18:50:56 UTC (rev 23)
@@ -143,9 +143,12 @@
Y_End : Float);
-- Same as above, but with the Cartesian destination.
- procedure Spot (Radius : Float := 1.0);
- -- Draw a spot in the current position with the given radius
+ procedure Point;
+ -- Draw a Point in the current position
+ procedure Point (Center_X : Float; Center_Y : Float);
+ -- Same as above but with a custom position
+
type X_Justification_Type is (Left, Center, Right);
type Y_Justification_Type is (Top, Center, Bottom);
procedure Insert_Image
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
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.
|
|
From: <bec...@us...> - 2006-11-28 20:50:50
|
Revision: 21
http://svn.sourceforge.net/gtkada-wrapper/?rev=21&view=rev
Author: bechir_zalila
Date: 2006-11-28 12:50:50 -0800 (Tue, 28 Nov 2006)
Log Message:
-----------
* (gtkada_wrapper.ad?): Emproved considerably the rafresh mechanism.
Now we draw directly on the GDK components and we backup in the
pixmap.
Get_Mouse_Pointer now raises an exception if the window is closed
before the user gives the mouse click.
* (protected_queue.ad?) customized Number_Waiting
* (/examples/*): Removed useless call to refresh from the example
and test the immediate refreshing on basic_drawings.
Modified Paths:
--------------
trunk/TODO
trunk/examples/basic_drawings/basic_drawings.adb
trunk/examples/fractal/fractal.adb
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
trunk/src/protected_queue.adb
trunk/src/protected_queue.ads
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-27 21:18:02 UTC (rev 20)
+++ trunk/TODO 2006-11-28 20:50:50 UTC (rev 21)
@@ -2,7 +2,6 @@
* Implement fill color
* Implement forms
* Implement Text area
- * Get_Mouse_Pointer will block forever if the user closes the window
/doc:
* Write the documentation
Modified: trunk/examples/basic_drawings/basic_drawings.adb
===================================================================
--- trunk/examples/basic_drawings/basic_drawings.adb 2006-11-27 21:18:02 UTC (rev 20)
+++ trunk/examples/basic_drawings/basic_drawings.adb 2006-11-28 20:50:50 UTC (rev 21)
@@ -35,26 +35,31 @@
Set_Line_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);
Jump (50.0, 50.0);
Spot (20.0);
+ Get_Mouse_Pointer (X, Y, Button);
+
Jump (100.0, 100.0);
Spot (10.0);
+ Get_Mouse_Pointer (X, Y, Button);
+
Set_Line_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_Thickness (8.0);
Line (100.0, 100.0, 200.0, 400.0);
Line (100.0, 100.0, 100.0, 400.0);
- Rafresh;
-
Get_Mouse_Pointer (X, Y, Button);
Ada.Text_IO.Put_Line ("Got Click:");
Ada.Text_IO.Put_Line (" X = " & X'Img);
Modified: trunk/examples/fractal/fractal.adb
===================================================================
--- trunk/examples/fractal/fractal.adb 2006-11-27 21:18:02 UTC (rev 20)
+++ trunk/examples/fractal/fractal.adb 2006-11-28 20:50:50 UTC (rev 21)
@@ -38,8 +38,6 @@
Draw_Fractal (150.0, 100.0, 350.0, 400.0);
Draw_Fractal (350.0, 400.0, 150.0, 100.0);
- Rafresh;
-
Get_Mouse_Pointer (X, Y, Button);
Ada.Text_IO.Put_Line ("Got Click:");
Ada.Text_IO.Put_Line (" X = " & X'Img);
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-27 21:18:02 UTC (rev 20)
+++ trunk/src/gtkada_wrapper.adb 2006-11-28 20:50:50 UTC (rev 21)
@@ -112,7 +112,7 @@
-- The drawing area of the main window
Pixmap : Gdk_Pixmap;
- -- Pixmap usefult when rafreshing the drawing area
+ -- Pixmap useful when rafreshing the drawing area
package Color_Table is new GNAT.Table
(Gdk_Color, Color_Type, 1, 20, 10);
@@ -536,7 +536,8 @@
-------------------
task body Event_Handler is
- Cmd : Command;
+ Cmd : Command;
+ N_Wait_Rsp : Natural;
begin
loop
select
@@ -567,10 +568,20 @@
pragma Debug (O ("Event_Handler: done"));
end if;
end loop;
+ pragma Debug (O ("Resetting the event handler: firing"
+ &" all waiters for response"));
+ N_Wait_Rsp := Response_Queue.Number_Waiting
+ (Response_Queue.To_Dequeue);
+ for I in 1 .. N_Wait_Rsp loop
+ Response_Queue.Enqueue (Response'(Rsp_Kind => R_None));
+ end loop;
+
pragma Debug (O ("Resetting the event handler: emptying queues"));
+
Command_Queue.Clear;
Response_Queue.Clear;
+
pragma Debug (O ("Resetting the event handler: done"));
end loop;
end Event_Handler;
@@ -744,15 +755,15 @@
-- one. Free the original.
if Pixmap /= Null_Pixmap then
- Draw_Pixmap (New_Pixmap,
- Get_Fg_GC (Get_Style (Drawing_Area), State_Normal),
- Pixmap,
- 0,
- 0,
- 0,
- 0,
- Gint'Min (Width, New_Width),
- Gint'Min (Height, New_Height));
+ Draw_Drawable (New_Pixmap,
+ Get_Fg_GC (Get_Style (Drawing_Area), State_Normal),
+ Pixmap,
+ 0,
+ 0,
+ 0,
+ 0,
+ Gint'Min (Width, New_Width),
+ Gint'Min (Height, New_Height));
Gdk.Pixmap.Unref (Pixmap);
end if;
@@ -833,6 +844,16 @@
-- Redraw a white rectangle on the drawing area
+ Draw_Rectangle (Get_Window (Drawing_Area),
+ Get_White (Get_Style (Drawing_Area)),
+ True,
+ 0,
+ 0,
+ Width,
+ Height);
+
+ -- Backup
+
Draw_Rectangle (Pixmap,
Get_White (Get_Style (Drawing_Area)),
True,
@@ -1142,7 +1163,21 @@
procedure Do_Spot (Cmd : Command) is
begin
pragma Debug (O ("Do_Spot: 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,
@@ -1152,6 +1187,7 @@
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"));
@@ -1200,6 +1236,15 @@
begin
pragma Debug (O ("Draw_Line: begin"));
+ Draw_Line (Get_Window (Drawing_Area),
+ Graphic_Context,
+ Gint (X_Start),
+ Height - Gint (Y_Start),
+ Gint (X_End),
+ Height - Gint (Y_End));
+
+ -- Backup
+
Draw_Line (Pixmap,
Graphic_Context,
Gint (X_Start),
@@ -1226,17 +1271,18 @@
begin
pragma Debug (O ("Main window exposed: handling"));
- -- Restore screen from backing store pixmap
+ -- Restore the alterated zone of the drawing area from the
+ -- backup pixmap.
- Draw_Pixmap (Get_Window (Drawing_Area),
- Get_Fg_GC (Get_Style (Drawing_Area), State_Normal),
- Pixmap,
- Area.X,
- Area.Y,
- Area.X,
- Area.Y,
- Gint (Area.Width),
- Gint (Area.Height));
+ Draw_Drawable (Get_Window (Drawing_Area),
+ Get_Fg_GC (Get_Style (Drawing_Area), State_Normal),
+ Pixmap,
+ Area.X,
+ Area.Y,
+ Area.X,
+ Area.Y,
+ Gint (Area.Width),
+ Gint (Area.Height));
return True;
end Expose_Event;
@@ -1339,7 +1385,8 @@
Button := Rsp.Button;
when R_None =>
- raise Lost_Main_Window;
+ raise Lost_Main_Window with "Get_Mouse_Pointer: The main"
+ & " window have been closed and no click have been received";
when others =>
raise Program_Error;
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-27 21:18:02 UTC (rev 20)
+++ trunk/src/gtkada_wrapper.ads 2006-11-28 20:50:50 UTC (rev 21)
@@ -185,7 +185,8 @@
Button : out Natural);
-- Wait for a mous button action and stores the mouse pointer
-- coordinate in X and Y and the mouse button used to do the
- -- action.
+ -- action. If the user closes the windows before giving a mouse
+ -- click, 'Lost_Main_Window' will be raised.
---------------------------------
-- Text Area Specific Routines --
Modified: trunk/src/protected_queue.adb
===================================================================
--- trunk/src/protected_queue.adb 2006-11-27 21:18:02 UTC (rev 20)
+++ trunk/src/protected_queue.adb 2006-11-28 20:50:50 UTC (rev 21)
@@ -4,9 +4,6 @@
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
-
type Queue_Array_Type is array (1 .. Max_Length) of Element_Type;
-- The protected object that ensure concurrency safety
@@ -156,9 +153,9 @@
-- Number_Waiting --
--------------------
- function Number_Waiting return Natural is
+ function Number_Waiting (To : Waiting_Type := To_Dequeue)return Natural is
begin
- return The_Protected_Queue.Number_Waiting;
+ return The_Protected_Queue.Number_Waiting (To);
end Number_Waiting;
end Protected_Queue;
Modified: trunk/src/protected_queue.ads
===================================================================
--- trunk/src/protected_queue.ads 2006-11-27 21:18:02 UTC (rev 20)
+++ trunk/src/protected_queue.ads 2006-11-28 20:50:50 UTC (rev 21)
@@ -29,8 +29,10 @@
procedure Clear;
-- Delete all the elements of the queue
- function Number_Waiting return Natural;
+ type Waiting_Type is (To_Enqueue, To_Dequeue, To_Enqueue_Plus_Dequeue);
+ -- To choose which number of waiting task we want to get
+
+ function Number_Waiting (To : Waiting_Type := To_Dequeue) return Natural;
-- Return the number of tasks waiting on the queue entries
- -- (enqueuing and dequeuing).
end Protected_Queue;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-11-27 21:18:02
|
Revision: 20
http://svn.sourceforge.net/gtkada-wrapper/?rev=20&view=rev
Author: bechir_zalila
Date: 2006-11-27 13:18:02 -0800 (Mon, 27 Nov 2006)
Log Message:
-----------
* Debug message reformatting
Modified Paths:
--------------
trunk/src/gtkada_wrapper.adb
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-27 21:13:04 UTC (rev 19)
+++ trunk/src/gtkada_wrapper.adb 2006-11-27 21:18:02 UTC (rev 20)
@@ -527,7 +527,7 @@
Command_Queue.Enqueue (Command'(Action => A_Reset_Handler));
- pragma Debug (O ("Main windows task terminated"));
+ pragma Debug (O ("Main windows task reinitiated"));
end loop;
end Main_Window;
@@ -562,9 +562,9 @@
if Cmd.Action = A_Reset_Handler then
exit;
elsif Dispatch_Table (Cmd.Action) /= null then
- pragma Debug (O ("Main_Loop: executing command"));
+ pragma Debug (O ("Event_Handler: executing command"));
Dispatch_Table (Cmd.Action).all (Cmd);
- pragma Debug (O ("Main_Loop: done"));
+ pragma Debug (O ("Event_Handler: done"));
end if;
end loop;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-11-27 21:13:07
|
Revision: 19
http://svn.sourceforge.net/gtkada-wrapper/?rev=19&view=rev
Author: bechir_zalila
Date: 2006-11-27 13:13:04 -0800 (Mon, 27 Nov 2006)
Log Message:
-----------
* Minor reformatting
Modified Paths:
--------------
trunk/src/gtkada_wrapper.adb
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-27 21:12:21 UTC (rev 18)
+++ trunk/src/gtkada_wrapper.adb 2006-11-27 21:13:04 UTC (rev 19)
@@ -301,7 +301,7 @@
procedure Do_Get_Line_String (Cmd : Command);
procedure Do_Get_Immediate_Character (Cmd : Command);
- -- Dispatch table
+ -- Dispatch table
type Command_Proc_Type is access procedure (Cmd : Command);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-11-27 21:12:20
|
Revision: 18
http://svn.sourceforge.net/gtkada-wrapper/?rev=18&view=rev
Author: bechir_zalila
Date: 2006-11-27 13:12:21 -0800 (Mon, 27 Nov 2006)
Log Message:
-----------
* Minor reformatting
Modified Paths:
--------------
trunk/src/gtkada_wrapper.adb
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-27 21:05:51 UTC (rev 17)
+++ trunk/src/gtkada_wrapper.adb 2006-11-27 21:12:21 UTC (rev 18)
@@ -218,11 +218,11 @@
X_Start : Float;
Y_Start : Float;
- -- These 2 component are not necesary in the case of
+ -- These 2 components 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.
+ -- A_Line_With_Start_Length).
case Action is
when A_Jump_With_End
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-11-27 21:05:54
|
Revision: 17
http://svn.sourceforge.net/gtkada-wrapper/?rev=17&view=rev
Author: bechir_zalila
Date: 2006-11-27 13:05:51 -0800 (Mon, 27 Nov 2006)
Log Message:
-----------
* (configure.ac, examples/Makefile.am, examples/fractal/*): Added a
new example "fractal" to test the drawing speed.
* (TODO): Removed some resolve item and added some new ones.
* (gtkada_wrapper.ad?): Got rid of the Idle main loop mechanisme
which, when it has time delays is very slow and when not consumes
100% of CPU. Replaced the old mechanisme by and event handler
task which guarantees tha thread safety of th drawing. Used
terminate to control task termination.
Default fill color is black.
Defaul spot radius is 1.0.
* (gtkada_wrapper.gpr): Compile with -O3 in release mode.
Modified Paths:
--------------
trunk/TODO
trunk/configure.ac
trunk/examples/Makefile.am
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
trunk/src/gtkada_wrapper.gpr
Added Paths:
-----------
trunk/examples/fractal/
trunk/examples/fractal/Makefile.am
trunk/examples/fractal/README
trunk/examples/fractal/fractal.adb
trunk/examples/fractal/fractal.gpr
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-26 23:58:45 UTC (rev 16)
+++ trunk/TODO 2006-11-27 21:05:51 UTC (rev 17)
@@ -2,7 +2,7 @@
* Implement fill color
* Implement forms
* Implement Text area
- * Remove the Idle loop
+ * Get_Mouse_Pointer will block forever if the user closes the window
/doc:
* Write the documentation
Modified: trunk/configure.ac
===================================================================
--- trunk/configure.ac 2006-11-26 23:58:45 UTC (rev 16)
+++ trunk/configure.ac 2006-11-27 21:05:51 UTC (rev 17)
@@ -89,6 +89,7 @@
examples/Makefile
examples/empty_window/Makefile
examples/basic_drawings/Makefile
+ examples/fractal/Makefile
src/Makefile
])
Modified: trunk/examples/Makefile.am
===================================================================
--- trunk/examples/Makefile.am 2006-11-26 23:58:45 UTC (rev 16)
+++ trunk/examples/Makefile.am 2006-11-27 21:05:51 UTC (rev 17)
@@ -1 +1 @@
-SUBDIRS = empty_window basic_drawings
+SUBDIRS = empty_window basic_drawings fractal
Added: trunk/examples/fractal/Makefile.am
===================================================================
--- trunk/examples/fractal/Makefile.am (rev 0)
+++ trunk/examples/fractal/Makefile.am 2006-11-27 21:05:51 UTC (rev 17)
@@ -0,0 +1,5 @@
+include ../Makefile.common
+
+PROJECT_FILE = $(srcdir)/fractal.gpr
+SOURCES = $(srcdir)/fractal.adb
+
Added: trunk/examples/fractal/README
===================================================================
--- trunk/examples/fractal/README (rev 0)
+++ trunk/examples/fractal/README 2006-11-27 21:05:51 UTC (rev 17)
@@ -0,0 +1 @@
+This example test the speed of the drawing by building a fractal.
Added: trunk/examples/fractal/fractal.adb
===================================================================
--- trunk/examples/fractal/fractal.adb (rev 0)
+++ trunk/examples/fractal/fractal.adb 2006-11-27 21:05:51 UTC (rev 17)
@@ -0,0 +1,49 @@
+-- $Id$
+-- Copyright (C) 2006 Bechir Zalila <bec...@en...>
+-- See COPYING file for license
+
+-- This example tests some basic drawings using GTKAda Wrapper
+
+with Gtkada_Wrapper; use Gtkada_Wrapper;
+
+with Ada.Text_IO;
+
+procedure Fractal is
+
+ procedure Draw_Fractal (X1, Y1, X2, Y2 : in Float);
+ -- Draw a fractal recursively
+
+ ------------------
+ -- Draw_Fractal --
+ ------------------
+
+ procedure Draw_Fractal (X1, Y1, X2, Y2 : in Float) is
+ X3 : constant Float := (X1 + X2) / 2.0 - (Y2 - Y1) / 3.0;
+ Y3 : constant Float := (Y1 + Y2) / 2.0 + (X2 - X1) / 3.0;
+ begin
+ if abs (X1 - X2) > 1.0 or abs (Y1 - Y2) > 1.0 then
+ Jump (X1, Y1);
+ Spot;
+ Draw_Fractal (X1, Y1, X3, Y3);
+ Draw_Fractal (X3, Y3, X2, Y2);
+ end if;
+ end Draw_Fractal;
+
+ X : Float;
+ Y : Float;
+ Button : Natural;
+begin
+ Create_Main_Window;
+
+ Draw_Fractal (150.0, 100.0, 350.0, 400.0);
+ Draw_Fractal (350.0, 400.0, 150.0, 100.0);
+
+ Rafresh;
+
+ Get_Mouse_Pointer (X, Y, Button);
+ Ada.Text_IO.Put_Line ("Got Click:");
+ Ada.Text_IO.Put_Line (" X = " & X'Img);
+ Ada.Text_IO.Put_Line (" Y = " & Y'Img);
+ Ada.Text_IO.Put_Line (" Button = " & Button'Img);
+ Destroy_Main_Window;
+end Fractal;
Property changes on: trunk/examples/fractal/fractal.adb
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/examples/fractal/fractal.gpr
===================================================================
--- trunk/examples/fractal/fractal.gpr (rev 0)
+++ trunk/examples/fractal/fractal.gpr 2006-11-27 21:05:51 UTC (rev 17)
@@ -0,0 +1,10 @@
+with "../../src/gtkada_wrapper.gpr";
+
+project Fractal is
+ for main use ("fractal.adb");
+
+ Build : GTKAda_Wrapper.Build_Type := External ("BUILD", "debug");
+
+ package Compiler renames GTKAda_Wrapper.Compiler;
+ package Binder renames GTKAda_Wrapper.Binder;
+end Fractal;
Property changes on: trunk/examples/fractal/fractal.gpr
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-26 23:58:45 UTC (rev 16)
+++ trunk/src/gtkada_wrapper.adb 2006-11-27 21:05:51 UTC (rev 17)
@@ -39,7 +39,7 @@
procedure O (Message : String);
-- For debugging purpose
- procedure Quit (Window : access Gtk.Window.Gtk_Window_Record'Class);
+ procedure Quit (Win : access Gtk.Window.Gtk_Window_Record'Class);
-- Quit the main loop when the user closes the window
procedure Assert_Main_Window_Exits;
@@ -62,10 +62,6 @@
return Boolean;
-- Handler for the "button_press_event" signal of the drawing area
- function Main_Loop return Boolean;
- -- This is the main loop that handle the user commands. It is
- -- registered as an "Idle" function of the main window
-
function To_Gdk_Color (C : Color_Type) return Gdk_Color;
pragma Inline (To_Gdk_Color);
-- Convert user colors to GDK colors
@@ -92,10 +88,6 @@
Have_Text_Area : Boolean;
-- Properties of the main window
- Main_Loop_Id : Idle_Handler_Id;
- pragma Unreferenced (Main_Loop_Id);
- -- Id of the main loop function
-
Width : Gint;
Height : Gint;
-- Dimensions of the drawing and text areas
@@ -104,7 +96,7 @@
Brush_Y : Float := 0.0;
Angle : Float := 0.0;
Thickness : Float := 1.0;
- Line_Color : Color_Type := Red;
+ Line_Color : Color_Type := Black;
Fill_Color : Color_Type := White;
-- Properties of the virtual brush
@@ -159,6 +151,7 @@
type Action_Kind is
(A_None,
+ A_Reset_Handler, -- For internal use
A_Destroy,
A_Clear_Drawing_Area,
A_Line_Color,
@@ -196,6 +189,7 @@
type Command (Action : Action_Kind := A_None) is record
case Action is
when A_None
+ | A_Reset_Handler
| A_Destroy
| A_Clear_Drawing_Area
| A_Rafresh
@@ -307,6 +301,41 @@
procedure Do_Get_Line_String (Cmd : Command);
procedure Do_Get_Immediate_Character (Cmd : Command);
+ -- Dispatch table
+
+ type Command_Proc_Type is access procedure (Cmd : Command);
+
+ Dispatch_Table : constant array (Action_Kind) of Command_Proc_Type :=
+ (A_Angle => Do_Angle'Access,
+ A_Clear_Drawing_Area => Do_Clear_Drawing_Area'Access,
+ A_Clear_Text_Area => Do_Clear_Text_Area'Access,
+ A_Destroy => Do_Destroy'Access,
+ A_Fill_Color => Do_Fill_Color'Access,
+ A_Get_Immediate_Character => Do_Get_Immediate_Character'Access,
+ A_Get_Line_String => Do_Get_Line_String'Access,
+ A_Get_Mouse_Pointer => Do_Get_Mouse_Pointer'Access,
+ A_Get_String => Do_Get_String'Access,
+ A_Image => Do_Image'Access,
+ A_Jump_With_End => Do_Jump_With_End'Access,
+ A_Jump_With_Length => Do_Jump_With_Length'Access,
+ A_Line_Color => Do_Line_Color'Access,
+ A_Line_With_End => Do_Line_With_End'Access,
+ A_Line_With_Length => Do_Line_With_Length'Access,
+ A_Line_With_Start_End => Do_Line_With_Start_End'Access,
+ A_Line_With_Start_Length => Do_Line_With_Start_Length'Access,
+ A_New_Line => Do_New_Line'Access,
+ A_None => null,
+ A_Put_Character => Do_Put_Character'Access,
+ A_Put_Line_Character => Do_Put_Line_Character'Access,
+ A_Put_Line_String => Do_Put_Line_String'Access,
+ A_Put_String => Do_Put_String'Access,
+ A_Rafresh => Do_Rafresh'Access,
+ A_Reset_Handler => null,
+ A_Rotate => Do_Rotate'Access,
+ A_Spot => Do_Spot'Access,
+ A_Text => Do_Text'Access,
+ A_Thickness => Do_Thickness'Access);
+
-- The user command queue
package Command_Queue is new Protected_Queue (Command, 10000);
@@ -350,127 +379,202 @@
-- The main window is created by a task that is allocated on the
-- user demand.
- -- The main windows task type
+ Main_Window_Exists : Boolean := False;
+ -- Used to see whether the main exists or not
- task type Main_Window_Type;
- type Main_Window_Access is access all Main_Window_Type;
+ -- The main windows task
- -- The Main windows
+ task Main_Window is
+ entry Init;
+ -- After the call to this entry, a main windows is created
+ end Main_Window;
- Main_Window : Main_Window_Access;
+ -- The event handler task
- ----------------------
- -- Main_Window_Type --
- ----------------------
+ task Event_Handler is
+ entry Init;
+ -- After the call to this entry, the main venet handling loop
+ -- is started.
+ end Event_Handler;
- task body Main_Window_Type is
+ -----------------
+ -- Main_Window --
+ -----------------
+
+ task body Main_Window is
begin
- -- Initialize GTK
+ loop
+ select
+ accept Init do
+ Main_Window_Exists := True;
+ pragma Debug (O ("Main_Task.Init: done"));
+ end Init;
+ or
+ terminate;
+ end select;
- Gtk.Main.Init;
+ -- Initialize GTK
- -- Setup the main windows
+ Gtk.Main.Init;
- Gtk_New (Window, Window_Toplevel);
- Set_Title (Window, "GTKAda Wrapper");
- Set_Border_Width (Window, Border_Width => 5);
+ -- Setup the main windows
- -- When the window is destroyed, some work has to be done
+ Gtk_New (Window, Window_Toplevel);
+ Set_Title (Window, "GTKAda Wrapper");
+ Set_Border_Width (Window, Border_Width => 5);
- Main_Window_Handlers.Connect
- (Window,
- "destroy",
- Main_Window_Handlers.To_Marshaller (Quit'Access));
+ -- When the window is destroyed, some work has to be done
- -- Create the immediate window vertical box and adding it to
- -- the windows
+ Main_Window_Handlers.Connect
+ (Window,
+ "destroy",
+ Main_Window_Handlers.To_Marshaller (Quit'Access));
- Gtk_New_Vbox (VBox, Homogeneous => False, Spacing => 0);
- Add (Window, VBox);
+ -- Create the immediate window vertical box and adding it to
+ -- the windows.
- -- Create the horizontal paned and adding it to the box
+ Gtk_New_Vbox (VBox, Homogeneous => False, Spacing => 0);
+ Add (Window, VBox);
- Gtk_New_Hpaned (HPaned);
- Pack_Start (VBox, HPaned);
+ -- Create the horizontal paned and adding it to the box
- -- If the user requested a drawing area, create it and append
- -- it to the paned.
+ Gtk_New_Hpaned (HPaned);
+ Pack_Start (VBox, HPaned);
- if Have_Drawing_Area then
- Gtk_New (Drawing_Area);
- Size (Drawing_Area, Width, Height);
- Pack1 (HPaned, Drawing_Area, Resize => False, Shrink => False);
+ -- If the user requested a drawing area, create it and
+ -- append it to the paned.
- -- The only user event that may trigger the drawing area are
- -- mouse clicks and exposure evenets (to rafresh it).
+ if Have_Drawing_Area then
+ Gtk_New (Drawing_Area);
+ Size (Drawing_Area, Width, Height);
+ Pack1 (HPaned, Drawing_Area, Resize => False, Shrink => False);
- Set_Events (Drawing_Area, Exposure_Mask or Button_Press_Mask);
+ -- The only user event that may trigger the drawing area
+ -- are mouse clicks and exposure evenets (to rafresh it).
- Drawing_Area_Handlers.Connect
- (Widget => Drawing_Area,
- Name => "expose_event",
- Marsh => Drawing_Area_Handlers.To_Marshaller
- (Expose_Event'Access));
+ Set_Events (Drawing_Area, Exposure_Mask or Button_Press_Mask);
- Drawing_Area_Handlers.Connect
- (Widget => Drawing_Area,
- Name => "button_press_event",
- Marsh => Drawing_Area_Handlers.To_Marshaller
- (Button_Press_Event'Access));
+ Drawing_Area_Handlers.Connect
+ (Widget => Drawing_Area,
+ Name => "expose_event",
+ Marsh => Drawing_Area_Handlers.To_Marshaller
+ (Expose_Event'Access));
- -- Configure event is called when the window configuration
- -- is changed (moved, resized, became visible...)
+ Drawing_Area_Handlers.Connect
+ (Widget => Drawing_Area,
+ Name => "button_press_event",
+ Marsh => Drawing_Area_Handlers.To_Marshaller
+ (Button_Press_Event'Access));
- Drawing_Area_Handlers.Connect
- (Widget => Drawing_Area,
- Name => "configure_event",
- Marsh => Drawing_Area_Handlers.To_Marshaller
- (Configure_Event'Access));
- end if;
+ -- Configure event is called when the window
+ -- configuration is changed (moved, resized, became
+ -- visible...)
- -- If the user requested a text area, create it and append
- -- it to the paned.
+ Drawing_Area_Handlers.Connect
+ (Widget => Drawing_Area,
+ Name => "configure_event",
+ Marsh => Drawing_Area_Handlers.To_Marshaller
+ (Configure_Event'Access));
+ end if;
- if Have_Text_Area then
- null;
- end if;
+ -- If the user requested a text area, create it and append
+ -- it to the paned.
- -- Set the main loop function as "Idle"
+ if Have_Text_Area then
+ -- FIXME: Create text area
+ null;
+ end if;
- Main_Loop_Id := Idle_Add (Main_Loop'Access);
+ Show_All (Window);
- Show_All (Window);
+ -- It is necessary to set the graphic context *after*
+ -- showing the main window.
- -- It is necessary to set the graphic context *after* showing
- -- the main window.
+ if Have_Drawing_Area then
+ -- Create the graohic context (color, line width...)
- if Have_Drawing_Area then
- -- Create the graohic context (color, line width...)
+ Gdk_New (Graphic_Context, Get_Window (Drawing_Area));
- Gdk_New (Graphic_Context, Get_Window (Drawing_Area));
+ -- Initialize the current line styles
- -- Initialize the current line styles
+ Set_Line_Attributes (GC => Graphic_Context,
+ Line_Width => Gint (Thickness),
+ Line_Style => Line_Solid,
+ Cap_Style => Cap_Round,
+ Join_Style => Join_Round);
- Set_Line_Attributes (GC => Graphic_Context,
- Line_Width => Gint (Thickness),
- Line_Style => Line_Solid,
- Cap_Style => Cap_Round,
- Join_Style => Join_Round);
+ -- Allocate predefined colors
- -- Allocate predefined colors
+ Allocate_Colors;
- Allocate_Colors;
+ Set_Foreground (Graphic_Context, To_Gdk_Color (Line_Color));
+ Set_Background (Graphic_Context, To_Gdk_Color (Fill_Color));
+ end if;
- Set_Foreground (Graphic_Context, To_Gdk_Color (Line_Color));
- Set_Background (Graphic_Context, To_Gdk_Color (Fill_Color));
- end if;
+ -- Initialize the event handler task
- Gtk.Main.Main;
+ Event_Handler.Init;
- -- FIXME: Handle exit
+ -- Run the GTK main loop
- end Main_Window_Type;
+ Gtk.Main.Main;
+ -- The main loop ended, reset all the mechanism
+
+ Main_Window_Exists := False;
+
+ -- Reset the handler
+
+ Command_Queue.Enqueue (Command'(Action => A_Reset_Handler));
+
+ pragma Debug (O ("Main windows task terminated"));
+ end loop;
+ end Main_Window;
+
+ -------------------
+ -- Event_Handler --
+ -------------------
+
+ task body Event_Handler is
+ Cmd : Command;
+ begin
+ loop
+ select
+ accept Init do
+ -- Synchronize only
+
+ pragma Debug (O ("Event_Handler.Init: done"));
+ null;
+ end Init;
+ or
+ terminate;
+ end select;
+
+ -- Main local loop
+
+ loop
+ -- Block waiting for a new command
+
+ Cmd := Command_Queue.Dequeue;
+
+ -- Run the command if it is valid
+
+ if Cmd.Action = A_Reset_Handler then
+ exit;
+ elsif Dispatch_Table (Cmd.Action) /= null then
+ pragma Debug (O ("Main_Loop: executing command"));
+ Dispatch_Table (Cmd.Action).all (Cmd);
+ pragma Debug (O ("Main_Loop: done"));
+ end if;
+ end loop;
+
+ pragma Debug (O ("Resetting the event handler: emptying queues"));
+ Command_Queue.Clear;
+ Response_Queue.Clear;
+ pragma Debug (O ("Resetting the event handler: done"));
+ end loop;
+ end Event_Handler;
+
---------------------
-- Allocate_Colors --
---------------------
@@ -535,7 +639,7 @@
procedure Assert_Main_Window_Exits is
begin
- if Main_Window = null then
+ if not Main_Window_Exists then
raise Lost_Main_Window with "The main window does not exist";
end if;
end Assert_Main_Window_Exits;
@@ -673,11 +777,11 @@
Drawing_Area : Boolean := True)
is
begin
- if Main_Window /= null then
+ if Main_Window_Exists then
raise Program_Error with "The main windows already exists";
end if;
- pragma Debug (O ("Creating main window task"));
+ pragma Debug (O ("Initializing main window task"));
Width := Gint (X_Max);
Height := Gint (Y_Max);
@@ -688,9 +792,11 @@
Have_Drawing_Area := Drawing_Area;
Have_Text_Area := Text_Area;
- Main_Window := new Main_Window_Type;
+ -- Initialize main window task
- pragma Debug (O ("Main window task created"));
+ Main_Window.Init;
+
+ pragma Debug (O ("Main window task initialized"));
end Create_Main_Window;
-------------------------
@@ -1417,64 +1523,6 @@
pragma Debug (O ("Line with start and end : enqueued"));
end Line;
- -- Dispatch table
-
- type Command_Proc_Type is access procedure (Cmd : Command);
-
- Dispatch_Table : constant array (Action_Kind) of Command_Proc_Type :=
- (A_Angle => Do_Angle'Access,
- A_Clear_Drawing_Area => Do_Clear_Drawing_Area'Access,
- A_Clear_Text_Area => Do_Clear_Text_Area'Access,
- A_Destroy => Do_Destroy'Access,
- A_Fill_Color => Do_Fill_Color'Access,
- A_Get_Immediate_Character => Do_Get_Immediate_Character'Access,
- A_Get_Line_String => Do_Get_Line_String'Access,
- A_Get_Mouse_Pointer => Do_Get_Mouse_Pointer'Access,
- A_Get_String => Do_Get_String'Access,
- A_Image => Do_Image'Access,
- A_Jump_With_End => Do_Jump_With_End'Access,
- A_Jump_With_Length => Do_Jump_With_Length'Access,
- A_Line_Color => Do_Line_Color'Access,
- A_Line_With_End => Do_Line_With_End'Access,
- A_Line_With_Length => Do_Line_With_Length'Access,
- A_Line_With_Start_End => Do_Line_With_Start_End'Access,
- A_Line_With_Start_Length => Do_Line_With_Start_Length'Access,
- A_New_Line => Do_New_Line'Access,
- A_None => null,
- A_Put_Character => Do_Put_Character'Access,
- A_Put_Line_Character => Do_Put_Line_Character'Access,
- A_Put_Line_String => Do_Put_Line_String'Access,
- A_Put_String => Do_Put_String'Access,
- A_Rafresh => Do_Rafresh'Access,
- A_Rotate => Do_Rotate'Access,
- A_Spot => Do_Spot'Access,
- A_Text => Do_Text'Access,
- A_Thickness => Do_Thickness'Access);
-
- ---------------
- -- Main_Loop --
- ---------------
-
- function Main_Loop return Boolean is
- Cmd : Command;
- begin
- if Command_Queue.Length > 0 then
- Cmd := Command_Queue.Dequeue;
-
- if Dispatch_Table (Cmd.Action) /= null then
- pragma Debug (O ("Main_Loop: executing command"));
- Dispatch_Table (Cmd.Action).all (Cmd);
- pragma Debug (O ("Main_Loop: done"));
- end if;
- end if;
-
- -- Mark a small delay to not have 100% of CPU occupied
-
- delay 0.001;
-
- return True;
- end Main_Loop;
-
--------------
-- New_Line --
--------------
@@ -1554,8 +1602,8 @@
-- Quit --
----------
- procedure Quit (Window : access Gtk.Window.Gtk_Window_Record'Class) is
- pragma Unreferenced (Window);
+ procedure Quit (Win : access Gtk.Window.Gtk_Window_Record'Class) is
+ pragma Unreferenced (Win);
begin
Gtk.Main.Main_Quit;
pragma Debug (O ("Quit: done"));
@@ -1583,7 +1631,7 @@
Gdk_Col : Gdk_Color;
Position : Color_Type;
begin
- if Main_Window /= null then
+ if Main_Window_Exists then
raise Program_Error with "RGB must be calle BEFORE the"
& " creation of the main window";
end if;
@@ -1694,7 +1742,7 @@
-- Spot --
----------
- procedure Spot (Radius : Float := 4.0) is
+ procedure Spot (Radius : Float := 1.0) is
begin
Assert_Main_Window_Exits;
pragma Debug (O ("Spot : begin"));
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-26 23:58:45 UTC (rev 16)
+++ trunk/src/gtkada_wrapper.ads 2006-11-27 21:05:51 UTC (rev 17)
@@ -151,7 +151,7 @@
Y_End : Float);
-- Same as above, but with the Cartesian destination.
- procedure Spot (Radius : Float := 4.0);
+ procedure Spot (Radius : Float := 1.0);
-- Draw a spot in the current position with the given radius
type X_Justification_Type is (Left, Center, Right);
Modified: trunk/src/gtkada_wrapper.gpr
===================================================================
--- trunk/src/gtkada_wrapper.gpr 2006-11-26 23:58:45 UTC (rev 16)
+++ trunk/src/gtkada_wrapper.gpr 2006-11-27 21:05:51 UTC (rev 17)
@@ -23,7 +23,7 @@
"-fstack-check", "-gnatg");
when "release" =>
for Default_Switches ("Ada") use
- ("-g", "-O2", "-gnat05", "-gnatfy", "-gnatwae", "-gnatpn",
+ ("-g", "-O3", "-gnat05", "-gnatfy", "-gnatwae", "-gnatpn",
"-gnatg");
end case;
end Compiler;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
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.
|
|
From: <bec...@us...> - 2006-11-26 23:48:19
|
Revision: 15
http://svn.sourceforge.net/gtkada-wrapper/?rev=15&view=rev
Author: bechir_zalila
Date: 2006-11-26 15:48:18 -0800 (Sun, 26 Nov 2006)
Log Message:
-----------
* Fixed a bug in the color allocation. All color have to be
allocated at before the execution of the Gtk main loop.
* Finished the basic drawings examples
Modified Paths:
--------------
trunk/TODO
trunk/examples/basic_drawings/basic_drawings.adb
trunk/examples/basic_drawings/basic_drawings.gpr
trunk/examples/empty_window/empty_window.adb
trunk/examples/empty_window/empty_window.gpr
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-26 22:41:08 UTC (rev 14)
+++ trunk/TODO 2006-11-26 23:48:18 UTC (rev 15)
@@ -1,5 +1,6 @@
/src:
- * Implement custom colors
+ * Implement fill color
+ * Implement forms
* Implement Text area
* Remove the Idle loop
Modified: trunk/examples/basic_drawings/basic_drawings.adb
===================================================================
--- trunk/examples/basic_drawings/basic_drawings.adb 2006-11-26 22:41:08 UTC (rev 14)
+++ trunk/examples/basic_drawings/basic_drawings.adb 2006-11-26 23:48:18 UTC (rev 15)
@@ -4,7 +4,7 @@
-- This example tests some basic drawings using GTKAda Wrapper
-with GTKAda_Wrapper; use GTKAda_Wrapper;
+with Gtkada_Wrapper; use Gtkada_Wrapper;
with Ada.Text_IO;
@@ -22,6 +22,9 @@
Magenta,
Cyan,
Orange);
+
+ My_Color_1 : constant Color_Type := RGB (30000, 30000, 30000);
+ My_Color_2 : constant Color_Type := RGB (50000, 50000, 0);
begin
Create_Main_Window;
@@ -34,6 +37,22 @@
Rotate (45.0);
end loop;
+ Set_Line_Color (My_Color_1);
+ Jump (50.0, 50.0);
+ Spot (20.0);
+
+ Jump (100.0, 100.0);
+ Spot (10.0);
+
+ Set_Line_Color (My_Color_2);
+ Jump (100.0, 400.0);
+ Spot (10.0);
+
+ Set_Line_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);
+
Rafresh;
Get_Mouse_Pointer (X, Y, Button);
Modified: trunk/examples/basic_drawings/basic_drawings.gpr
===================================================================
--- trunk/examples/basic_drawings/basic_drawings.gpr 2006-11-26 22:41:08 UTC (rev 14)
+++ trunk/examples/basic_drawings/basic_drawings.gpr 2006-11-26 23:48:18 UTC (rev 15)
@@ -2,4 +2,9 @@
project Basic_Drawings is
for main use ("basic_drawings.adb");
+
+ Build : GTKAda_Wrapper.Build_Type := External ("BUILD", "debug");
+
+ package Compiler renames GTKAda_Wrapper.Compiler;
+ package Binder renames GTKAda_Wrapper.Binder;
end Basic_Drawings;
Modified: trunk/examples/empty_window/empty_window.adb
===================================================================
--- trunk/examples/empty_window/empty_window.adb 2006-11-26 22:41:08 UTC (rev 14)
+++ trunk/examples/empty_window/empty_window.adb 2006-11-26 23:48:18 UTC (rev 15)
@@ -4,7 +4,7 @@
-- This example, creates an empty default main window then exits
-with GTKAda_Wrapper; use GTKAda_Wrapper;
+with Gtkada_Wrapper; use Gtkada_Wrapper;
with Ada.Text_IO;
Modified: trunk/examples/empty_window/empty_window.gpr
===================================================================
--- trunk/examples/empty_window/empty_window.gpr 2006-11-26 22:41:08 UTC (rev 14)
+++ trunk/examples/empty_window/empty_window.gpr 2006-11-26 23:48:18 UTC (rev 15)
@@ -2,4 +2,9 @@
project Empty_Window is
for main use ("empty_window.adb");
+
+ Build : GTKAda_Wrapper.Build_Type := External ("BUILD", "debug");
+
+ package Compiler renames GTKAda_Wrapper.Compiler;
+ package Binder renames GTKAda_Wrapper.Binder;
end Empty_Window;
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-26 22:41:08 UTC (rev 14)
+++ trunk/src/gtkada_wrapper.adb 2006-11-26 23:48:18 UTC (rev 15)
@@ -31,7 +31,7 @@
with Protected_Queue;
-pragma Debug_Policy (Ignore); -- 'Ignore' Or 'Check'
+pragma Debug_Policy (Check); -- 'Ignore' Or 'Check'
package body Gtkada_Wrapper is
@@ -76,9 +76,9 @@
Y_End : Float);
-- Draw a line with the current graphic properties
- procedure Allocate_Predefined_Colors;
- -- Allocate the predefined colors. This is necessary for them to
- -- be valid.
+ procedure Allocate_Colors;
+ -- Allocate the predefined colors and the user colors. This is
+ -- necessary for them to be valid.
----------------------
-- Global Variables --
@@ -126,6 +126,10 @@
-- The table of colors. Predefined colors are allocated at the
-- beginning of the table. User colors are allocated after.
+ N_Predefined_Colors : constant Color_Type := 13;
+ -- IMPRTANT: Youmust edit this variable each time the predefined
+ -- color set is modified.
+
-- User_Task : Task_Id := Null_Task_ID; -- Task that sets up world.
-- Pixmap : Gdk_Pixmap; -- Pixmap used as backing store.
-- Pausing : Boolean := False;
@@ -454,7 +458,7 @@
-- Allocate predefined colors
- Allocate_Predefined_Colors;
+ Allocate_Colors;
Set_Foreground (Graphic_Context, To_Gdk_Color (Line_Color));
Set_Background (Graphic_Context, To_Gdk_Color (Fill_Color));
@@ -466,11 +470,11 @@
end Main_Window_Type;
- --------------------------------
- -- Allocate_Predefined_Colors --
- --------------------------------
+ ---------------------
+ -- Allocate_Colors --
+ ---------------------
- procedure Allocate_Predefined_Colors is
+ procedure Allocate_Colors is
procedure Allocate_Predefined_Color
(Col : Color_Type;
R : Guint16;
@@ -497,6 +501,11 @@
Color_Table.Set_Item (Col, Gdk_Col);
end Allocate_Predefined_Color;
begin
+ -- Allocate predefined colors
+
+ -- IMPORTANT: Don't forget to update N_Predefined_Colors each
+ -- time the predefined color set is edited.
+
Allocate_Predefined_Color (Black, 0, 0, 0);
Allocate_Predefined_Color (Red, 65535, 0, 0);
Allocate_Predefined_Color (Green, 0, 65535, 0);
@@ -510,8 +519,15 @@
Allocate_Predefined_Color (Gray, 32767, 32767, 32767);
Allocate_Predefined_Color (Light_Gray, 46003, 46003, 46003);
Allocate_Predefined_Color (White, 65535, 65535, 65535);
- end Allocate_Predefined_Colors;
+ -- Allocate user colors, which exist already in the color table
+
+ for I in N_Predefined_Colors + 1 .. Color_Table.Last loop
+ Alloc (Colormap => Gtk.Widget.Get_Default_Colormap,
+ Color => Color_Table.Table (I));
+ end loop;
+ end Allocate_Colors;
+
------------------------------
-- Assert_Main_Window_Exits --
------------------------------
@@ -903,7 +919,7 @@
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;
+ Y_End : constant Float := Cmd.Y_End;
begin
pragma Debug (O ("Do_Line_With_Start_End: begin"));
Draw_Line (X_Start, Y_Start, X_End, Y_End);
@@ -1551,13 +1567,29 @@
---------
function RGB (R : Integer; G : Integer; B : Integer) return Color_Type is
- Gdk_Col : Gdk_Color;
+ use Color_Table;
+
+ Gdk_Col : Gdk_Color;
+ Position : Color_Type;
begin
- Color_Table.Increment_Last;
- Set_Rgb (Gdk_Col, Guint16 (R), Guint16 (G), Guint16 (B));
- Alloc (Colormap => Gtk.Widget.Get_Default_Colormap,
- Color => Gdk_Col);
- return Color_Table.Last;
+ if Main_Window /= null then
+ raise Program_Error with "RGB must be calle BEFORE the"
+ & " creation of the main window";
+ end if;
+
+ Increment_Last;
+ if Last > N_Predefined_Colors + 1 then
+ Position := Last + 1;
+ else
+ Position := N_Predefined_Colors + 1;
+ end if;
+
+ Set_Rgb (Gdk_Col,
+ Guint16 (R),
+ Guint16 (G),
+ Guint16 (B));
+ Set_Item (Position, Gdk_Col);
+ return Position;
end RGB;
------------
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-26 22:41:08 UTC (rev 14)
+++ trunk/src/gtkada_wrapper.ads 2006-11-26 23:48:18 UTC (rev 15)
@@ -12,6 +12,8 @@
package Gtkada_Wrapper is
+ pragma Elaborate_Body;
+
Lost_Main_Window : exception;
-- This exception is raised if the user tries to manipulate the
-- windows before creating it or after destroying it.
@@ -55,7 +57,10 @@
function RGB (R : Integer; G : Integer; B : Integer) return Color_Type;
-- Create an RGB (Red Green Blue) color. All the given parameter
- -- are considered modulo 256.
+ -- 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
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.
|
|
From: <bec...@us...> - 2006-11-26 22:41:09
|
Revision: 14
http://svn.sourceforge.net/gtkada-wrapper/?rev=14&view=rev
Author: bechir_zalila
Date: 2006-11-26 14:41:08 -0800 (Sun, 26 Nov 2006)
Log Message:
-----------
* Fixed the color problem. Now, we use a color table. Predefined
colors are allocated at the beginning of theis table. Possible
user custom color may be allocated during the execution of the
program.
Modified Paths:
--------------
trunk/TODO
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-26 20:30:23 UTC (rev 13)
+++ trunk/TODO 2006-11-26 22:41:08 UTC (rev 14)
@@ -1,5 +1,4 @@
/src:
- * Solve the color problem
* Implement custom colors
* Implement Text area
* Remove the Idle loop
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-26 20:30:23 UTC (rev 13)
+++ trunk/src/gtkada_wrapper.adb 2006-11-26 22:41:08 UTC (rev 14)
@@ -6,6 +6,8 @@
with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;
with Unchecked_Deallocation;
+with GNAT.Table;
+
with Glib; use Glib;
with Gdk.Color; use Gdk.Color;
@@ -29,6 +31,8 @@
with Protected_Queue;
+pragma Debug_Policy (Ignore); -- 'Ignore' Or 'Check'
+
package body Gtkada_Wrapper is
procedure O (Message : String) renames Ada.Text_IO.Put_Line;
@@ -61,9 +65,6 @@
-- 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
@@ -75,6 +76,10 @@
Y_End : Float);
-- Draw a line with the current graphic properties
+ procedure Allocate_Predefined_Colors;
+ -- Allocate the predefined colors. This is necessary for them to
+ -- be valid.
+
----------------------
-- Global Variables --
----------------------
@@ -102,10 +107,6 @@
Fill_Color : Color_Type := White;
-- Properties of the virtual brush
- pragma Warnings (Off, Brush_X);
- pragma Warnings (Off, Brush_Y);
- pragma Warnings (Off, Angle);
-
VBox : Gtk_Vbox;
-- The immediate container of the windows
@@ -120,34 +121,11 @@
Pixmap : Gdk_Pixmap;
-- Pixmap usefult when rafreshing the drawing area
- N_Colors : constant := 13;
+ package Color_Table is new GNAT.Table
+ (Gdk_Color, Color_Type, 1, 20, 10);
+ -- The table of colors. Predefined colors are allocated at the
+ -- beginning of the table. User colors are allocated after.
- 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;
@@ -474,21 +452,9 @@
Cap_Style => Cap_Round,
Join_Style => Join_Round);
- -- Allocate colors
+ -- Allocate predefined 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;
+ Allocate_Predefined_Colors;
Set_Foreground (Graphic_Context, To_Gdk_Color (Line_Color));
Set_Background (Graphic_Context, To_Gdk_Color (Fill_Color));
@@ -500,6 +466,52 @@
end Main_Window_Type;
+ --------------------------------
+ -- Allocate_Predefined_Colors --
+ --------------------------------
+
+ procedure Allocate_Predefined_Colors is
+ procedure Allocate_Predefined_Color
+ (Col : Color_Type;
+ R : Guint16;
+ G : Guint16;
+ B : Guint16);
+ -- Allocate a predefined color and insert it in its predefined
+ -- position in the color table.
+
+ -------------------------------
+ -- Allocate_Predefined_Color --
+ -------------------------------
+
+ procedure Allocate_Predefined_Color
+ (Col : Color_Type;
+ R : Guint16;
+ G : Guint16;
+ B : Guint16)
+ is
+ Gdk_Col : Gdk_Color;
+ begin
+ Set_Rgb (Gdk_Col, R, G, B);
+ Alloc (Colormap => Gtk.Widget.Get_Default_Colormap,
+ Color => Gdk_Col);
+ Color_Table.Set_Item (Col, Gdk_Col);
+ end Allocate_Predefined_Color;
+ begin
+ Allocate_Predefined_Color (Black, 0, 0, 0);
+ Allocate_Predefined_Color (Red, 65535, 0, 0);
+ Allocate_Predefined_Color (Green, 0, 65535, 0);
+ Allocate_Predefined_Color (Yellow, 65535, 65535, 0);
+ Allocate_Predefined_Color (Blue, 0, 0, 65535);
+ Allocate_Predefined_Color (Magenta, 65535, 0, 65535);
+ Allocate_Predefined_Color (Cyan, 0, 65535, 65535);
+ Allocate_Predefined_Color (Dark_Gray, 19789, 19789, 19789);
+ Allocate_Predefined_Color (Orange, 65535, 42405, 0);
+ Allocate_Predefined_Color (Pink, 65535, 49344, 52171);
+ Allocate_Predefined_Color (Gray, 32767, 32767, 32767);
+ Allocate_Predefined_Color (Light_Gray, 46003, 46003, 46003);
+ Allocate_Predefined_Color (White, 65535, 65535, 65535);
+ end Allocate_Predefined_Colors;
+
------------------------------
-- Assert_Main_Window_Exits --
------------------------------
@@ -741,8 +753,9 @@
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" & Image (Fill_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;
@@ -847,7 +860,8 @@
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 ("Line color changed to "
+ & To_String (Color_Table.Table (Line_Color))));
pragma Debug (O ("Do_Line_Color: done"));
end Do_Line_Color;
@@ -1234,37 +1248,6 @@
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 --
------------------
@@ -1468,7 +1451,7 @@
end if;
end if;
- -- Mark a small delay to not hav 100% of CPU occupied
+ -- Mark a small delay to not have 100% of CPU occupied
delay 0.001;
@@ -1568,10 +1551,13 @@
---------
function RGB (R : Integer; G : Integer; B : Integer) return Color_Type is
+ Gdk_Col : Gdk_Color;
begin
- -- FIXME
- raise Program_Error with "Not Yet Implemented";
- return 1;
+ Color_Table.Increment_Last;
+ Set_Rgb (Gdk_Col, Guint16 (R), Guint16 (G), Guint16 (B));
+ Alloc (Colormap => Gtk.Widget.Get_Default_Colormap,
+ Color => Gdk_Col);
+ return Color_Table.Last;
end RGB;
------------
@@ -1681,7 +1667,7 @@
function To_Gdk_Color (C : Color_Type) return Gdk_Color is
begin
- return Color_Table (Positive (C));
+ return Color_Table.Table (C);
end To_Gdk_Color;
end Gtkada_Wrapper;
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-26 20:30:23 UTC (rev 13)
+++ trunk/src/gtkada_wrapper.ads 2006-11-26 22:41:08 UTC (rev 14)
@@ -220,8 +220,6 @@
private
- type Single_Color is mod 256;
-
type Color_Type is new Positive;
Black : constant Color_Type := 1;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
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.
|
|
From: <bec...@us...> - 2006-11-26 02:02:56
|
Revision: 12
http://svn.sourceforge.net/gtkada-wrapper/?rev=12&view=rev
Author: bechir_zalila
Date: 2006-11-25 18:02:56 -0800 (Sat, 25 Nov 2006)
Log Message:
-----------
* minor reformatting
Modified Paths:
--------------
trunk/src/gtkada_wrapper.ads
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-26 02:02:01 UTC (rev 11)
+++ trunk/src/gtkada_wrapper.ads 2006-11-26 02:02:56 UTC (rev 12)
@@ -228,15 +228,15 @@
B : Single_Color;
end record;
- 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);
+ 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);
+ 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);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-11-26 02:02:06
|
Revision: 11
http://svn.sourceforge.net/gtkada-wrapper/?rev=11&view=rev
Author: bechir_zalila
Date: 2006-11-25 18:02:01 -0800 (Sat, 25 Nov 2006)
Log Message:
-----------
* (gtkada_wrapper.adb): Creation of the drawing area. Addition of the
main loop function. Handling of some user commands (mouse click,
and destroy).
* (empty_window.adb): First example fully operational.
Modified Paths:
--------------
trunk/examples/empty_window/README
trunk/examples/empty_window/empty_window.adb
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
Modified: trunk/examples/empty_window/README
===================================================================
--- trunk/examples/empty_window/README 2006-11-25 23:12:11 UTC (rev 10)
+++ trunk/examples/empty_window/README 2006-11-26 02:02:01 UTC (rev 11)
@@ -1,3 +1,2 @@
This example test the creation, the display, and the destruction of a
-main windows. The main windows is destroyed when the user close it or
-clic on it.
+main windows. The main windows is destroyed when the user clicks on it.
Modified: trunk/examples/empty_window/empty_window.adb
===================================================================
--- trunk/examples/empty_window/empty_window.adb 2006-11-25 23:12:11 UTC (rev 10)
+++ trunk/examples/empty_window/empty_window.adb 2006-11-26 02:02:01 UTC (rev 11)
@@ -6,9 +6,18 @@
with GTKAda_Wrapper; use GTKAda_Wrapper;
+with Ada.Text_IO;
+
procedure Empty_Window is
+ X : Float;
+ Y : Float;
+ Button : Natural;
begin
Create_Main_Window;
-
- delay 5.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);
+ Ada.Text_IO.Put_Line (" Button = " & Button'Img);
+ Destroy_Main_Window;
end Empty_Window;
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-25 23:12:11 UTC (rev 10)
+++ trunk/src/gtkada_wrapper.adb 2006-11-26 02:02:01 UTC (rev 11)
@@ -2,19 +2,26 @@
-- Copyright (C) 2006 Bechir Zalila <bec...@en...>
-- See COPYING file for license
+with Ada.Text_IO;
with Unchecked_Deallocation;
with Glib; use Glib;
--- with Gdk.Window; use Gdk.Window;
+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.Types; use Gdk.Types;
+with Gtk.Drawing_Area; use Gtk.Drawing_Area;
with Gtk.Window; use Gtk.Window;
with Gtk.Enums; use Gtk.Enums;
with Gtk.Box; use Gtk.Box;
with Gtk.Paned; use Gtk.Paned;
with Gtk.Main; use Gtk.Main;
with Gtk.Handlers; use Gtk.Handlers;
+with Gtk.Style; use Gtk.Style;
with Protected_Queue;
@@ -26,6 +33,27 @@
procedure Assert_Main_Window_Exits;
-- Raises an error if the Main windows does not exist
+ function Configure_Event
+ (Drawing_Area : access Gtk_Drawing_Area_Record'Class)
+ return Boolean;
+ -- Handler for the "configure_event" signal of the drawing area
+
+ function Expose_Event
+ (Drawing_Area : access Gtk_Drawing_Area_Record'Class;
+ Event : Gdk.Event.Gdk_Event)
+ return Boolean;
+ -- Handler for the "expose_event" signal of the drawing area
+
+ function Button_Press_Event
+ (Drawing_Area : access Gtk_Drawing_Area_Record'Class;
+ Event : Gdk.Event.Gdk_Event)
+ return Boolean;
+ -- Handler for the "button_press_event" signal of the drawing area
+
+ function Main_Loop return Boolean;
+ -- This is the main loop that handle the user commands. It is
+ -- registered as an "Idle" function of the main window
+
----------------------
-- Global Variables --
----------------------
@@ -33,6 +61,14 @@
Window : Gtk_Window;
-- The main window of the application
+ Have_Drawing_Area : Boolean;
+ Have_Text_Area : Boolean;
+ -- Properties of the main window
+
+ Main_Loop_Id : Idle_Handler_Id;
+ pragma Unreferenced (Main_Loop_Id);
+ -- Id of the main loop function
+
Width : Gint;
Height : Gint;
-- Dimensions of the drawing and text areas
@@ -53,6 +89,12 @@
-- The container of the window components (the drawing area and
-- the text area).
+ Drawing_Area : Gtk_Drawing_Area;
+ -- The drawing area of the main window
+
+ Pixmap : Gdk_Pixmap;
+ -- Pixmap usefult when rafreshing the drawing area
+
-- User_Task : Task_Id := Null_Task_ID; -- Task that sets up world.
-- Pixmap : Gdk_Pixmap; -- Pixmap used as backing store.
-- Pausing : Boolean := False;
@@ -64,13 +106,19 @@
-- Width, Height : Gint;
-- Gc : Gdk_Gc;
- --------------
- -- Handlers --
- --------------
+ --------------------
+ -- Event Handlers --
+ --------------------
- package Destroyed is new Gtk.Handlers.Callback
+ package Main_Window_Handlers is new Gtk.Handlers.Callback
(Widget_Type => Gtk_Window_Record);
+ -- Handler management of the main window
+ package Drawing_Area_Handlers is new Gtk.Handlers.Return_Callback
+ (Widget_Type => Gtk_Drawing_Area_Record,
+ Return_Type => Boolean);
+ -- Handler management of the drawing area
+
-- The actions the user can do
type Action_Kind is
@@ -188,6 +236,36 @@
end case;
end record;
+ -- 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);
+
-- The user command queue
package Command_Queue is new Protected_Queue (Command, 10000);
@@ -200,6 +278,10 @@
R_Console,
R_Immediate);
+ -- Current waited reponse
+
+ Current_Waited_Response : Response_Kind := R_None;
+
-- The response data
type Response (Rsp_Kind : Response_Kind := R_None) is record
@@ -223,7 +305,6 @@
-- Response queue
package Response_Queue is new Protected_Queue (Response, 10000);
- pragma Unreferenced (Response_Queue);
-- The main window is created by a task that is allocated on the
-- user demand.
@@ -255,9 +336,10 @@
-- When the window is destroyed, some work has to be done
- Destroyed.Connect (Window,
- "destroy",
- Destroyed.To_Marshaller (Quit'Access));
+ Main_Window_Handlers.Connect
+ (Window,
+ "destroy",
+ Main_Window_Handlers.To_Marshaller (Quit'Access));
-- Create the immediate window vertical box and adding it to
-- the windows
@@ -270,8 +352,52 @@
Gtk_New_Hpaned (HPaned);
Pack_Start (VBox, HPaned);
- -- FIXME: Create the drawing area and the text area
+ -- If the user requested a drawing area, create it and append
+ -- it to the paned.
+ if Have_Drawing_Area then
+ Gtk_New (Drawing_Area);
+ Size (Drawing_Area, Width, Height);
+ Pack1 (HPaned, Drawing_Area, Resize => False, Shrink => False);
+
+ -- The only user event that may trigger the drawing area are
+ -- mouse clicks and exposure evenets (to rafresh it).
+
+ Set_Events (Drawing_Area, Exposure_Mask or Button_Press_Mask);
+
+ Drawing_Area_Handlers.Connect
+ (Widget => Drawing_Area,
+ Name => "expose_event",
+ Marsh => Drawing_Area_Handlers.To_Marshaller
+ (Expose_Event'Access));
+
+ Drawing_Area_Handlers.Connect
+ (Widget => Drawing_Area,
+ Name => "button_press_event",
+ Marsh => Drawing_Area_Handlers.To_Marshaller
+ (Button_Press_Event'Access));
+
+ -- Configure event is called when the window configuration
+ -- is changed (moved, resized, became visible...)
+
+ Drawing_Area_Handlers.Connect
+ (Widget => Drawing_Area,
+ Name => "configure_event",
+ Marsh => Drawing_Area_Handlers.To_Marshaller
+ (Configure_Event'Access));
+ end if;
+
+ -- If the user requested a text area, create it and append
+ -- it to the paned.
+
+ if Have_Text_Area then
+ null;
+ end if;
+
+ -- Set the main loop function as "Idle"
+
+ Main_Loop_Id := Idle_Add (Main_Loop'Access);
+
Show_All (Window);
Gtk.Main.Main;
@@ -286,11 +412,44 @@
procedure Assert_Main_Window_Exits is
begin
if Main_Window = null then
- raise Lost_Main_Windows with "The main window does not exist";
+ raise Lost_Main_Window with "The main window does not exist";
end if;
end Assert_Main_Window_Exits;
------------------------
+ -- Button_Press_Event --
+ ------------------------
+
+ function Button_Press_Event
+ (Drawing_Area : access Gtk_Drawing_Area_Record'Class;
+ Event : Gdk.Event.Gdk_Event)
+ return Boolean
+ is
+ pragma Unreferenced (Drawing_Area);
+ begin
+ -- 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");
+
+ -- Restore the current waited response
+
+ Current_Waited_Response := R_None;
+
+ -- Enqueue the response to the user
+
+ Response_Queue.Enqueue
+ (Response'(Rsp_Kind => R_Mouse,
+ X => Float (Get_X (Event)),
+ Y => Float (Get_Y (Event)),
+ Button => Natural (Get_Button (Event))));
+ end if;
+
+ return True;
+ end Button_Press_Event;
+
+ ------------------------
-- Clear_Drawing_Area --
------------------------
@@ -308,6 +467,63 @@
Assert_Main_Window_Exits;
end Clear_Text_Area;
+ ---------------------
+ -- Configure_Event --
+ ---------------------
+
+ function Configure_Event
+ (Drawing_Area : access Gtk_Drawing_Area_Record'Class)
+ return Boolean
+ is
+ Win : Gdk_Window;
+ New_Width : Gint;
+ New_Height : Gint;
+ New_Pixmap : Gdk_Pixmap;
+
+ use type Gdk.Gdk_Drawable;
+ begin
+ Ada.Text_IO.Put_Line ("configure");
+ Win := Get_Window (Drawing_Area);
+
+ -- Allocate a new pixmap of the reconfigured size and clear it
+ -- to white.
+
+ Get_Size (Win, New_Width, New_Height);
+ Gdk.Pixmap.Gdk_New (New_Pixmap, Win, New_Width, New_Height, -1);
+ Draw_Rectangle (New_Pixmap,
+ Get_White (Get_Style (Drawing_Area)),
+ True,
+ 0,
+ 0,
+ New_Width,
+ New_Height);
+
+ -- If there was a pixmap previously, copy the image to the new
+ -- one. Free the original.
+
+ if Pixmap /= Null_Pixmap then
+ Draw_Pixmap (New_Pixmap,
+ Get_Fg_GC (Get_Style (Drawing_Area), State_Normal),
+ Pixmap,
+ 0,
+ 0,
+ 0,
+ 0,
+ Gint'Min (Width, New_Width),
+ Gint'Min (Height, New_Height));
+
+ Gdk.Pixmap.Unref (Pixmap);
+ end if;
+
+ -- Update the drawing area properties
+
+ Pixmap := New_Pixmap;
+ Height := New_Height;
+ Width := New_Width;
+
+ return True;
+ end Configure_Event;
+
------------------------
-- Create_Main_Window --
------------------------
@@ -318,7 +534,6 @@
Text_Area : Boolean := False;
Drawing_Area : Boolean := True)
is
- pragma Unreferenced (Text_Area, Drawing_Area);
begin
if Main_Window /= null then
raise Program_Error with "The main windows already exists";
@@ -330,6 +545,9 @@
Brush_X := Float (Width) / 2.0;
Brush_Y := Float (Height) / 2.0;
+ Have_Drawing_Area := Drawing_Area;
+ Have_Text_Area := Text_Area;
+
Main_Window := new Main_Window_Type;
end Create_Main_Window;
@@ -343,6 +561,303 @@
Command_Queue.Enqueue (Command'(Action => A_Destroy));
end Destroy_Main_Window;
+ --------------
+ -- Do_Angle --
+ --------------
+
+ procedure Do_Angle (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Angle;
+
+ ---------------------------
+ -- Do_Clear_Drawing_Area --
+ ---------------------------
+
+ procedure Do_Clear_Drawing_Area (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Clear_Drawing_Area;
+
+ ------------------------
+ -- Do_Clear_Text_Area --
+ ------------------------
+
+ procedure Do_Clear_Text_Area (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Clear_Text_Area;
+
+ ----------------
+ -- Do_Destroy --
+ ----------------
+
+ procedure Do_Destroy (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ Quit (Window);
+ end Do_Destroy;
+
+ -------------------
+ -- Do_Fill_Color --
+ -------------------
+
+ procedure Do_Fill_Color (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Fill_Color;
+
+ --------------------------------
+ -- Do_Get_Immediate_Character --
+ --------------------------------
+
+ procedure Do_Get_Immediate_Character (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Get_Immediate_Character;
+
+ ------------------------
+ -- Do_Get_Line_String --
+ ------------------------
+
+ procedure Do_Get_Line_String (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Get_Line_String;
+
+ --------------------------
+ -- Do_Get_Mouse_Pointer --
+ --------------------------
+
+ procedure Do_Get_Mouse_Pointer (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ Current_Waited_Response := R_Mouse;
+ end Do_Get_Mouse_Pointer;
+
+ -------------------
+ -- Do_Get_String --
+ -------------------
+
+ procedure Do_Get_String (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Get_String;
+
+ --------------
+ -- Do_Image --
+ --------------
+
+ procedure Do_Image (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Image;
+
+ ----------------------
+ -- Do_Jump_With_End --
+ ----------------------
+
+ procedure Do_Jump_With_End (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Jump_With_End;
+
+ -------------------------
+ -- Do_Jump_With_Length --
+ -------------------------
+
+ procedure Do_Jump_With_Length (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Jump_With_Length;
+
+ -------------------
+ -- Do_Line_Color --
+ -------------------
+
+ procedure Do_Line_Color (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Line_Color;
+
+ ----------------------
+ -- Do_Line_With_End --
+ ----------------------
+
+ procedure Do_Line_With_End (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Line_With_End;
+
+ -------------------------
+ -- Do_Line_With_Length --
+ -------------------------
+
+ procedure Do_Line_With_Length (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Line_With_Length;
+
+ ----------------------------
+ -- Do_Line_With_Start_End --
+ ----------------------------
+
+ procedure Do_Line_With_Start_End (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Line_With_Start_End;
+
+ -------------------------------
+ -- Do_Line_With_Start_Length --
+ -------------------------------
+
+ procedure Do_Line_With_Start_Length (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Line_With_Start_Length;
+
+ -----------------
+ -- Do_New_Line --
+ -----------------
+
+ procedure Do_New_Line (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_New_Line;
+
+ ----------------------
+ -- Do_Put_Character --
+ ----------------------
+
+ procedure Do_Put_Character (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Put_Character;
+
+ ---------------------------
+ -- Do_Put_Line_Character --
+ ---------------------------
+
+ procedure Do_Put_Line_Character (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Put_Line_Character;
+
+ ------------------------
+ -- Do_Put_Line_String --
+ ------------------------
+
+ procedure Do_Put_Line_String (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Put_Line_String;
+
+ -------------------
+ -- Do_Put_String --
+ -------------------
+
+ procedure Do_Put_String (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Put_String;
+
+ ----------------
+ -- Do_Rafresh --
+ ----------------
+
+ procedure Do_Rafresh (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Rafresh;
+
+ ---------------
+ -- Do_Rotate --
+ ---------------
+
+ procedure Do_Rotate (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Rotate;
+
+ -------------
+ -- Do_Spot --
+ -------------
+
+ procedure Do_Spot (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Spot;
+
+ -------------
+ -- Do_Text --
+ -------------
+
+ procedure Do_Text (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Text;
+
+ ------------------
+ -- Do_Thickness --
+ ------------------
+
+ procedure Do_Thickness (Cmd : Command) is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Do_Thickness;
+
+ ------------------
+ -- Expose_Event --
+ ------------------
+
+ function Expose_Event
+ (Drawing_Area : access Gtk_Drawing_Area_Record'Class;
+ Event : Gdk.Event.Gdk_Event)
+ return Boolean
+ is
+ Area : constant Gdk_Rectangle := Get_Area (Event);
+ begin
+ Ada.Text_IO.Put_Line ("expose");
+
+ -- Restore screen from backing store pixmap
+
+ Draw_Pixmap (Get_Window (Drawing_Area),
+ Get_Fg_GC (Get_Style (Drawing_Area), State_Normal),
+ Pixmap,
+ Area.X,
+ Area.Y,
+ Area.X,
+ Area.Y,
+ Gint (Area.Width),
+ Gint (Area.Height));
+ return True;
+ end Expose_Event;
+
---------
-- Get --
---------
@@ -412,9 +927,24 @@
Y : out Float;
Button : out Natural)
is
- pragma Unreferenced (X, Y, Button);
+ Rsp : Response;
begin
Assert_Main_Window_Exits;
+ Command_Queue.Enqueue (Command'(Action => A_Get_Mouse_Pointer));
+ Rsp := Response_Queue.Dequeue;
+
+ case Rsp.Rsp_Kind is
+ when R_Mouse =>
+ X := Rsp.X;
+ Y := Rsp.Y;
+ Button := Rsp.Button;
+
+ when R_None =>
+ raise Lost_Main_Window;
+
+ when others =>
+ raise Program_Error;
+ end case;
end Get_Mouse_Pointer;
------------------
@@ -536,6 +1066,62 @@
Assert_Main_Window_Exits;
end Line;
+ -- Dispatch table
+
+ type Command_Proc_Type is access procedure (Cmd : Command);
+
+ Dispatch_Table : constant array (Action_Kind) of Command_Proc_Type :=
+ (A_Angle => Do_Angle'Access,
+ A_Clear_Drawing_Area => Do_Clear_Drawing_Area'Access,
+ A_Clear_Text_Area => Do_Clear_Text_Area'Access,
+ A_Destroy => Do_Destroy'Access,
+ A_Fill_Color => Do_Fill_Color'Access,
+ A_Get_Immediate_Character => Do_Get_Immediate_Character'Access,
+ A_Get_Line_String => Do_Get_Line_String'Access,
+ A_Get_Mouse_Pointer => Do_Get_Mouse_Pointer'Access,
+ A_Get_String => Do_Get_String'Access,
+ A_Image => Do_Image'Access,
+ A_Jump_With_End => Do_Jump_With_End'Access,
+ A_Jump_With_Length => Do_Jump_With_Length'Access,
+ A_Line_Color => Do_Line_Color'Access,
+ A_Line_With_End => Do_Line_With_End'Access,
+ A_Line_With_Length => Do_Line_With_Length'Access,
+ A_Line_With_Start_End => Do_Line_With_Start_End'Access,
+ A_Line_With_Start_Length => Do_Line_With_Start_Length'Access,
+ A_New_Line => Do_New_Line'Access,
+ A_None => null,
+ A_Put_Character => Do_Put_Character'Access,
+ A_Put_Line_Character => Do_Put_Line_Character'Access,
+ A_Put_Line_String => Do_Put_Line_String'Access,
+ A_Put_String => Do_Put_String'Access,
+ A_Rafresh => Do_Rafresh'Access,
+ A_Rotate => Do_Rotate'Access,
+ A_Spot => Do_Spot'Access,
+ A_Text => Do_Text'Access,
+ A_Thickness => Do_Thickness'Access);
+
+ ---------------
+ -- Main_Loop --
+ ---------------
+
+ function Main_Loop return Boolean is
+ Cmd : Command;
+ begin
+ if Command_Queue.Length > 0 then
+ Cmd := Command_Queue.Dequeue;
+
+ if Dispatch_Table (Cmd.Action) /= null then
+ Dispatch_Table (Cmd.Action).all (Cmd);
+ end if;
+ end if;
+
+ -- Mark a small delay to not hav 100% of CPU occupied
+
+ delay 0.001;
+
+ return True;
+ end Main_Loop;
+
--------------
-- New_Line --
--------------
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-25 23:12:11 UTC (rev 10)
+++ trunk/src/gtkada_wrapper.ads 2006-11-26 02:02:01 UTC (rev 11)
@@ -12,7 +12,7 @@
package Gtkada_Wrapper is
- Lost_Main_Windows : exception;
+ Lost_Main_Window : exception;
-- This exception is raised if the user tries to manipulate the
-- windows before creating it or after destroying it.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-11-25 23:12:11
|
Revision: 10
http://svn.sourceforge.net/gtkada-wrapper/?rev=10&view=rev
Author: bechir_zalila
Date: 2006-11-25 15:12:11 -0800 (Sat, 25 Nov 2006)
Log Message:
-----------
* Renamed the example to 'empty_window'
Modified Paths:
--------------
trunk/configure.ac
trunk/examples/Makefile.am
Added Paths:
-----------
trunk/examples/empty_window/
trunk/examples/empty_window/Makefile.am
trunk/examples/empty_window/README
trunk/examples/empty_window/empty_window.adb
trunk/examples/empty_window/empty_window.gpr
Removed Paths:
-------------
trunk/examples/empty_window/Makefile.am
trunk/examples/empty_window/README
trunk/examples/empty_windows/
Modified: trunk/configure.ac
===================================================================
--- trunk/configure.ac 2006-11-25 23:06:27 UTC (rev 9)
+++ trunk/configure.ac 2006-11-25 23:12:11 UTC (rev 10)
@@ -87,7 +87,7 @@
Makefile
doc/Makefile
examples/Makefile
- examples/empty_windows/Makefile
+ examples/empty_window/Makefile
src/Makefile
])
Modified: trunk/examples/Makefile.am
===================================================================
--- trunk/examples/Makefile.am 2006-11-25 23:06:27 UTC (rev 9)
+++ trunk/examples/Makefile.am 2006-11-25 23:12:11 UTC (rev 10)
@@ -1 +1 @@
-SUBDIRS = empty_windows
+SUBDIRS = empty_window
Copied: trunk/examples/empty_window (from rev 4, trunk/examples/empty_windows)
Deleted: trunk/examples/empty_window/Makefile.am
===================================================================
Copied: trunk/examples/empty_window/Makefile.am (from rev 9, trunk/examples/empty_windows/Makefile.am)
===================================================================
--- trunk/examples/empty_window/Makefile.am (rev 0)
+++ trunk/examples/empty_window/Makefile.am 2006-11-25 23:12:11 UTC (rev 10)
@@ -0,0 +1,5 @@
+include ../Makefile.common
+
+PROJECT_FILE = $(srcdir)/empty_window.gpr
+SOURCES = $(srcdir)/empty_window.adb
+
Deleted: trunk/examples/empty_window/README
===================================================================
--- trunk/examples/empty_windows/README 2006-11-25 00:05:56 UTC (rev 4)
+++ trunk/examples/empty_window/README 2006-11-25 23:12:11 UTC (rev 10)
@@ -1,3 +0,0 @@
-This example test the creation, the display, and the destruction of a
-main windows. The main windows is destroyed when the user close it or
-clic on it.
Copied: trunk/examples/empty_window/README (from rev 9, trunk/examples/empty_windows/README)
===================================================================
--- trunk/examples/empty_window/README (rev 0)
+++ trunk/examples/empty_window/README 2006-11-25 23:12:11 UTC (rev 10)
@@ -0,0 +1,3 @@
+This example test the creation, the display, and the destruction of a
+main windows. The main windows is destroyed when the user close it or
+clic on it.
Copied: trunk/examples/empty_window/empty_window.adb (from rev 9, trunk/examples/empty_windows/empty_window.adb)
===================================================================
--- trunk/examples/empty_window/empty_window.adb (rev 0)
+++ trunk/examples/empty_window/empty_window.adb 2006-11-25 23:12:11 UTC (rev 10)
@@ -0,0 +1,14 @@
+-- $Id$
+-- Copyright (C) 2006 Bechir Zalila <bec...@en...>
+-- See COPYING file for license
+
+-- This example, creates an empty default main window then exits
+
+with GTKAda_Wrapper; use GTKAda_Wrapper;
+
+procedure Empty_Window is
+begin
+ Create_Main_Window;
+
+ delay 5.0;
+end Empty_Window;
Copied: trunk/examples/empty_window/empty_window.gpr (from rev 9, trunk/examples/empty_windows/empty_window.gpr)
===================================================================
--- trunk/examples/empty_window/empty_window.gpr (rev 0)
+++ trunk/examples/empty_window/empty_window.gpr 2006-11-25 23:12:11 UTC (rev 10)
@@ -0,0 +1,5 @@
+with "../../src/gtkada_wrapper.gpr";
+
+project Empty_Window is
+ for main use ("empty_window.adb");
+end Empty_Window;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <bec...@us...> - 2006-11-25 23:06:27
|
Revision: 9
http://svn.sourceforge.net/gtkada-wrapper/?rev=9&view=rev
Author: bechir_zalila
Date: 2006-11-25 15:06:27 -0800 (Sat, 25 Nov 2006)
Log Message:
-----------
* (gtkada_wrapper.ad?): Added the routines that create the main
windows (empty for now). Minor reformatting.
* (examples/empty_windows): A very simple example that displays
an empty window.
Modified Paths:
--------------
trunk/TODO
trunk/examples/Makefile.am
trunk/examples/empty_windows/Makefile.am
trunk/src/gtkada_wrapper.adb
trunk/src/gtkada_wrapper.ads
Added Paths:
-----------
trunk/examples/Makefile.common
trunk/examples/empty_windows/empty_window.adb
trunk/examples/empty_windows/empty_window.gpr
Modified: trunk/TODO
===================================================================
--- trunk/TODO 2006-11-25 17:18:47 UTC (rev 8)
+++ trunk/TODO 2006-11-25 23:06:27 UTC (rev 9)
@@ -7,3 +7,6 @@
/:
* Add a projects subdirectory that will contain the project
files that will be installed.
+
+/examples:
+ * Install examples
\ No newline at end of file
Modified: trunk/examples/Makefile.am
===================================================================
--- trunk/examples/Makefile.am 2006-11-25 17:18:47 UTC (rev 8)
+++ trunk/examples/Makefile.am 2006-11-25 23:06:27 UTC (rev 9)
@@ -1 +1 @@
-SRCDIRS=empty_windows
\ No newline at end of file
+SUBDIRS = empty_windows
Added: trunk/examples/Makefile.common
===================================================================
--- trunk/examples/Makefile.common (rev 0)
+++ trunk/examples/Makefile.common 2006-11-25 23:06:27 UTC (rev 9)
@@ -0,0 +1,8 @@
+EXTRA_DIST = $(SOURCES) $(PROJECT_FILE);
+
+all-local:
+ $(GNATMAKE) -P $(PROJECT_FILE) $(GNATFLAGS)
+
+clean-local:
+ $(GNATCLEAN) -P $(PROJECT_FILE) $(GNATFLAGS)
+
Modified: trunk/examples/empty_windows/Makefile.am
===================================================================
--- trunk/examples/empty_windows/Makefile.am 2006-11-25 17:18:47 UTC (rev 8)
+++ trunk/examples/empty_windows/Makefile.am 2006-11-25 23:06:27 UTC (rev 9)
@@ -0,0 +1,5 @@
+include ../Makefile.common
+
+PROJECT_FILE = $(srcdir)/empty_window.gpr
+SOURCES = $(srcdir)/empty_window.adb
+
Added: trunk/examples/empty_windows/empty_window.adb
===================================================================
--- trunk/examples/empty_windows/empty_window.adb (rev 0)
+++ trunk/examples/empty_windows/empty_window.adb 2006-11-25 23:06:27 UTC (rev 9)
@@ -0,0 +1,14 @@
+-- $Id$
+-- Copyright (C) 2006 Bechir Zalila <bec...@en...>
+-- See COPYING file for license
+
+-- This example, creates an empty default main window then exits
+
+with GTKAda_Wrapper; use GTKAda_Wrapper;
+
+procedure Empty_Window is
+begin
+ Create_Main_Window;
+
+ delay 5.0;
+end Empty_Window;
Property changes on: trunk/examples/empty_windows/empty_window.adb
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Added: trunk/examples/empty_windows/empty_window.gpr
===================================================================
--- trunk/examples/empty_windows/empty_window.gpr (rev 0)
+++ trunk/examples/empty_windows/empty_window.gpr 2006-11-25 23:06:27 UTC (rev 9)
@@ -0,0 +1,5 @@
+with "../../src/gtkada_wrapper.gpr";
+
+project Empty_Window is
+ for main use ("empty_window.adb");
+end Empty_Window;
Property changes on: trunk/examples/empty_windows/empty_window.gpr
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Modified: trunk/src/gtkada_wrapper.adb
===================================================================
--- trunk/src/gtkada_wrapper.adb 2006-11-25 17:18:47 UTC (rev 8)
+++ trunk/src/gtkada_wrapper.adb 2006-11-25 23:06:27 UTC (rev 9)
@@ -4,12 +4,73 @@
with Unchecked_Deallocation;
+with Glib; use Glib;
+
+-- with Gdk.Window; use Gdk.Window;
+
with Gdk.Types; use Gdk.Types;
+with Gtk.Window; use Gtk.Window;
+with Gtk.Enums; use Gtk.Enums;
+with Gtk.Box; use Gtk.Box;
+with Gtk.Paned; use Gtk.Paned;
+with Gtk.Main; use Gtk.Main;
+with Gtk.Handlers; use Gtk.Handlers;
with Protected_Queue;
package body Gtkada_Wrapper is
+ procedure Quit (Window : access Gtk.Window.Gtk_Window_Record'Class);
+ -- Quit the main loop when the user closes the window
+
+ procedure Assert_Main_Window_Exits;
+ -- Raises an error if the Main windows does not exist
+
+ ----------------------
+ -- Global Variables --
+ ----------------------
+
+ Window : Gtk_Window;
+ -- The main window of the application
+
+ Width : Gint;
+ Height : Gint;
+ -- Dimensions of the drawing and text areas
+
+ Brush_X : Float := 0.0;
+ Brush_Y : Float := 0.0;
+ Angle : Float := 0.0;
+ -- Properties of the virtual brush
+
+ pragma Warnings (Off, Brush_X);
+ pragma Warnings (Off, Brush_Y);
+ pragma Warnings (Off, Angle);
+
+ VBox : Gtk_Vbox;
+ -- The immediate container of the windows
+
+ HPaned : Gtk_Hpaned;
+ -- The container of the window components (the drawing area and
+ -- the text area).
+
+ -- User_Task : Task_Id := Null_Task_ID; -- Task that sets up world.
+ -- Pixmap : Gdk_Pixmap; -- Pixmap used as backing store.
+ -- Pausing : Boolean := False;
+ -- Drawing_Area : Gtk_Drawing_Area;
+ -- Console : Interactive_Console;
+ -- Idle_Function_Id : Idle_Handler_Id;
+ -- Pause_Timeout_Function_Id : Timeout_Handler_Id;
+ -- Draw_Timeout_Function_Id : Timeout_Handler_Id;
+ -- Width, Height : Gint;
+ -- Gc : Gdk_Gc;
+
+ --------------
+ -- Handlers --
+ --------------
+
+ package Destroyed is new Gtk.Handlers.Callback
+ (Widget_Type => Gtk_Window_Record);
+
-- The actions the user can do
type Action_Kind is
@@ -130,7 +191,6 @@
-- The user command queue
package Command_Queue is new Protected_Queue (Command, 10000);
- pragma Unreferenced (Command_Queue);
-- The response kind
@@ -165,13 +225,78 @@
package Response_Queue is new Protected_Queue (Response, 10000);
pragma Unreferenced (Response_Queue);
+ -- The main window is created by a task that is allocated on the
+ -- user demand.
+
+ -- The main windows task type
+
+ task type Main_Window_Type;
+ type Main_Window_Access is access all Main_Window_Type;
+
+ -- The Main windows
+
+ Main_Window : Main_Window_Access;
+
+ ----------------------
+ -- Main_Window_Type --
+ ----------------------
+
+ task body Main_Window_Type is
+ begin
+ -- Initialize GTK
+
+ Gtk.Main.Init;
+
+ -- Setup the main windows
+
+ Gtk_New (Window, Window_Toplevel);
+ Set_Title (Window, "GTKAda Wrapper");
+ Set_Border_Width (Window, Border_Width => 5);
+
+ -- When the window is destroyed, some work has to be done
+
+ Destroyed.Connect (Window,
+ "destroy",
+ Destroyed.To_Marshaller (Quit'Access));
+
+ -- Create the immediate window vertical box and adding it to
+ -- the windows
+
+ Gtk_New_Vbox (VBox, Homogeneous => False, Spacing => 0);
+ Add (Window, VBox);
+
+ -- Create the horizontal paned and adding it to the box
+
+ Gtk_New_Hpaned (HPaned);
+ Pack_Start (VBox, HPaned);
+
+ -- FIXME: Create the drawing area and the text area
+
+ Show_All (Window);
+ Gtk.Main.Main;
+
+ -- FIXME: Handle exit
+
+ end Main_Window_Type;
+
+ ------------------------------
+ -- Assert_Main_Window_Exits --
+ ------------------------------
+
+ procedure Assert_Main_Window_Exits is
+ begin
+ if Main_Window = null then
+ raise Lost_Main_Windows with "The main window does not exist";
+ end if;
+ end Assert_Main_Window_Exits;
+
------------------------
-- Clear_Drawing_Area --
------------------------
procedure Clear_Drawing_Area is
begin
- null;
+ Assert_Main_Window_Exits;
end Clear_Drawing_Area;
---------------------
@@ -180,7 +305,7 @@
procedure Clear_Text_Area is
begin
- null;
+ Assert_Main_Window_Exits;
end Clear_Text_Area;
------------------------
@@ -193,9 +318,19 @@
Text_Area : Boolean := False;
Drawing_Area : Boolean := True)
is
- pragma Unreferenced (X_Max, Y_Max, Text_Area, Drawing_Area);
+ pragma Unreferenced (Text_Area, Drawing_Area);
begin
- null;
+ if Main_Window /= null then
+ raise Program_Error with "The main windows already exists";
+ end if;
+
+ Width := Gint (X_Max);
+ Height := Gint (Y_Max);
+
+ Brush_X := Float (Width) / 2.0;
+ Brush_Y := Float (Height) / 2.0;
+
+ Main_Window := new Main_Window_Type;
end Create_Main_Window;
-------------------------
@@ -204,7 +339,8 @@
procedure Destroy_Main_Window is
begin
- null;
+ Assert_Main_Window_Exits;
+ Command_Queue.Enqueue (Command'(Action => A_Destroy));
end Destroy_Main_Window;
---------
@@ -213,6 +349,7 @@
function Get return String is
begin
+ Assert_Main_Window_Exits;
return "";
end Get;
@@ -222,6 +359,7 @@
function Get_Angle return Float is
begin
+ Assert_Main_Window_Exits;
return 0.0;
end Get_Angle;
@@ -231,6 +369,7 @@
function Get_Fill_Color return Color_Type is
begin
+ Assert_Main_Window_Exits;
return Black;
end Get_Fill_Color;
@@ -241,7 +380,7 @@
procedure Get_Immediate (Item : out Character) is
pragma Unreferenced (Item);
begin
- null;
+ Assert_Main_Window_Exits;
end Get_Immediate;
--------------
@@ -250,6 +389,7 @@
function Get_Line return String is
begin
+ Assert_Main_Window_Exits;
return "";
end Get_Line;
@@ -259,6 +399,7 @@
function Get_Line_Color return Color_Type is
begin
+ Assert_Main_Window_Exits;
return Black;
end Get_Line_Color;
@@ -273,7 +414,7 @@
is
pragma Unreferenced (X, Y, Button);
begin
- null;
+ Assert_Main_Window_Exits;
end Get_Mouse_Pointer;
------------------
@@ -283,7 +424,7 @@
procedure Get_Position (X : out Float; Y : out Float) is
pragma Unreferenced (X, Y);
begin
- null;
+ Assert_Main_Window_Exits;
end Get_Position;
-------------------
@@ -292,6 +433,7 @@
function Get_Thickness return Float is
begin
+ Assert_Main_Window_Exits;
return 0.0;
end Get_Thickness;
@@ -307,7 +449,7 @@
is
pragma Unreferenced (File_Name, Scale, X_Justification, Y_Justification);
begin
- null;
+ Assert_Main_Window_Exits;
end Insert_Image;
-----------------
@@ -322,7 +464,7 @@
is
pragma Unreferenced (Text, Size, X_Justification, Y_Justification);
begin
- null;
+ Assert_Main_Window_Exits;
end Insert_Text;
----------
@@ -332,7 +474,7 @@
procedure Jump (Distance : Float) is
pragma Unreferenced (Distance);
begin
- null;
+ Assert_Main_Window_Exits;
end Jump;
----------
@@ -342,7 +484,7 @@
procedure Jump (X : Float; Y : Float) is
pragma Unreferenced (X, Y);
begin
- null;
+ Assert_Main_Window_Exits;
end Jump;
----------
@@ -352,7 +494,7 @@
procedure Line (Distance : Float) is
pragma Unreferenced (Distance);
begin
- null;
+ Assert_Main_Window_Exits;
end Line;
----------
@@ -362,7 +504,7 @@
procedure Line (X : Float; Y : Float) is
pragma Unreferenced (X, Y);
begin
- null;
+ Assert_Main_Window_Exits;
end Line;
----------
@@ -376,7 +518,7 @@
is
pragma Unreferenced (X_Start, Y_Start, Distance);
begin
- null;
+ Assert_Main_Window_Exits;
end Line;
----------
@@ -391,7 +533,7 @@
is
pragma Unreferenced (X_Start, Y_Start, X_End, Y_End);
begin
- null;
+ Assert_Main_Window_Exits;
end Line;
--------------
@@ -401,7 +543,7 @@
procedure New_Line (Spacing : Positive := 1) is
pragma Unreferenced (Spacing);
begin
- null;
+ Assert_Main_Window_Exits;
end New_Line;
---------
@@ -411,7 +553,7 @@
procedure Put (Item : String) is
pragma Unreferenced (Item);
begin
- null;
+ Assert_Main_Window_Exits;
end Put;
---------
@@ -421,7 +563,7 @@
procedure Put (Item : Character) is
pragma Unreferenced (Item);
begin
- null;
+ Assert_Main_Window_Exits;
end Put;
--------------
@@ -431,7 +573,7 @@
procedure Put_Line (Item : String) is
pragma Unreferenced (Item);
begin
- null;
+ Assert_Main_Window_Exits;
end Put_Line;
--------------
@@ -441,16 +583,26 @@
procedure Put_Line (Item : Character) is
pragma Unreferenced (Item);
begin
- null;
+ Assert_Main_Window_Exits;
end Put_Line;
+ ----------
+ -- Quit --
+ ----------
+
+ procedure Quit (Window : access Gtk.Window.Gtk_Window_Record'Class) is
+ pragma Unreferenced (Window);
+ begin
+ Gtk.Main.Main_Quit;
+ end Quit;
+
-------------
-- Rafresh --
-------------
procedure Rafresh is
begin
- null;
+ Assert_Main_Window_Exits;
end Rafresh;
---------
@@ -471,7 +623,7 @@
procedure Rotate (Angle : Float) is
pragma Unreferenced (Angle);
begin
- null;
+ Assert_Main_Window_Exits;
end Rotate;
---------------
@@ -481,7 +633,7 @@
procedure Set_Angle (Angle : Float) is
pragma Unreferenced (Angle);
begin
- null;
+ Assert_Main_Window_Exits;
end Set_Angle;
--------------------
@@ -491,7 +643,7 @@
procedure Set_Fill_Color (C : Color_Type) is
pragma Unreferenced (C);
begin
- null;
+ Assert_Main_Window_Exits;
end Set_Fill_Color;
--------------------
@@ -501,7 +653,7 @@
procedure Set_Line_Color (C : Color_Type) is
pragma Unreferenced (C);
begin
- null;
+ Assert_Main_Window_Exits;
end Set_Line_Color;
------------------
@@ -511,7 +663,7 @@
procedure Set_Position (X : Float; Y : Float) is
pragma Unreferenced (X, Y);
begin
- null;
+ Assert_Main_Window_Exits;
end Set_Position;
-------------------
@@ -521,7 +673,7 @@
procedure Set_Thickness (T : Float) is
pragma Unreferenced (T);
begin
- null;
+ Assert_Main_Window_Exits;
end Set_Thickness;
----------
@@ -531,7 +683,7 @@
procedure Spot (Radius : Float := 4.0) is
pragma Unreferenced (Radius);
begin
- null;
+ Assert_Main_Window_Exits;
end Spot;
end Gtkada_Wrapper;
Modified: trunk/src/gtkada_wrapper.ads
===================================================================
--- trunk/src/gtkada_wrapper.ads 2006-11-25 17:18:47 UTC (rev 8)
+++ trunk/src/gtkada_wrapper.ads 2006-11-25 23:06:27 UTC (rev 9)
@@ -12,6 +12,10 @@
package Gtkada_Wrapper is
+ Lost_Main_Windows : exception;
+ -- This exception is raised if the user tries to manipulate the
+ -- windows before creating it or after destroying it.
+
procedure Create_Main_Window
(X_Max : Float := 512.0;
Y_Max : Float := 512.0;
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.
|
