[Gtkada-wrapper-devel] SF.net SVN: gtkada-wrapper: [26] trunk
Brought to you by:
bechir_zalila
Menu
▾
▴
[Gtkada-wrapper-devel] SF.net SVN: gtkada-wrapper: [26] trunk
|
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] |
