diff options
Diffstat (limited to 'Ada95/samples')
85 files changed, 11851 insertions, 0 deletions
diff --git a/Ada95/samples/Makefile.in b/Ada95/samples/Makefile.in new file mode 100644 index 000000000000..aa839ffbaf68 --- /dev/null +++ b/Ada95/samples/Makefile.in @@ -0,0 +1,155 @@ +############################################################################## +# Copyright (c) 1998-2010,2011 Free Software Foundation, Inc. # +# # +# Permission is hereby granted, free of charge, to any person obtaining a # +# copy of this software and associated documentation files (the "Software"), # +# to deal in the Software without restriction, including without limitation # +# the rights to use, copy, modify, merge, publish, distribute, distribute # +# with modifications, sublicense, and/or sell copies of the Software, and to # +# permit persons to whom the Software is furnished to do so, subject to the # +# following conditions: # +# # +# The above copyright notice and this permission notice shall be included in # +# all copies or substantial portions of the Software. # +# # +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL # +# THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER # +# DEALINGS IN THE SOFTWARE. # +# # +# Except as contained in this notice, the name(s) of the above copyright # +# holders shall not be used in advertising or otherwise to promote the sale, # +# use or other dealings in this Software without prior written # +# authorization. # +############################################################################## +# +# Author: Juergen Pfeifer, 1996 +# +# $Id: Makefile.in,v 1.46 2011/03/28 23:45:08 tom Exp $ +# +.SUFFIXES: + +SHELL = /bin/sh +VPATH = @srcdir@ +THIS = Makefile + +x = @PROG_EXT@ + +srcdir = @srcdir@ +prefix = @prefix@ +exec_prefix = @exec_prefix@ +bindir = @bindir@ +datadir = @datadir@ +libdir = @libdir@ +includedir = @includedir@ + +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ + +AWK = @AWK@ +LN_S = @LN_S@ + +CC = @CC@ +CFLAGS = @CFLAGS@ + +CPPFLAGS = @ACPPFLAGS@ \ + -DHAVE_CONFIG_H -I$(srcdir) + +CCFLAGS = $(CPPFLAGS) $(CFLAGS) + +CFLAGS_NORMAL = $(CCFLAGS) +CFLAGS_DEBUG = $(CCFLAGS) @CC_G_OPT@ -DTRACE +CFLAGS_PROFILE = $(CCFLAGS) -pg +CFLAGS_SHARED = $(CCFLAGS) @CC_SHARED_OPTS@ + +CFLAGS_DEFAULT = $(CFLAGS_@DFT_UPR_MODEL@) + +REL_VERSION = @cf_cv_rel_version@ +ABI_VERSION = @cf_cv_abi_version@ +LOCAL_LIBDIR = @top_builddir@/lib + +LINK = $(CC) +LDFLAGS = @LDFLAGS@ @LD_MODEL@ @LIBS@ + +RANLIB = @RANLIB@ +################################################################################ +BINDIR = $(DESTDIR)$(bindir) +DATADIR = $(DESTDIR)$(datadir) +LIBDIR = $(DESTDIR)$(libdir) + +MY_DATADIR = $(DATADIR)/AdaCurses + +################################################################################ +ada_srcdir=../src + +LD_FLAGS = @LD_MODEL@ $(LOCAL_LIBS) @LDFLAGS@ @LIBS@ @LOCAL_LDFLAGS2@ $(LDFLAGS) + +ADA = @cf_ada_compiler@ +ADAFLAGS = @ADAFLAGS@ -I$(srcdir) + +ADAMAKE = @cf_ada_make@ +ADAMAKEFLAGS = -a -A$(srcdir) -A$(ada_srcdir) -A$(srcdir)/$(ada_srcdir) + +ALIB = @cf_ada_package@ +ABASE = $(ALIB)-curses + +CARGS =-cargs $(ADAFLAGS) +LARGS =-largs -L../lib -lAdaCurses @TEST_ARG2@ $(LD_FLAGS) @TEST_LIBS2@ + +PROGS = tour$x ncurses$x @USE_GNAT_SIGINT@ rain$x + +all :: $(PROGS) + @echo made $@ + +sources : + @echo made $@ + +libs \ +install \ +install.libs :: + @echo made $@ + +uninstall \ +uninstall.libs :: + @echo made $@ + +install.examples :: $(BINDIR) $(PROGS) + $(INSTALL) $(PROGS) $(BINDIR) + +install.examples :: $(MY_DATADIR) + $(INSTALL_DATA) explain.txt $(MY_DATADIR) + +uninstall.examples :: + -cd $(BINDIR) && rm -f $(PROGS) + -rmdir $(BINDIR) + -rm -f $(MY_DATADIR)/explain.txt + -rmdir $(MY_DATADIR) + +$(BINDIR) \ +$(MY_DATADIR) : + mkdir -p $@ + +ncurses$x : + $(ADAMAKE) $(ADAMAKEFLAGS) ncurses $(CARGS) $(LARGS) + +tour$x : + $(ADAMAKE) $(ADAMAKEFLAGS) tour $(CARGS) $(LARGS) + +rain$x : + $(ADAMAKE) $(ADAMAKEFLAGS) rain $(CARGS) $(LARGS) + +mostlyclean: + @echo made $@ + +clean :: mostlyclean + rm -f *.o *.ali b_t*.* *.s $(PROGS) a.out core b_*_test.c *.xr[bs] \ + trace screendump b~*.ad[bs] + +distclean :: clean + rm -f Makefile + +realclean :: distclean + @echo made $@ diff --git a/Ada95/samples/README b/Ada95/samples/README new file mode 100644 index 000000000000..c4f16ad306dc --- /dev/null +++ b/Ada95/samples/README @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------- +-- Copyright (c) 1998,2006 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell copies -- +-- of the Software, and to permit persons to whom the Software is furnished -- +-- to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN -- +-- NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE -- +-- USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------- +-- $Id: README,v 1.2 2006/04/22 22:24:12 tom Exp $ +------------------------------------------------------------------------------- + +The intention of the demo at this point in time is not to demonstrate all +the features of (n)curses and its subsystems, but to give some sample +sources how to use the binding at all. + +Ideally in the future we can combine both goals. diff --git a/Ada95/samples/explain.txt b/Ada95/samples/explain.txt new file mode 100644 index 000000000000..be2cba154ee2 --- /dev/null +++ b/Ada95/samples/explain.txt @@ -0,0 +1,186 @@ +#VERSION +This is Version 00.90.00 of the demo package. +#MENUKEYS +In a menu you can use the following Keys in the whole application: + + - CTRL-X eXit the menu + - CTRL-N Go to next item + - CTRL-P Go to previous item + - CTRL-U Scroll up one line + - CTRL-D Scroll down one line + - CTRL-F Scroll down one page + - PAGE DOWN Scroll down one page + - PAGE UP Scroll back one page + - CTRL-B Scroll back one page + - CTRL-Y Clear pattern + - CTRL-H Delete last character from pattern + - Backspace Delete last character from pattern + - CTRL-A Next pattern match + - CTRL-E Previous pattern match + - CTRL-T Toggle item in a multi-selection menu + - CR or LF Select an item + - HOME Key Go to the first item + - F3 Quit the menu + - Cursor Down Down one item + - Cursor Up Up one item + - Cursor Left Left one item + - Cursor Right Right one item + - END Key Go to last item +#FORMKEYS + - CTRL-X eXit the form + - CTRL-F Go forward to the next field + - CTRL-B Go backward to the previous field + - CTRL-L Go to the field left of the current one + - CTRL-R Go to the field right of the current one + - CTRL-U Go to the field above the current one + - CTRL-D Go to the field below the current one + + - CTRL-W Go to the next word in the field + - CTRL-T Go to the previous word in the field + + - CTRL-A Go to the beginning of the field + - CTRL-E Go to the end of the field + + - CTRL-I Insert a blank character at the current position + - CTRL-O Insert a line + - CTRL-V Delete a character + - CTRL-H Delete previous character + - CTRL-Y Delete a line + - CTRL-G Delete a word + - CTRL-K Clear to end of field + + - CTRL-N Next choice in a choice field (Enumerations etc.) + - CTRL-P Previous choice in a choice field. +#HELP +#HELPKEYS +You may scroll with the Cursor Up/Down Keys. +You may leave the help with the Function Key labeled 'Quit'. +#INHELP +You are already in the help system. +You may leave the help with the Function Key labeled 'Quit'. +#MAIN +This is the main menu of the sample program for the ncurses Ada95 +binding. The main intention of the demo is not to demonstrate or +test all the features of ncurses and it's subsystems, but to provide +to you some sample code how to use the binding with Ada95. + +You may select this options: + + * Look at some ncurses core functions + * Look at some features of the menu subsystem + * Look at some features of the form subsystem + * Look at the output of the Ada.Text_IO like functions + for ncurses. + +#MAINPAD +You may press at any place in this demo CTRL-C. This will give you a command +window. You can just type in the Label-String of a function key, then this +key will be simulated. This should help you to run the application even if +you run it on a terminal with no or only a few function keys. With CTRL-N +and CTRL-P you may browse through the possible values in the command window. +#MENU00 +Here we give you a selection of various menu demonstrations. +#MENU-PAD00 +This menu itself is a demo for a single valued, 1-column menu with +descriptions for the items, a marker and a padding character between +the item name and the description. +#MENU01 +This is a demo of the some of the menu layout options. One of them +is the spacing functionality. Just press the Key labeled "Flip" to +flip between the non-spaced and a spaced version of the menu. Please +note that this functionality is unique for ncurses and is not found +in the SVr4 menu implementation. + +This is a menu that sometimes does not fit into it's window and +therefore it becomes a scroll menu. + +You can also see here very nicely the pattern matching functionality +of menus. Type for example a 'J' and you will be positioned to the +next item after the current starting with a 'J'. Any more characters +you type in make the pattern more specific. With CTRL-A and CTRL-Z +(for more details press the Key labeled "Keys") you can browse +through all the items matching the pattern. + +You may change the format of the menu. Just press one of the keys +labeled "4x1", "4x2" or "4x3" to get a menu with that many rows +and columns. + +With the Keys "O-Row" or "O-Col" (they occupy the same label and +switch on selection) you can change the major order scheme for +the menu. If "O-Col" is visible, the menu is currently major +ordered by rows, you can switch to major column order by pressing +the key. If "O-Row" is visible, it's just the reverse situation. +This Key is not visible in "4x1" layout mode, because in this case +the functionality makes no sense. + +With the Keys "Multi" or "Singl" (they occupy the same label and +switch on selection) you can change whether or not the menu allows +multiple or only single selection. + +With the Keys "+Desc" or "-Desc" (they occupy the same label and +switch on selection) you can change whether or not the descriptions +for each item should be displayed. Please not that this key is +not visible in the "4x3" layout mode, because in this case the +menu would not fit on a typical 80x24 screen. + +With the Keys "Disab" or "Enab" (they occupy the same label and +switch on selection) you can dis- or enable the selectability of +the month with 31 days. +#MENU-PAD01 +You may press "Flip" to see the effect of ncurses unique menu-spacing. +The Keys "4x1", "4x2" and "4x3" will change the format of the menu. +Please note that this is a scrolling menu. You may also play with the +pattern matching functionality or try to change the format of the menu. +For more details press the Key labeled "Help". +#FORM00 +This is a demo of the forms package. +#FORM-PAD00 +Please note that this demo is far from being complete. It really shows +only a small part of the functionality of the forms package. Let's hope +the next version will have a richer demo (You want to contribute ?). +#NOTIMPL +Sorry this functionality of the demo is not implemented at the moment. +Remember this is a freeware project, so I can use only my very rare +free time to continue coding. If you would like to contribute, you +are very welcome ! +#CURSES00 +This is a menu where you can select some different demos of the ncurses +functionality. +#CURSES-PAD00 +Please note that this demo is far from being complete. It really shows +only a small part of the functionality of the curses package. Let's hope +the next version will have a richer demo (You want to contribute ?). +#MOUSEKEYS +In this demo you may use this keys: + + - Key labeled "Help" to get a help + - Key labeled "Keys" is what you are reading now + - Key labeled "Quit" to leave the demo + +You may click the mouse buttons at any location at the screen and look +at the protocol window ! +#MOUSE00 +A rather simple use of a mouse as demo. It's there just to test the +code and to provide the sample source. + +It might be of interest, that the output into the protocol window is +done by the (n)curses Text_IO subpackages. Especially the output of +the button and state names is done by Ads's enumeration IO, which +allows you to print the names of enumeration literals. That's really +nice. +#MOUSE-PAD00 +This is a very simple demo of the mouse features of ncurses. It's there +just to test whether or not the generated code for the binding really +works on the different architectures (seems so). +#ATTRIBDEMO +Again this is a more than simple demo and just here to give you the +sourcecode. +#ATTRIBKEYS +You may press one of the three well known standard keys of this demo. +#ATTRIB-PAD00 +Again this is a more than simple demo and just here to give you the +source code. Feel free to contribute more. +#TEXTIO +#TEXTIOKEYS +#TEXTIO-PAD00 +#END diff --git a/Ada95/samples/ncurses.adb b/Ada95/samples/ncurses.adb new file mode 100644 index 000000000000..19f658d5632c --- /dev/null +++ b/Ada95/samples/ncurses.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.m; use ncurses2.m; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +procedure ncurses is +begin + OS_Exit (main); +end ncurses; diff --git a/Ada95/samples/ncurses2-acs_and_scroll.adb b/Ada95/samples/ncurses2-acs_and_scroll.adb new file mode 100644 index 000000000000..00e9afc26078 --- /dev/null +++ b/Ada95/samples/ncurses2-acs_and_scroll.adb @@ -0,0 +1,714 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.11 $ +-- $Date: 2011/03/23 00:33:00 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- Windows and scrolling tester. +-- Demonstrate windows + +with Ada.Strings.Fixed; +with Ada.Strings; + +with ncurses2.util; use ncurses2.util; +with ncurses2.genericPuts; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse; +with Terminal_Interface.Curses.PutWin; use Terminal_Interface.Curses.PutWin; + +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; +with Ada.Streams; use Ada.Streams; + +procedure ncurses2.acs_and_scroll is + + Macro_Quit : constant Key_Code := Character'Pos ('Q') mod 16#20#; + Macro_Escape : constant Key_Code := Character'Pos ('[') mod 16#20#; + + Quit : constant Key_Code := CTRL ('Q'); + Escape : constant Key_Code := CTRL ('['); + + Botlines : constant Line_Position := 4; + + type pair is record + y : Line_Position; + x : Column_Position; + end record; + + type Frame; + type FrameA is access Frame; + + f : File_Type; + dumpfile : constant String := "screendump"; + + procedure Outerbox (ul, lr : pair; onoff : Boolean); + function HaveKeyPad (w : Window) return Boolean; + function HaveScroll (w : Window) return Boolean; + procedure newwin_legend (curpw : Window); + procedure transient (curpw : Window; msg : String); + procedure newwin_report (win : Window := Standard_Window); + procedure selectcell (uli : Line_Position; + ulj : Column_Position; + lri : Line_Position; + lrj : Column_Position; + p : out pair; + b : out Boolean); + function getwindow return Window; + procedure newwin_move (win : Window; + dy : Line_Position; + dx : Column_Position); + function delete_framed (fp : FrameA; showit : Boolean) return FrameA; + + -- A linked list + -- I wish there was a standard library linked list. Oh well. + type Frame is record + next, last : FrameA; + do_scroll : Boolean; + do_keypad : Boolean; + wind : Window; + end record; + + current : FrameA; + + c : Key_Code; + + procedure Outerbox (ul, lr : pair; onoff : Boolean) is + begin + if onoff then + -- Note the fix of an obscure bug + -- try making a 1x1 box then enlarging it, the is a blank + -- upper left corner! + Add (Line => ul.y - 1, Column => ul.x - 1, + Ch => ACS_Map (ACS_Upper_Left_Corner)); + Add (Line => ul.y - 1, Column => lr.x + 1, + Ch => ACS_Map (ACS_Upper_Right_Corner)); + Add (Line => lr.y + 1, Column => lr.x + 1, + Ch => ACS_Map (ACS_Lower_Right_Corner)); + Add (Line => lr.y + 1, Column => ul.x - 1, + Ch => ACS_Map (ACS_Lower_Left_Corner)); + + Move_Cursor (Line => ul.y - 1, Column => ul.x); + Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line), + Line_Size => Integer (lr.x - ul.x) + 1); + Move_Cursor (Line => ul.y, Column => ul.x - 1); + Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line), + Line_Size => Integer (lr.y - ul.y) + 1); + Move_Cursor (Line => lr.y + 1, Column => ul.x); + Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line), + Line_Size => Integer (lr.x - ul.x) + 1); + Move_Cursor (Line => ul.y, Column => lr.x + 1); + Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line), + Line_Size => Integer (lr.y - ul.y) + 1); + else + Add (Line => ul.y - 1, Column => ul.x - 1, Ch => ' '); + Add (Line => ul.y - 1, Column => lr.x + 1, Ch => ' '); + Add (Line => lr.y + 1, Column => lr.x + 1, Ch => ' '); + Add (Line => lr.y + 1, Column => ul.x - 1, Ch => ' '); + + Move_Cursor (Line => ul.y - 1, Column => ul.x); + Horizontal_Line (Line_Symbol => Blank2, + Line_Size => Integer (lr.x - ul.x) + 1); + Move_Cursor (Line => ul.y, Column => ul.x - 1); + Vertical_Line (Line_Symbol => Blank2, + Line_Size => Integer (lr.y - ul.y) + 1); + Move_Cursor (Line => lr.y + 1, Column => ul.x); + Horizontal_Line (Line_Symbol => Blank2, + Line_Size => Integer (lr.x - ul.x) + 1); + Move_Cursor (Line => ul.y, Column => lr.x + 1); + Vertical_Line (Line_Symbol => Blank2, + Line_Size => Integer (lr.y - ul.y) + 1); + end if; + end Outerbox; + + function HaveKeyPad (w : Window) return Boolean is + begin + return Get_KeyPad_Mode (w); + exception + when Curses_Exception => return False; + end HaveKeyPad; + + function HaveScroll (w : Window) return Boolean is + begin + return Scrolling_Allowed (w); + exception + when Curses_Exception => return False; + end HaveScroll; + + procedure newwin_legend (curpw : Window) is + + package p is new genericPuts (200); + use p; + use p.BS; + + type string_a is access String; + + type rrr is record + msg : string_a; + code : Integer range 0 .. 3; + end record; + + legend : constant array (Positive range <>) of rrr := + ( + ( + new String'("^C = create window"), 0 + ), + ( + new String'("^N = next window"), 0 + ), + ( + new String'("^P = previous window"), 0 + ), + ( + new String'("^F = scroll forward"), 0 + ), + ( + new String'("^B = scroll backward"), 0 + ), + ( + new String'("^K = keypad(%s)"), 1 + ), + ( + new String'("^S = scrollok(%s)"), 2 + ), + ( + new String'("^W = save window to file"), 0 + ), + ( + new String'("^R = restore window"), 0 + ), + ( + new String'("^X = resize"), 0 + ), + ( + new String'("^Q%s = exit"), 3 + ) + ); + + buf : Bounded_String; + do_keypad : constant Boolean := HaveKeyPad (curpw); + do_scroll : constant Boolean := HaveScroll (curpw); + + pos : Natural; + + mypair : pair; + + use Ada.Strings.Fixed; + + begin + Move_Cursor (Line => Lines - 4, Column => 0); + for n in legend'Range loop + pos := Ada.Strings.Fixed.Index (Source => legend (n).msg.all, + Pattern => "%s"); + -- buf := (others => ' '); + buf := To_Bounded_String (legend (n).msg.all); + case legend (n).code is + when 0 => null; + when 1 => + if do_keypad then + Replace_Slice (buf, pos, pos + 1, "yes"); + else + Replace_Slice (buf, pos, pos + 1, "no"); + end if; + when 2 => + if do_scroll then + Replace_Slice (buf, pos, pos + 1, "yes"); + else + Replace_Slice (buf, pos, pos + 1, "no"); + end if; + when 3 => + if do_keypad then + Replace_Slice (buf, pos, pos + 1, "/ESC"); + else + Replace_Slice (buf, pos, pos + 1, ""); + end if; + end case; + Get_Cursor_Position (Line => mypair.y, Column => mypair.x); + if Columns < mypair.x + 3 + Column_Position (Length (buf)) then + Add (Ch => newl); + elsif n /= 1 then -- n /= legen'First + Add (Str => ", "); + end if; + myAdd (Str => buf); + end loop; + Clear_To_End_Of_Line; + end newwin_legend; + + procedure transient (curpw : Window; msg : String) is + begin + newwin_legend (curpw); + if msg /= "" then + Add (Line => Lines - 1, Column => 0, Str => msg); + Refresh; + Nap_Milli_Seconds (1000); + end if; + + Move_Cursor (Line => Lines - 1, Column => 0); + + if HaveKeyPad (curpw) then + Add (Str => "Non-arrow"); + else + Add (Str => "All other"); + end if; + Add (Str => " characters are echoed, window should "); + if not HaveScroll (curpw) then + Add (Str => "not "); + end if; + Add (Str => "scroll"); + + Clear_To_End_Of_Line; + end transient; + + procedure newwin_report (win : Window := Standard_Window) is + y : Line_Position; + x : Column_Position; + use Int_IO; + tmp2a : String (1 .. 2); + tmp2b : String (1 .. 2); + begin + if win /= Standard_Window then + transient (win, ""); + end if; + Get_Cursor_Position (win, y, x); + Move_Cursor (Line => Lines - 1, Column => Columns - 17); + Put (tmp2a, Integer (y)); + Put (tmp2b, Integer (x)); + Add (Str => "Y = " & tmp2a & " X = " & tmp2b); + if win /= Standard_Window then + Refresh; + else + Move_Cursor (win, y, x); + end if; + end newwin_report; + + procedure selectcell (uli : Line_Position; + ulj : Column_Position; + lri : Line_Position; + lrj : Column_Position; + p : out pair; + b : out Boolean) is + c : Key_Code; + res : pair; + i : Line_Position := 0; + j : Column_Position := 0; + si : constant Line_Position := lri - uli + 1; + sj : constant Column_Position := lrj - ulj + 1; + begin + res.y := uli; + res.x := ulj; + loop + Move_Cursor (Line => uli + i, Column => ulj + j); + newwin_report; + + c := Getchar; + case c is + when + Macro_Quit | + Macro_Escape => + -- on the same line macro calls interfere due to the # comment + -- this is needed because keypad off affects all windows. + -- try removing the ESCAPE and see what happens. + b := False; + return; + when KEY_UP => + i := i + si - 1; + -- same as i := i - 1 because of Modulus arithmetic, + -- on Line_Position, which is a Natural + -- the C version uses this form too, interestingly. + when KEY_DOWN => + i := i + 1; + when KEY_LEFT => + j := j + sj - 1; + when KEY_RIGHT => + j := j + 1; + when Key_Mouse => + declare + event : Mouse_Event; + y : Line_Position; + x : Column_Position; + Button : Mouse_Button; + State : Button_State; + + begin + event := Get_Mouse; + Get_Event (Event => event, + Y => y, + X => x, + Button => Button, + State => State); + if y > uli and x > ulj then + i := y - uli; + j := x - ulj; + -- same as when others => + res.y := uli + i; + res.x := ulj + j; + p := res; + b := True; + return; + else + Beep; + end if; + end; + when others => + res.y := uli + i; + res.x := ulj + j; + p := res; + b := True; + return; + end case; + i := i mod si; + j := j mod sj; + end loop; + end selectcell; + + function getwindow return Window is + rwindow : Window; + ul, lr : pair; + result : Boolean; + begin + Move_Cursor (Line => 0, Column => 0); + Clear_To_End_Of_Line; + Add (Str => "Use arrows to move cursor, anything else to mark corner 1"); + Refresh; + selectcell (2, 1, Lines - Botlines - 2, Columns - 2, ul, result); + if not result then + return Null_Window; + end if; + Add (Line => ul.y - 1, Column => ul.x - 1, + Ch => ACS_Map (ACS_Upper_Left_Corner)); + Move_Cursor (Line => 0, Column => 0); + Clear_To_End_Of_Line; + Add (Str => "Use arrows to move cursor, anything else to mark corner 2"); + Refresh; + selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2, lr, result); + if not result then + return Null_Window; + end if; + + rwindow := Sub_Window (Number_Of_Lines => lr.y - ul.y + 1, + Number_Of_Columns => lr.x - ul.x + 1, + First_Line_Position => ul.y, + First_Column_Position => ul.x); + + Outerbox (ul, lr, True); + Refresh; + + Refresh (rwindow); + + Move_Cursor (Line => 0, Column => 0); + Clear_To_End_Of_Line; + return rwindow; + end getwindow; + + procedure newwin_move (win : Window; + dy : Line_Position; + dx : Column_Position) is + cur_y, max_y : Line_Position; + cur_x, max_x : Column_Position; + begin + Get_Cursor_Position (win, cur_y, cur_x); + Get_Size (win, max_y, max_x); + cur_x := Column_Position'Min (Column_Position'Max (cur_x + dx, 0), + max_x - 1); + cur_y := Line_Position'Min (Line_Position'Max (cur_y + dy, 0), + max_y - 1); + + Move_Cursor (win, Line => cur_y, Column => cur_x); + end newwin_move; + + function delete_framed (fp : FrameA; showit : Boolean) return FrameA is + np : FrameA; + begin + fp.all.last.all.next := fp.all.next; + fp.all.next.all.last := fp.all.last; + + if showit then + Erase (fp.all.wind); + Refresh (fp.all.wind); + end if; + Delete (fp.all.wind); + + if fp = fp.all.next then + np := null; + else + np := fp.all.next; + end if; + -- TODO free(fp); + return np; + end delete_framed; + + Mask : Event_Mask := No_Events; + Mask2 : Event_Mask; + + usescr : Window; + +begin + if Has_Mouse then + Register_Reportable_Event ( + Button => Left, + State => Clicked, + Mask => Mask); + Mask2 := Start_Mouse (Mask); + end if; + c := CTRL ('C'); + Set_Raw_Mode (SwitchOn => True); + loop + transient (Standard_Window, ""); + case c is + when Character'Pos ('c') mod 16#20# => -- Ctrl('c') + declare + neww : constant FrameA := new Frame'(null, null, + False, False, + Null_Window); + begin + neww.all.wind := getwindow; + if neww.all.wind = Null_Window then + exit; + -- was goto breakout; ha ha ha + else + + if current = null then + neww.all.next := neww; + neww.all.last := neww; + else + neww.all.next := current.all.next; + neww.all.last := current; + neww.all.last.all.next := neww; + neww.all.next.all.last := neww; + end if; + current := neww; + + Set_KeyPad_Mode (current.all.wind, True); + current.all.do_keypad := HaveKeyPad (current.all.wind); + current.all.do_scroll := HaveScroll (current.all.wind); + end if; + end; + when Character'Pos ('N') mod 16#20# => -- Ctrl('N') + if current /= null then + current := current.all.next; + end if; + when Character'Pos ('P') mod 16#20# => -- Ctrl('P') + if current /= null then + current := current.all.last; + end if; + when Character'Pos ('F') mod 16#20# => -- Ctrl('F') + if current /= null and then HaveScroll (current.all.wind) then + Scroll (current.all.wind, 1); + end if; + when Character'Pos ('B') mod 16#20# => -- Ctrl('B') + if current /= null and then HaveScroll (current.all.wind) then + -- The C version of Scroll may return ERR which is ignored + -- we need to avoid the exception + -- with the 'and HaveScroll(current.wind)' + Scroll (current.all.wind, -1); + end if; + when Character'Pos ('K') mod 16#20# => -- Ctrl('K') + if current /= null then + current.all.do_keypad := not current.all.do_keypad; + Set_KeyPad_Mode (current.all.wind, current.all.do_keypad); + end if; + when Character'Pos ('S') mod 16#20# => -- Ctrl('S') + if current /= null then + current.all.do_scroll := not current.all.do_scroll; + Allow_Scrolling (current.all.wind, current.all.do_scroll); + end if; + when Character'Pos ('W') mod 16#20# => -- Ctrl('W') + if current /= current.all.next then + Create (f, Name => dumpfile); -- TODO error checking + if not Is_Open (f) then + raise Curses_Exception; + end if; + Put_Window (current.all.wind, f); + Close (f); + current := delete_framed (current, True); + end if; + when Character'Pos ('R') mod 16#20# => -- Ctrl('R') + declare + neww : FrameA := new Frame'(null, null, False, False, + Null_Window); + begin + Open (f, Mode => In_File, Name => dumpfile); + neww := new Frame'(null, null, False, False, Null_Window); + + neww.all.next := current.all.next; + neww.all.last := current; + neww.all.last.all.next := neww; + neww.all.next.all.last := neww; + + neww.all.wind := Get_Window (f); + Close (f); + + Refresh (neww.all.wind); + end; + when Character'Pos ('X') mod 16#20# => -- Ctrl('X') + if current /= null then + declare + tmp, ul, lr : pair; + mx : Column_Position; + my : Line_Position; + tmpbool : Boolean; + begin + Move_Cursor (Line => 0, Column => 0); + Clear_To_End_Of_Line; + Add (Str => "Use arrows to move cursor, anything else " & + "to mark new corner"); + Refresh; + + Get_Window_Position (current.all.wind, ul.y, ul.x); + + selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2, + tmp, tmpbool); + if not tmpbool then + -- the C version had a goto. I refuse gotos. + Beep; + else + Get_Size (current.all.wind, lr.y, lr.x); + lr.y := lr.y + ul.y - 1; + lr.x := lr.x + ul.x - 1; + Outerbox (ul, lr, False); + Refresh_Without_Update; + + Get_Size (current.all.wind, my, mx); + if my > tmp.y - ul.y then + Get_Cursor_Position (current.all.wind, lr.y, lr.x); + Move_Cursor (current.all.wind, tmp.y - ul.y + 1, 0); + Clear_To_End_Of_Screen (current.all.wind); + Move_Cursor (current.all.wind, lr.y, lr.x); + end if; + if mx > tmp.x - ul.x then + for i in 0 .. my - 1 loop + Move_Cursor (current.all.wind, i, tmp.x - ul.x + 1); + Clear_To_End_Of_Line (current.all.wind); + end loop; + end if; + Refresh_Without_Update (current.all.wind); + + lr := tmp; + -- The C version passes invalid args to resize + -- which returns an ERR. For Ada we avoid the exception. + if lr.y /= ul.y and lr.x /= ul.x then + Resize (current.all.wind, lr.y - ul.y + 0, + lr.x - ul.x + 0); + end if; + + Get_Window_Position (current.all.wind, ul.y, ul.x); + Get_Size (current.all.wind, lr.y, lr.x); + lr.y := lr.y + ul.y - 1; + lr.x := lr.x + ul.x - 1; + Outerbox (ul, lr, True); + Refresh_Without_Update; + + Refresh_Without_Update (current.all.wind); + Move_Cursor (Line => 0, Column => 0); + Clear_To_End_Of_Line; + Update_Screen; + end if; + end; + end if; + when Key_F10 => + declare tmp : pair; tmpbool : Boolean; + begin + -- undocumented --- use this to test area clears + selectcell (0, 0, Lines - 1, Columns - 1, tmp, tmpbool); + Clear_To_End_Of_Screen; + Refresh; + end; + when Key_Cursor_Up => + newwin_move (current.all.wind, -1, 0); + when Key_Cursor_Down => + newwin_move (current.all.wind, 1, 0); + when Key_Cursor_Left => + newwin_move (current.all.wind, 0, -1); + when Key_Cursor_Right => + newwin_move (current.all.wind, 0, 1); + when Key_Backspace | Key_Delete_Char => + declare + y : Line_Position; + x : Column_Position; + tmp : Line_Position; + begin + Get_Cursor_Position (current.all.wind, y, x); + -- x := x - 1; + -- I got tricked by the -1 = Max_Natural - 1 result + -- y := y - 1; + if not (x = 0 and y = 0) then + if x = 0 then + y := y - 1; + Get_Size (current.all.wind, tmp, x); + end if; + x := x - 1; + Delete_Character (current.all.wind, y, x); + end if; + end; + when others => + -- TODO c = '\r' ? + if current /= null then + declare + begin + Add (current.all.wind, Ch => Code_To_Char (c)); + exception + when Curses_Exception => null; + -- this happens if we are at the + -- lower right of a window and add a character. + end; + else + Beep; + end if; + end case; + newwin_report (current.all.wind); + if current /= null then + usescr := current.all.wind; + else + usescr := Standard_Window; + end if; + Refresh (usescr); + c := Getchar (usescr); + exit when c = Quit or (c = Escape and HaveKeyPad (usescr)); + -- TODO when does c = ERR happen? + end loop; + + -- TODO while current /= null loop + -- current := delete_framed(current, False); + -- end loop; + + Allow_Scrolling (Mode => True); + + End_Mouse (Mask2); + Set_Raw_Mode (SwitchOn => True); + Erase; + End_Windows; + +end ncurses2.acs_and_scroll; diff --git a/Ada95/samples/ncurses2-acs_and_scroll.ads b/Ada95/samples/ncurses2-acs_and_scroll.ads new file mode 100644 index 000000000000..79e4862af0f6 --- /dev/null +++ b/Ada95/samples/ncurses2-acs_and_scroll.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.acs_and_scroll; diff --git a/Ada95/samples/ncurses2-acs_display.adb b/Ada95/samples/ncurses2-acs_display.adb new file mode 100644 index 000000000000..a71c61d5daff --- /dev/null +++ b/Ada95/samples/ncurses2-acs_display.adb @@ -0,0 +1,235 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2006,2008 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.6 $ +-- $Date: 2008/07/26 18:47:34 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; +with ncurses2.genericPuts; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +with Ada.Strings.Unbounded; +with Ada.Strings.Fixed; + +procedure ncurses2.acs_display is + use Int_IO; + + procedure show_upper_chars (first : Integer); + function show_1_acs (N : Integer; + name : String; + code : Attributed_Character) + return Integer; + procedure show_acs_chars; + + procedure show_upper_chars (first : Integer) is + C1 : constant Boolean := (first = 128); + last : constant Integer := first + 31; + package p is new ncurses2.genericPuts (200); + use p; + use p.BS; + use Ada.Strings.Unbounded; + + tmpa : Unbounded_String; + tmpb : BS.Bounded_String; + begin + Erase; + Switch_Character_Attribute + (Attr => (Bold_Character => True, others => False)); + Move_Cursor (Line => 0, Column => 20); + tmpa := To_Unbounded_String ("Display of "); + if C1 then + tmpa := tmpa & "C1"; + else + tmpa := tmpa & "GR"; + end if; + tmpa := tmpa & " Character Codes "; + myPut (tmpb, first); + Append (tmpa, To_String (tmpb)); + Append (tmpa, " to "); + myPut (tmpb, last); + Append (tmpa, To_String (tmpb)); + Add (Str => To_String (tmpa)); + Switch_Character_Attribute + (On => False, + Attr => (Bold_Character => True, others => False)); + Refresh; + + for code in first .. last loop + declare + row : constant Line_Position + := Line_Position (4 + ((code - first) mod 16)); + col : constant Column_Position + := Column_Position (((code - first) / 16) * + Integer (Columns) / 2); + tmp3 : String (1 .. 3); + tmpx : String (1 .. Integer (Columns / 4)); + reply : Key_Code; + begin + Put (tmp3, code); + myPut (tmpb, code, 16); + tmpa := To_Unbounded_String (tmp3 & " (" & To_String (tmpb) & ')'); + + Ada.Strings.Fixed.Move (To_String (tmpa), tmpx, + Justify => Ada.Strings.Right); + Add (Line => row, Column => col, + Str => tmpx & ' ' & ':' & ' '); + if C1 then + Set_NoDelay_Mode (Mode => True); + end if; + Add_With_Immediate_Echo (Ch => Code_To_Char (Key_Code (code))); + -- TODO check this + if C1 then + reply := Getchar; + while reply /= Key_None loop + Add (Ch => Code_To_Char (reply)); + Nap_Milli_Seconds (10); + reply := Getchar; + end loop; + Set_NoDelay_Mode (Mode => False); + end if; + end; + end loop; + end show_upper_chars; + + function show_1_acs (N : Integer; + name : String; + code : Attributed_Character) + return Integer is + height : constant Integer := 16; + row : constant Line_Position := Line_Position (4 + (N mod height)); + col : constant Column_Position := Column_Position ((N / height) * + Integer (Columns) / 2); + tmpx : String (1 .. Integer (Columns) / 3); + begin + Ada.Strings.Fixed.Move (name, tmpx, + Justify => Ada.Strings.Right, + Drop => Ada.Strings.Left); + Add (Line => row, Column => col, Str => tmpx & ' ' & ':' & ' '); + -- we need more room than C because our identifiers are longer + -- 22 chars actually + Add (Ch => code); + return N + 1; + end show_1_acs; + + procedure show_acs_chars is + n : Integer; + begin + Erase; + Switch_Character_Attribute + (Attr => (Bold_Character => True, others => False)); + Add (Line => 0, Column => 20, + Str => "Display of the ACS Character Set"); + Switch_Character_Attribute (On => False, + Attr => (Bold_Character => True, + others => False)); + Refresh; + + -- the following is useful to generate the below + -- grep '^[ ]*ACS_' ../src/terminal_interface-curses.ads | + -- awk '{print "n := show_1_acs(n, \""$1"\", ACS_Map("$1"));"}' + + n := show_1_acs (0, "ACS_Upper_Left_Corner", + ACS_Map (ACS_Upper_Left_Corner)); + n := show_1_acs (n, "ACS_Lower_Left_Corner", + ACS_Map (ACS_Lower_Left_Corner)); + n := show_1_acs (n, "ACS_Upper_Right_Corner", + ACS_Map (ACS_Upper_Right_Corner)); + n := show_1_acs (n, "ACS_Lower_Right_Corner", + ACS_Map (ACS_Lower_Right_Corner)); + n := show_1_acs (n, "ACS_Left_Tee", ACS_Map (ACS_Left_Tee)); + n := show_1_acs (n, "ACS_Right_Tee", ACS_Map (ACS_Right_Tee)); + n := show_1_acs (n, "ACS_Bottom_Tee", ACS_Map (ACS_Bottom_Tee)); + n := show_1_acs (n, "ACS_Top_Tee", ACS_Map (ACS_Top_Tee)); + n := show_1_acs (n, "ACS_Horizontal_Line", + ACS_Map (ACS_Horizontal_Line)); + n := show_1_acs (n, "ACS_Vertical_Line", ACS_Map (ACS_Vertical_Line)); + n := show_1_acs (n, "ACS_Plus_Symbol", ACS_Map (ACS_Plus_Symbol)); + n := show_1_acs (n, "ACS_Scan_Line_1", ACS_Map (ACS_Scan_Line_1)); + n := show_1_acs (n, "ACS_Scan_Line_9", ACS_Map (ACS_Scan_Line_9)); + n := show_1_acs (n, "ACS_Diamond", ACS_Map (ACS_Diamond)); + n := show_1_acs (n, "ACS_Checker_Board", ACS_Map (ACS_Checker_Board)); + n := show_1_acs (n, "ACS_Degree", ACS_Map (ACS_Degree)); + n := show_1_acs (n, "ACS_Plus_Minus", ACS_Map (ACS_Plus_Minus)); + n := show_1_acs (n, "ACS_Bullet", ACS_Map (ACS_Bullet)); + n := show_1_acs (n, "ACS_Left_Arrow", ACS_Map (ACS_Left_Arrow)); + n := show_1_acs (n, "ACS_Right_Arrow", ACS_Map (ACS_Right_Arrow)); + n := show_1_acs (n, "ACS_Down_Arrow", ACS_Map (ACS_Down_Arrow)); + n := show_1_acs (n, "ACS_Up_Arrow", ACS_Map (ACS_Up_Arrow)); + n := show_1_acs (n, "ACS_Board_Of_Squares", + ACS_Map (ACS_Board_Of_Squares)); + n := show_1_acs (n, "ACS_Lantern", ACS_Map (ACS_Lantern)); + n := show_1_acs (n, "ACS_Solid_Block", ACS_Map (ACS_Solid_Block)); + n := show_1_acs (n, "ACS_Scan_Line_3", ACS_Map (ACS_Scan_Line_3)); + n := show_1_acs (n, "ACS_Scan_Line_7", ACS_Map (ACS_Scan_Line_7)); + n := show_1_acs (n, "ACS_Less_Or_Equal", ACS_Map (ACS_Less_Or_Equal)); + n := show_1_acs (n, "ACS_Greater_Or_Equal", + ACS_Map (ACS_Greater_Or_Equal)); + n := show_1_acs (n, "ACS_PI", ACS_Map (ACS_PI)); + n := show_1_acs (n, "ACS_Not_Equal", ACS_Map (ACS_Not_Equal)); + n := show_1_acs (n, "ACS_Sterling", ACS_Map (ACS_Sterling)); + + if n = 0 then + raise Constraint_Error; + end if; + end show_acs_chars; + + c1 : Key_Code; + c : Character := 'a'; +begin + loop + case c is + when 'a' => + show_acs_chars; + when '0' | '1' | '2' | '3' => + show_upper_chars (ctoi (c) * 32 + 128); + when others => + null; + end case; + Add (Line => Lines - 3, Column => 0, + Str => "Note: ANSI terminals may not display C1 characters."); + Add (Line => Lines - 2, Column => 0, + Str => "Select: a=ACS, 0=C1, 1,2,3=GR characters, q=quit"); + Refresh; + c1 := Getchar; + c := Code_To_Char (c1); + exit when c = 'q' or c = 'x'; + end loop; + Pause; + Erase; + End_Windows; +end ncurses2.acs_display; diff --git a/Ada95/samples/ncurses2-acs_display.ads b/Ada95/samples/ncurses2-acs_display.ads new file mode 100644 index 000000000000..4e616c5e1443 --- /dev/null +++ b/Ada95/samples/ncurses2-acs_display.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.acs_display; diff --git a/Ada95/samples/ncurses2-attr_test.adb b/Ada95/samples/ncurses2-attr_test.adb new file mode 100644 index 000000000000..66271042c0bb --- /dev/null +++ b/Ada95/samples/ncurses2-attr_test.adb @@ -0,0 +1,362 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2007,2008 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.9 $ +-- $Date: 2008/07/26 18:47:26 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Terminfo; +use Terminal_Interface.Curses.Terminfo; +with Ada.Characters.Handling; +with Ada.Strings.Fixed; + +procedure ncurses2.attr_test is + + function subset (super, sub : Character_Attribute_Set) return Boolean; + function intersect (b, a : Character_Attribute_Set) return Boolean; + function has_A_COLOR (attr : Attributed_Character) return Boolean; + function show_attr (row : Line_Position; + skip : Natural; + attr : Character_Attribute_Set; + name : String; + once : Boolean) return Line_Position; + procedure attr_getc (skip : in out Integer; + fg, bg : in out Color_Number; + result : out Boolean); + + function subset (super, sub : Character_Attribute_Set) return Boolean is + begin + if + (super.Stand_Out or not sub.Stand_Out) and + (super.Under_Line or not sub.Under_Line) and + (super.Reverse_Video or not sub.Reverse_Video) and + (super.Blink or not sub.Blink) and + (super.Dim_Character or not sub.Dim_Character) and + (super.Bold_Character or not sub.Bold_Character) and + (super.Alternate_Character_Set or not sub.Alternate_Character_Set) and + (super.Invisible_Character or not sub.Invisible_Character) -- and +-- (super.Protected_Character or not sub.Protected_Character) and +-- (super.Horizontal or not sub.Horizontal) and +-- (super.Left or not sub.Left) and +-- (super.Low or not sub.Low) and +-- (super.Right or not sub.Right) and +-- (super.Top or not sub.Top) and +-- (super.Vertical or not sub.Vertical) + then + return True; + else + return False; + end if; + end subset; + + function intersect (b, a : Character_Attribute_Set) return Boolean is + begin + if + (a.Stand_Out and b.Stand_Out) or + (a.Under_Line and b.Under_Line) or + (a.Reverse_Video and b.Reverse_Video) or + (a.Blink and b.Blink) or + (a.Dim_Character and b.Dim_Character) or + (a.Bold_Character and b.Bold_Character) or + (a.Alternate_Character_Set and b.Alternate_Character_Set) or + (a.Invisible_Character and b.Invisible_Character) -- or +-- (a.Protected_Character and b.Protected_Character) or +-- (a.Horizontal and b.Horizontal) or +-- (a.Left and b.Left) or +-- (a.Low and b.Low) or +-- (a.Right and b.Right) or +-- (a.Top and b.Top) or +-- (a.Vertical and b.Vertical) + then + return True; + else + return False; + end if; + end intersect; + + function has_A_COLOR (attr : Attributed_Character) return Boolean is + begin + if attr.Color /= Color_Pair (0) then + return True; + else + return False; + end if; + end has_A_COLOR; + + -- Print some text with attributes. + function show_attr (row : Line_Position; + skip : Natural; + attr : Character_Attribute_Set; + name : String; + once : Boolean) return Line_Position is + + function make_record (n : Integer) return Character_Attribute_Set; + function make_record (n : Integer) return Character_Attribute_Set is + -- unsupported means true + a : Character_Attribute_Set := (others => False); + m : Integer; + rest : Integer; + begin + -- ncv is a bitmap with these fields + -- A_STANDOUT, + -- A_UNDERLINE, + -- A_REVERSE, + -- A_BLINK, + -- A_DIM, + -- A_BOLD, + -- A_INVIS, + -- A_PROTECT, + -- A_ALTCHARSET + -- It means no_color_video, + -- video attributes that can't be used with colors + -- see man terminfo.5 + m := n mod 2; + rest := n / 2; + if 1 = m then + a.Stand_Out := True; + end if; + m := rest mod 2; + rest := rest / 2; + if 1 = m then + a.Under_Line := True; + end if; + m := rest mod 2; + rest := rest / 2; + if 1 = m then + a.Reverse_Video := True; + end if; + m := rest mod 2; + rest := rest / 2; + if 1 = m then + a.Blink := True; + end if; + m := rest mod 2; + rest := rest / 2; + if 1 = m then + a.Bold_Character := True; + end if; + m := rest mod 2; + rest := rest / 2; + if 1 = m then + a.Invisible_Character := True; + end if; + m := rest mod 2; + rest := rest / 2; + if 1 = m then + a.Protected_Character := True; + end if; + m := rest mod 2; + rest := rest / 2; + if 1 = m then + a.Alternate_Character_Set := True; + end if; + + return a; + end make_record; + + ncv : constant Integer := Get_Number ("ncv"); + + begin + Move_Cursor (Line => row, Column => 8); + Add (Str => name & " mode:"); + Move_Cursor (Line => row, Column => 24); + Add (Ch => '|'); + if skip /= 0 then + -- printw("%*s", skip, " ") + Add (Str => Ada.Strings.Fixed."*" (skip, ' ')); + end if; + if once then + Switch_Character_Attribute (Attr => attr); + else + Set_Character_Attributes (Attr => attr); + end if; + Add (Str => "abcde fghij klmno pqrst uvwxy z"); + if once then + Switch_Character_Attribute (Attr => attr, On => False); + end if; + if skip /= 0 then + Add (Str => Ada.Strings.Fixed."*" (skip, ' ')); + end if; + Add (Ch => '|'); + if attr /= Normal_Video then + declare begin + if not subset (super => Supported_Attributes, sub => attr) then + Add (Str => " (N/A)"); + elsif ncv > 0 and has_A_COLOR (Get_Background) then + declare + Color_Supported_Attributes : + constant Character_Attribute_Set := make_record (ncv); + begin + if intersect (Color_Supported_Attributes, attr) then + Add (Str => " (NCV) "); + end if; + end; + end if; + end; + end if; + return row + 2; + end show_attr; + + procedure attr_getc (skip : in out Integer; + fg, bg : in out Color_Number; + result : out Boolean) is + ch : constant Key_Code := Getchar; + nc : constant Color_Number := Color_Number (Number_Of_Colors); + begin + result := True; + if Ada.Characters.Handling.Is_Digit (Character'Val (ch)) then + skip := ctoi (Code_To_Char (ch)); + elsif ch = CTRL ('L') then + Touch; + Touch (Current_Window); + Refresh; + elsif Has_Colors then + case ch is + -- Note the mathematical elegance compared to the C version. + when Character'Pos ('f') => fg := (fg + 1) mod nc; + when Character'Pos ('F') => fg := (fg - 1) mod nc; + when Character'Pos ('b') => bg := (bg + 1) mod nc; + when Character'Pos ('B') => bg := (bg - 1) mod nc; + when others => + result := False; + end case; + else + result := False; + end if; + end attr_getc; + + -- pairs could be defined as array ( Color_Number(0) .. colors - 1) of + -- array (Color_Number(0).. colors - 1) of Boolean; + pairs : array (Color_Pair'Range) of Boolean := (others => False); + fg, bg : Color_Number := Black; -- = 0; + xmc : constant Integer := Get_Number ("xmc"); + skip : Integer := xmc; + n : Integer; + + use Int_IO; + +begin + pairs (0) := True; + + if skip < 0 then + skip := 0; + end if; + n := skip; + + loop + declare + row : Line_Position := 2; + normal : Attributed_Character := Blank2; + -- ??? + begin + -- row := 2; -- weird, row is set to 0 without this. + -- TODO delete the above line, it was a gdb quirk that confused me + if Has_Colors then + declare pair : constant Color_Pair := + Color_Pair (fg * Color_Number (Number_Of_Colors) + bg); + begin + -- Go though each color pair. Assume that the number of + -- Redefinable_Color_Pairs is 8*8 with predefined Colors 0..7 + if not pairs (pair) then + Init_Pair (pair, fg, bg); + pairs (pair) := True; + end if; + normal.Color := pair; + end; + end if; + Set_Background (Ch => normal); + Erase; + + Add (Line => 0, Column => 20, + Str => "Character attribute test display"); + + row := show_attr (row, n, (Stand_Out => True, others => False), + "STANDOUT", True); + row := show_attr (row, n, (Reverse_Video => True, others => False), + "REVERSE", True); + row := show_attr (row, n, (Bold_Character => True, others => False), + "BOLD", True); + row := show_attr (row, n, (Under_Line => True, others => False), + "UNDERLINE", True); + row := show_attr (row, n, (Dim_Character => True, others => False), + "DIM", True); + row := show_attr (row, n, (Blink => True, others => False), + "BLINK", True); +-- row := show_attr (row, n, (Protected_Character => True, +-- others => False), "PROTECT", True); + row := show_attr (row, n, (Invisible_Character => True, + others => False), "INVISIBLE", True); + row := show_attr (row, n, Normal_Video, "NORMAL", False); + + Move_Cursor (Line => row, Column => 8); + if xmc > -1 then + Add (Str => "This terminal does have the magic-cookie glitch"); + else + Add (Str => "This terminal does not have the magic-cookie glitch"); + end if; + Move_Cursor (Line => row + 1, Column => 8); + Add (Str => "Enter a digit to set gaps on each side of " & + "displayed attributes"); + Move_Cursor (Line => row + 2, Column => 8); + Add (Str => "^L = repaint"); + if Has_Colors then + declare tmp1 : String (1 .. 1); + begin + Add (Str => ". f/F/b/F toggle colors ("); + Put (tmp1, Integer (fg)); + Add (Str => tmp1); + Add (Ch => '/'); + Put (tmp1, Integer (bg)); + Add (Str => tmp1); + Add (Ch => ')'); + end; + end if; + Refresh; + end; + + declare result : Boolean; begin + attr_getc (n, fg, bg, result); + exit when not result; + end; + end loop; + + Set_Background (Ch => Blank2); + Erase; + End_Windows; +end ncurses2.attr_test; diff --git a/Ada95/samples/ncurses2-attr_test.ads b/Ada95/samples/ncurses2-attr_test.ads new file mode 100644 index 000000000000..51c51435eab5 --- /dev/null +++ b/Ada95/samples/ncurses2-attr_test.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000,2006 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.2 $ +-- $Date: 2006/06/25 14:24:40 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.attr_test; diff --git a/Ada95/samples/ncurses2-color_edit.adb b/Ada95/samples/ncurses2-color_edit.adb new file mode 100644 index 000000000000..098f98d837b2 --- /dev/null +++ b/Ada95/samples/ncurses2-color_edit.adb @@ -0,0 +1,259 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2006,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.6 $ +-- $Date: 2009/12/26 17:38:58 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; +with ncurses2.genericPuts; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +procedure ncurses2.color_edit is + use Int_IO; + + type RGB_Enum is (Redx, Greenx, Bluex); + + procedure change_color (current : Color_Number; + field : RGB_Enum; + value : RGB_Value; + usebase : Boolean); + + procedure change_color (current : Color_Number; + field : RGB_Enum; + value : RGB_Value; + usebase : Boolean) is + red, green, blue : RGB_Value; + begin + if usebase then + Color_Content (current, red, green, blue); + else + red := 0; + green := 0; + blue := 0; + end if; + + case field is + when Redx => red := red + value; + when Greenx => green := green + value; + when Bluex => blue := blue + value; + end case; + + declare + begin + Init_Color (current, red, green, blue); + exception + when Curses_Exception => Beep; + end; + + end change_color; + + package x is new ncurses2.genericPuts (100); use x; + + tmpb : x.BS.Bounded_String; + + tmp4 : String (1 .. 4); + tmp6 : String (1 .. 6); + tmp8 : String (1 .. 8); + -- This would be easier if Ada had a Bounded_String + -- defined as a class instead of the inferior generic package, + -- then I could define Put, Add, and Get for them. Blech. + value : RGB_Value := 0; + red, green, blue : RGB_Value; + max_colors : constant Natural := Number_Of_Colors; + current : Color_Number := 0; + field : RGB_Enum := Redx; + this_c : Key_Code := 0; +begin + Refresh; + + for i in Color_Number'(0) .. Color_Number (Number_Of_Colors) loop + Init_Pair (Color_Pair (i), White, i); + end loop; + + Move_Cursor (Line => Lines - 2, Column => 0); + Add (Str => "Number: "); + myPut (tmpb, Integer (value)); + myAdd (Str => tmpb); + + loop + + Switch_Character_Attribute (On => False, + Attr => (Bold_Character => True, + others => False)); + Add (Line => 0, Column => 20, Str => "Color RGB Value Editing"); + + Switch_Character_Attribute (On => False, + Attr => (Bold_Character => True, + others => False)); + + for i in Color_Number'(0) .. Color_Number (Number_Of_Colors) loop + Move_Cursor (Line => 2 + Line_Position (i), Column => 0); + if current = i then + Add (Ch => '>'); + else + Add (Ch => ' '); + end if; + -- TODO if i <= color_names'Max then + Put (tmp8, Integer (i)); + Set_Character_Attributes (Color => Color_Pair (i)); + Add (Str => " "); + Set_Character_Attributes; + + Refresh; + + Color_Content (i, red, green, blue); + Add (Str => " R = "); + if current = i and field = Redx then + Switch_Character_Attribute (On => True, + Attr => (Stand_Out => True, + others => False)); + end if; + Put (tmp4, Integer (red)); + Add (Str => tmp4); + if current = i and field = Redx then + Set_Character_Attributes; + end if; + Add (Str => " G = "); + if current = i and field = Greenx then + Switch_Character_Attribute (On => True, + Attr => (Stand_Out => True, + others => False)); + end if; + Put (tmp4, Integer (green)); + Add (Str => tmp4); + if current = i and field = Greenx then + Set_Character_Attributes; + end if; + Add (Str => " B = "); + if current = i and field = Bluex then + Switch_Character_Attribute (On => True, + Attr => (Stand_Out => True, + others => False)); + end if; + Put (tmp4, Integer (blue)); + Add (Str => tmp4); + if current = i and field = Bluex then + Set_Character_Attributes; + end if; + Set_Character_Attributes; + Add (Ch => ')'); + end loop; + Add (Line => Line_Position (Number_Of_Colors + 3), Column => 0, + Str => "Use up/down to select a color, left/right to change " & + "fields."); + Add (Line => Line_Position (Number_Of_Colors + 4), Column => 0, + Str => "Modify field by typing nnn=, nnn-, or nnn+. ? for help."); + + Move_Cursor (Line => 2 + Line_Position (current), Column => 0); + + this_c := Getchar; + if Is_Digit (this_c) then + value := 0; + end if; + + case this_c is + when KEY_UP => + current := (current - 1) mod Color_Number (max_colors); + when KEY_DOWN => + current := (current + 1) mod Color_Number (max_colors); + when KEY_RIGHT => + field := RGB_Enum'Val ((RGB_Enum'Pos (field) + 1) mod 3); + when KEY_LEFT => + field := RGB_Enum'Val ((RGB_Enum'Pos (field) - 1) mod 3); + when + Character'Pos ('0') | + Character'Pos ('1') | + Character'Pos ('2') | + Character'Pos ('3') | + Character'Pos ('4') | + Character'Pos ('5') | + Character'Pos ('6') | + Character'Pos ('7') | + Character'Pos ('8') | + Character'Pos ('9') => + value := value * 10 + RGB_Value (ctoi (Code_To_Char (this_c))); + + when Character'Pos ('+') => + change_color (current, field, value, True); + + when Character'Pos ('-') => + change_color (current, field, -value, True); + + when Character'Pos ('=') => + change_color (current, field, value, False); + + when Character'Pos ('?') => + Erase; + P (" RGB Value Editing Help"); + P (""); + P ("You are in the RGB value editor. Use the arrow keys to " & + "select one of"); + P ("the fields in one of the RGB triples of the current colors;" & + " the one"); + P ("currently selected will be reverse-video highlighted."); + P (""); + P ("To change a field, enter the digits of the new value; they" & + " are echoed"); + P ("as entered. Finish by typing `='. The change will take" & + " effect instantly."); + P ("To increment or decrement a value, use the same procedure," & + " but finish"); + P ("with a `+' or `-'."); + P (""); + P ("To quit, do `x' or 'q'"); + + Pause; + Erase; + when Character'Pos ('q') | + Character'Pos ('x') => + null; + when others => + Beep; + end case; + Move_Cursor (Line => Lines - 2, Column => 0); + Put (tmp6, Integer (value)); + Add (Str => "Number: " & tmp6); + + Clear_To_End_Of_Line; + exit when this_c = Character'Pos ('x') or + this_c = Character'Pos ('q'); + end loop; + + Erase; + End_Windows; +end ncurses2.color_edit; diff --git a/Ada95/samples/ncurses2-color_edit.ads b/Ada95/samples/ncurses2-color_edit.ads new file mode 100644 index 000000000000..3e8e392dfe8e --- /dev/null +++ b/Ada95/samples/ncurses2-color_edit.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.color_edit; diff --git a/Ada95/samples/ncurses2-color_test.adb b/Ada95/samples/ncurses2-color_test.adb new file mode 100644 index 000000000000..c8f6c837ae17 --- /dev/null +++ b/Ada95/samples/ncurses2-color_test.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2006,2008 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.3 $ +-- $Date: 2008/07/26 18:47:17 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; + +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Ada.Strings.Fixed; + +procedure ncurses2.color_test is + use Int_IO; + + procedure show_color_name (y, x : Integer; color : Integer); + + color_names : constant array (0 .. 15) of String (1 .. 7) := + ( + "black ", + "red ", + "green ", + "yellow ", + "blue ", + "magenta", + "cyan ", + "white ", + "BLACK ", + "RED ", + "GREEN ", + "YELLOW ", + "BLUE ", + "MAGENTA", + "CYAN ", + "WHITE " + ); + + procedure show_color_name (y, x : Integer; color : Integer) is + tmp5 : String (1 .. 5); + begin + if Number_Of_Colors > 8 then + + Put (tmp5, color); + Add (Line => Line_Position (y), Column => Column_Position (x), + Str => tmp5); + else + Add (Line => Line_Position (y), Column => Column_Position (x), + Str => color_names (color)); + end if; + end show_color_name; + + top, width : Integer; + hello : String (1 .. 5); + -- tmp3 : String (1 .. 3); + -- tmp2 : String (1 .. 2); + +begin + Refresh; + Add (Str => "There are "); + -- Put(tmp3, Number_Of_Colors*Number_Of_Colors); + Add (Str => Ada.Strings.Fixed.Trim (Integer'Image (Number_Of_Colors * + Number_Of_Colors), + Ada.Strings.Left)); + Add (Str => " color pairs"); + Add (Ch => newl); + + if Number_Of_Colors > 8 then + width := 4; + else + width := 8; + end if; + + if Number_Of_Colors > 8 then + hello := "Test "; + else + hello := "Hello"; + end if; + + for Bright in Boolean loop + if Number_Of_Colors > 8 then + top := 0; + else + top := Boolean'Pos (Bright) * (Number_Of_Colors + 3); + end if; + Clear_To_End_Of_Screen; + Move_Cursor (Line => Line_Position (top) + 1, Column => 0); + -- Put(tmp2, Number_Of_Colors); + Add (Str => Ada.Strings.Fixed.Trim (Integer'Image (Number_Of_Colors), + Ada.Strings.Left)); + Add (Ch => 'x'); + Add (Str => Ada.Strings.Fixed.Trim (Integer'Image (Number_Of_Colors), + Ada.Strings.Left)); + Add (Str => " matrix of foreground/background colors, bright *"); + if Bright then + Add (Str => "on"); + else + Add (Str => "off"); + end if; + Add (Ch => '*'); + + for i in 0 .. Number_Of_Colors - 1 loop + show_color_name (top + 2, (i + 1) * width, i); + end loop; + for i in 0 .. Number_Of_Colors - 1 loop + show_color_name (top + 3 + i, 0, i); + end loop; + for i in 1 .. Number_Of_Color_Pairs - 1 loop + Init_Pair (Color_Pair (i), Color_Number (i mod Number_Of_Colors), + Color_Number (i / Number_Of_Colors)); + -- attron((attr_t) COLOR_PAIR(i)) -- Huh? + Set_Color (Pair => Color_Pair (i)); + if Bright then + Switch_Character_Attribute (Attr => (Bold_Character => True, + others => False)); + end if; + Add (Line => Line_Position (top + 3 + (i / Number_Of_Colors)), + Column => Column_Position ((i mod Number_Of_Colors + 1) * + width), + Str => hello); + Set_Character_Attributes; + end loop; + if Number_Of_Colors > 8 or Bright then + Pause; + end if; + end loop; + + Erase; + End_Windows; +end ncurses2.color_test; diff --git a/Ada95/samples/ncurses2-color_test.ads b/Ada95/samples/ncurses2-color_test.ads new file mode 100644 index 000000000000..6e663181a9bc --- /dev/null +++ b/Ada95/samples/ncurses2-color_test.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.color_test; diff --git a/Ada95/samples/ncurses2-demo_forms.adb b/Ada95/samples/ncurses2-demo_forms.adb new file mode 100644 index 000000000000..1afbb88bf3ff --- /dev/null +++ b/Ada95/samples/ncurses2-demo_forms.adb @@ -0,0 +1,497 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2006,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.6 $ +-- $Date: 2011/03/23 00:44:12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Forms; use Terminal_Interface.Curses.Forms; +with Terminal_Interface.Curses.Forms.Field_User_Data; +with Ada.Characters.Handling; +with Ada.Strings; +with Ada.Strings.Bounded; + +procedure ncurses2.demo_forms is + package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (80); + + type myptr is access Integer; + + -- The C version stores a pointer in the userptr and + -- converts it into a long integer. + -- The correct, but inconvenient way to do it is to use a + -- pointer to long and keep the pointer constant. + -- It just adds one memory piece to allocate and deallocate (not done here) + + package StringData is new + Terminal_Interface.Curses.Forms.Field_User_Data (Integer, myptr); + + function edit_secure (me : Field; c_in : Key_Code) return Key_Code; + function form_virtualize (f : Form; w : Window) return Key_Code; + function my_form_driver (f : Form; c : Key_Code) return Boolean; + function make_label (frow : Line_Position; + fcol : Column_Position; + label : String) return Field; + function make_field (frow : Line_Position; + fcol : Column_Position; + rows : Line_Count; + cols : Column_Count; + secure : Boolean) return Field; + procedure display_form (f : Form); + procedure erase_form (f : Form); + + -- prints '*' instead of characters. + -- Not that this keeps a bug from the C version: + -- type in the psasword field then move off and back. + -- the cursor is at position one, but + -- this assumes it as at the end so text gets appended instead + -- of overwtitting. + function edit_secure (me : Field; c_in : Key_Code) return Key_Code is + rows, frow : Line_Position; + nrow : Natural; + cols, fcol : Column_Position; + nbuf : Buffer_Number; + c : Key_Code := c_in; + c2 : Character; + + use StringData; + begin + Info (me, rows, cols, frow, fcol, nrow, nbuf); + -- TODO if result = Form_Ok and nbuf > 0 then + -- C version checked the return value + -- of Info, the Ada binding throws an exception I think. + if nbuf > 0 then + declare + temp : BS.Bounded_String; + temps : String (1 .. 10); + -- TODO Get_Buffer povides no information on the field length? + len : myptr; + begin + Get_Buffer (me, 1, Str => temps); + -- strcpy(temp, field_buffer(me, 1)); + Get_User_Data (me, len); + temp := BS.To_Bounded_String (temps (1 .. len.all)); + if c <= Key_Max then + c2 := Code_To_Char (c); + if Ada.Characters.Handling.Is_Graphic (c2) then + BS.Append (temp, c2); + len.all := len.all + 1; + Set_Buffer (me, 1, BS.To_String (temp)); + c := Character'Pos ('*'); + else + c := 0; + end if; + else + case c is + when REQ_BEG_FIELD | + REQ_CLR_EOF | + REQ_CLR_EOL | + REQ_DEL_LINE | + REQ_DEL_WORD | + REQ_DOWN_CHAR | + REQ_END_FIELD | + REQ_INS_CHAR | + REQ_INS_LINE | + REQ_LEFT_CHAR | + REQ_NEW_LINE | + REQ_NEXT_WORD | + REQ_PREV_WORD | + REQ_RIGHT_CHAR | + REQ_UP_CHAR => + c := 0; -- we don't want to do inline editing + when REQ_CLR_FIELD => + if len.all /= 0 then + temp := BS.To_Bounded_String (""); + Set_Buffer (me, 1, BS.To_String (temp)); + len.all := 0; + end if; + + when REQ_DEL_CHAR | + REQ_DEL_PREV => + if len.all /= 0 then + BS.Delete (temp, BS.Length (temp), BS.Length (temp)); + Set_Buffer (me, 1, BS.To_String (temp)); + len.all := len.all - 1; + end if; + when others => null; + end case; + end if; + end; + end if; + return c; + end edit_secure; + + mode : Key_Code := REQ_INS_MODE; + + function form_virtualize (f : Form; w : Window) return Key_Code is + type lookup_t is record + code : Key_Code; + result : Key_Code; + -- should be Form_Request_Code, but we need MAX_COMMAND + 1 + end record; + + lookup : constant array (Positive range <>) of lookup_t := + ( + ( + Character'Pos ('A') mod 16#20#, REQ_NEXT_CHOICE + ), + ( + Character'Pos ('B') mod 16#20#, REQ_PREV_WORD + ), + ( + Character'Pos ('C') mod 16#20#, REQ_CLR_EOL + ), + ( + Character'Pos ('D') mod 16#20#, REQ_DOWN_FIELD + ), + ( + Character'Pos ('E') mod 16#20#, REQ_END_FIELD + ), + ( + Character'Pos ('F') mod 16#20#, REQ_NEXT_PAGE + ), + ( + Character'Pos ('G') mod 16#20#, REQ_DEL_WORD + ), + ( + Character'Pos ('H') mod 16#20#, REQ_DEL_PREV + ), + ( + Character'Pos ('I') mod 16#20#, REQ_INS_CHAR + ), + ( + Character'Pos ('K') mod 16#20#, REQ_CLR_EOF + ), + ( + Character'Pos ('L') mod 16#20#, REQ_LEFT_FIELD + ), + ( + Character'Pos ('M') mod 16#20#, REQ_NEW_LINE + ), + ( + Character'Pos ('N') mod 16#20#, REQ_NEXT_FIELD + ), + ( + Character'Pos ('O') mod 16#20#, REQ_INS_LINE + ), + ( + Character'Pos ('P') mod 16#20#, REQ_PREV_FIELD + ), + ( + Character'Pos ('R') mod 16#20#, REQ_RIGHT_FIELD + ), + ( + Character'Pos ('S') mod 16#20#, REQ_BEG_FIELD + ), + ( + Character'Pos ('U') mod 16#20#, REQ_UP_FIELD + ), + ( + Character'Pos ('V') mod 16#20#, REQ_DEL_CHAR + ), + ( + Character'Pos ('W') mod 16#20#, REQ_NEXT_WORD + ), + ( + Character'Pos ('X') mod 16#20#, REQ_CLR_FIELD + ), + ( + Character'Pos ('Y') mod 16#20#, REQ_DEL_LINE + ), + ( + Character'Pos ('Z') mod 16#20#, REQ_PREV_CHOICE + ), + ( + Character'Pos ('[') mod 16#20#, -- ESCAPE + Form_Request_Code'Last + 1 + ), + ( + Key_Backspace, REQ_DEL_PREV + ), + ( + KEY_DOWN, REQ_DOWN_CHAR + ), + ( + Key_End, REQ_LAST_FIELD + ), + ( + Key_Home, REQ_FIRST_FIELD + ), + ( + KEY_LEFT, REQ_LEFT_CHAR + ), + ( + KEY_LL, REQ_LAST_FIELD + ), + ( + Key_Next, REQ_NEXT_FIELD + ), + ( + KEY_NPAGE, REQ_NEXT_PAGE + ), + ( + KEY_PPAGE, REQ_PREV_PAGE + ), + ( + Key_Previous, REQ_PREV_FIELD + ), + ( + KEY_RIGHT, REQ_RIGHT_CHAR + ), + ( + KEY_UP, REQ_UP_CHAR + ), + ( + Character'Pos ('Q') mod 16#20#, -- QUIT + Form_Request_Code'Last + 1 -- TODO MAX_FORM_COMMAND + 1 + ) + ); + + c : Key_Code := Getchar (w); + me : constant Field := Current (f); + + begin + if c = Character'Pos (']') mod 16#20# then + if mode = REQ_INS_MODE then + mode := REQ_OVL_MODE; + else + mode := REQ_INS_MODE; + end if; + c := mode; + else + for n in lookup'Range loop + if lookup (n).code = c then + c := lookup (n).result; + exit; + end if; + end loop; + end if; + + -- Force the field that the user is typing into to be in reverse video, + -- while the other fields are shown underlined. + if c <= Key_Max then + c := edit_secure (me, c); + Set_Background (me, (Reverse_Video => True, others => False)); + elsif c <= Form_Request_Code'Last then + c := edit_secure (me, c); + Set_Background (me, (Under_Line => True, others => False)); + end if; + return c; + end form_virtualize; + + function my_form_driver (f : Form; c : Key_Code) return Boolean is + flag : constant Driver_Result := Driver (f, F_Validate_Field); + begin + if c = Form_Request_Code'Last + 1 + and flag = Form_Ok then + return True; + else + Beep; + return False; + end if; + end my_form_driver; + + function make_label (frow : Line_Position; + fcol : Column_Position; + label : String) return Field is + f : constant Field := Create (1, label'Length, frow, fcol, 0, 0); + o : Field_Option_Set := Get_Options (f); + begin + if f /= Null_Field then + Set_Buffer (f, 0, label); + o.Active := False; + Set_Options (f, o); + end if; + return f; + end make_label; + + function make_field (frow : Line_Position; + fcol : Column_Position; + rows : Line_Count; + cols : Column_Count; + secure : Boolean) return Field is + f : Field; + use StringData; + len : myptr; + begin + if secure then + f := Create (rows, cols, frow, fcol, 0, 1); + else + f := Create (rows, cols, frow, fcol, 0, 0); + end if; + + if f /= Null_Field then + Set_Background (f, (Under_Line => True, others => False)); + len := new Integer; + len.all := 0; + Set_User_Data (f, len); + end if; + return f; + end make_field; + + procedure display_form (f : Form) is + w : Window; + rows : Line_Count; + cols : Column_Count; + begin + Scale (f, rows, cols); + + w := New_Window (rows + 2, cols + 4, 0, 0); + if w /= Null_Window then + Set_Window (f, w); + Set_Sub_Window (f, Derived_Window (w, rows, cols, 1, 2)); + Box (w); -- 0,0 + Set_KeyPad_Mode (w, True); + end if; + + -- TODO if Post(f) /= Form_Ok then it's a procedure + declare + begin + Post (f); + exception + when + Eti_System_Error | + Eti_Bad_Argument | + Eti_Posted | + Eti_Connected | + Eti_Bad_State | + Eti_No_Room | + Eti_Not_Posted | + Eti_Unknown_Command | + Eti_No_Match | + Eti_Not_Selectable | + Eti_Not_Connected | + Eti_Request_Denied | + Eti_Invalid_Field | + Eti_Current => + Refresh (w); + end; + -- end if; + end display_form; + + procedure erase_form (f : Form) is + w : Window := Get_Window (f); + s : Window := Get_Sub_Window (f); + begin + Post (f, False); + Erase (w); + Refresh (w); + Delete (s); + Delete (w); + end erase_form; + + finished : Boolean := False; + f : constant Field_Array_Access := new Field_Array (1 .. 12); + secure : Field; + myform : Form; + w : Window; + c : Key_Code; + result : Driver_Result; +begin + Move_Cursor (Line => 18, Column => 0); + Add (Str => "Defined form-traversal keys: ^Q/ESC- exit form"); + Add (Ch => newl); + Add (Str => "^N -- go to next field ^P -- go to previous field"); + Add (Ch => newl); + Add (Str => "Home -- go to first field End -- go to last field"); + Add (Ch => newl); + Add (Str => "^L -- go to field to left ^R -- go to field to right"); + Add (Ch => newl); + Add (Str => "^U -- move upward to field ^D -- move downward to field"); + Add (Ch => newl); + Add (Str => "^W -- go to next word ^B -- go to previous word"); + Add (Ch => newl); + Add (Str => "^S -- go to start of field ^E -- go to end of field"); + Add (Ch => newl); + Add (Str => "^H -- delete previous char ^Y -- delete line"); + Add (Ch => newl); + Add (Str => "^G -- delete current word ^C -- clear to end of line"); + Add (Ch => newl); + Add (Str => "^K -- clear to end of field ^X -- clear field"); + Add (Ch => newl); + Add (Str => "Arrow keys move within a field as you would expect."); + + Add (Line => 4, Column => 57, Str => "Forms Entry Test"); + + Refresh; + + -- describe the form + f.all (1) := make_label (0, 15, "Sample Form"); + f.all (2) := make_label (2, 0, "Last Name"); + f.all (3) := make_field (3, 0, 1, 18, False); + f.all (4) := make_label (2, 20, "First Name"); + f.all (5) := make_field (3, 20, 1, 12, False); + f.all (6) := make_label (2, 34, "Middle Name"); + f.all (7) := make_field (3, 34, 1, 12, False); + f.all (8) := make_label (5, 0, "Comments"); + f.all (9) := make_field (6, 0, 4, 46, False); + f.all (10) := make_label (5, 20, "Password:"); + f.all (11) := make_field (5, 30, 1, 9, True); + secure := f.all (11); + f.all (12) := Null_Field; + + myform := New_Form (f); + + display_form (myform); + + w := Get_Window (myform); + Set_Raw_Mode (SwitchOn => True); + Set_NL_Mode (SwitchOn => True); -- lets us read ^M's + while not finished loop + c := form_virtualize (myform, w); + result := Driver (myform, c); + case result is + when Form_Ok => + Add (Line => 5, Column => 57, Str => Get_Buffer (secure, 1)); + Clear_To_End_Of_Line; + Refresh; + when Unknown_Request => + finished := my_form_driver (myform, c); + when others => + Beep; + end case; + end loop; + + erase_form (myform); + + -- TODO Free_Form(myform); + -- for (c = 0; f[c] != 0; c++) free_field(f[c]); + Set_Raw_Mode (SwitchOn => False); + Set_NL_Mode (SwitchOn => True); + +end ncurses2.demo_forms; diff --git a/Ada95/samples/ncurses2-demo_forms.ads b/Ada95/samples/ncurses2-demo_forms.ads new file mode 100644 index 000000000000..eabaa01b9e91 --- /dev/null +++ b/Ada95/samples/ncurses2-demo_forms.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.demo_forms; diff --git a/Ada95/samples/ncurses2-demo_pad.adb b/Ada95/samples/ncurses2-demo_pad.adb new file mode 100644 index 000000000000..b1b72aec0b60 --- /dev/null +++ b/Ada95/samples/ncurses2-demo_pad.adb @@ -0,0 +1,675 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2008,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.8 $ +-- $Date: 2011/03/23 00:44:12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; + +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +with Interfaces.C; +with System.Storage_Elements; +with System.Address_To_Access_Conversions; + +with Ada.Text_IO; +-- with Ada.Real_Time; use Ada.Real_Time; +-- TODO is there a way to use Real_Time or Ada.Calendar in place of +-- gettimeofday? + +-- Demonstrate pads. +procedure ncurses2.demo_pad is + + type timestruct is record + seconds : Integer; + microseconds : Integer; + end record; + + type myfunc is access function (w : Window) return Key_Code; + + function gettime return timestruct; + procedure do_h_line (y : Line_Position; + x : Column_Position; + c : Attributed_Character; + to : Column_Position); + procedure do_v_line (y : Line_Position; + x : Column_Position; + c : Attributed_Character; + to : Line_Position); + function padgetch (win : Window) return Key_Code; + function panner_legend (line : Line_Position) return Boolean; + procedure panner_legend (line : Line_Position); + procedure panner_h_cleanup (from_y : Line_Position; + from_x : Column_Position; + to_x : Column_Position); + procedure panner_v_cleanup (from_y : Line_Position; + from_x : Column_Position; + to_y : Line_Position); + procedure panner (pad : Window; + top_xp : Column_Position; + top_yp : Line_Position; + portyp : Line_Position; + portxp : Column_Position; + pgetc : myfunc); + + function gettime return timestruct is + + retval : timestruct; + + use Interfaces.C; + type timeval is record + tv_sec : long; + tv_usec : long; + end record; + pragma Convention (C, timeval); + + -- TODO function from_timeval is new Ada.Unchecked_Conversion( + -- timeval_a, System.Storage_Elements.Integer_Address); + -- should Interfaces.C.Pointers be used here? + + package myP is new System.Address_To_Access_Conversions (timeval); + use myP; + + t : constant Object_Pointer := new timeval; + + function gettimeofday + (TP : System.Storage_Elements.Integer_Address; + TZP : System.Storage_Elements.Integer_Address) return int; + pragma Import (C, gettimeofday, "gettimeofday"); + tmp : int; + begin + tmp := gettimeofday (System.Storage_Elements.To_Integer + (myP.To_Address (t)), + System.Storage_Elements.To_Integer + (myP.To_Address (null))); + if tmp < 0 then + retval.seconds := 0; + retval.microseconds := 0; + else + retval.seconds := Integer (t.all.tv_sec); + retval.microseconds := Integer (t.all.tv_usec); + end if; + return retval; + end gettime; + + -- in C, The behavior of mvhline, mvvline for negative/zero length is + -- unspecified, though we can rely on negative x/y values to stop the + -- macro. Except Ada makes Line_Position(-1) = Natural - 1 so forget it. + procedure do_h_line (y : Line_Position; + x : Column_Position; + c : Attributed_Character; + to : Column_Position) is + begin + if to > x then + Move_Cursor (Line => y, Column => x); + Horizontal_Line (Line_Size => Natural (to - x), Line_Symbol => c); + end if; + end do_h_line; + + procedure do_v_line (y : Line_Position; + x : Column_Position; + c : Attributed_Character; + to : Line_Position) is + begin + if to > y then + Move_Cursor (Line => y, Column => x); + Vertical_Line (Line_Size => Natural (to - y), Line_Symbol => c); + end if; + end do_v_line; + + function padgetch (win : Window) return Key_Code is + c : Key_Code; + c2 : Character; + begin + c := Getchar (win); + c2 := Code_To_Char (c); + + case c2 is + when '!' => + ShellOut (False); + return Key_Refresh; + when Character'Val (Character'Pos ('r') mod 16#20#) => -- CTRL('r') + End_Windows; + Refresh; + return Key_Refresh; + when Character'Val (Character'Pos ('l') mod 16#20#) => -- CTRL('l') + return Key_Refresh; + when 'U' => + return Key_Cursor_Up; + when 'D' => + return Key_Cursor_Down; + when 'R' => + return Key_Cursor_Right; + when 'L' => + return Key_Cursor_Left; + when '+' => + return Key_Insert_Line; + when '-' => + return Key_Delete_Line; + when '>' => + return Key_Insert_Char; + when '<' => + return Key_Delete_Char; + -- when ERR=> /* FALLTHRU */ + when 'q' => + return (Key_Exit); + when others => + return (c); + end case; + end padgetch; + + show_panner_legend : Boolean := True; + + function panner_legend (line : Line_Position) return Boolean is + legend : constant array (0 .. 3) of String (1 .. 61) := + ( + "Use arrow keys (or U,D,L,R) to pan, q to quit (?,t,s flags) ", + "Use ! to shell-out. Toggle legend:?, timer:t, scroll mark:s.", + "Use +,- (or j,k) to grow/shrink the panner vertically. ", + "Use <,> (or h,l) to grow/shrink the panner horizontally. "); + legendsize : constant := 4; + + n : constant Integer := legendsize - Integer (Lines - line); + begin + if line < Lines and n >= 0 then + Move_Cursor (Line => line, Column => 0); + if show_panner_legend then + Add (Str => legend (n)); + end if; + Clear_To_End_Of_Line; + return show_panner_legend; + end if; + return False; + end panner_legend; + + procedure panner_legend (line : Line_Position) is + begin + if not panner_legend (line) then + Beep; + end if; + end panner_legend; + + procedure panner_h_cleanup (from_y : Line_Position; + from_x : Column_Position; + to_x : Column_Position) is + begin + if not panner_legend (from_y) then + do_h_line (from_y, from_x, Blank2, to_x); + end if; + end panner_h_cleanup; + + procedure panner_v_cleanup (from_y : Line_Position; + from_x : Column_Position; + to_y : Line_Position) is + begin + if not panner_legend (from_y) then + do_v_line (from_y, from_x, Blank2, to_y); + end if; + end panner_v_cleanup; + + procedure panner (pad : Window; + top_xp : Column_Position; + top_yp : Line_Position; + portyp : Line_Position; + portxp : Column_Position; + pgetc : myfunc) is + + function f (y : Line_Position) return Line_Position; + function f (x : Column_Position) return Column_Position; + function greater (y1, y2 : Line_Position) return Integer; + function greater (x1, x2 : Column_Position) return Integer; + + top_x : Column_Position := top_xp; + top_y : Line_Position := top_yp; + porty : Line_Position := portyp; + portx : Column_Position := portxp; + + -- f[x] returns max[x - 1, 0] + function f (y : Line_Position) return Line_Position is + begin + if y > 0 then + return y - 1; + else + return y; -- 0 + end if; + end f; + + function f (x : Column_Position) return Column_Position is + begin + if x > 0 then + return x - 1; + else + return x; -- 0 + end if; + end f; + + function greater (y1, y2 : Line_Position) return Integer is + begin + if y1 > y2 then + return 1; + else + return 0; + end if; + end greater; + + function greater (x1, x2 : Column_Position) return Integer is + begin + if x1 > x2 then + return 1; + else + return 0; + end if; + end greater; + + pymax : Line_Position; + basey : Line_Position := 0; + pxmax : Column_Position; + basex : Column_Position := 0; + c : Key_Code; + scrollers : Boolean := True; + before, after : timestruct; + timing : Boolean := True; + + package floatio is new Ada.Text_IO.Float_IO (Long_Float); + begin + Get_Size (pad, pymax, pxmax); + Allow_Scrolling (Mode => False); -- we don't want stdscr to scroll! + + c := Key_Refresh; + loop + -- During shell-out, the user may have resized the window. Adjust + -- the port size of the pad to accommodate this. Ncurses + -- automatically resizes all of the normal windows to fit on the + -- new screen. + if top_x > Columns then + top_x := Columns; + end if; + if portx > Columns then + portx := Columns; + end if; + if top_y > Lines then + top_y := Lines; + end if; + if porty > Lines then + porty := Lines; + end if; + + case c is + when Key_Refresh | Character'Pos ('?') => + if c = Key_Refresh then + Erase; + else -- '?' + show_panner_legend := not show_panner_legend; + end if; + panner_legend (Lines - 4); + panner_legend (Lines - 3); + panner_legend (Lines - 2); + panner_legend (Lines - 1); + when Character'Pos ('t') => + timing := not timing; + if not timing then + panner_legend (Lines - 1); + end if; + when Character'Pos ('s') => + scrollers := not scrollers; + + -- Move the top-left corner of the pad, keeping the + -- bottom-right corner fixed. + when Character'Pos ('h') => + -- increase-columns: move left edge to left + if top_x = 0 then + Beep; + else + panner_v_cleanup (top_y, top_x, porty); + top_x := top_x - 1; + end if; + + when Character'Pos ('j') => + -- decrease-lines: move top-edge down + if top_y >= porty then + Beep; + else + if top_y /= 0 then + panner_h_cleanup (top_y - 1, f (top_x), portx); + end if; + top_y := top_y + 1; + end if; + when Character'Pos ('k') => + -- increase-lines: move top-edge up + if top_y = 0 then + Beep; + else + top_y := top_y - 1; + panner_h_cleanup (top_y, top_x, portx); + end if; + + when Character'Pos ('l') => + -- decrease-columns: move left-edge to right + if top_x >= portx then + Beep; + else + if top_x /= 0 then + panner_v_cleanup (f (top_y), top_x - 1, porty); + end if; + top_x := top_x + 1; + end if; + + -- Move the bottom-right corner of the pad, keeping the + -- top-left corner fixed. + when Key_Insert_Char => + -- increase-columns: move right-edge to right + if portx >= pxmax or portx >= Columns then + Beep; + else + panner_v_cleanup (f (top_y), portx - 1, porty); + portx := portx + 1; + -- C had ++portx instead of portx++, weird. + end if; + when Key_Insert_Line => + -- increase-lines: move bottom-edge down + if porty >= pymax or porty >= Lines then + Beep; + else + panner_h_cleanup (porty - 1, f (top_x), portx); + porty := porty + 1; + end if; + + when Key_Delete_Char => + -- decrease-columns: move bottom edge up + if portx <= top_x then + Beep; + else + portx := portx - 1; + panner_v_cleanup (f (top_y), portx, porty); + end if; + + when Key_Delete_Line => + -- decrease-lines + if porty <= top_y then + Beep; + else + porty := porty - 1; + panner_h_cleanup (porty, f (top_x), portx); + end if; + when Key_Cursor_Left => + -- pan leftwards + if basex > 0 then + basex := basex - 1; + else + Beep; + end if; + when Key_Cursor_Right => + -- pan rightwards + -- if (basex + portx - (pymax > porty) < pxmax) + if basex + portx - + Column_Position (greater (pymax, porty)) < pxmax then + -- if basex + portx < pxmax or + -- (pymax > porty and basex + portx - 1 < pxmax) then + basex := basex + 1; + else + Beep; + end if; + + when Key_Cursor_Up => + -- pan upwards + if basey > 0 then + basey := basey - 1; + else + Beep; + end if; + + when Key_Cursor_Down => + -- pan downwards + -- same as if (basey + porty - (pxmax > portx) < pymax) + if basey + porty - + Line_Position (greater (pxmax, portx)) < pymax then + -- if (basey + porty < pymax) or + -- (pxmax > portx and basey + porty - 1 < pymax) then + basey := basey + 1; + else + Beep; + end if; + + when Character'Pos ('H') | + Key_Home | + Key_Find => + basey := 0; + + when Character'Pos ('E') | + Key_End | + Key_Select => + if pymax < porty then + basey := 0; + else + basey := pymax - porty; + end if; + + when others => + Beep; + end case; + + -- more writing off the screen. + -- Interestingly, the exception is not handled if + -- we put a block around this. + -- delcare --begin + if top_y /= 0 and top_x /= 0 then + Add (Line => top_y - 1, Column => top_x - 1, + Ch => ACS_Map (ACS_Upper_Left_Corner)); + end if; + if top_x /= 0 then + do_v_line (top_y, top_x - 1, ACS_Map (ACS_Vertical_Line), porty); + end if; + if top_y /= 0 then + do_h_line (top_y - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx); + end if; + -- exception when Curses_Exception => null; end; + + -- in C was ... pxmax > portx - 1 + if scrollers and pxmax >= portx then + declare + length : constant Column_Position := portx - top_x - 1; + lowend, highend : Column_Position; + begin + -- Instead of using floats, I'll use integers only. + lowend := top_x + (basex * length) / pxmax; + highend := top_x + ((basex + length) * length) / pxmax; + + do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line), + lowend); + if highend < portx then + Switch_Character_Attribute + (Attr => (Reverse_Video => True, others => False), + On => True); + do_h_line (porty - 1, lowend, Blank2, highend + 1); + Switch_Character_Attribute + (Attr => (Reverse_Video => True, others => False), + On => False); + do_h_line (porty - 1, highend + 1, + ACS_Map (ACS_Horizontal_Line), portx); + end if; + end; + else + do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx); + end if; + + if scrollers and pymax >= porty then + declare + length : constant Line_Position := porty - top_y - 1; + lowend, highend : Line_Position; + begin + lowend := top_y + (basey * length) / pymax; + highend := top_y + ((basey + length) * length) / pymax; + + do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line), + lowend); + if highend < porty then + Switch_Character_Attribute + (Attr => (Reverse_Video => True, others => False), + On => True); + do_v_line (lowend, portx - 1, Blank2, highend + 1); + Switch_Character_Attribute + (Attr => (Reverse_Video => True, others => False), + On => False); + do_v_line (highend + 1, portx - 1, + ACS_Map (ACS_Vertical_Line), porty); + end if; + end; + else + do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line), porty); + end if; + + if top_y /= 0 then + Add (Line => top_y - 1, Column => portx - 1, + Ch => ACS_Map (ACS_Upper_Right_Corner)); + end if; + if top_x /= 0 then + Add (Line => porty - 1, Column => top_x - 1, + Ch => ACS_Map (ACS_Lower_Left_Corner)); + end if; + declare + begin + -- Here is another place where it is possible + -- to write to the corner of the screen. + Add (Line => porty - 1, Column => portx - 1, + Ch => ACS_Map (ACS_Lower_Right_Corner)); + exception + when Curses_Exception => null; + end; + + before := gettime; + + Refresh_Without_Update; + + declare + -- the C version allows the panel to have a zero height + -- wich raise the exception + begin + Refresh_Without_Update + ( + pad, + basey, basex, + top_y, top_x, + porty - Line_Position (greater (pxmax, portx)) - 1, + portx - Column_Position (greater (pymax, porty)) - 1); + exception + when Curses_Exception => null; + end; + + Update_Screen; + + if timing then + declare + s : String (1 .. 7); + elapsed : Long_Float; + begin + after := gettime; + elapsed := (Long_Float (after.seconds - before.seconds) + + Long_Float (after.microseconds + - before.microseconds) + / 1.0e6); + Move_Cursor (Line => Lines - 1, Column => Columns - 20); + floatio.Put (s, elapsed, Aft => 3, Exp => 0); + Add (Str => s); + Refresh; + end; + end if; + + c := pgetc (pad); + exit when c = Key_Exit; + + end loop; + + Allow_Scrolling (Mode => True); + + end panner; + + Gridsize : constant := 3; + Gridcount : Integer := 0; + + Pad_High : constant Line_Count := 200; + Pad_Wide : constant Column_Count := 200; + panpad : Window := New_Pad (Pad_High, Pad_Wide); +begin + if panpad = Null_Window then + Cannot ("cannot create requested pad"); + return; + end if; + + for i in 0 .. Pad_High - 1 loop + for j in 0 .. Pad_Wide - 1 loop + if i mod Gridsize = 0 and j mod Gridsize = 0 then + if i = 0 or j = 0 then + Add (panpad, '+'); + else + -- depends on ASCII? + Add (panpad, + Ch => Character'Val (Character'Pos ('A') + + Gridcount mod 26)); + Gridcount := Gridcount + 1; + end if; + elsif i mod Gridsize = 0 then + Add (panpad, '-'); + elsif j mod Gridsize = 0 then + Add (panpad, '|'); + else + declare + -- handle the write to the lower right corner error + begin + Add (panpad, ' '); + exception + when Curses_Exception => null; + end; + end if; + end loop; + end loop; + panner_legend (Lines - 4); + panner_legend (Lines - 3); + panner_legend (Lines - 2); + panner_legend (Lines - 1); + + Set_KeyPad_Mode (panpad, True); + -- Make the pad (initially) narrow enough that a trace file won't wrap. + -- We'll still be able to widen it during a test, since that's required + -- for testing boundaries. + + panner (panpad, 2, 2, Lines - 5, Columns - 15, padgetch'Access); + + Delete (panpad); + End_Windows; -- Hmm, Erase after End_Windows + Erase; +end ncurses2.demo_pad; diff --git a/Ada95/samples/ncurses2-demo_pad.ads b/Ada95/samples/ncurses2-demo_pad.ads new file mode 100644 index 000000000000..b996263c1cde --- /dev/null +++ b/Ada95/samples/ncurses2-demo_pad.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.demo_pad; diff --git a/Ada95/samples/ncurses2-demo_panels.adb b/Ada95/samples/ncurses2-demo_panels.adb new file mode 100644 index 000000000000..9693e1a13ba3 --- /dev/null +++ b/Ada95/samples/ncurses2-demo_panels.adb @@ -0,0 +1,382 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2008,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.7 $ +-- $Date: 2011/03/23 00:44:12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Panels.User_Data; + +with ncurses2.genericPuts; + +procedure ncurses2.demo_panels (nap_mseci : Integer) is + use Int_IO; + + function mkpanel (color : Color_Number; + rows : Line_Count; + cols : Column_Count; + tly : Line_Position; + tlx : Column_Position) return Panel; + procedure rmpanel (pan : in out Panel); + procedure pflush; + procedure wait_a_while (msec : Integer); + procedure saywhat (text : String); + procedure fill_panel (pan : Panel); + + nap_msec : Integer := nap_mseci; + + function mkpanel (color : Color_Number; + rows : Line_Count; + cols : Column_Count; + tly : Line_Position; + tlx : Column_Position) return Panel is + win : Window; + pan : Panel := Null_Panel; + begin + win := New_Window (rows, cols, tly, tlx); + if Null_Window /= win then + pan := New_Panel (win); + if pan = Null_Panel then + Delete (win); + elsif Has_Colors then + declare + fg, bg : Color_Number; + begin + if color = Blue then + fg := White; + else + fg := Black; + end if; + bg := color; + Init_Pair (Color_Pair (color), fg, bg); + Set_Background (win, (Ch => ' ', + Attr => Normal_Video, + Color => Color_Pair (color))); + end; + else + Set_Background (win, (Ch => ' ', + Attr => (Bold_Character => True, + others => False), + Color => Color_Pair (color))); + end if; + end if; + return pan; + end mkpanel; + + procedure rmpanel (pan : in out Panel) is + win : Window := Panel_Window (pan); + begin + Delete (pan); + Delete (win); + end rmpanel; + + procedure pflush is + begin + Update_Panels; + Update_Screen; + end pflush; + + procedure wait_a_while (msec : Integer) is + begin + -- The C version had some #ifdef blocks here + if msec = 1 then + Getchar; + else + Nap_Milli_Seconds (msec); + end if; + end wait_a_while; + + procedure saywhat (text : String) is + begin + Move_Cursor (Line => Lines - 1, Column => 0); + Clear_To_End_Of_Line; + Add (Str => text); + end saywhat; + + -- from sample-curses_demo.adb + type User_Data is new String (1 .. 2); + type User_Data_Access is access all User_Data; + package PUD is new Panels.User_Data (User_Data, User_Data_Access); + + use PUD; + + procedure fill_panel (pan : Panel) is + win : constant Window := Panel_Window (pan); + num : constant Character := Get_User_Data (pan).all (2); + tmp6 : String (1 .. 6) := "-panx-"; + maxy : Line_Count; + maxx : Column_Count; + + begin + Move_Cursor (win, 1, 1); + tmp6 (5) := num; + Add (win, Str => tmp6); + Clear_To_End_Of_Line (win); + Box (win); + Get_Size (win, maxy, maxx); + for y in 2 .. maxy - 3 loop + for x in 1 .. maxx - 3 loop + Move_Cursor (win, y, x); + Add (win, num); + end loop; + end loop; + exception + when Curses_Exception => null; + end fill_panel; + + modstr : constant array (0 .. 5) of String (1 .. 5) := + ("test ", + "TEST ", + "(**) ", + "*()* ", + "<--> ", + "LAST " + ); + + package p is new ncurses2.genericPuts (1024); + use p; + use p.BS; + -- the C version said register int y, x; + tmpb : BS.Bounded_String; + +begin + Refresh; + + for y in 0 .. Integer (Lines - 2) loop + for x in 0 .. Integer (Columns - 1) loop + myPut (tmpb, (y + x) mod 10); + myAdd (Str => tmpb); + end loop; + end loop; + for y in 0 .. 4 loop + declare + p1, p2, p3, p4, p5 : Panel; + U1 : constant User_Data_Access := new User_Data'("p1"); + U2 : constant User_Data_Access := new User_Data'("p2"); + U3 : constant User_Data_Access := new User_Data'("p3"); + U4 : constant User_Data_Access := new User_Data'("p4"); + U5 : constant User_Data_Access := new User_Data'("p5"); + + begin + p1 := mkpanel (Red, Lines / 2 - 2, Columns / 8 + 1, 0, 0); + Set_User_Data (p1, U1); + p2 := mkpanel (Green, Lines / 2 + 1, Columns / 7, Lines / 4, + Columns / 10); + Set_User_Data (p2, U2); + p3 := mkpanel (Yellow, Lines / 4, Columns / 10, Lines / 2, + Columns / 9); + Set_User_Data (p3, U3); + p4 := mkpanel (Blue, Lines / 2 - 2, Columns / 8, Lines / 2 - 2, + Columns / 3); + Set_User_Data (p4, U4); + p5 := mkpanel (Magenta, Lines / 2 - 2, Columns / 8, Lines / 2, + Columns / 2 - 2); + Set_User_Data (p5, U5); + + fill_panel (p1); + fill_panel (p2); + fill_panel (p3); + fill_panel (p4); + fill_panel (p5); + Hide (p4); + Hide (p5); + pflush; + saywhat ("press any key to continue"); + wait_a_while (nap_msec); + + saywhat ("h3 s1 s2 s4 s5; press any key to continue"); + Move (p1, 0, 0); + Hide (p3); + Show (p1); + Show (p2); + Show (p4); + Show (p5); + pflush; + wait_a_while (nap_msec); + + saywhat ("s1; press any key to continue"); + Show (p1); + pflush; + wait_a_while (nap_msec); + + saywhat ("s2; press any key to continue"); + Show (p2); + pflush; + wait_a_while (nap_msec); + + saywhat ("m2; press any key to continue"); + Move (p2, Lines / 3 + 1, Columns / 8); + pflush; + wait_a_while (nap_msec); + + saywhat ("s3;"); + Show (p3); + pflush; + wait_a_while (nap_msec); + + saywhat ("m3; press any key to continue"); + Move (p3, Lines / 4 + 1, Columns / 15); + pflush; + wait_a_while (nap_msec); + + saywhat ("b3; press any key to continue"); + Bottom (p3); + pflush; + wait_a_while (nap_msec); + + saywhat ("s4; press any key to continue"); + Show (p4); + pflush; + wait_a_while (nap_msec); + + saywhat ("s5; press any key to continue"); + Show (p5); + pflush; + wait_a_while (nap_msec); + + saywhat ("t3; press any key to continue"); + Top (p3); + pflush; + wait_a_while (nap_msec); + + saywhat ("t1; press any key to continue"); + Top (p1); + pflush; + wait_a_while (nap_msec); + + saywhat ("t2; press any key to continue"); + Top (p2); + pflush; + wait_a_while (nap_msec); + + saywhat ("t3; press any key to continue"); + Top (p3); + pflush; + wait_a_while (nap_msec); + + saywhat ("t4; press any key to continue"); + Top (p4); + pflush; + wait_a_while (nap_msec); + + for itmp in 0 .. 5 loop + declare + w4 : constant Window := Panel_Window (p4); + w5 : constant Window := Panel_Window (p5); + begin + + saywhat ("m4; press any key to continue"); + Move_Cursor (w4, Lines / 8, 1); + Add (w4, modstr (itmp)); + Move (p4, Lines / 6, Column_Position (itmp) * (Columns / 8)); + Move_Cursor (w5, Lines / 6, 1); + Add (w5, modstr (itmp)); + pflush; + wait_a_while (nap_msec); + + saywhat ("m5; press any key to continue"); + Move_Cursor (w4, Lines / 6, 1); + Add (w4, modstr (itmp)); + Move (p5, Lines / 3 - 1, (Column_Position (itmp) * 10) + 6); + Move_Cursor (w5, Lines / 8, 1); + Add (w5, modstr (itmp)); + pflush; + wait_a_while (nap_msec); + end; + end loop; + + saywhat ("m4; press any key to continue"); + Move (p4, Lines / 6, 6 * (Columns / 8)); + -- Move(p4, Lines / 6, itmp * (Columns / 8)); + pflush; + wait_a_while (nap_msec); + + saywhat ("t5; press any key to continue"); + Top (p5); + pflush; + wait_a_while (nap_msec); + + saywhat ("t2; press any key to continue"); + Top (p2); + pflush; + wait_a_while (nap_msec); + + saywhat ("t1; press any key to continue"); + Top (p1); + pflush; + wait_a_while (nap_msec); + + saywhat ("d2; press any key to continue"); + rmpanel (p2); + pflush; + wait_a_while (nap_msec); + + saywhat ("h3; press any key to continue"); + Hide (p3); + pflush; + wait_a_while (nap_msec); + + saywhat ("d1; press any key to continue"); + rmpanel (p1); + pflush; + wait_a_while (nap_msec); + + saywhat ("d4; press any key to continue"); + rmpanel (p4); + pflush; + wait_a_while (nap_msec); + + saywhat ("d5; press any key to continue"); + rmpanel (p5); + pflush; + wait_a_while (nap_msec); + if nap_msec = 1 then + exit; + else + nap_msec := 100; + end if; + + end; + end loop; + + Erase; + End_Windows; + +end ncurses2.demo_panels; diff --git a/Ada95/samples/ncurses2-demo_panels.ads b/Ada95/samples/ncurses2-demo_panels.ads new file mode 100644 index 000000000000..eb2878c8501e --- /dev/null +++ b/Ada95/samples/ncurses2-demo_panels.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.demo_panels (nap_mseci : Integer); diff --git a/Ada95/samples/ncurses2-flushinp_test.adb b/Ada95/samples/ncurses2-flushinp_test.adb new file mode 100644 index 000000000000..9ea98e158c34 --- /dev/null +++ b/Ada95/samples/ncurses2-flushinp_test.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with ncurses2.util; use ncurses2.util; + +procedure ncurses2.flushinp_test (win : Window) is + + procedure Continue (win : Window); + + procedure Continue (win : Window) is + begin + Set_Echo_Mode (False); + Move_Cursor (win, 10, 1); + Add (win, 10, 1, " Press any key to continue"); + Refresh (win); + Getchar (win); + end Continue; + + h, by, sh : Line_Position; + w, bx, sw : Column_Position; + + subWin : Window; + +begin + Clear (win); + Get_Size (win, h, w); + Get_Window_Position (win, by, bx); + sw := w / 3; + sh := h / 3; + subWin := Sub_Window (win, sh, sw, by + h - sh - 2, bx + w - sw - 2); + + if Has_Colors then + Init_Pair (2, Cyan, Blue); + Change_Background (subWin, + Attributed_Character'(Ch => ' ', Color => 2, + Attr => Normal_Video)); + end if; + + Set_Character_Attributes (subWin, + (Bold_Character => True, others => False)); + Box (subWin); + Add (subWin, 2, 1, "This is a subwindow"); + Refresh (win); + + Set_Cbreak_Mode (True); + Add (win, 0, 1, "This is a test of the flushinp() call."); + + Add (win, 2, 1, "Type random keys for 5 seconds."); + Add (win, 3, 1, + "These should be discarded (not echoed) after the subwindow " & + "goes away."); + Refresh (win); + + for i in 0 .. 4 loop + Move_Cursor (subWin, 1, 1); + Add (subWin, Str => "Time = "); + Add (subWin, Str => Integer'Image (i)); + Refresh (subWin); + Nap_Milli_Seconds (1000); + Flush_Input; + end loop; + + Delete (subWin); + Erase (win); + Flash_Screen; + Refresh (win); + Nap_Milli_Seconds (1000); + + Add (win, 2, 1, + Str => "If you were still typing when the window timer expired,"); + Add (win, 3, 1, + "or else you typed nothing at all while it was running,"); + Add (win, 4, 1, + "test was invalid. You'll see garbage or nothing at all. "); + Add (win, 6, 1, "Press a key"); + Move_Cursor (win, 9, 10); + Refresh (win); + Set_Echo_Mode (True); + Getchar (win); + Flush_Input; + Add (win, 12, 0, + "If you see any key other than what you typed, flushinp() is broken."); + Continue (win); + + Move_Cursor (win, 9, 10); + Delete_Character (win); + Refresh (win); + Move_Cursor (win, 12, 0); + Clear_To_End_Of_Line; + Add (win, + "What you typed should now have been deleted; if not, wdelch() " & + "failed."); + Continue (win); + + Set_Cbreak_Mode (True); + +end ncurses2.flushinp_test; diff --git a/Ada95/samples/ncurses2-flushinp_test.ads b/Ada95/samples/ncurses2-flushinp_test.ads new file mode 100644 index 000000000000..5376c94a54b2 --- /dev/null +++ b/Ada95/samples/ncurses2-flushinp_test.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; + +procedure ncurses2.flushinp_test (win : Terminal_Interface.Curses.Window); diff --git a/Ada95/samples/ncurses2-genericputs.adb b/Ada95/samples/ncurses2-genericputs.adb new file mode 100644 index 000000000000..829d08d23a2f --- /dev/null +++ b/Ada95/samples/ncurses2-genericputs.adb @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2008,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.4 $ +-- $Date: 2009/12/26 17:38:58 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; + +package body ncurses2.genericPuts is + + procedure myGet (Win : Window := Standard_Window; + Str : out BS.Bounded_String; + Len : Integer := -1) + is + function Wgetnstr (Win : Window; + Str : char_array; + Len : int) return int; + pragma Import (C, Wgetnstr, "wgetnstr"); + + N : Integer := Len; + Txt : char_array (0 .. size_t (Max_Length)); + xStr : String (1 .. Max_Length); + Cnt : Natural; + begin + if N < 0 then + N := Max_Length; + end if; + if N > Max_Length then + raise Constraint_Error; + end if; + Txt (0) := Interfaces.C.char'First; + if Wgetnstr (Win, Txt, C_Int (N)) = Curses_Err then + raise Curses_Exception; + end if; + To_Ada (Txt, xStr, Cnt, True); + Str := To_Bounded_String (xStr (1 .. Cnt)); + end myGet; + + procedure myPut (Str : out BS.Bounded_String; + i : Integer; + Base : Number_Base := 10) is + package Int_IO is new Integer_IO (Integer); use Int_IO; + tmp : String (1 .. BS.Max_Length); + begin + Put (tmp, i, Base); + Str := To_Bounded_String (tmp); + Trim (Str, Ada.Strings.Trim_End'(Ada.Strings.Left)); + end myPut; + + procedure myAdd (Str : BS.Bounded_String) is + begin + Add (Str => To_String (Str)); + end myAdd; + + -- from ncurses-aux + procedure Fill_String (Cp : chars_ptr; + Str : out BS.Bounded_String) + is + -- Fill the string with the characters referenced by the + -- chars_ptr. + -- + Len : Natural; + begin + if Cp /= Null_Ptr then + Len := Natural (Strlen (Cp)); + if Max_Length < Len then + raise Constraint_Error; + end if; + declare + S : String (1 .. Len); + begin + S := Value (Cp); + Str := To_Bounded_String (S); + end; + else + Str := Null_Bounded_String; + end if; + + end Fill_String; + +end ncurses2.genericPuts; diff --git a/Ada95/samples/ncurses2-genericputs.ads b/Ada95/samples/ncurses2-genericputs.ads new file mode 100644 index 000000000000..accc3cc63d70 --- /dev/null +++ b/Ada95/samples/ncurses2-genericputs.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2006,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.3 $ +-- $Date: 2009/12/26 17:38:58 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ + +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Strings.Bounded; +use Ada.Strings.Bounded; +with Interfaces.C; use Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with Terminal_Interface.Curses; + +generic + Max : Natural; + -- type mystring is private; + -- type myint is +package ncurses2.genericPuts is + package BS is new + Ada.Strings.Bounded.Generic_Bounded_Length (Max); + use BS; + + procedure myGet (Win : Terminal_Interface.Curses.Window + := Terminal_Interface.Curses.Standard_Window; + Str : out BS.Bounded_String; + Len : Integer := -1); + + procedure myPut (Str : out BS.Bounded_String; + i : Integer; + Base : Number_Base := 10); + -- the default should be Ada.Text_IO.Integer_IO.Default_Base + -- but Default_Base is hidden in the generic so doesn't exist! + procedure myAdd (Str : BS.Bounded_String); + + procedure Fill_String (Cp : chars_ptr; Str : out BS.Bounded_String); +end ncurses2.genericPuts; diff --git a/Ada95/samples/ncurses2-getch.ads b/Ada95/samples/ncurses2-getch.ads new file mode 100644 index 000000000000..21a09f3160f2 --- /dev/null +++ b/Ada95/samples/ncurses2-getch.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure getch_test; diff --git a/Ada95/samples/ncurses2-getch_test.adb b/Ada95/samples/ncurses2-getch_test.adb new file mode 100644 index 000000000000..2802cfb55017 --- /dev/null +++ b/Ada95/samples/ncurses2-getch_test.adb @@ -0,0 +1,254 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2008,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.8 $ +-- $Date: 2009/12/26 17:38:58 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- Character input test +-- test the keypad feature + +with ncurses2.util; use ncurses2.util; + +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse; +with Ada.Characters.Handling; +with Ada.Strings.Bounded; + +with ncurses2.genericPuts; + +procedure ncurses2.getch_test is + use Int_IO; + + function mouse_decode (ep : Mouse_Event) return String; + + function mouse_decode (ep : Mouse_Event) return String is + Y : Line_Position; + X : Column_Position; + Button : Mouse_Button; + State : Button_State; + package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (200); + use BS; + buf : Bounded_String := To_Bounded_String (""); + begin + -- Note that these bindings do not allow + -- two button states, + -- The C version can print {click-1, click-3} for example. + -- They also don't have the 'id' or z coordinate. + Get_Event (ep, Y, X, Button, State); + + -- TODO Append (buf, "id "); from C version + Append (buf, "at ("); + Append (buf, Column_Position'Image (X)); + Append (buf, ", "); + Append (buf, Line_Position'Image (Y)); + Append (buf, ") state"); + Append (buf, Mouse_Button'Image (Button)); + + Append (buf, " = "); + Append (buf, Button_State'Image (State)); + return To_String (buf); + end mouse_decode; + + buf : String (1 .. 1024); -- TODO was BUFSIZE + n : Integer; + c : Key_Code; + blockflag : Timeout_Mode := Blocking; + firsttime : Boolean := True; + tmp2 : Event_Mask; + tmp6 : String (1 .. 6); + tmp20 : String (1 .. 20); + x : Column_Position; + y : Line_Position; + tmpx : Integer; + incount : Integer := 0; + +begin + Refresh; + tmp2 := Start_Mouse (All_Events); + Add (Str => "Delay in 10ths of a second (<CR> for blocking input)? "); + Set_Echo_Mode (SwitchOn => True); + Get (Str => buf); + + Set_Echo_Mode (SwitchOn => False); + Set_NL_Mode (SwitchOn => False); + + if Ada.Characters.Handling.Is_Digit (buf (1)) then + Get (Item => n, From => buf, Last => tmpx); + Set_Timeout_Mode (Mode => Delayed, Amount => n * 100); + blockflag := Delayed; + end if; + + c := Character'Pos ('?'); + Set_Raw_Mode (SwitchOn => True); + loop + if not firsttime then + Add (Str => "Key pressed: "); + Put (tmp6, Integer (c), 8); + Add (Str => tmp6); + Add (Ch => ' '); + if c = Key_Mouse then + declare + event : Mouse_Event; + begin + event := Get_Mouse; + Add (Str => "KEY_MOUSE, "); + Add (Str => mouse_decode (event)); + Add (Ch => newl); + end; + elsif c >= Key_Min then + Key_Name (c, tmp20); + Add (Str => tmp20); + -- I used tmp and got bitten by the length problem:-> + Add (Ch => newl); + elsif c > 16#80# then -- TODO fix, use constant if possible + declare + c2 : constant Character := Character'Val (c mod 16#80#); + begin + if Ada.Characters.Handling.Is_Graphic (c2) then + Add (Str => "M-"); + Add (Ch => c2); + else + Add (Str => "M-"); + Add (Str => Un_Control ((Ch => c2, + Color => Color_Pair'First, + Attr => Normal_Video))); + end if; + Add (Str => " (high-half character)"); + Add (Ch => newl); + end; + else + declare + c2 : constant Character := Character'Val (c mod 16#80#); + begin + if Ada.Characters.Handling.Is_Graphic (c2) then + Add (Ch => c2); + Add (Str => " (ASCII printable character)"); + Add (Ch => newl); + else + Add (Str => Un_Control ((Ch => c2, + Color => Color_Pair'First, + Attr => Normal_Video))); + Add (Str => " (ASCII control character)"); + Add (Ch => newl); + end if; + end; + end if; + -- TODO I am not sure why this was in the C version + -- the delay statement scroll anyway. + Get_Cursor_Position (Line => y, Column => x); + if y >= Lines - 1 then + Move_Cursor (Line => 0, Column => 0); + end if; + Clear_To_End_Of_Line; + end if; + + firsttime := False; + if c = Character'Pos ('g') then + declare + package p is new ncurses2.genericPuts (1024); + use p; + use p.BS; + timedout : Boolean := False; + boundedbuf : Bounded_String; + begin + Add (Str => "getstr test: "); + Set_Echo_Mode (SwitchOn => True); + -- Note that if delay mode is set + -- Get can raise an exception. + -- The C version would print the string it had so far + -- also TODO get longer length string, like the C version + declare begin + myGet (Str => boundedbuf); + exception when Curses_Exception => + Add (Str => "Timed out."); + Add (Ch => newl); + timedout := True; + end; + -- note that the Ada Get will stop reading at 1024. + if not timedout then + Set_Echo_Mode (SwitchOn => False); + Add (Str => " I saw '"); + myAdd (Str => boundedbuf); + Add (Str => "'."); + Add (Ch => newl); + end if; + end; + elsif c = Character'Pos ('s') then + ShellOut (True); + elsif c = Character'Pos ('x') or c = Character'Pos ('q') or + (c = Key_None and blockflag = Blocking) then + exit; + elsif c = Character'Pos ('?') then + Add (Str => "Type any key to see its keypad value. Also:"); + Add (Ch => newl); + Add (Str => "g -- triggers a getstr test"); + Add (Ch => newl); + Add (Str => "s -- shell out"); + Add (Ch => newl); + Add (Str => "q -- quit"); + Add (Ch => newl); + Add (Str => "? -- repeats this help message"); + Add (Ch => newl); + end if; + + loop + c := Getchar; + exit when c /= Key_None; + if blockflag /= Blocking then + Put (tmp6, incount); -- argh string length! + Add (Str => tmp6); + Add (Str => ": input timed out"); + Add (Ch => newl); + else + Put (tmp6, incount); + Add (Str => tmp6); + Add (Str => ": input error"); + Add (Ch => newl); + exit; + end if; + incount := incount + 1; + end loop; + end loop; + + End_Mouse (tmp2); + Set_Timeout_Mode (Mode => Blocking, Amount => 0); -- amount is ignored + Set_Raw_Mode (SwitchOn => False); + Set_NL_Mode (SwitchOn => True); + Erase; + End_Windows; +end ncurses2.getch_test; diff --git a/Ada95/samples/ncurses2-getch_test.ads b/Ada95/samples/ncurses2-getch_test.ads new file mode 100644 index 000000000000..78a0a48c172e --- /dev/null +++ b/Ada95/samples/ncurses2-getch_test.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.getch_test; diff --git a/Ada95/samples/ncurses2-getopt.adb b/Ada95/samples/ncurses2-getopt.adb new file mode 100644 index 000000000000..29f1fee8281a --- /dev/null +++ b/Ada95/samples/ncurses2-getopt.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2008,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.8 $ +-- $Date: 2011/03/19 12:09:51 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- A simplified version of the GNU getopt function +-- copyright Free Software Foundtion + +with Ada.Strings.Fixed; +with Ada.Strings.Bounded; +with Ada.Text_IO; use Ada.Text_IO; + +package body ncurses2.getopt is + + nextchar : Natural := 0; + + -- Ncurses doesn't use the non option elements so we are spared + -- the job of computing those. + + -- also the user is not allowed to modify argv or argc + -- Doing so is Erroneous execution. + + -- long options are not handled. + + procedure Qgetopt (retval : out Integer; + argc : Integer; + argv : stringfunc; + -- argv will be the Argument function. + optstring : String; + optind : in out Integer; + -- ignored for ncurses, must be initialized to 1 by + -- the caller + Optarg : out stringa + -- a garbage collector would be useful here. + ) is + + package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (200); + use BS; + optargx : Bounded_String; + begin + + if argc < optind then + retval := -1; + return; + end if; + + optargx := To_Bounded_String (""); + + if nextchar = 0 then + + if argv (optind) = "--" then + -- the rest are non-options, we ignore them + retval := -1; + return; + end if; + + if argv (optind)(1) /= '-' or argv (optind)'Length = 1 then + optind := optind + 1; + Optarg := new String'(argv (optind)); + retval := 1; + return; + end if; + + nextchar := 2; -- skip the one hyphen. + end if; + + -- Look at and handle the next short option-character. + declare + c : Character := argv (optind) (nextchar); + temp : constant Natural := + Ada.Strings.Fixed.Index (optstring, String'(1 => c)); + begin + if temp = 0 or c = ':' then + Put_Line (Standard_Error, + argv (optind) & ": invalid option -- " & c); + c := '?'; + return; + end if; + + if optstring (temp + 1) = ':' then + if optstring (temp + 2) = ':' then + -- This is an option that accepts an argument optionally. + if nextchar /= argv (optind)'Length then + optargx := To_Bounded_String + (argv (optind) (nextchar .. argv (optind)'Length)); + else + Optarg := null; + end if; + else + -- This is an option that requires an argument. + if nextchar /= argv (optind)'Length then + optargx := To_Bounded_String + (argv (optind) (nextchar .. argv (optind)'Length)); + optind := optind + 1; + elsif optind = argc then + Put_Line (Standard_Error, + argv (optind) & + ": option requires an argument -- " & c); + if optstring (optstring'First) = ':' then + c := ':'; + else + c := '?'; + end if; + else + -- increment it again when taking next ARGV-elt as argument. + optind := optind + 1; + optargx := To_Bounded_String (argv (optind)); + optind := optind + 1; + end if; + end if; + nextchar := 0; + else -- no argument for the option + if nextchar = argv (optind)'Length then + optind := optind + 1; + nextchar := 0; + else + nextchar := nextchar + 1; + end if; + end if; + + retval := Character'Pos (c); + Optarg := new String'(To_String (optargx)); + return; + end; + end Qgetopt; + +end ncurses2.getopt; diff --git a/Ada95/samples/ncurses2-getopt.ads b/Ada95/samples/ncurses2-getopt.ads new file mode 100644 index 000000000000..a8b356e968d6 --- /dev/null +++ b/Ada95/samples/ncurses2-getopt.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000,2006 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.2 $ +-- $Date: 2006/06/25 14:24:40 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +package ncurses2.getopt is + + type stringa is access String; + + type stringfunc is access + function (n : Positive) return String; + + procedure Qgetopt (retval : out Integer; + argc : Integer; + argv : stringfunc; + optstring : String; + optind : in out Integer; + -- ignored for ncurses, must be initialized to 0 + -- by the caller + Optarg : out stringa + -- a garbage collector would be useful here. + ); + +end ncurses2.getopt; diff --git a/Ada95/samples/ncurses2-m.adb b/Ada95/samples/ncurses2-m.adb new file mode 100644 index 000000000000..5b20428c20a1 --- /dev/null +++ b/Ada95/samples/ncurses2-m.adb @@ -0,0 +1,448 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2006,2008 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.8 $ +-- $Date: 2008/07/26 18:47:50 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- TODO use Default_Character where appropriate + +-- This is an Ada version of ncurses +-- I translated this because it tests the most features. + +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace; + +with Ada.Text_IO; use Ada.Text_IO; + +with Ada.Characters.Latin_1; +-- with Ada.Characters.Handling; + +with Ada.Command_Line; use Ada.Command_Line; + +with Ada.Strings.Unbounded; + +with ncurses2.util; use ncurses2.util; +with ncurses2.getch_test; +with ncurses2.attr_test; +with ncurses2.color_test; +with ncurses2.demo_panels; +with ncurses2.color_edit; +with ncurses2.slk_test; +with ncurses2.acs_display; +with ncurses2.acs_and_scroll; +with ncurses2.flushinp_test; +with ncurses2.test_sgr_attributes; +with ncurses2.menu_test; +with ncurses2.demo_pad; +with ncurses2.demo_forms; +with ncurses2.overlap_test; +with ncurses2.trace_set; + +with ncurses2.getopt; use ncurses2.getopt; + +package body ncurses2.m is + use Int_IO; + + function To_trace (n : Integer) return Trace_Attribute_Set; + procedure usage; + procedure Set_Terminal_Modes; + function Do_Single_Test (c : Character) return Boolean; + + function To_trace (n : Integer) return Trace_Attribute_Set is + a : Trace_Attribute_Set := (others => False); + m : Integer; + rest : Integer; + begin + m := n mod 2; + if 1 = m then + a.Times := True; + end if; + rest := n / 2; + + m := rest mod 2; + if 1 = m then + a.Tputs := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.Update := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.Cursor_Move := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.Character_Output := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.Calls := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.Virtual_Puts := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.Input_Events := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.TTY_State := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.Internal_Calls := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.Character_Calls := True; + end if; + rest := rest / 2; + m := rest mod 2; + if 1 = m then + a.Termcap_TermInfo := True; + end if; + + return a; + end To_trace; + + -- these are type Stdscr_Init_Proc; + + function rip_footer ( + Win : Window; + Columns : Column_Count) return Integer; + pragma Convention (C, rip_footer); + + function rip_footer ( + Win : Window; + Columns : Column_Count) return Integer is + begin + Set_Background (Win, (Ch => ' ', + Attr => (Reverse_Video => True, others => False), + Color => 0)); + Erase (Win); + Move_Cursor (Win, 0, 0); + Add (Win, "footer:" & Columns'Img & " columns"); + Refresh_Without_Update (Win); + return 0; -- Curses_OK; + end rip_footer; + + function rip_header ( + Win : Window; + Columns : Column_Count) return Integer; + pragma Convention (C, rip_header); + + function rip_header ( + Win : Window; + Columns : Column_Count) return Integer is + begin + Set_Background (Win, (Ch => ' ', + Attr => (Reverse_Video => True, others => False), + Color => 0)); + Erase (Win); + Move_Cursor (Win, 0, 0); + Add (Win, "header:" & Columns'Img & " columns"); + -- 'Img is a GNAT extention + Refresh_Without_Update (Win); + return 0; -- Curses_OK; + end rip_header; + + procedure usage is + -- type Stringa is access String; + use Ada.Strings.Unbounded; + -- tbl : constant array (Positive range <>) of Stringa := ( + tbl : constant array (Positive range <>) of Unbounded_String + := ( + To_Unbounded_String ("Usage: ncurses [options]"), + To_Unbounded_String (""), + To_Unbounded_String ("Options:"), + To_Unbounded_String (" -a f,b set default-colors " & + "(assumed white-on-black)"), + To_Unbounded_String (" -d use default-colors if terminal " & + "supports them"), + To_Unbounded_String (" -e fmt specify format for soft-keys " & + "test (e)"), + To_Unbounded_String (" -f rip-off footer line " & + "(can repeat)"), + To_Unbounded_String (" -h rip-off header line " & + "(can repeat)"), + To_Unbounded_String (" -s msec specify nominal time for " & + "panel-demo (default: 1, to hold)"), + To_Unbounded_String (" -t mask specify default trace-level " & + "(may toggle with ^T)") + ); + begin + for n in tbl'Range loop + Put_Line (Standard_Error, To_String (tbl (n))); + end loop; + -- exit(EXIT_FAILURE); + -- TODO should we use Set_Exit_Status and throw and exception? + end usage; + + procedure Set_Terminal_Modes is begin + Set_Raw_Mode (SwitchOn => False); + Set_Cbreak_Mode (SwitchOn => True); + Set_Echo_Mode (SwitchOn => False); + Allow_Scrolling (Mode => True); + Use_Insert_Delete_Line (Do_Idl => True); + Set_KeyPad_Mode (SwitchOn => True); + end Set_Terminal_Modes; + + nap_msec : Integer := 1; + + function Do_Single_Test (c : Character) return Boolean is + begin + case c is + when 'a' => + getch_test; + when 'b' => + attr_test; + when 'c' => + if not Has_Colors then + Cannot ("does not support color."); + else + color_test; + end if; + when 'd' => + if not Has_Colors then + Cannot ("does not support color."); + elsif not Can_Change_Color then + Cannot ("has hardwired color values."); + else + color_edit; + end if; + when 'e' => + slk_test; + when 'f' => + acs_display; + when 'o' => + demo_panels (nap_msec); + when 'g' => + acs_and_scroll; + when 'i' => + flushinp_test (Standard_Window); + when 'k' => + test_sgr_attributes; + when 'm' => + menu_test; + when 'p' => + demo_pad; + when 'r' => + demo_forms; + when 's' => + overlap_test; + when 't' => + trace_set; + when '?' => + null; + when others => return False; + end case; + return True; + end Do_Single_Test; + + command : Character; + my_e_param : Soft_Label_Key_Format := Four_Four; + assumed_colors : Boolean := False; + default_colors : Boolean := False; + default_fg : Color_Number := White; + default_bg : Color_Number := Black; + -- nap_msec was an unsigned long integer in the C version, + -- yet napms only takes an int! + + c : Integer; + c2 : Character; + optind : Integer := 1; -- must be initialized to one. + optarg : getopt.stringa; + + length : Integer; + tmpi : Integer; + + package myio is new Ada.Text_IO.Integer_IO (Integer); + use myio; + + save_trace : Integer := 0; + save_trace_set : Trace_Attribute_Set; + + function main return Integer is + begin + loop + Qgetopt (c, Argument_Count, Argument'Access, + "a:de:fhs:t:", optind, optarg); + exit when c = -1; + c2 := Character'Val (c); + case c2 is + when 'a' => + -- Ada doesn't have scanf, it doesn't even have a + -- regular expression library. + assumed_colors := True; + myio.Get (optarg.all, Integer (default_fg), length); + myio.Get (optarg.all (length + 2 .. optarg.all'Length), + Integer (default_bg), length); + when 'd' => + default_colors := True; + when 'e' => + myio.Get (optarg.all, tmpi, length); + if tmpi > 3 then + usage; + return 1; + end if; + my_e_param := Soft_Label_Key_Format'Val (tmpi); + when 'f' => + Rip_Off_Lines (-1, rip_footer'Access); + when 'h' => + Rip_Off_Lines (1, rip_header'Access); + when 's' => + myio.Get (optarg.all, nap_msec, length); + when 't' => + myio.Get (optarg.all, save_trace, length); + when others => + usage; + return 1; + end case; + end loop; + + -- the C version had a bunch of macros here. + + -- if (!isatty(fileno(stdin))) + -- isatty is not available in the standard Ada so skip it. + save_trace_set := To_trace (save_trace); + Trace_On (save_trace_set); + + Init_Soft_Label_Keys (my_e_param); + + Init_Screen; + Set_Background (Ch => (Ch => Blank, + Attr => Normal_Video, + Color => Color_Pair'First)); + + if Has_Colors then + Start_Color; + if default_colors then + Use_Default_Colors; + elsif assumed_colors then + Assume_Default_Colors (default_fg, default_bg); + end if; + end if; + + Set_Terminal_Modes; + Save_Curses_Mode (Curses); + + End_Windows; + + -- TODO add macro #if blocks. + Put_Line ("Welcome to " & Curses_Version & ". Press ? for help."); + + loop + Put_Line ("This is the ncurses main menu"); + Put_Line ("a = keyboard and mouse input test"); + Put_Line ("b = character attribute test"); + Put_Line ("c = color test pattern"); + Put_Line ("d = edit RGB color values"); + Put_Line ("e = exercise soft keys"); + Put_Line ("f = display ACS characters"); + Put_Line ("g = display windows and scrolling"); + Put_Line ("i = test of flushinp()"); + Put_Line ("k = display character attributes"); + Put_Line ("m = menu code test"); + Put_Line ("o = exercise panels library"); + Put_Line ("p = exercise pad features"); + Put_Line ("q = quit"); + Put_Line ("r = exercise forms code"); + Put_Line ("s = overlapping-refresh test"); + Put_Line ("t = set trace level"); + Put_Line ("? = repeat this command summary"); + + Put ("> "); + Flush; + + command := Ada.Characters.Latin_1.NUL; + -- get_input: + -- loop + declare + Ch : Character; + begin + Get (Ch); + -- TODO if read(ch) <= 0 + -- TODO ada doesn't have an Is_Space function + command := Ch; + -- TODO if ch = '\n' or '\r' are these in Ada? + end; + -- end loop get_input; + + declare + begin + if Do_Single_Test (command) then + Flush_Input; + Set_Terminal_Modes; + Reset_Curses_Mode (Curses); + Clear; + Refresh; + End_Windows; + if command = '?' then + Put_Line ("This is the ncurses capability tester."); + Put_Line ("You may select a test from the main menu by " & + "typing the"); + Put_Line ("key letter of the choice (the letter to left " & + "of the =)"); + Put_Line ("at the > prompt. The commands `x' or `q' will " & + "exit."); + end if; + -- continue; --why continue in the C version? + end if; + exception + when Curses_Exception => End_Windows; + end; + + exit when command = 'q'; + end loop; + Curses_Free_All; + return 0; -- TODO ExitProgram(EXIT_SUCCESS); + end main; + +end ncurses2.m; diff --git a/Ada95/samples/ncurses2-m.ads b/Ada95/samples/ncurses2-m.ads new file mode 100644 index 000000000000..c32d895dc147 --- /dev/null +++ b/Ada95/samples/ncurses2-m.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +package ncurses2.m is + function main return Integer; +end ncurses2.m; diff --git a/Ada95/samples/ncurses2-menu_test.adb b/Ada95/samples/ncurses2-menu_test.adb new file mode 100644 index 000000000000..bce9782372a4 --- /dev/null +++ b/Ada95/samples/ncurses2-menu_test.adb @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2006,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.8 $ +-- $Date: 2011/03/23 00:39:28 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; + +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus; +with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse; + +procedure ncurses2.menu_test is + function menu_virtualize (c : Key_Code) return Key_Code; + procedure xAdd (l : Line_Position; c : Column_Position; s : String); + + function menu_virtualize (c : Key_Code) return Key_Code is + begin + case c is + when Character'Pos (newl) | Key_Exit => + return Menu_Request_Code'Last + 1; -- MAX_COMMAND? TODO + when Character'Pos ('u') => + return M_ScrollUp_Line; + when Character'Pos ('d') => + return M_ScrollDown_Line; + when Character'Pos ('b') | Key_Next_Page => + return M_ScrollUp_Page; + when Character'Pos ('f') | Key_Previous_Page => + return M_ScrollDown_Page; + when Character'Pos ('n') | Key_Cursor_Down => + return M_Next_Item; + when Character'Pos ('p') | Key_Cursor_Up => + return M_Previous_Item; + when Character'Pos (' ') => + return M_Toggle_Item; + when Key_Mouse => + return c; + when others => + Beep; + return c; + end case; + end menu_virtualize; + + MENU_Y : constant Line_Count := 8; + MENU_X : constant Column_Count := 8; + + type String_Access is access String; + + animals : constant array (Positive range <>) of String_Access := + (new String'("Lions"), + new String'("Tigers"), + new String'("Bears"), + new String'("(Oh my!)"), + new String'("Newts"), + new String'("Platypi"), + new String'("Lemurs")); + + items_a : constant Item_Array_Access := + new Item_Array (1 .. animals'Last + 1); + + tmp : Event_Mask; + + procedure xAdd (l : Line_Position; c : Column_Position; s : String) is + begin + Add (Line => l, Column => c, Str => s); + end xAdd; + + mrows : Line_Count; + mcols : Column_Count; + + menuwin : Window; + + m : Menu; + + c1 : Key_Code; + + c : Driver_Result; + r : Key_Code; +begin + tmp := Start_Mouse; + xAdd (0, 0, "This is the menu test:"); + xAdd (2, 0, " Use up and down arrow to move the select bar."); + xAdd (3, 0, " 'n' and 'p' act like arrows."); + xAdd (4, 0, " 'b' and 'f' scroll up/down (page), 'u' and 'd' (line)."); + xAdd (5, 0, " Press return to exit."); + Refresh; + + for i in animals'Range loop + items_a.all (i) := New_Item (animals (i).all); + end loop; + items_a.all (animals'Last + 1) := Null_Item; + + m := New_Menu (items_a); + + Set_Format (m, Line_Position (animals'Last + 1) / 2, 1); + Scale (m, mrows, mcols); + + menuwin := Create (mrows + 2, mcols + 2, MENU_Y, MENU_X); + Set_Window (m, menuwin); + Set_KeyPad_Mode (menuwin, True); + Box (menuwin); -- 0,0? + + Set_Sub_Window (m, Derived_Window (menuwin, mrows, mcols, 1, 1)); + + Post (m); + + loop + c1 := Getchar (menuwin); + r := menu_virtualize (c1); + c := Driver (m, r); + exit when c = Unknown_Request; -- E_UNKNOWN_COMMAND? + if c = Request_Denied then + Beep; + end if; + -- continue ? + end loop; + + Move_Cursor (Line => Lines - 2, Column => 0); + Add (Str => "You chose: "); + Add (Str => Name (Current (m))); + Add (Ch => newl); + Pause; -- the C version didn't use Pause, it spelled it out + + Post (m, False); -- unpost, not clear :-( + declare begin + Delete (menuwin); + exception when Curses_Exception => null; end; + -- menuwin has children so will raise the exception. + + Delete (m); + + End_Mouse (tmp); +end ncurses2.menu_test; diff --git a/Ada95/samples/ncurses2-menu_test.ads b/Ada95/samples/ncurses2-menu_test.ads new file mode 100644 index 000000000000..17e5b16b3e48 --- /dev/null +++ b/Ada95/samples/ncurses2-menu_test.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.menu_test; diff --git a/Ada95/samples/ncurses2-overlap_test.adb b/Ada95/samples/ncurses2-overlap_test.adb new file mode 100644 index 000000000000..ddf8a9a31f64 --- /dev/null +++ b/Ada95/samples/ncurses2-overlap_test.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2004,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.5 $ +-- $Date: 2011/03/19 12:07:18 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +-- test effects of overlapping windows + +procedure ncurses2.overlap_test is + + procedure fillwin (win : Window; ch : Character); + procedure crosswin (win : Window; ch : Character); + + procedure fillwin (win : Window; ch : Character) is + y1 : Line_Position; + x1 : Column_Position; + begin + Get_Size (win, y1, x1); + for y in 0 .. y1 - 1 loop + Move_Cursor (win, y, 0); + for x in 0 .. x1 - 1 loop + Add (win, Ch => ch); + end loop; + end loop; + exception + when Curses_Exception => null; + -- write to lower right corner + end fillwin; + + procedure crosswin (win : Window; ch : Character) is + y1 : Line_Position; + x1 : Column_Position; + begin + Get_Size (win, y1, x1); + for y in 0 .. y1 - 1 loop + for x in 0 .. x1 - 1 loop + if ((x > (x1 - 1) / 3) and (x <= (2 * (x1 - 1)) / 3)) + or (((y > (y1 - 1) / 3) and (y <= (2 * (y1 - 1)) / 3))) then + Move_Cursor (win, y, x); + Add (win, Ch => ch); + end if; + end loop; + end loop; + end crosswin; + + -- In a 24x80 screen like some xterms are, the instructions will + -- be overwritten. + ch : Character; + win1 : Window := New_Window (9, 20, 3, 3); + win2 : Window := New_Window (9, 20, 9, 16); +begin + Set_Raw_Mode (SwitchOn => True); + Refresh; + Move_Cursor (Line => 0, Column => 0); + Add (Str => "This test shows the behavior of wnoutrefresh() with " & + "respect to"); + Add (Ch => newl); + Add (Str => "the shared region of two overlapping windows A and B. "& + "The cross"); + Add (Ch => newl); + Add (Str => "pattern in each window does not overlap the other."); + Add (Ch => newl); + + Move_Cursor (Line => 18, Column => 0); + Add (Str => "a = refresh A, then B, then doupdate. b = refresh B, " & + "then A, then doupdate"); + Add (Ch => newl); + Add (Str => "c = fill window A with letter A. d = fill window B " & + "with letter B."); + Add (Ch => newl); + Add (Str => "e = cross pattern in window A. f = cross pattern " & + "in window B."); + Add (Ch => newl); + Add (Str => "g = clear window A. h = clear window B."); + Add (Ch => newl); + Add (Str => "i = overwrite A onto B. j = overwrite " & + "B onto A."); + Add (Ch => newl); + Add (Str => "^Q/ESC = terminate test."); + + loop + ch := Code_To_Char (Getchar); + exit when ch = CTRL ('Q') or ch = CTRL ('['); -- QUIT or ESCAPE + case ch is + when 'a' => -- refresh window A first, then B + Refresh_Without_Update (win1); + Refresh_Without_Update (win2); + Update_Screen; + when 'b' => -- refresh window B first, then A + Refresh_Without_Update (win2); + Refresh_Without_Update (win1); + Update_Screen; + when 'c' => -- fill window A so it's visible + fillwin (win1, 'A'); + when 'd' => -- fill window B so it's visible + fillwin (win2, 'B'); + when 'e' => -- cross test pattern in window A + crosswin (win1, 'A'); + when 'f' => -- cross test pattern in window B + crosswin (win2, 'B'); + when 'g' => -- clear window A + Clear (win1); + Move_Cursor (win1, 0, 0); + when 'h' => -- clear window B + Clear (win2); + Move_Cursor (win2, 0, 0); + when 'i' => -- overwrite A onto B + Overwrite (win1, win2); + when 'j' => -- overwrite B onto A + Overwrite (win2, win1); + when others => null; + end case; + end loop; + + Delete (win2); + Delete (win1); + Erase; + End_Windows; +end ncurses2.overlap_test; diff --git a/Ada95/samples/ncurses2-overlap_test.ads b/Ada95/samples/ncurses2-overlap_test.ads new file mode 100644 index 000000000000..ce6e3e696121 --- /dev/null +++ b/Ada95/samples/ncurses2-overlap_test.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.overlap_test; diff --git a/Ada95/samples/ncurses2-slk_test.adb b/Ada95/samples/ncurses2-slk_test.adb new file mode 100644 index 000000000000..aa368ba5f9ce --- /dev/null +++ b/Ada95/samples/ncurses2-slk_test.adb @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.9 $ +-- $Date: 2011/03/19 12:03:08 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +with Ada.Strings.Unbounded; +with Interfaces.C; +with Terminal_Interface.Curses.Aux; + +procedure ncurses2.slk_test is + procedure myGet (Win : Window := Standard_Window; + Str : out Ada.Strings.Unbounded.Unbounded_String; + Len : Integer := -1); + + procedure myGet (Win : Window := Standard_Window; + Str : out Ada.Strings.Unbounded.Unbounded_String; + Len : Integer := -1) + is + use Ada.Strings.Unbounded; + use Interfaces.C; + use Terminal_Interface.Curses.Aux; + + function Wgetnstr (Win : Window; + Str : char_array; + Len : int) return int; + pragma Import (C, Wgetnstr, "wgetnstr"); + + -- FIXME: how to construct "(Len > 0) ? Len : 80"? + Ask : constant Interfaces.C.size_t := Interfaces.C.size_t'Val (Len + 80); + Txt : char_array (0 .. Ask); + + begin + Txt (0) := Interfaces.C.char'First; + if Wgetnstr (Win, Txt, Txt'Length) = Curses_Err then + raise Curses_Exception; + end if; + Str := To_Unbounded_String (To_Ada (Txt, True)); + end myGet; + + use Int_IO; + + use Ada.Strings.Unbounded; + + c : Key_Code; + buf : Unbounded_String; + c2 : Character; + fmt : Label_Justification := Centered; + tmp : Integer; + +begin + c := CTRL ('l'); + loop + Move_Cursor (Line => 0, Column => 0); + c2 := Code_To_Char (c); + case c2 is + when Character'Val (Character'Pos ('l') mod 16#20#) => -- CTRL('l') + Erase; + Switch_Character_Attribute (Attr => (Bold_Character => True, + others => False)); + Add (Line => 0, Column => 20, + Str => "Soft Key Exerciser"); + Switch_Character_Attribute (On => False, + Attr => (Bold_Character => True, + others => False)); + + Move_Cursor (Line => 2, Column => 0); + P ("Available commands are:"); + P (""); + P ("^L -- refresh screen"); + P ("a -- activate or restore soft keys"); + P ("d -- disable soft keys"); + P ("c -- set centered format for labels"); + P ("l -- set left-justified format for labels"); + P ("r -- set right-justified format for labels"); + P ("[12345678] -- set label; labels are numbered 1 through 8"); + P ("e -- erase stdscr (should not erase labels)"); + P ("s -- test scrolling of shortened screen"); + P ("x, q -- return to main menu"); + P (""); + P ("Note: if activating the soft keys causes your terminal to"); + P ("scroll up one line, your terminal auto-scrolls when anything"); + P ("is written to the last screen position. The ncurses code"); + P ("does not yet handle this gracefully."); + Refresh; + Restore_Soft_Label_Keys; + + when 'a' => + Restore_Soft_Label_Keys; + when 'e' => + Clear; + when 's' => + Add (Line => 20, Column => 0, + Str => "Press Q to stop the scrolling-test: "); + loop + c := Getchar; + c2 := Code_To_Char (c); + exit when c2 = 'Q'; + -- c = ERR? + -- TODO when c is not a character (arrow key) + -- the behavior is different from the C version. + Add (Ch => c2); + end loop; + when 'd' => + Clear_Soft_Label_Keys; + when 'l' => + fmt := Left; + when 'c' => + fmt := Centered; + when 'r' => + fmt := Right; + when '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' => + Add (Line => 20, Column => 0, + Str => "Please enter the label value: "); + Set_Echo_Mode (SwitchOn => True); + myGet (Str => buf); + Set_Echo_Mode (SwitchOn => False); + tmp := ctoi (c2); + Set_Soft_Label_Key (Label_Number (tmp), To_String (buf), fmt); + Refresh_Soft_Label_Keys; + Move_Cursor (Line => 20, Column => 0); + Clear_To_End_Of_Line; + when 'x' | 'q' => + exit; + -- the C version needed a goto, ha ha + -- breaks exit the case not the loop because fall-through + -- happens in C! + when others => + Beep; + end case; + c := Getchar; + -- TODO exit when c = EOF + end loop; + Erase; + End_Windows; +end ncurses2.slk_test; diff --git a/Ada95/samples/ncurses2-slk_test.ads b/Ada95/samples/ncurses2-slk_test.ads new file mode 100644 index 000000000000..51e95871a97c --- /dev/null +++ b/Ada95/samples/ncurses2-slk_test.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.slk_test; diff --git a/Ada95/samples/ncurses2-test_sgr_attributes.adb b/Ada95/samples/ncurses2-test_sgr_attributes.adb new file mode 100644 index 000000000000..97449a40cafc --- /dev/null +++ b/Ada95/samples/ncurses2-test_sgr_attributes.adb @@ -0,0 +1,185 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000,2006 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.2 $ +-- $Date: 2006/06/25 14:24:40 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with ncurses2.util; use ncurses2.util; + +-- Graphic-rendition test (adapted from vttest) + +procedure ncurses2.test_sgr_attributes is + + procedure xAdd (l : Line_Position; c : Column_Position; s : String); + + procedure xAdd (l : Line_Position; c : Column_Position; s : String) is + begin + Add (Line => l, Column => c, Str => s); + end xAdd; + + normal, current : Attributed_Character; +begin + for pass in reverse Boolean loop + if pass then + normal := (Ch => ' ', Attr => Normal_Video, Color => 0); + else + normal := (Ch => ' ', Attr => + (Reverse_Video => True, others => False), Color => 0); + end if; + + -- Use non-default colors if possible to exercise bce a little + if Has_Colors then + Init_Pair (1, White, Blue); + normal.Color := 1; + end if; + Set_Background (Ch => normal); + Erase; + xAdd (1, 20, "Graphic rendition test pattern:"); + + xAdd (4, 1, "vanilla"); + + current := normal; + current.Attr.Bold_Character := not current.Attr.Bold_Character; + Set_Background (Ch => current); + xAdd (4, 40, "bold"); + + current := normal; + current.Attr.Under_Line := not current.Attr.Under_Line; + Set_Background (Ch => current); + xAdd (6, 6, "underline"); + + current := normal; + current.Attr.Bold_Character := not current.Attr.Bold_Character; + current.Attr.Under_Line := not current.Attr.Under_Line; + Set_Background (Ch => current); + xAdd (6, 45, "bold underline"); + + current := normal; + current.Attr.Blink := not current.Attr.Blink; + Set_Background (Ch => current); + xAdd (8, 1, "blink"); + + current := normal; + current.Attr.Blink := not current.Attr.Blink; + current.Attr.Bold_Character := not current.Attr.Bold_Character; + Set_Background (Ch => current); + xAdd (8, 40, "bold blink"); + + current := normal; + current.Attr.Under_Line := not current.Attr.Under_Line; + current.Attr.Blink := not current.Attr.Blink; + Set_Background (Ch => current); + xAdd (10, 6, "underline blink"); + + current := normal; + current.Attr.Bold_Character := not current.Attr.Bold_Character; + current.Attr.Under_Line := not current.Attr.Under_Line; + current.Attr.Blink := not current.Attr.Blink; + Set_Background (Ch => current); + xAdd (10, 45, "bold underline blink"); + + current := normal; + current.Attr.Reverse_Video := not current.Attr.Reverse_Video; + Set_Background (Ch => current); + xAdd (12, 1, "negative"); + + current := normal; + current.Attr.Bold_Character := not current.Attr.Bold_Character; + current.Attr.Reverse_Video := not current.Attr.Reverse_Video; + Set_Background (Ch => current); + xAdd (12, 40, "bold negative"); + + current := normal; + current.Attr.Under_Line := not current.Attr.Under_Line; + current.Attr.Reverse_Video := not current.Attr.Reverse_Video; + Set_Background (Ch => current); + xAdd (14, 6, "underline negative"); + + current := normal; + current.Attr.Bold_Character := not current.Attr.Bold_Character; + current.Attr.Under_Line := not current.Attr.Under_Line; + current.Attr.Reverse_Video := not current.Attr.Reverse_Video; + Set_Background (Ch => current); + xAdd (14, 45, "bold underline negative"); + + current := normal; + current.Attr.Blink := not current.Attr.Blink; + current.Attr.Reverse_Video := not current.Attr.Reverse_Video; + Set_Background (Ch => current); + xAdd (16, 1, "blink negative"); + + current := normal; + current.Attr.Bold_Character := not current.Attr.Bold_Character; + current.Attr.Blink := not current.Attr.Blink; + current.Attr.Reverse_Video := not current.Attr.Reverse_Video; + Set_Background (Ch => current); + xAdd (16, 40, "bold blink negative"); + + current := normal; + current.Attr.Under_Line := not current.Attr.Under_Line; + current.Attr.Blink := not current.Attr.Blink; + current.Attr.Reverse_Video := not current.Attr.Reverse_Video; + Set_Background (Ch => current); + xAdd (18, 6, "underline blink negative"); + + current := normal; + current.Attr.Bold_Character := not current.Attr.Bold_Character; + current.Attr.Under_Line := not current.Attr.Under_Line; + current.Attr.Blink := not current.Attr.Blink; + current.Attr.Reverse_Video := not current.Attr.Reverse_Video; + Set_Background (Ch => current); + xAdd (18, 45, "bold underline blink negative"); + + Set_Background (Ch => normal); + Move_Cursor (Line => Lines - 2, Column => 1); + if pass then + Add (Str => "Dark"); + else + Add (Str => "Light"); + end if; + Add (Str => " background. "); + Clear_To_End_Of_Line; + Pause; + end loop; + + Set_Background (Ch => Blank2); + Erase; + End_Windows; + +end ncurses2.test_sgr_attributes; diff --git a/Ada95/samples/ncurses2-test_sgr_attributes.ads b/Ada95/samples/ncurses2-test_sgr_attributes.ads new file mode 100644 index 000000000000..241118094e16 --- /dev/null +++ b/Ada95/samples/ncurses2-test_sgr_attributes.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.test_sgr_attributes; diff --git a/Ada95/samples/ncurses2-trace_set.adb b/Ada95/samples/ncurses2-trace_set.adb new file mode 100644 index 000000000000..7537afe407ee --- /dev/null +++ b/Ada95/samples/ncurses2-trace_set.adb @@ -0,0 +1,480 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses2.trace_set -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2008,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.5 $ +-- $Date: 2011/03/23 00:40:33 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with ncurses2.util; use ncurses2.util; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace; +with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus; + +with Ada.Strings.Bounded; + +-- interactively set the trace level + +procedure ncurses2.trace_set is + + function menu_virtualize (c : Key_Code) return Key_Code; + function subset (super, sub : Trace_Attribute_Set) return Boolean; + function trace_or (a, b : Trace_Attribute_Set) return Trace_Attribute_Set; + function trace_num (tlevel : Trace_Attribute_Set) return String; + function tracetrace (tlevel : Trace_Attribute_Set) return String; + function run_trace_menu (m : Menu; count : Integer) return Boolean; + + function menu_virtualize (c : Key_Code) return Key_Code is + begin + case c is + when Character'Pos (newl) | Key_Exit => + return Menu_Request_Code'Last + 1; -- MAX_COMMAND? TODO + when Character'Pos ('u') => + return M_ScrollUp_Line; + when Character'Pos ('d') => + return M_ScrollDown_Line; + when Character'Pos ('b') | Key_Next_Page => + return M_ScrollUp_Page; + when Character'Pos ('f') | Key_Previous_Page => + return M_ScrollDown_Page; + when Character'Pos ('n') | Key_Cursor_Down => + return M_Next_Item; + when Character'Pos ('p') | Key_Cursor_Up => + return M_Previous_Item; + when Character'Pos (' ') => + return M_Toggle_Item; + when Key_Mouse => + return c; + when others => + Beep; + return c; + end case; + end menu_virtualize; + + type string_a is access String; + type tbl_entry is record + name : string_a; + mask : Trace_Attribute_Set; + end record; + + t_tbl : constant array (Positive range <>) of tbl_entry := + ( + (new String'("Disable"), + Trace_Disable), + (new String'("Times"), + Trace_Attribute_Set'(Times => True, others => False)), + (new String'("Tputs"), + Trace_Attribute_Set'(Tputs => True, others => False)), + (new String'("Update"), + Trace_Attribute_Set'(Update => True, others => False)), + (new String'("Cursor_Move"), + Trace_Attribute_Set'(Cursor_Move => True, others => False)), + (new String'("Character_Output"), + Trace_Attribute_Set'(Character_Output => True, others => False)), + (new String'("Ordinary"), + Trace_Ordinary), + (new String'("Calls"), + Trace_Attribute_Set'(Calls => True, others => False)), + (new String'("Virtual_Puts"), + Trace_Attribute_Set'(Virtual_Puts => True, others => False)), + (new String'("Input_Events"), + Trace_Attribute_Set'(Input_Events => True, others => False)), + (new String'("TTY_State"), + Trace_Attribute_Set'(TTY_State => True, others => False)), + (new String'("Internal_Calls"), + Trace_Attribute_Set'(Internal_Calls => True, others => False)), + (new String'("Character_Calls"), + Trace_Attribute_Set'(Character_Calls => True, others => False)), + (new String'("Termcap_TermInfo"), + Trace_Attribute_Set'(Termcap_TermInfo => True, others => False)), + (new String'("Maximium"), + Trace_Maximum) + ); + + package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (300); + + function subset (super, sub : Trace_Attribute_Set) return Boolean is + begin + if + (super.Times or not sub.Times) and + (super.Tputs or not sub.Tputs) and + (super.Update or not sub.Update) and + (super.Cursor_Move or not sub.Cursor_Move) and + (super.Character_Output or not sub.Character_Output) and + (super.Calls or not sub.Calls) and + (super.Virtual_Puts or not sub.Virtual_Puts) and + (super.Input_Events or not sub.Input_Events) and + (super.TTY_State or not sub.TTY_State) and + (super.Internal_Calls or not sub.Internal_Calls) and + (super.Character_Calls or not sub.Character_Calls) and + (super.Termcap_TermInfo or not sub.Termcap_TermInfo) and + True then + return True; + else + return False; + end if; + end subset; + + function trace_or (a, b : Trace_Attribute_Set) return Trace_Attribute_Set is + retval : Trace_Attribute_Set := Trace_Disable; + begin + retval.Times := (a.Times or b.Times); + retval.Tputs := (a.Tputs or b.Tputs); + retval.Update := (a.Update or b.Update); + retval.Cursor_Move := (a.Cursor_Move or b.Cursor_Move); + retval.Character_Output := (a.Character_Output or b.Character_Output); + retval.Calls := (a.Calls or b.Calls); + retval.Virtual_Puts := (a.Virtual_Puts or b.Virtual_Puts); + retval.Input_Events := (a.Input_Events or b.Input_Events); + retval.TTY_State := (a.TTY_State or b.TTY_State); + retval.Internal_Calls := (a.Internal_Calls or b.Internal_Calls); + retval.Character_Calls := (a.Character_Calls or b.Character_Calls); + retval.Termcap_TermInfo := (a.Termcap_TermInfo or b.Termcap_TermInfo); + + return retval; + end trace_or; + + -- Print the hexadecimal value of the mask so + -- users can set it from the command line. + + function trace_num (tlevel : Trace_Attribute_Set) return String is + result : Integer := 0; + m : Integer := 1; + begin + + if tlevel.Times then + result := result + m; + end if; + m := m * 2; + + if tlevel.Tputs then + result := result + m; + end if; + m := m * 2; + + if tlevel.Update then + result := result + m; + end if; + m := m * 2; + + if tlevel.Cursor_Move then + result := result + m; + end if; + m := m * 2; + + if tlevel.Character_Output then + result := result + m; + end if; + m := m * 2; + + if tlevel.Calls then + result := result + m; + end if; + m := m * 2; + + if tlevel.Virtual_Puts then + result := result + m; + end if; + m := m * 2; + + if tlevel.Input_Events then + result := result + m; + end if; + m := m * 2; + + if tlevel.TTY_State then + result := result + m; + end if; + m := m * 2; + + if tlevel.Internal_Calls then + result := result + m; + end if; + m := m * 2; + + if tlevel.Character_Calls then + result := result + m; + end if; + m := m * 2; + + if tlevel.Termcap_TermInfo then + result := result + m; + end if; + m := m * 2; + return result'Img; + end trace_num; + + function tracetrace (tlevel : Trace_Attribute_Set) return String is + + use BS; + buf : Bounded_String := To_Bounded_String (""); + begin + -- The C version prints the hexadecimal value of the mask, we + -- won't do that here because this is Ada. + + if tlevel = Trace_Disable then + Append (buf, "Trace_Disable"); + else + + if subset (tlevel, + Trace_Attribute_Set'(Times => True, others => False)) then + Append (buf, "Times"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Tputs => True, others => False)) then + Append (buf, "Tputs"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Update => True, others => False)) then + Append (buf, "Update"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Cursor_Move => True, + others => False)) then + Append (buf, "Cursor_Move"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Character_Output => True, + others => False)) then + Append (buf, "Character_Output"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Ordinary) then + Append (buf, "Ordinary"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Calls => True, others => False)) then + Append (buf, "Calls"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Virtual_Puts => True, + others => False)) then + Append (buf, "Virtual_Puts"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Input_Events => True, + others => False)) then + Append (buf, "Input_Events"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(TTY_State => True, + others => False)) then + Append (buf, "TTY_State"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Internal_Calls => True, + others => False)) then + Append (buf, "Internal_Calls"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Character_Calls => True, + others => False)) then + Append (buf, "Character_Calls"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Attribute_Set'(Termcap_TermInfo => True, + others => False)) then + Append (buf, "Termcap_TermInfo"); + Append (buf, ", "); + end if; + + if subset (tlevel, + Trace_Maximum) then + Append (buf, "Maximium"); + Append (buf, ", "); + end if; + end if; + + if To_String (buf) (Length (buf) - 1) = ',' then + Delete (buf, Length (buf) - 1, Length (buf)); + end if; + + return To_String (buf); + end tracetrace; + + function run_trace_menu (m : Menu; count : Integer) return Boolean is + i, p : Item; + changed : Boolean; + c, v : Key_Code; + begin + loop + changed := (count /= 0); + c := Getchar (Get_Window (m)); + v := menu_virtualize (c); + case Driver (m, v) is + when Unknown_Request => + return False; + when others => + i := Current (m); + if i = Menus.Items (m, 1) then -- the first item + for n in t_tbl'First + 1 .. t_tbl'Last loop + if Value (i) then + Set_Value (i, False); + changed := True; + end if; + end loop; + else + for n in t_tbl'First + 1 .. t_tbl'Last loop + p := Menus.Items (m, n); + if Value (p) then + Set_Value (Menus.Items (m, 1), False); + changed := True; + exit; + end if; + end loop; + end if; + if not changed then + return True; + end if; + end case; + end loop; + end run_trace_menu; + + nc_tracing, mask : Trace_Attribute_Set; + pragma Import (C, nc_tracing, "_nc_tracing"); + items_a : constant Item_Array_Access := + new Item_Array (t_tbl'First .. t_tbl'Last + 1); + mrows : Line_Count; + mcols : Column_Count; + menuwin : Window; + menu_y : constant Line_Position := 8; + menu_x : constant Column_Position := 8; + ip : Item; + m : Menu; + count : Integer; + newtrace : Trace_Attribute_Set; +begin + Add (Line => 0, Column => 0, Str => "Interactively set trace level:"); + Add (Line => 2, Column => 0, + Str => " Press space bar to toggle a selection."); + Add (Line => 3, Column => 0, + Str => " Use up and down arrow to move the select bar."); + Add (Line => 4, Column => 0, + Str => " Press return to set the trace level."); + Add (Line => 6, Column => 0, Str => "(Current trace level is "); + Add (Str => tracetrace (nc_tracing) & " numerically: " & + trace_num (nc_tracing)); + Add (Ch => ')'); + + Refresh; + + for n in t_tbl'Range loop + items_a.all (n) := New_Item (t_tbl (n).name.all); + end loop; + items_a.all (t_tbl'Last + 1) := Null_Item; + + m := New_Menu (items_a); + + Set_Format (m, 16, 2); + Scale (m, mrows, mcols); + + Switch_Options (m, (One_Valued => True, others => False), On => False); + menuwin := New_Window (mrows + 2, mcols + 2, menu_y, menu_x); + Set_Window (m, menuwin); + Set_KeyPad_Mode (menuwin, SwitchOn => True); + Box (menuwin); + + Set_Sub_Window (m, Derived_Window (menuwin, mrows, mcols, 1, 1)); + + Post (m); + + for n in t_tbl'Range loop + ip := Items (m, n); + mask := t_tbl (n).mask; + if mask = Trace_Disable then + Set_Value (ip, nc_tracing = Trace_Disable); + elsif subset (sub => mask, super => nc_tracing) then + Set_Value (ip, True); + end if; + end loop; + + count := 1; + while run_trace_menu (m, count) loop + count := count + 1; + end loop; + + newtrace := Trace_Disable; + for n in t_tbl'Range loop + ip := Items (m, n); + if Value (ip) then + mask := t_tbl (n).mask; + newtrace := trace_or (newtrace, mask); + end if; + end loop; + + Trace_On (newtrace); + Trace_Put ("trace level interactively set to " & + tracetrace (nc_tracing)); + + Move_Cursor (Line => Lines - 4, Column => 0); + Add (Str => "Trace level is "); + Add (Str => tracetrace (nc_tracing)); + Add (Ch => newl); + Pause; -- was just Add(); Getchar + + Post (m, False); + -- menuwin has subwindows I think, which makes an error. + declare begin + Delete (menuwin); + exception when Curses_Exception => null; end; + + -- free_menu(m); + -- free_item() +end ncurses2.trace_set; diff --git a/Ada95/samples/ncurses2-trace_set.ads b/Ada95/samples/ncurses2-trace_set.ads new file mode 100644 index 000000000000..7bbf8ca5450a --- /dev/null +++ b/Ada95/samples/ncurses2-trace_set.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses2.trace_set -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure ncurses2.trace_set; diff --git a/Ada95/samples/ncurses2-util.adb b/Ada95/samples/ncurses2-util.adb new file mode 100644 index 000000000000..8ae327242ba4 --- /dev/null +++ b/Ada95/samples/ncurses2-util.adb @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses2.util -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000-2006,2008 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.7 $ +-- $Date: 2008/07/26 18:51:20 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Ada.Text_IO; use Ada.Text_IO; + +pragma Warnings (Off); +with Terminal_Interface.Curses.Aux; +pragma Warnings (On); + +with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace; + +with Interfaces.C; +with Interfaces.C.Strings; + +with Ada.Characters.Handling; + +with ncurses2.genericPuts; + +package body ncurses2.util is + + -- #defines from C + -- #define CTRL(x) ((x) & 0x1f) + function CTRL (c : Character) return Key_Code is + begin + return Character'Pos (c) mod 16#20#; + -- uses a property of ASCII + -- A = 16#41#; a = 16#61#; ^A = 1 or 16#1# + end CTRL; + + function CTRL (c : Character) return Character is + begin + return Character'Val (Character'Pos (c) mod 16#20#); + -- uses a property of ASCII + -- A = 16#41#; a = 16#61#; ^A = 1 or 16#1# + end CTRL; + + save_trace : Trace_Attribute_Set; + -- Common function to allow ^T to toggle trace-mode in the middle of a test + -- so that trace-files can be made smaller. + function Getchar (win : Window := Standard_Window) return Key_Code is + c : Key_Code; + begin + -- #ifdef TRACE + c := Get_Keystroke (win); + while c = CTRL ('T') loop + -- if _nc_tracing in C + if Current_Trace_Setting /= Trace_Disable then + save_trace := Current_Trace_Setting; + Trace_Put ("TOGGLE-TRACING OFF"); + Current_Trace_Setting := Trace_Disable; + else + Current_Trace_Setting := save_trace; + end if; + Trace_On (Current_Trace_Setting); + if Current_Trace_Setting /= Trace_Disable then + Trace_Put ("TOGGLE-TRACING ON"); + end if; + end loop; + -- #else c := Get_Keystroke; + return c; + end Getchar; + + procedure Getchar (win : Window := Standard_Window) is + begin + if Getchar (win) < 0 then + Beep; + end if; + end Getchar; + + procedure Pause is + begin + Move_Cursor (Line => Lines - 1, Column => 0); + Add (Str => "Press any key to continue... "); + Getchar; + end Pause; + + procedure Cannot (s : String) is + use Interfaces.C; + use Interfaces.C.Strings; + use Terminal_Interface.Curses.Aux; + function getenv (x : char_array) return chars_ptr; + pragma Import (C, getenv, "getenv"); + tmp1 : char_array (0 .. 10); + package p is new ncurses2.genericPuts (1024); + use p; + use p.BS; + + tmpb : BS.Bounded_String; + + Length : size_t; + begin + To_C ("TERM", tmp1, Length); + Fill_String (getenv (tmp1), tmpb); + Add (Ch => newl); + myAdd (Str => "This " & tmpb & " terminal " & s); + Pause; + end Cannot; + + procedure ShellOut (message : Boolean) is + use Interfaces.C; + Txt : char_array (0 .. 10); + Length : size_t; + procedure system (x : char_array); + pragma Import (C, system, "system"); + begin + To_C ("sh", Txt, Length); + if message then + Add (Str => "Shelling out..."); + end if; + Save_Curses_Mode (Mode => Curses); + End_Windows; + system (Txt); + if message then + Add (Str => "returned from shellout."); + Add (Ch => newl); + end if; + Refresh; + end ShellOut; + + function Is_Digit (c : Key_Code) return Boolean is + begin + if c >= 16#100# then + return False; + else + return Ada.Characters.Handling.Is_Digit (Character'Val (c)); + end if; + end Is_Digit; + + procedure P (s : String) is + begin + Add (Str => s); + Add (Ch => newl); + end P; + + function Code_To_Char (c : Key_Code) return Character is + begin + if c > Character'Pos (Character'Last) then + return Character'Val (0); + -- maybe raise exception? + else + return Character'Val (c); + end if; + end Code_To_Char; + + -- This was untestable due to a bug in GNAT (3.12p) + -- Hmm, what bug? I don't remember. + function ctoi (c : Character) return Integer is + begin + return Character'Pos (c) - Character'Pos ('0'); + end ctoi; + +end ncurses2.util; diff --git a/Ada95/samples/ncurses2-util.ads b/Ada95/samples/ncurses2-util.ads new file mode 100644 index 000000000000..f46749f06862 --- /dev/null +++ b/Ada95/samples/ncurses2-util.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses2.util -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000,2006 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.2 $ +-- $Date: 2006/06/25 14:24:40 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +with Ada.Text_IO; +package ncurses2.util is + + Blank : constant Character := ' '; + Blank2 : constant Attributed_Character := + (Ch => Blank, Attr => Normal_Video, Color => Color_Pair'First); + + newl : constant Character := Character'Val (10); + + function CTRL (c : Character) return Key_Code; + + function CTRL (c : Character) return Character; + + function Getchar (win : Window := Standard_Window) return Key_Code; + + procedure Getchar (win : Window := Standard_Window); + + procedure Pause; + + procedure Cannot (s : String); + + procedure ShellOut (message : Boolean); + + package Int_IO is new Ada.Text_IO.Integer_IO (Integer); + + function Is_Digit (c : Key_Code) return Boolean; + + procedure P (s : String); + + function Code_To_Char (c : Key_Code) return Character; + function ctoi (c : Character) return Integer; + +end ncurses2.util; diff --git a/Ada95/samples/ncurses2.ads b/Ada95/samples/ncurses2.ads new file mode 100644 index 000000000000..2fe01970899d --- /dev/null +++ b/Ada95/samples/ncurses2.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 +-- Version Control +-- $Revision: 1.1 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ + +package ncurses2 is + pragma Pure (ncurses2); +end ncurses2; diff --git a/Ada95/samples/rain.adb b/Ada95/samples/rain.adb new file mode 100644 index 000000000000..d673018eb036 --- /dev/null +++ b/Ada95/samples/rain.adb @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Rain -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2007,2008 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Laurent Pautet <pautet@gnat.com> +-- Modified by: Juergen Pfeifer, 1997 +-- Version Control +-- $Revision: 1.8 $ +-- $Date: 2008/08/30 21:38:07 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- -- +with ncurses2.util; use ncurses2.util; +with Ada.Numerics.Float_Random; use Ada.Numerics.Float_Random; +with Status; use Status; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +procedure Rain is + + Visibility : Cursor_Visibility; + + subtype X_Position is Line_Position; + subtype Y_Position is Column_Position; + + Xpos : array (1 .. 5) of X_Position; + Ypos : array (1 .. 5) of Y_Position; + + done : Boolean; + + c : Key_Code; + + N : Integer; + + G : Generator; + + Max_X, X : X_Position; + Max_Y, Y : Y_Position; + + procedure Next (J : in out Integer); + procedure Cursor (X : X_Position; Y : Y_Position); + + procedure Next (J : in out Integer) is + begin + if J = 5 then + J := 1; + else + J := J + 1; + end if; + end Next; + + procedure Cursor (X : X_Position; Y : Y_Position) is + begin + Move_Cursor (Line => X, Column => Y); + end Cursor; + pragma Inline (Cursor); + +begin + + Init_Screen; + Set_NL_Mode; + Set_Echo_Mode (False); + + Visibility := Invisible; + Set_Cursor_Visibility (Visibility); + Set_Timeout_Mode (Standard_Window, Non_Blocking, 0); + + Max_X := Lines - 5; + Max_Y := Columns - 5; + + for I in Xpos'Range loop + Xpos (I) := X_Position (Float (Max_X) * Random (G)) + 2; + Ypos (I) := Y_Position (Float (Max_Y) * Random (G)) + 2; + end loop; + + N := 1; + done := False; + while not done and Process.Continue loop + + X := X_Position (Float (Max_X) * Random (G)) + 2; + Y := Y_Position (Float (Max_Y) * Random (G)) + 2; + + Cursor (X, Y); + Add (Ch => '.'); + + Cursor (Xpos (N), Ypos (N)); + Add (Ch => 'o'); + + -- + Next (N); + Cursor (Xpos (N), Ypos (N)); + Add (Ch => 'O'); + + -- + Next (N); + Cursor (Xpos (N) - 1, Ypos (N)); + Add (Ch => '-'); + Cursor (Xpos (N), Ypos (N) - 1); + Add (Str => "|.|"); + Cursor (Xpos (N) + 1, Ypos (N)); + Add (Ch => '-'); + + -- + Next (N); + Cursor (Xpos (N) - 2, Ypos (N)); + Add (Ch => '-'); + Cursor (Xpos (N) - 1, Ypos (N) - 1); + Add (Str => "/\\"); + Cursor (Xpos (N), Ypos (N) - 2); + Add (Str => "| O |"); + Cursor (Xpos (N) + 1, Ypos (N) - 1); + Add (Str => "\\/"); + Cursor (Xpos (N) + 2, Ypos (N)); + Add (Ch => '-'); + + -- + Next (N); + Cursor (Xpos (N) - 2, Ypos (N)); + Add (Ch => ' '); + Cursor (Xpos (N) - 1, Ypos (N) - 1); + Add (Str => " "); + Cursor (Xpos (N), Ypos (N) - 2); + Add (Str => " "); + Cursor (Xpos (N) + 1, Ypos (N) - 1); + Add (Str => " "); + Cursor (Xpos (N) + 2, Ypos (N)); + Add (Ch => ' '); + + Xpos (N) := X; + Ypos (N) := Y; + + c := Getchar; + case c is + when Character'Pos ('q') => done := True; + when Character'Pos ('Q') => done := True; + when Character'Pos ('s') => Set_NoDelay_Mode (Standard_Window, False); + when Character'Pos (' ') => Set_NoDelay_Mode (Standard_Window, True); + when others => null; + end case; + + Nap_Milli_Seconds (50); + end loop; + + Visibility := Normal; + Set_Cursor_Visibility (Visibility); + End_Windows; + Curses_Free_All; + +end Rain; diff --git a/Ada95/samples/rain.ads b/Ada95/samples/rain.ads new file mode 100644 index 000000000000..3ad1912c5e49 --- /dev/null +++ b/Ada95/samples/rain.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Rain -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Laurent Pautet <pautet@gnat.com> +-- Modified by: Juergen Pfeifer, 1997 +-- Version Control +-- $Revision: 1.6 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- -- +procedure Rain; diff --git a/Ada95/samples/sample-curses_demo-attributes.adb b/Ada95/samples/sample-curses_demo-attributes.adb new file mode 100644 index 000000000000..c49f37d60246 --- /dev/null +++ b/Ada95/samples/sample-curses_demo-attributes.adb @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Curses_Demo.Attributes -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; + +with Sample.Manifest; use Sample.Manifest; +with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; +with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; +with Sample.Explanation; use Sample.Explanation; + +package body Sample.Curses_Demo.Attributes is + + procedure Demo + is + P : Panel := Create (Standard_Window); + K : Real_Key_Code; + begin + Set_Meta_Mode; + Set_KeyPad_Mode; + + Top (P); + + Push_Environment ("ATTRIBDEMO"); + Default_Labels; + Notepad ("ATTRIB-PAD00"); + + Set_Character_Attributes (Attr => (others => False)); + Add (Line => 1, Column => Columns / 2 - 10, + Str => "This is NORMAL"); + + Set_Character_Attributes (Attr => (Stand_Out => True, + others => False)); + Add (Line => 2, Column => Columns / 2 - 10, + Str => "This is Stand_Out"); + + Set_Character_Attributes (Attr => (Under_Line => True, + others => False)); + Add (Line => 3, Column => Columns / 2 - 10, + Str => "This is Under_Line"); + + Set_Character_Attributes (Attr => (Reverse_Video => True, + others => False)); + Add (Line => 4, Column => Columns / 2 - 10, + Str => "This is Reverse_Video"); + + Set_Character_Attributes (Attr => (Blink => True, + others => False)); + Add (Line => 5, Column => Columns / 2 - 10, + Str => "This is Blink"); + + Set_Character_Attributes (Attr => (Dim_Character => True, + others => False)); + Add (Line => 6, Column => Columns / 2 - 10, + Str => "This is Dim_Character"); + + Set_Character_Attributes (Attr => (Bold_Character => True, + others => False)); + Add (Line => 7, Column => Columns / 2 - 10, + Str => "This is Bold_Character"); + + Refresh_Without_Update; + Update_Panels; Update_Screen; + + loop + K := Get_Key; + if K in Special_Key_Code'Range then + case K is + when QUIT_CODE => exit; + when HELP_CODE => Explain_Context; + when EXPLAIN_CODE => Explain ("ATTRIBKEYS"); + when others => null; + end case; + end if; + end loop; + + Pop_Environment; + Clear; + Refresh_Without_Update; + Delete (P); + Update_Panels; Update_Screen; + + end Demo; + +end Sample.Curses_Demo.Attributes; diff --git a/Ada95/samples/sample-curses_demo-attributes.ads b/Ada95/samples/sample-curses_demo-attributes.ads new file mode 100644 index 000000000000..6d9b4e8df80f --- /dev/null +++ b/Ada95/samples/sample-curses_demo-attributes.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Curses_Demo.Attributes -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +package Sample.Curses_Demo.Attributes is + + procedure Demo; + +end Sample.Curses_Demo.Attributes; diff --git a/Ada95/samples/sample-curses_demo-mouse.adb b/Ada95/samples/sample-curses_demo-mouse.adb new file mode 100644 index 000000000000..490685c75076 --- /dev/null +++ b/Ada95/samples/sample-curses_demo-mouse.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Curses_Demo.Mouse -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2006,2008 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.16 $ +-- $Date: 2008/07/26 18:48:19 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse; +with Terminal_Interface.Curses.Text_IO; use Terminal_Interface.Curses.Text_IO; +with Terminal_Interface.Curses.Text_IO.Integer_IO; +with Terminal_Interface.Curses.Text_IO.Enumeration_IO; + +with Sample.Helpers; use Sample.Helpers; +with Sample.Manifest; use Sample.Manifest; +with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; +with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; +with Sample.Explanation; use Sample.Explanation; + +package body Sample.Curses_Demo.Mouse is + + package Int_IO is new + Terminal_Interface.Curses.Text_IO.Integer_IO (Integer); + use Int_IO; + + package Button_IO is new + Terminal_Interface.Curses.Text_IO.Enumeration_IO (Mouse_Button); + use Button_IO; + + package State_IO is new + Terminal_Interface.Curses.Text_IO.Enumeration_IO (Button_State); + use State_IO; + + procedure Demo is + + type Controls is array (1 .. 3) of Panel; + + Frame : Window; + Msg : Window; + Ctl : Controls; + Pan : Panel; + K : Real_Key_Code; + V : Cursor_Visibility := Invisible; + W : Window; + Note : Window; + Msg_L : constant Line_Count := 8; + Lins : Line_Position := Lines; + Cols : Column_Position; + Mask : Event_Mask; + procedure Show_Mouse_Event; + + procedure Show_Mouse_Event + is + Evt : constant Mouse_Event := Get_Mouse; + Y : Line_Position; + X : Column_Position; + Button : Mouse_Button; + State : Button_State; + W : Window; + begin + Get_Event (Evt, Y, X, Button, State); + Put (Msg, "Event at"); + Put (Msg, " X="); Put (Msg, Integer (X), 3); + Put (Msg, ", Y="); Put (Msg, Integer (Y), 3); + Put (Msg, ", Btn="); Put (Msg, Button, 10); + Put (Msg, ", Stat="); Put (Msg, State, 15); + for I in Ctl'Range loop + W := Get_Window (Ctl (I)); + if Enclosed_In_Window (W, Evt) then + Transform_Coordinates (W, Y, X, From_Screen); + Put (Msg, ",Box("); + Put (Msg, (I), 1); Put (Msg, ","); + Put (Msg, Integer (Y), 1); Put (Msg, ","); + Put (Msg, Integer (X), 1); Put (Msg, ")"); + end if; + end loop; + New_Line (Msg); + Flush (Msg); + Update_Panels; Update_Screen; + end Show_Mouse_Event; + + begin + Push_Environment ("MOUSE00"); + Notepad ("MOUSE-PAD00"); + Default_Labels; + Set_Cursor_Visibility (V); + + Note := Notepad_Window; + if Note /= Null_Window then + Get_Window_Position (Note, Lins, Cols); + end if; + Frame := Create (Msg_L, Columns, Lins - Msg_L, 0); + if Has_Colors then + Set_Background (Win => Frame, + Ch => (Color => Default_Colors, + Attr => Normal_Video, + Ch => ' ')); + Set_Character_Attributes (Win => Frame, + Attr => Normal_Video, + Color => Default_Colors); + Erase (Frame); + end if; + Msg := Derived_Window (Frame, Msg_L - 2, Columns - 2, 1, 1); + Pan := Create (Frame); + + Set_Meta_Mode; + Set_KeyPad_Mode; + Mask := Start_Mouse; + + Box (Frame); + Window_Title (Frame, "Mouse Protocol"); + Refresh_Without_Update (Frame); + Allow_Scrolling (Msg, True); + + declare + Middle_Column : constant Integer := Integer (Columns) / 2; + Middle_Index : constant Natural := Ctl'First + (Ctl'Length / 2); + Width : constant Column_Count := 5; + Height : constant Line_Count := 3; + Half : constant Column_Count := Width / 2; + Space : constant Column_Count := 3; + Position : Integer; + W : Window; + begin + for I in Ctl'Range loop + Position := ((I) - Integer (Middle_Index)) * + Integer (Half + Space + Width) + Middle_Column; + W := Create (Height, + Width, + 1, + Column_Position (Position)); + if Has_Colors then + Set_Background (Win => W, + Ch => (Color => Menu_Back_Color, + Attr => Normal_Video, + Ch => ' ')); + Set_Character_Attributes (Win => W, + Attr => Normal_Video, + Color => Menu_Fore_Color); + Erase (W); + end if; + Ctl (I) := Create (W); + Box (W); + Move_Cursor (W, 1, Half); + Put (W, (I), 1); + Refresh_Without_Update (W); + end loop; + end; + + Update_Panels; Update_Screen; + + loop + K := Get_Key; + if K in Special_Key_Code'Range then + case K is + when QUIT_CODE => exit; + when HELP_CODE => Explain_Context; + when EXPLAIN_CODE => Explain ("MOUSEKEYS"); + when Key_Mouse => Show_Mouse_Event; + when others => null; + end case; + end if; + end loop; + + for I in Ctl'Range loop + W := Get_Window (Ctl (I)); + Clear (W); + Delete (Ctl (I)); + Delete (W); + end loop; + + Clear (Frame); + Delete (Pan); + Delete (Msg); + Delete (Frame); + + Set_Cursor_Visibility (V); + End_Mouse (Mask); + + Pop_Environment; + Update_Panels; Update_Screen; + + end Demo; + +end Sample.Curses_Demo.Mouse; diff --git a/Ada95/samples/sample-curses_demo-mouse.ads b/Ada95/samples/sample-curses_demo-mouse.ads new file mode 100644 index 000000000000..ad78d0d0a750 --- /dev/null +++ b/Ada95/samples/sample-curses_demo-mouse.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Curses_Demo.Mouse -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +package Sample.Curses_Demo.Mouse is + + procedure Demo; + +end Sample.Curses_Demo.Mouse; diff --git a/Ada95/samples/sample-curses_demo.adb b/Ada95/samples/sample-curses_demo.adb new file mode 100644 index 000000000000..4dd96a721d2a --- /dev/null +++ b/Ada95/samples/sample-curses_demo.adb @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Curses_Demo -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2004,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.17 $ +-- $Date: 2011/03/23 00:29:04 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus; +with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Panels.User_Data; + +with Sample.Manifest; use Sample.Manifest; +with Sample.Helpers; use Sample.Helpers; +with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; + +with Sample.Explanation; use Sample.Explanation; + +with Sample.Menu_Demo.Handler; +with Sample.Curses_Demo.Mouse; +with Sample.Curses_Demo.Attributes; + +package body Sample.Curses_Demo is + + type User_Data is new Integer; + type User_Data_Access is access all User_Data; + package PUD is new Panels.User_Data (User_Data, User_Data_Access); + -- We use above instantiation of the generic User_Data package to + -- demonstrate and test the use of the user data mechanism. + + procedure Demo + is + function My_Driver (M : Menu; + K : Key_Code; + Pan : Panel) return Boolean; + package Mh is new Sample.Menu_Demo.Handler (My_Driver); + + Itm : Item_Array_Access := new Item_Array' + (New_Item ("Attributes Demo"), + New_Item ("Mouse Demo"), + Null_Item); + M : Menu := New_Menu (Itm); + U1 : constant User_Data_Access := new User_Data'(4711); + U2 : User_Data_Access; + + function My_Driver (M : Menu; + K : Key_Code; + Pan : Panel) return Boolean + is + Idx : constant Positive := Get_Index (Current (M)); + Result : Boolean := False; + begin + PUD.Set_User_Data (Pan, U1); -- set some user data, just for fun + if K in User_Key_Code'Range then + if K = QUIT then + Result := True; + elsif K = SELECT_ITEM then + if Idx in Itm'Range then + Hide (Pan); + Update_Panels; + end if; + case Idx is + when 1 => Sample.Curses_Demo.Attributes.Demo; + when 2 => Sample.Curses_Demo.Mouse.Demo; + when others => Not_Implemented; + end case; + if Idx in Itm'Range then + Top (Pan); + Show (Pan); + Update_Panels; + Update_Screen; + end if; + end if; + end if; + PUD.Get_User_Data (Pan, U2); -- get the user data + pragma Assert (U1.all = U2.all and then U1 = U2); + return Result; + end My_Driver; + + begin + + if (1 + Item_Count (M)) /= Itm'Length then + raise Constraint_Error; + end if; + + if not Has_Mouse then + declare + O : Item_Option_Set; + begin + Get_Options (Itm.all (2), O); + O.Selectable := False; + Set_Options (Itm.all (2), O); + end; + end if; + + Push_Environment ("CURSES00"); + Notepad ("CURSES-PAD00"); + Default_Labels; + Refresh_Soft_Label_Keys_Without_Update; + + Mh.Drive_Me (M, " Demo "); + Pop_Environment; + + Delete (M); + Free (Itm, True); + end Demo; + +end Sample.Curses_Demo; diff --git a/Ada95/samples/sample-curses_demo.ads b/Ada95/samples/sample-curses_demo.ads new file mode 100644 index 000000000000..ed4ad0f019f8 --- /dev/null +++ b/Ada95/samples/sample-curses_demo.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Curses_Demo -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +package Sample.Curses_Demo is + + procedure Demo; + +end Sample.Curses_Demo; diff --git a/Ada95/samples/sample-explanation.adb b/Ada95/samples/sample-explanation.adb new file mode 100644 index 000000000000..5587099b242a --- /dev/null +++ b/Ada95/samples/sample-explanation.adb @@ -0,0 +1,430 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Explanation -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.26 $ +-- $Date: 2011/03/26 22:33:29 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- Poor mans help system. This scans a sequential file for key lines and +-- then reads the lines up to the next key. Those lines are presented in +-- a window as help or explanation. +-- +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Unchecked_Deallocation; +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; + +with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; +with Sample.Manifest; use Sample.Manifest; +with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; +with Sample.Helpers; use Sample.Helpers; + +package body Sample.Explanation is + + Help_Keys : constant String := "HELPKEYS"; + In_Help : constant String := "INHELP"; + + File_Name : constant String := "explain.txt"; + F : File_Type; + + type Help_Line; + type Help_Line_Access is access Help_Line; + pragma Controlled (Help_Line_Access); + type String_Access is access String; + pragma Controlled (String_Access); + + type Help_Line is + record + Prev, Next : Help_Line_Access; + Line : String_Access; + end record; + + procedure Explain (Key : String; + Win : Window); + + procedure Release_String is + new Ada.Unchecked_Deallocation (String, + String_Access); + procedure Release_Help_Line is + new Ada.Unchecked_Deallocation (Help_Line, + Help_Line_Access); + + function Search (Key : String) return Help_Line_Access; + procedure Release_Help (Root : in out Help_Line_Access); + + function Check_File (Name : String) return Boolean; + + procedure Explain (Key : String) + is + begin + Explain (Key, Null_Window); + end Explain; + + procedure Explain (Key : String; + Win : Window) + is + -- Retrieve the text associated with this key and display it in this + -- window. If no window argument is passed, the routine will create + -- a temporary window and use it. + + function Filter_Key return Real_Key_Code; + procedure Unknown_Key; + procedure Redo; + procedure To_Window (C : in out Help_Line_Access; + More : in out Boolean); + + Frame : Window := Null_Window; + + W : Window := Win; + K : Real_Key_Code; + P : Panel; + + Height : Line_Count; + Width : Column_Count; + Help : Help_Line_Access := Search (Key); + Current : Help_Line_Access; + Top_Line : Help_Line_Access; + + Has_More : Boolean := True; + + procedure Unknown_Key + is + begin + Add (W, "Help message with ID "); + Add (W, Key); + Add (W, " not found."); + Add (W, Character'Val (10)); + Add (W, "Press the Function key labeled 'Quit' key to continue."); + end Unknown_Key; + + procedure Redo + is + H : Help_Line_Access := Top_Line; + begin + if Top_Line /= null then + for L in 0 .. (Height - 1) loop + Add (W, L, 0, H.all.Line.all); + exit when H.all.Next = null; + H := H.all.Next; + end loop; + else + Unknown_Key; + end if; + end Redo; + + function Filter_Key return Real_Key_Code + is + K : Real_Key_Code; + begin + loop + K := Get_Key (W); + if K in Special_Key_Code'Range then + case K is + when HELP_CODE => + if not Find_Context (In_Help) then + Push_Environment (In_Help, False); + Explain (In_Help, W); + Pop_Environment; + Redo; + end if; + when EXPLAIN_CODE => + if not Find_Context (Help_Keys) then + Push_Environment (Help_Keys, False); + Explain (Help_Keys, W); + Pop_Environment; + Redo; + end if; + when others => exit; + end case; + else + exit; + end if; + end loop; + return K; + end Filter_Key; + + procedure To_Window (C : in out Help_Line_Access; + More : in out Boolean) + is + L : Line_Position := 0; + begin + loop + Add (W, L, 0, C.all.Line.all); + L := L + 1; + exit when C.all.Next = null or else L = Height; + C := C.all.Next; + end loop; + if C.all.Next /= null then + pragma Assert (L = Height); + More := True; + else + More := False; + end if; + end To_Window; + + begin + if W = Null_Window then + Push_Environment ("HELP"); + Default_Labels; + Frame := New_Window (Lines - 2, Columns, 0, 0); + if Has_Colors then + Set_Background (Win => Frame, + Ch => (Ch => ' ', + Color => Help_Color, + Attr => Normal_Video)); + Set_Character_Attributes (Win => Frame, + Attr => Normal_Video, + Color => Help_Color); + Erase (Frame); + end if; + Box (Frame); + Set_Character_Attributes (Frame, (Reverse_Video => True, + others => False)); + Add (Frame, Lines - 3, 2, "Cursor Up/Down scrolls"); + Set_Character_Attributes (Frame); -- Back to default. + Window_Title (Frame, "Explanation"); + W := Derived_Window (Frame, Lines - 4, Columns - 2, 1, 1); + Refresh_Without_Update (Frame); + Get_Size (W, Height, Width); + Set_Meta_Mode (W); + Set_KeyPad_Mode (W); + Allow_Scrolling (W, True); + Set_Echo_Mode (False); + P := Create (Frame); + Top (P); + Update_Panels; + else + Clear (W); + Refresh_Without_Update (W); + end if; + + Current := Help; Top_Line := Help; + + if null = Help then + Unknown_Key; + loop + K := Filter_Key; + exit when K = QUIT_CODE; + end loop; + else + To_Window (Current, Has_More); + if Has_More then + -- This means there are more lines available, so we have to go + -- into a scroll manager. + loop + K := Filter_Key; + if K in Special_Key_Code'Range then + case K is + when Key_Cursor_Down => + if Current.all.Next /= null then + Move_Cursor (W, Height - 1, 0); + Scroll (W, 1); + Current := Current.all.Next; + Top_Line := Top_Line.all.Next; + Add (W, Current.all.Line.all); + end if; + when Key_Cursor_Up => + if Top_Line.all.Prev /= null then + Move_Cursor (W, 0, 0); + Scroll (W, -1); + Top_Line := Top_Line.all.Prev; + Current := Current.all.Prev; + Add (W, Top_Line.all.Line.all); + end if; + when QUIT_CODE => exit; + when others => null; + end case; + end if; + end loop; + else + loop + K := Filter_Key; + exit when K = QUIT_CODE; + end loop; + end if; + end if; + + Clear (W); + + if Frame /= Null_Window then + Clear (Frame); + Delete (P); + Delete (W); + Delete (Frame); + Pop_Environment; + end if; + + Update_Panels; + Update_Screen; + + Release_Help (Help); + + end Explain; + + function Search (Key : String) return Help_Line_Access + is + Last : Natural; + Buffer : String (1 .. 256); + Root : Help_Line_Access := null; + Current : Help_Line_Access; + Tail : Help_Line_Access := null; + + function Next_Line return Boolean; + + function Next_Line return Boolean + is + H_End : constant String := "#END"; + begin + Get_Line (F, Buffer, Last); + if Last = H_End'Length and then H_End = Buffer (1 .. Last) then + return False; + else + return True; + end if; + end Next_Line; + begin + Reset (F); + Outer : + loop + exit Outer when not Next_Line; + if Last = (1 + Key'Length) and then Key = Buffer (2 .. Last) + and then Buffer (1) = '#' then + loop + exit when not Next_Line; + exit when Buffer (1) = '#'; + Current := new Help_Line'(null, null, + new String'(Buffer (1 .. Last))); + if Tail = null then + Release_Help (Root); + Root := Current; + else + Tail.all.Next := Current; + Current.all.Prev := Tail; + end if; + Tail := Current; + end loop; + exit Outer; + end if; + end loop Outer; + return Root; + end Search; + + procedure Release_Help (Root : in out Help_Line_Access) + is + Next : Help_Line_Access; + begin + loop + exit when Root = null; + Next := Root.all.Next; + Release_String (Root.all.Line); + Release_Help_Line (Root); + Root := Next; + end loop; + end Release_Help; + + procedure Explain_Context + is + begin + Explain (Context); + end Explain_Context; + + procedure Notepad (Key : String) + is + H : constant Help_Line_Access := Search (Key); + T : Help_Line_Access := H; + N : Line_Count := 1; + L : Line_Position := 0; + W : Window; + P : Panel; + begin + if H /= null then + loop + T := T.all.Next; + exit when T = null; + N := N + 1; + end loop; + W := New_Window (N + 2, Columns, Lines - N - 2, 0); + if Has_Colors then + Set_Background (Win => W, + Ch => (Ch => ' ', + Color => Notepad_Color, + Attr => Normal_Video)); + Set_Character_Attributes (Win => W, + Attr => Normal_Video, + Color => Notepad_Color); + Erase (W); + end if; + Box (W); + Window_Title (W, "Notepad"); + P := New_Panel (W); + T := H; + loop + Add (W, L + 1, 1, T.all.Line.all, Integer (Columns - 2)); + L := L + 1; + T := T.all.Next; + exit when T = null; + end loop; + T := H; + Release_Help (T); + Refresh_Without_Update (W); + Notepad_To_Context (P); + end if; + end Notepad; + + function Check_File (Name : String) return Boolean is + The_File : File_Type; + begin + Open (The_File, In_File, Name); + Close (The_File); + return True; + exception + when Name_Error => + return False; + end Check_File; + +begin + if Check_File ("/usr/share/AdaCurses/" & File_Name) then + Open (F, In_File, "/usr/share/AdaCurses/" & File_Name); + elsif Check_File (File_Name) then + Open (F, In_File, File_Name); + else + Put_Line (Standard_Error, + "The file explain.txt was not found in the current directory." + ); + raise Name_Error; + end if; +end Sample.Explanation; diff --git a/Ada95/samples/sample-explanation.ads b/Ada95/samples/sample-explanation.ads new file mode 100644 index 000000000000..728825e2c9d7 --- /dev/null +++ b/Ada95/samples/sample-explanation.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Explanation -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2003,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.11 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- Poor mans help system. This scans a sequential file for key lines and +-- then reads the lines up to the next key. Those lines are presented in +-- a window as help or explanation. +-- +package Sample.Explanation is + + procedure Explain (Key : String); + -- Retrieve the text associated with this key and display it. + + procedure Explain_Context; + -- Explain the current context. + + procedure Notepad (Key : String); + -- Put a note on the screen and maintain it with the context + + Explanation_Not_Found : exception; + Explanation_Error : exception; + +end Sample.Explanation; diff --git a/Ada95/samples/sample-form_demo-aux.adb b/Ada95/samples/sample-form_demo-aux.adb new file mode 100644 index 000000000000..a3b044dcc3eb --- /dev/null +++ b/Ada95/samples/sample-form_demo-aux.adb @@ -0,0 +1,263 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Form_Demo.Aux -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2004,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.17 $ +-- $Date: 2009/12/26 17:38:58 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; + +with Sample.Manifest; use Sample.Manifest; +with Sample.Helpers; use Sample.Helpers; +with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; +with Sample.Explanation; use Sample.Explanation; + +package body Sample.Form_Demo.Aux is + + procedure Geometry (F : Form; + L : out Line_Count; -- Lines used for menu + C : out Column_Count; -- Columns used for menu + Y : out Line_Position; -- Proposed Line for menu + X : out Column_Position) -- Proposed Column for menu + is + begin + Scale (F, L, C); + + L := L + 2; -- count for frame at top and bottom + C := C + 2; -- " + + -- Calculate horizontal coordinate at the screen center + X := (Columns - C) / 2; + Y := 1; -- start always in line 1 + end Geometry; + + function Create (F : Form; + Title : String; + Lin : Line_Position; + Col : Column_Position) return Panel + is + W, S : Window; + L : Line_Count; + C : Column_Count; + Y : Line_Position; + X : Column_Position; + Pan : Panel; + begin + Geometry (F, L, C, Y, X); + W := New_Window (L, C, Lin, Col); + Set_Meta_Mode (W); + Set_KeyPad_Mode (W); + if Has_Colors then + Set_Background (Win => W, + Ch => (Ch => ' ', + Color => Default_Colors, + Attr => Normal_Video)); + Set_Character_Attributes (Win => W, + Color => Default_Colors, + Attr => Normal_Video); + Erase (W); + end if; + S := Derived_Window (W, L - 2, C - 2, 1, 1); + Set_Meta_Mode (S); + Set_KeyPad_Mode (S); + Box (W); + Set_Window (F, W); + Set_Sub_Window (F, S); + if Title'Length > 0 then + Window_Title (W, Title); + end if; + Pan := New_Panel (W); + Post (F); + return Pan; + end Create; + + procedure Destroy (F : Form; + P : in out Panel) + is + W, S : Window; + begin + W := Get_Window (F); + S := Get_Sub_Window (F); + Post (F, False); + Erase (W); + Delete (P); + Set_Window (F, Null_Window); + Set_Sub_Window (F, Null_Window); + Delete (S); + Delete (W); + Update_Panels; + end Destroy; + + function Get_Request (F : Form; + P : Panel; + Handle_CRLF : Boolean := True) return Key_Code + is + W : constant Window := Get_Window (F); + K : Real_Key_Code; + Ch : Character; + begin + Top (P); + loop + K := Get_Key (W); + if K in Special_Key_Code'Range then + case K is + when HELP_CODE => Explain_Context; + when EXPLAIN_CODE => Explain ("FORMKEYS"); + when Key_Home => return F_First_Field; + when Key_End => return F_Last_Field; + when QUIT_CODE => return QUIT; + when Key_Cursor_Down => return F_Down_Char; + when Key_Cursor_Up => return F_Up_Char; + when Key_Cursor_Left => return F_Previous_Char; + when Key_Cursor_Right => return F_Next_Char; + when Key_Next_Page => return F_Next_Page; + when Key_Previous_Page => return F_Previous_Page; + when Key_Backspace => return F_Delete_Previous; + when Key_Clear_Screen => return F_Clear_Field; + when Key_Clear_End_Of_Line => return F_Clear_EOF; + when others => return K; + end case; + elsif K in Normal_Key_Code'Range then + Ch := Character'Val (K); + case Ch is + when CAN => return QUIT; -- CTRL-X + + when ACK => return F_Next_Field; -- CTRL-F + when STX => return F_Previous_Field; -- CTRL-B + when FF => return F_Left_Field; -- CTRL-L + when DC2 => return F_Right_Field; -- CTRL-R + when NAK => return F_Up_Field; -- CTRL-U + when EOT => return F_Down_Field; -- CTRL-D + + when ETB => return F_Next_Word; -- CTRL-W + when DC4 => return F_Previous_Word; -- CTRL-T + + when SOH => return F_Begin_Field; -- CTRL-A + when ENQ => return F_End_Field; -- CTRL-E + + when HT => return F_Insert_Char; -- CTRL-I + when SI => return F_Insert_Line; -- CTRL-O + when SYN => return F_Delete_Char; -- CTRL-V + when BS => return F_Delete_Previous; -- CTRL-H + when EM => return F_Delete_Line; -- CTRL-Y + when BEL => return F_Delete_Word; -- CTRL-G + when VT => return F_Clear_EOF; -- CTRL-K + + when SO => return F_Next_Choice; -- CTRL-N + when DLE => return F_Previous_Choice; -- CTRL-P + + when CR | LF => + if Handle_CRLF then + return F_New_Line; + else + return K; + end if; + when others => return K; + end case; + else + return K; + end if; + end loop; + end Get_Request; + + function Make (Top : Line_Position; + Left : Column_Position; + Text : String) return Field + is + Fld : Field; + C : constant Column_Count := Column_Count (Text'Length); + begin + Fld := New_Field (1, C, Top, Left); + Set_Buffer (Fld, 0, Text); + Switch_Options (Fld, (Active => True, others => False), False); + if Has_Colors then + Set_Background (Fld => Fld, Color => Default_Colors); + end if; + return Fld; + end Make; + + function Make (Height : Line_Count := 1; + Width : Column_Count; + Top : Line_Position; + Left : Column_Position; + Off_Screen : Natural := 0) return Field + is + Fld : constant Field := New_Field (Height, Width, Top, Left, Off_Screen); + begin + if Has_Colors then + Set_Foreground (Fld => Fld, Color => Form_Fore_Color); + Set_Background (Fld => Fld, Color => Form_Back_Color); + else + Set_Background (Fld, (Reverse_Video => True, others => False)); + end if; + return Fld; + end Make; + + function Default_Driver (F : Form; + K : Key_Code; + P : Panel) return Boolean + is + begin + if P = Null_Panel then + raise Panel_Exception; + end if; + if K in User_Key_Code'Range and then K = QUIT then + if Driver (F, F_Validate_Field) = Form_Ok then + return True; + end if; + end if; + return False; + end Default_Driver; + + function Count_Active (F : Form) return Natural + is + N : Natural := 0; + O : Field_Option_Set; + H : constant Natural := Field_Count (F); + begin + if H > 0 then + for I in 1 .. H loop + Get_Options (Fields (F, I), O); + if O.Active then + N := N + 1; + end if; + end loop; + end if; + return N; + end Count_Active; + +end Sample.Form_Demo.Aux; diff --git a/Ada95/samples/sample-form_demo-aux.ads b/Ada95/samples/sample-form_demo-aux.ads new file mode 100644 index 000000000000..7e7f7cd21e39 --- /dev/null +++ b/Ada95/samples/sample-form_demo-aux.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Form_Demo.Aux -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.11 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Forms; use Terminal_Interface.Curses.Forms; + +package Sample.Form_Demo.Aux is + + procedure Geometry (F : Form; + L : out Line_Count; + C : out Column_Count; + Y : out Line_Position; + X : out Column_Position); + -- Calculate the geometry for a panel being able to be used to display + -- the menu. + + function Create (F : Form; + Title : String; + Lin : Line_Position; + Col : Column_Position) return Panel; + -- Create a panel decorated with a frame and the title at the specified + -- position. The dimension of the panel is derived from the menus layout. + + procedure Destroy (F : Form; + P : in out Panel); + -- Destroy all the windowing structures associated with this menu and + -- panel. + + function Get_Request (F : Form; + P : Panel; + Handle_CRLF : Boolean := True) return Key_Code; + -- Centralized request driver for all menus in this sample. This + -- gives us a common key binding for all menus. + + function Make (Top : Line_Position; + Left : Column_Position; + Text : String) return Field; + -- create a label + + function Make (Height : Line_Count := 1; + Width : Column_Count; + Top : Line_Position; + Left : Column_Position; + Off_Screen : Natural := 0) return Field; + -- create a editable field + + function Default_Driver (F : Form; + K : Key_Code; + P : Panel) return Boolean; + + function Count_Active (F : Form) return Natural; + -- Count the number of active fields in the form + +end Sample.Form_Demo.Aux; diff --git a/Ada95/samples/sample-form_demo-handler.adb b/Ada95/samples/sample-form_demo-handler.adb new file mode 100644 index 000000000000..d871c1cc7796 --- /dev/null +++ b/Ada95/samples/sample-form_demo-handler.adb @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Form_Demo.Handler -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2004,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.14 $ +-- $Date: 2009/12/26 17:38:58 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Sample.Form_Demo.Aux; + +package body Sample.Form_Demo.Handler is + + package Aux renames Sample.Form_Demo.Aux; + + procedure Drive_Me (F : Form; + Title : String := "") + is + L : Line_Count; + C : Column_Count; + Y : Line_Position; + X : Column_Position; + begin + Aux.Geometry (F, L, C, Y, X); + Drive_Me (F, Y, X, Title); + end Drive_Me; + + procedure Drive_Me (F : Form; + Lin : Line_Position; + Col : Column_Position; + Title : String := "") + is + Pan : Panel := Aux.Create (F, Title, Lin, Col); + V : Cursor_Visibility := Normal; + Handle_CRLF : Boolean := True; + + begin + Set_Cursor_Visibility (V); + if Aux.Count_Active (F) = 1 then + Handle_CRLF := False; + end if; + loop + declare + K : constant Key_Code := Aux.Get_Request (F, Pan, Handle_CRLF); + R : Driver_Result; + begin + if (K = 13 or else K = 10) and then not Handle_CRLF then + R := Unknown_Request; + else + R := Driver (F, K); + end if; + case R is + when Form_Ok => null; + when Unknown_Request => + if My_Driver (F, K, Pan) then + exit; + end if; + when others => Beep; + end case; + end; + end loop; + Set_Cursor_Visibility (V); + Aux.Destroy (F, Pan); + end Drive_Me; + +end Sample.Form_Demo.Handler; diff --git a/Ada95/samples/sample-form_demo-handler.ads b/Ada95/samples/sample-form_demo-handler.ads new file mode 100644 index 000000000000..7d875a0fff6c --- /dev/null +++ b/Ada95/samples/sample-form_demo-handler.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Form_Demo.Handler -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2003,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.10 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; +use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; +use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Forms; +use Terminal_Interface.Curses.Forms; + +generic + with function My_Driver (Frm : Form; + K : Key_Code; + Pan : Panel) return Boolean; +package Sample.Form_Demo.Handler is + + procedure Drive_Me (F : Form; + Lin : Line_Position; + Col : Column_Position; + Title : String := ""); + -- Position the menu at the given point and drive it. + + procedure Drive_Me (F : Form; + Title : String := ""); + -- Center menu and drive it. + +end Sample.Form_Demo.Handler; diff --git a/Ada95/samples/sample-form_demo.adb b/Ada95/samples/sample-form_demo.adb new file mode 100644 index 000000000000..ed84526feae2 --- /dev/null +++ b/Ada95/samples/sample-form_demo.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Form_Demo -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2006,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.16 $ +-- $Date: 2011/03/23 00:44:12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Forms; use Terminal_Interface.Curses.Forms; +with Terminal_Interface.Curses.Forms.Field_User_Data; +with Sample.My_Field_Type; use Sample.My_Field_Type; +with Sample.Explanation; use Sample.Explanation; +with Sample.Form_Demo.Aux; use Sample.Form_Demo.Aux; +with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; +with Sample.Form_Demo.Handler; + +with Terminal_Interface.Curses.Forms.Field_Types.Enumeration.Ada; +with Terminal_Interface.Curses.Forms.Field_Types.Enumeration; +use Terminal_Interface.Curses.Forms.Field_Types.Enumeration; +with Terminal_Interface.Curses.Forms.Field_Types.IntField; +use Terminal_Interface.Curses.Forms.Field_Types.IntField; + +package body Sample.Form_Demo is + + type User_Data is + record + Data : Integer; + end record; + type User_Access is access User_Data; + + package Fld_U is new + Terminal_Interface.Curses.Forms.Field_User_Data (User_Data, + User_Access); + + type Weekday is (Sunday, Monday, Tuesday, Wednesday, Thursday, + Friday, Saturday); + + package Weekday_Enum is new + Terminal_Interface.Curses.Forms.Field_Types.Enumeration.Ada (Weekday); + + Enum_Field : constant Enumeration_Field := + Weekday_Enum.Create; + + procedure Demo + is + + Mft : constant My_Data := (Ch => 'X'); + + FA : Field_Array_Access := new Field_Array' + (Make (0, 14, "Sample Entry Form"), + Make (2, 0, "WeekdayEnumeration"), + Make (2, 20, "Numeric 1-10"), + Make (2, 34, "Only 'X'"), + Make (5, 0, "Multiple Lines offscreen(Scroll)"), + Make (Width => 18, Top => 3, Left => 0), + Make (Width => 12, Top => 3, Left => 20), + Make (Width => 12, Top => 3, Left => 34), + Make (Width => 46, Top => 6, Left => 0, Height => 4, Off_Screen => 2), + Null_Field + ); + + Frm : Terminal_Interface.Curses.Forms.Form := Create (FA); + + I_F : constant Integer_Field := (Precision => 0, + Lower_Limit => 1, + Upper_Limit => 10); + + F1, F2 : User_Access; + + package Fh is new Sample.Form_Demo.Handler (Default_Driver); + + begin + Push_Environment ("FORM00"); + Notepad ("FORM-PAD00"); + Default_Labels; + + Set_Field_Type (FA.all (6), Enum_Field); + Set_Field_Type (FA.all (7), I_F); + Set_Field_Type (FA.all (8), Mft); + + F1 := new User_Data'(Data => 4711); + Fld_U.Set_User_Data (FA.all (1), F1); + + Fh.Drive_Me (Frm); + + Fld_U.Get_User_Data (FA.all (1), F2); + pragma Assert (F1 = F2); + pragma Assert (F1.Data = F2.Data); + + Pop_Environment; + Delete (Frm); + + Free (FA, True); + end Demo; + +end Sample.Form_Demo; diff --git a/Ada95/samples/sample-form_demo.ads b/Ada95/samples/sample-form_demo.ads new file mode 100644 index 000000000000..bd33f578750d --- /dev/null +++ b/Ada95/samples/sample-form_demo.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Form_Demo -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +package Sample.Form_Demo is + + procedure Demo; + +end Sample.Form_Demo; diff --git a/Ada95/samples/sample-function_key_setting.adb b/Ada95/samples/sample-function_key_setting.adb new file mode 100644 index 000000000000..4ff70be7bb8a --- /dev/null +++ b/Ada95/samples/sample-function_key_setting.adb @@ -0,0 +1,214 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Function_Key_Setting -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.15 $ +-- $Date: 2011/03/23 00:44:12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Ada.Unchecked_Deallocation; +with Sample.Manifest; use Sample.Manifest; + +-- This package implements a simple stack of function key label environments. +-- +package body Sample.Function_Key_Setting is + + Max_Label_Length : constant Positive := 8; + Number_Of_Keys : Label_Number := Label_Number'Last; + Justification : Label_Justification := Left; + + subtype Label is String (1 .. Max_Label_Length); + type Label_Array is array (Label_Number range <>) of Label; + + type Key_Environment (N : Label_Number := Label_Number'Last); + type Env_Ptr is access Key_Environment; + pragma Controlled (Env_Ptr); + + type String_Access is access String; + pragma Controlled (String_Access); + + Active_Context : String_Access := new String'("MAIN"); + Active_Notepad : Panel := Null_Panel; + + type Key_Environment (N : Label_Number := Label_Number'Last) is + record + Prev : Env_Ptr; + Help : String_Access; + Notepad : Panel; + Labels : Label_Array (1 .. N); + end record; + + procedure Release_String is + new Ada.Unchecked_Deallocation (String, + String_Access); + + procedure Release_Environment is + new Ada.Unchecked_Deallocation (Key_Environment, + Env_Ptr); + + Top_Of_Stack : Env_Ptr := null; + + procedure Push_Environment (Key : String; + Reset : Boolean := True) + is + P : constant Env_Ptr := new Key_Environment (Number_Of_Keys); + begin + -- Store the current labels in the environment + for I in 1 .. Number_Of_Keys loop + Get_Soft_Label_Key (I, P.all.Labels (I)); + if Reset then + Set_Soft_Label_Key (I, " "); + end if; + end loop; + P.all.Prev := Top_Of_Stack; + -- now store active help context and notepad + P.all.Help := Active_Context; + P.all.Notepad := Active_Notepad; + -- The notepad must now vanish and the new notepad is empty. + if P.all.Notepad /= Null_Panel then + Hide (P.all.Notepad); + Update_Panels; + end if; + Active_Notepad := Null_Panel; + Active_Context := new String'(Key); + + Top_Of_Stack := P; + if Reset then + Refresh_Soft_Label_Keys_Without_Update; + end if; + end Push_Environment; + + procedure Pop_Environment + is + P : Env_Ptr := Top_Of_Stack; + begin + if Top_Of_Stack = null then + raise Function_Key_Stack_Error; + else + for I in 1 .. Number_Of_Keys loop + Set_Soft_Label_Key (I, P.all.Labels (I), Justification); + end loop; + pragma Assert (Active_Context /= null); + Release_String (Active_Context); + Active_Context := P.all.Help; + Refresh_Soft_Label_Keys_Without_Update; + Notepad_To_Context (P.all.Notepad); + Top_Of_Stack := P.all.Prev; + Release_Environment (P); + end if; + end Pop_Environment; + + function Context return String + is + begin + if Active_Context /= null then + return Active_Context.all; + else + return ""; + end if; + end Context; + + function Find_Context (Key : String) return Boolean + is + P : Env_Ptr := Top_Of_Stack; + begin + if Active_Context.all = Key then + return True; + else + loop + exit when P = null; + if P.all.Help.all = Key then + return True; + else + P := P.all.Prev; + end if; + end loop; + return False; + end if; + end Find_Context; + + procedure Notepad_To_Context (Pan : Panel) + is + W : Window; + begin + if Active_Notepad /= Null_Panel then + W := Get_Window (Active_Notepad); + Clear (W); + Delete (Active_Notepad); + Delete (W); + end if; + Active_Notepad := Pan; + if Pan /= Null_Panel then + Top (Pan); + end if; + Update_Panels; + Update_Screen; + end Notepad_To_Context; + + procedure Initialize (Mode : Soft_Label_Key_Format := PC_Style; + Just : Label_Justification := Left) + is + begin + case Mode is + when PC_Style .. PC_Style_With_Index + => Number_Of_Keys := 12; + when others + => Number_Of_Keys := 8; + end case; + Init_Soft_Label_Keys (Mode); + Justification := Just; + end Initialize; + + procedure Default_Labels + is + begin + Set_Soft_Label_Key (FKEY_QUIT, "Quit"); + Set_Soft_Label_Key (FKEY_HELP, "Help"); + Set_Soft_Label_Key (FKEY_EXPLAIN, "Keys"); + Refresh_Soft_Label_Keys_Without_Update; + end Default_Labels; + + function Notepad_Window return Window + is + begin + if Active_Notepad /= Null_Panel then + return Get_Window (Active_Notepad); + else + return Null_Window; + end if; + end Notepad_Window; + +end Sample.Function_Key_Setting; diff --git a/Ada95/samples/sample-function_key_setting.ads b/Ada95/samples/sample-function_key_setting.ads new file mode 100644 index 000000000000..4188158f05c9 --- /dev/null +++ b/Ada95/samples/sample-function_key_setting.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Function_Key_Setting -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.11 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; + +-- This package implements a simple stack of function key label environments. +-- +package Sample.Function_Key_Setting is + + procedure Push_Environment (Key : String; + Reset : Boolean := True); + -- Push the definition of the current function keys on an internal + -- stack. If the reset flag is true, all labels are reset while + -- pushed, so the new environment can assume a tabula rasa. + -- The Key defines the new Help Context associated with the new + -- Environment. This saves also the currently active Notepad. + + procedure Pop_Environment; + -- Pop the Definitions from the stack and make them the current ones. + -- This also restores the Help context and the previous Notepad. + + procedure Initialize (Mode : Soft_Label_Key_Format := PC_Style; + Just : Label_Justification := Left); + -- Initialize the environment + + function Context return String; + -- Return the current context identifier + + function Find_Context (Key : String) return Boolean; + -- Look for a context, return true if it is in the stack, + -- false otherwise. + + procedure Notepad_To_Context (Pan : Panel); + -- Add a panel representing a notepad to the current context. + + Function_Key_Stack_Error : exception; + + procedure Default_Labels; + -- Set the default labels used in all environments + + function Notepad_Window return Window; + -- Return the current notepad window or Null_Window if there is none. + +end Sample.Function_Key_Setting; diff --git a/Ada95/samples/sample-header_handler.adb b/Ada95/samples/sample-header_handler.adb new file mode 100644 index 000000000000..ad60caf4b0cb --- /dev/null +++ b/Ada95/samples/sample-header_handler.adb @@ -0,0 +1,182 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Header_Handler -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.19 $ +-- $Date: 2011/03/22 23:54:38 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Ada.Calendar; use Ada.Calendar; +with Terminal_Interface.Curses.Text_IO.Integer_IO; +with Sample.Manifest; use Sample.Manifest; + +pragma Elaborate_All (Terminal_Interface.Curses.Text_Io.Integer_IO); + +-- This package handles the painting of the header line of the screen. +-- +package body Sample.Header_Handler is + + package Int_IO is new + Terminal_Interface.Curses.Text_IO.Integer_IO (Integer); + use Int_IO; + + Header_Window : Window := Null_Window; + + Display_Hour : Integer := -1; -- hour last displayed + Display_Min : Integer := -1; -- minute last displayed + Display_Day : Integer := -1; -- day last displayed + Display_Month : Integer := -1; -- month last displayed + + -- This is the routine handed over to the curses library to be called + -- as initialization routine when ripping of the header lines from + -- the screen. This routine must follow C conventions. + function Init_Header_Window (Win : Window; + Columns : Column_Count) return Integer; + pragma Convention (C, Init_Header_Window); + + procedure Internal_Update_Header_Window (Do_Update : Boolean); + + -- The initialization must be called before Init_Screen. It steals two + -- lines from the top of the screen. + procedure Init_Header_Handler + is + begin + Rip_Off_Lines (2, Init_Header_Window'Access); + end Init_Header_Handler; + + procedure N_Out (N : Integer); + + -- Emit a two digit number and ensure that a leading zero is generated if + -- necessary. + procedure N_Out (N : Integer) + is + begin + if N < 10 then + Add (Header_Window, '0'); + Put (Header_Window, N, 1); + else + Put (Header_Window, N, 2); + end if; + end N_Out; + + -- Paint the header window. The input parameter is a flag indicating + -- whether or not the screen should be updated physically after painting. + procedure Internal_Update_Header_Window (Do_Update : Boolean) + is + type Month_Name_Array is + array (Month_Number'First .. Month_Number'Last) of String (1 .. 9); + + Month_Names : constant Month_Name_Array := + ("January ", + "February ", + "March ", + "April ", + "May ", + "June ", + "July ", + "August ", + "September", + "October ", + "November ", + "December "); + + Now : constant Time := Clock; + Sec : constant Integer := Integer (Seconds (Now)); + Hour : constant Integer := Sec / 3600; + Minute : constant Integer := (Sec - Hour * 3600) / 60; + Mon : constant Month_Number := Month (Now); + D : constant Day_Number := Day (Now); + begin + if Header_Window /= Null_Window then + if Minute /= Display_Min or else Hour /= Display_Hour + or else Display_Day /= D or else Display_Month /= Mon then + Move_Cursor (Header_Window, 0, 0); + N_Out (D); Add (Header_Window, '.'); + Add (Header_Window, Month_Names (Mon)); + Move_Cursor (Header_Window, 1, 0); + N_Out (Hour); Add (Header_Window, ':'); + N_Out (Minute); + Display_Min := Minute; + Display_Hour := Hour; + Display_Month := Mon; + Display_Day := D; + Refresh_Without_Update (Header_Window); + if Do_Update then + Update_Screen; + end if; + end if; + end if; + end Internal_Update_Header_Window; + + -- This routine is called in the keyboard input timeout handler. So it will + -- periodically update the header line of the screen. + procedure Update_Header_Window + is + begin + Internal_Update_Header_Window (True); + end Update_Header_Window; + + function Init_Header_Window (Win : Window; + Columns : Column_Count) return Integer + is + Title : constant String := "Ada 95 ncurses Binding Sample"; + Pos : Column_Position; + begin + Header_Window := Win; + if Win /= Null_Window then + if Has_Colors then + Set_Background (Win => Win, + Ch => (Ch => ' ', + Color => Header_Color, + Attr => Normal_Video)); + Set_Character_Attributes (Win => Win, + Attr => Normal_Video, + Color => Header_Color); + Erase (Win); + end if; + Leave_Cursor_After_Update (Win, True); + Pos := Columns - Column_Position (Title'Length); + Add (Win, 0, Pos / 2, Title); + -- In this phase we must not allow a physical update, because + -- ncurses is not properly initialized at this point. + Internal_Update_Header_Window (False); + return 0; + else + return -1; + end if; + end Init_Header_Window; + +end Sample.Header_Handler; diff --git a/Ada95/samples/sample-header_handler.ads b/Ada95/samples/sample-header_handler.ads new file mode 100644 index 000000000000..aa0a0c29e9f1 --- /dev/null +++ b/Ada95/samples/sample-header_handler.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Header_Handler -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +-- This package handles the painting of the header line of the screen. +-- +package Sample.Header_Handler is + + procedure Init_Header_Handler; + -- Initialize the handler for the headerlines. + + procedure Update_Header_Window; + -- Update the information in the header window + +end Sample.Header_Handler; diff --git a/Ada95/samples/sample-helpers.adb b/Ada95/samples/sample-helpers.adb new file mode 100644 index 000000000000..ceef268134a5 --- /dev/null +++ b/Ada95/samples/sample-helpers.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Helpers -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.14 $ +-- $Date: 2011/03/19 12:13:21 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Sample.Explanation; use Sample.Explanation; + +-- This package contains some convenient helper routines used throughout +-- this example. +-- +package body Sample.Helpers is + + procedure Window_Title (Win : Window; + Title : String) + is + Height : Line_Count; + Width : Column_Count; + Pos : Column_Position := 0; + begin + Get_Size (Win, Height, Width); + if Title'Length < Width then + Pos := (Width - Title'Length) / 2; + end if; + Add (Win, 0, Pos, Title); + end Window_Title; + + procedure Not_Implemented is + begin + Explain ("NOTIMPL"); + end Not_Implemented; + +end Sample.Helpers; diff --git a/Ada95/samples/sample-helpers.ads b/Ada95/samples/sample-helpers.ads new file mode 100644 index 000000000000..28e89bb5707c --- /dev/null +++ b/Ada95/samples/sample-helpers.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Helpers -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.11 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +-- This package contains some convenient helper routines used throughout +-- this example. +-- +package Sample.Helpers is + + procedure Window_Title (Win : Window; + Title : String); + -- Put a title string into the first line of the window + + procedure Not_Implemented; + +end Sample.Helpers; diff --git a/Ada95/samples/sample-keyboard_handler.adb b/Ada95/samples/sample-keyboard_handler.adb new file mode 100644 index 000000000000..1d3f20c74b4f --- /dev/null +++ b/Ada95/samples/sample-keyboard_handler.adb @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Keyboard_Handler -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2006,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.16 $ +-- $Date: 2011/03/23 00:34:24 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Ada.Strings; use Ada.Strings; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; +with Ada.Characters.Handling; use Ada.Characters.Handling; + +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Forms; use Terminal_Interface.Curses.Forms; +with Terminal_Interface.Curses.Forms.Field_Types.Enumeration; +use Terminal_Interface.Curses.Forms.Field_Types.Enumeration; + +with Sample.Header_Handler; use Sample.Header_Handler; +with Sample.Form_Demo.Aux; use Sample.Form_Demo.Aux; +with Sample.Manifest; use Sample.Manifest; +with Sample.Form_Demo.Handler; + +-- This package contains a centralized keyboard handler used throughout +-- this example. The handler establishes a timeout mechanism that provides +-- periodical updates of the common header lines used in this example. +-- + +package body Sample.Keyboard_Handler is + + In_Command : Boolean := False; + + function Get_Key (Win : Window := Standard_Window) return Real_Key_Code + is + K : Real_Key_Code; + + function Command return Real_Key_Code; + + function Command return Real_Key_Code + is + function My_Driver (F : Form; + C : Key_Code; + P : Panel) return Boolean; + package Fh is new Sample.Form_Demo.Handler (My_Driver); + + type Label_Array is array (Label_Number) of String (1 .. 8); + + Labels : Label_Array; + + FA : Field_Array_Access := new Field_Array' + (Make (0, 0, "Command:"), + Make (Top => 0, Left => 9, Width => Columns - 11), + Null_Field); + + K : Real_Key_Code := Key_None; + N : Natural := 0; + + function My_Driver (F : Form; + C : Key_Code; + P : Panel) return Boolean + is + Ch : Character; + begin + if P = Null_Panel then + raise Panel_Exception; + end if; + if C in User_Key_Code'Range and then C = QUIT then + if Driver (F, F_Validate_Field) = Form_Ok then + K := Key_None; + return True; + end if; + elsif C in Normal_Key_Code'Range then + Ch := Character'Val (C); + if Ch = LF or else Ch = CR then + if Driver (F, F_Validate_Field) = Form_Ok then + declare + Buffer : String (1 .. Positive (Columns - 11)); + Cmdc : String (1 .. 8); + begin + Get_Buffer (Fld => FA.all (2), Str => Buffer); + Trim (Buffer, Left); + if Buffer (1) /= ' ' then + Cmdc := To_Upper (Buffer (Cmdc'Range)); + for I in Labels'Range loop + if Cmdc = Labels (I) then + K := Function_Key_Code + (Function_Key_Number (I)); + exit; + end if; + end loop; + end if; + return True; + end; + end if; + end if; + end if; + return False; + end My_Driver; + + begin + In_Command := True; + for I in Label_Number'Range loop + Get_Soft_Label_Key (I, Labels (I)); + Trim (Labels (I), Left); + Translate (Labels (I), Upper_Case_Map); + if Labels (I) (1) /= ' ' then + N := N + 1; + end if; + end loop; + if N > 0 then -- some labels were really set + declare + Enum_Info : Enumeration_Info (N); + Enum_Field : Enumeration_Field; + J : Positive := Enum_Info.Names'First; + + Frm : Form := Create (FA); + + begin + for I in Label_Number'Range loop + if Labels (I) (1) /= ' ' then + Enum_Info.Names (J) := new String'(Labels (I)); + J := J + 1; + end if; + end loop; + Enum_Field := Create (Enum_Info, True); + Set_Field_Type (FA.all (2), Enum_Field); + Set_Background (FA.all (2), Normal_Video); + + Fh.Drive_Me (Frm, Lines - 3, 0); + Delete (Frm); + Update_Panels; Update_Screen; + end; + end if; + Free (FA, True); + In_Command := False; + return K; + end Command; + + begin + Set_Timeout_Mode (Win, Delayed, 30000); + loop + K := Get_Keystroke (Win); + if K = Key_None then -- a timeout occurred + Update_Header_Window; + elsif K = 3 and then not In_Command then -- CTRL-C + K := Command; + exit when K /= Key_None; + else + exit; + end if; + end loop; + return K; + end Get_Key; + + procedure Init_Keyboard_Handler is + begin + null; + end Init_Keyboard_Handler; + +end Sample.Keyboard_Handler; diff --git a/Ada95/samples/sample-keyboard_handler.ads b/Ada95/samples/sample-keyboard_handler.ads new file mode 100644 index 000000000000..ac5b1399db01 --- /dev/null +++ b/Ada95/samples/sample-keyboard_handler.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Keyboard_Handler -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +-- This package contains a centralized keyboard handler used throughout +-- this example. The handler establishes a timeout mechanism that provides +-- periodical updates of the common header lines used in this example. +-- +package Sample.Keyboard_Handler is + + function Get_Key (Win : Window := Standard_Window) return Real_Key_Code; + -- The central routine for handling keystrokes. + + procedure Init_Keyboard_Handler; + -- Initialize the keyboard + +end Sample.Keyboard_Handler; diff --git a/Ada95/samples/sample-manifest.ads b/Ada95/samples/sample-manifest.ads new file mode 100644 index 000000000000..bb76c4cba78c --- /dev/null +++ b/Ada95/samples/sample-manifest.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Manifest -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.11 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; + +package Sample.Manifest is + + QUIT : constant User_Key_Code := User_Key_Code'First; + SELECT_ITEM : constant User_Key_Code := QUIT + 1; + + FKEY_HELP : constant Label_Number := 1; + HELP_CODE : constant Special_Key_Code := Key_F1; + FKEY_EXPLAIN : constant Label_Number := 2; + EXPLAIN_CODE : constant Special_Key_Code := Key_F2; + FKEY_QUIT : constant Label_Number := 3; + QUIT_CODE : constant Special_Key_Code := Key_F3; + + Menu_Marker : constant String := "=> "; + + Default_Colors : constant Redefinable_Color_Pair := 1; + Menu_Fore_Color : constant Redefinable_Color_Pair := 2; + Menu_Back_Color : constant Redefinable_Color_Pair := 3; + Menu_Grey_Color : constant Redefinable_Color_Pair := 4; + Form_Fore_Color : constant Redefinable_Color_Pair := 5; + Form_Back_Color : constant Redefinable_Color_Pair := 6; + Notepad_Color : constant Redefinable_Color_Pair := 7; + Help_Color : constant Redefinable_Color_Pair := 8; + Header_Color : constant Redefinable_Color_Pair := 9; + +end Sample.Manifest; diff --git a/Ada95/samples/sample-menu_demo-aux.adb b/Ada95/samples/sample-menu_demo-aux.adb new file mode 100644 index 000000000000..091f08b92a37 --- /dev/null +++ b/Ada95/samples/sample-menu_demo-aux.adb @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Menu_Demo.Aux -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2006,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.14 $ +-- $Date: 2009/12/26 17:38:58 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; + +with Sample.Manifest; use Sample.Manifest; +with Sample.Helpers; use Sample.Helpers; +with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; +with Sample.Explanation; use Sample.Explanation; + +package body Sample.Menu_Demo.Aux is + + procedure Geometry (M : Menu; + L : out Line_Count; + C : out Column_Count; + Y : out Line_Position; + X : out Column_Position; + Fy : out Line_Position; + Fx : out Column_Position); + + procedure Geometry (M : Menu; + L : out Line_Count; -- Lines used for menu + C : out Column_Count; -- Columns used for menu + Y : out Line_Position; -- Proposed Line for menu + X : out Column_Position; -- Proposed Column for menu + Fy : out Line_Position; -- Vertical inner frame + Fx : out Column_Position) -- Horiz. inner frame + is + Spc_Desc : Column_Position; -- spaces between description and item + begin + Set_Mark (M, Menu_Marker); + + Spacing (M, Spc_Desc, Fy, Fx); + Scale (M, L, C); + + Fx := Fx + Column_Position (Fy - 1); -- looks a bit nicer + + L := L + 2 * Fy; -- count for frame at top and bottom + C := C + 2 * Fx; -- " + + -- Calculate horizontal coordinate at the screen center + X := (Columns - C) / 2; + Y := 1; -- always startin line 1 + + end Geometry; + + procedure Geometry (M : Menu; + L : out Line_Count; -- Lines used for menu + C : out Column_Count; -- Columns used for menu + Y : out Line_Position; -- Proposed Line for menu + X : out Column_Position) -- Proposed Column for menu + is + Fy : Line_Position; + Fx : Column_Position; + begin + Geometry (M, L, C, Y, X, Fy, Fx); + end Geometry; + + function Create (M : Menu; + Title : String; + Lin : Line_Position; + Col : Column_Position) return Panel + is + W, S : Window; + L : Line_Count; + C : Column_Count; + Y, Fy : Line_Position; + X, Fx : Column_Position; + Pan : Panel; + begin + Geometry (M, L, C, Y, X, Fy, Fx); + W := New_Window (L, C, Lin, Col); + Set_Meta_Mode (W); + Set_KeyPad_Mode (W); + if Has_Colors then + Set_Background (Win => W, + Ch => (Ch => ' ', + Color => Menu_Back_Color, + Attr => Normal_Video)); + Set_Foreground (Men => M, Color => Menu_Fore_Color); + Set_Background (Men => M, Color => Menu_Back_Color); + Set_Grey (Men => M, Color => Menu_Grey_Color); + Erase (W); + end if; + S := Derived_Window (W, L - Fy, C - Fx, Fy, Fx); + Set_Meta_Mode (S); + Set_KeyPad_Mode (S); + Box (W); + Set_Window (M, W); + Set_Sub_Window (M, S); + if Title'Length > 0 then + Window_Title (W, Title); + end if; + Pan := New_Panel (W); + Post (M); + return Pan; + end Create; + + procedure Destroy (M : Menu; + P : in out Panel) + is + W, S : Window; + begin + W := Get_Window (M); + S := Get_Sub_Window (M); + Post (M, False); + Erase (W); + Delete (P); + Set_Window (M, Null_Window); + Set_Sub_Window (M, Null_Window); + Delete (S); + Delete (W); + Update_Panels; + end Destroy; + + function Get_Request (M : Menu; P : Panel) return Key_Code + is + W : constant Window := Get_Window (M); + K : Real_Key_Code; + Ch : Character; + begin + Top (P); + loop + K := Get_Key (W); + if K in Special_Key_Code'Range then + case K is + when HELP_CODE => Explain_Context; + when EXPLAIN_CODE => Explain ("MENUKEYS"); + when Key_Home => return REQ_FIRST_ITEM; + when QUIT_CODE => return QUIT; + when Key_Cursor_Down => return REQ_DOWN_ITEM; + when Key_Cursor_Up => return REQ_UP_ITEM; + when Key_Cursor_Left => return REQ_LEFT_ITEM; + when Key_Cursor_Right => return REQ_RIGHT_ITEM; + when Key_End => return REQ_LAST_ITEM; + when Key_Backspace => return REQ_BACK_PATTERN; + when Key_Next_Page => return REQ_SCR_DPAGE; + when Key_Previous_Page => return REQ_SCR_UPAGE; + when others => return K; + end case; + elsif K in Normal_Key_Code'Range then + Ch := Character'Val (K); + case Ch is + when CAN => return QUIT; -- CTRL-X + when SO => return REQ_NEXT_ITEM; -- CTRL-N + when DLE => return REQ_PREV_ITEM; -- CTRL-P + when NAK => return REQ_SCR_ULINE; -- CTRL-U + when EOT => return REQ_SCR_DLINE; -- CTRL-D + when ACK => return REQ_SCR_DPAGE; -- CTRL-F + when STX => return REQ_SCR_UPAGE; -- CTRL-B + when EM => return REQ_CLEAR_PATTERN; -- CTRL-Y + when BS => return REQ_BACK_PATTERN; -- CTRL-H + when SOH => return REQ_NEXT_MATCH; -- CTRL-A + when ENQ => return REQ_PREV_MATCH; -- CTRL-E + when DC4 => return REQ_TOGGLE_ITEM; -- CTRL-T + + when CR | LF => return SELECT_ITEM; + when others => return K; + end case; + else + return K; + end if; + end loop; + end Get_Request; + +end Sample.Menu_Demo.Aux; diff --git a/Ada95/samples/sample-menu_demo-aux.ads b/Ada95/samples/sample-menu_demo-aux.ads new file mode 100644 index 000000000000..e82aedf995b0 --- /dev/null +++ b/Ada95/samples/sample-menu_demo-aux.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Menu_Demo.Aux -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.11 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus; + +package Sample.Menu_Demo.Aux is + + procedure Geometry (M : Menu; + L : out Line_Count; + C : out Column_Count; + Y : out Line_Position; + X : out Column_Position); + -- Calculate the geometry for a panel being able to be used to display + -- the menu. + + function Create (M : Menu; + Title : String; + Lin : Line_Position; + Col : Column_Position) return Panel; + -- Create a panel decorated with a frame and the title at the specified + -- position. The dimension of the panel is derived from the menus layout. + + procedure Destroy (M : Menu; + P : in out Panel); + -- Destroy all the windowing structures associated with this menu and + -- panel. + + function Get_Request (M : Menu; P : Panel) return Key_Code; + -- Centralized request driver for all menus in this sample. This + -- gives us a common key binding for all menus. + +end Sample.Menu_Demo.Aux; diff --git a/Ada95/samples/sample-menu_demo-handler.adb b/Ada95/samples/sample-menu_demo-handler.adb new file mode 100644 index 000000000000..84d29f6351bf --- /dev/null +++ b/Ada95/samples/sample-menu_demo-handler.adb @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Menu_Demo.Handler -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2004,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions : -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.16 $ +-- $Date: 2009/12/26 17:38:58 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Sample.Menu_Demo.Aux; +with Sample.Manifest; use Sample.Manifest; +with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse; + +package body Sample.Menu_Demo.Handler is + + package Aux renames Sample.Menu_Demo.Aux; + + procedure Drive_Me (M : Menu; + Title : String := "") + is + L : Line_Count; + C : Column_Count; + Y : Line_Position; + X : Column_Position; + begin + Aux.Geometry (M, L, C, Y, X); + Drive_Me (M, Y, X, Title); + end Drive_Me; + + procedure Drive_Me (M : Menu; + Lin : Line_Position; + Col : Column_Position; + Title : String := "") + is + Mask : Event_Mask := No_Events; + Old : Event_Mask; + Pan : Panel := Aux.Create (M, Title, Lin, Col); + V : Cursor_Visibility := Invisible; + begin + -- We are only interested in Clicks with the left button + Register_Reportable_Events (Left, All_Clicks, Mask); + Old := Start_Mouse (Mask); + Set_Cursor_Visibility (V); + loop + declare + K : Key_Code := Aux.Get_Request (M, Pan); + R : constant Driver_Result := Driver (M, K); + begin + case R is + when Menu_Ok => null; + when Unknown_Request => + declare + I : constant Item := Current (M); + O : Item_Option_Set; + begin + if K = Key_Mouse then + K := SELECT_ITEM; + end if; + Get_Options (I, O); + if K = SELECT_ITEM and then not O.Selectable then + Beep; + else + if My_Driver (M, K, Pan) then + exit; + end if; + end if; + end; + when others => Beep; + end case; + end; + end loop; + End_Mouse (Old); + Aux.Destroy (M, Pan); + end Drive_Me; + +end Sample.Menu_Demo.Handler; diff --git a/Ada95/samples/sample-menu_demo-handler.ads b/Ada95/samples/sample-menu_demo-handler.ads new file mode 100644 index 000000000000..e9eaa6b74b76 --- /dev/null +++ b/Ada95/samples/sample-menu_demo-handler.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Menu_Demo.Handler -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2003,2009 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.10 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; +use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; +use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Menus; +use Terminal_Interface.Curses.Menus; + +generic + with function My_Driver (Men : Menu; + K : Key_Code; + Pan : Panel) return Boolean; +package Sample.Menu_Demo.Handler is + + procedure Drive_Me (M : Menu; + Lin : Line_Position; + Col : Column_Position; + Title : String := ""); + -- Position the menu at the given point and drive it. + + procedure Drive_Me (M : Menu; + Title : String := ""); + -- Center menu and drive it. + +end Sample.Menu_Demo.Handler; diff --git a/Ada95/samples/sample-menu_demo.adb b/Ada95/samples/sample-menu_demo.adb new file mode 100644 index 000000000000..80cd94b1d4e5 --- /dev/null +++ b/Ada95/samples/sample-menu_demo.adb @@ -0,0 +1,396 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Menu_Demo -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2008,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.19 $ +-- $Date: 2011/03/23 00:44:12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus; +with Terminal_Interface.Curses.Menus.Menu_User_Data; +with Terminal_Interface.Curses.Menus.Item_User_Data; + +with Sample.Manifest; use Sample.Manifest; +with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; +with Sample.Menu_Demo.Handler; +with Sample.Helpers; use Sample.Helpers; +with Sample.Explanation; use Sample.Explanation; + +package body Sample.Menu_Demo is + + package Spacing_Demo is + procedure Spacing_Test; + end Spacing_Demo; + + package body Spacing_Demo is + + procedure Spacing_Test + is + function My_Driver (M : Menu; + K : Key_Code; + P : Panel) return Boolean; + + procedure Set_Option_Key; + procedure Set_Select_Key; + procedure Set_Description_Key; + procedure Set_Hide_Key; + + package Mh is new Sample.Menu_Demo.Handler (My_Driver); + + I : Item_Array_Access := new Item_Array' + (New_Item ("January", "31 Days"), + New_Item ("February", "28/29 Days"), + New_Item ("March", "31 Days"), + New_Item ("April", "30 Days"), + New_Item ("May", "31 Days"), + New_Item ("June", "30 Days"), + New_Item ("July", "31 Days"), + New_Item ("August", "31 Days"), + New_Item ("September", "30 Days"), + New_Item ("October", "31 Days"), + New_Item ("November", "30 Days"), + New_Item ("December", "31 Days"), + Null_Item); + + M : Menu := New_Menu (I); + Flip_State : Boolean := True; + Hide_Long : Boolean := False; + + type Format_Code is (Four_By_1, Four_By_2, Four_By_3); + type Operations is (Flip, Reorder, Reformat, Reselect, Describe); + + type Change is array (Operations) of Boolean; + pragma Pack (Change); + No_Change : constant Change := Change'(others => False); + + Current_Format : Format_Code := Four_By_1; + To_Change : Change := No_Change; + + function My_Driver (M : Menu; + K : Key_Code; + P : Panel) return Boolean + is + begin + if M = Null_Menu then + raise Menu_Exception; + end if; + if P = Null_Panel then + raise Panel_Exception; + end if; + To_Change := No_Change; + if K in User_Key_Code'Range then + if K = QUIT then + return True; + end if; + end if; + if K in Special_Key_Code'Range then + case K is + when Key_F4 => + To_Change (Flip) := True; + return True; + when Key_F5 => + To_Change (Reformat) := True; + Current_Format := Four_By_1; + return True; + when Key_F6 => + To_Change (Reformat) := True; + Current_Format := Four_By_2; + return True; + when Key_F7 => + To_Change (Reformat) := True; + Current_Format := Four_By_3; + return True; + when Key_F8 => + To_Change (Reorder) := True; + return True; + when Key_F9 => + To_Change (Reselect) := True; + return True; + when Key_F10 => + if Current_Format /= Four_By_3 then + To_Change (Describe) := True; + return True; + else + return False; + end if; + when Key_F11 => + Hide_Long := not Hide_Long; + declare + O : Item_Option_Set; + begin + for J in I'Range loop + Get_Options (I.all (J), O); + O.Selectable := True; + if Hide_Long then + case J is + when 1 | 3 | 5 | 7 | 8 | 10 | 12 => + O.Selectable := False; + when others => null; + end case; + end if; + Set_Options (I.all (J), O); + end loop; + end; + return False; + when others => null; + end case; + end if; + return False; + end My_Driver; + + procedure Set_Option_Key + is + O : Menu_Option_Set; + begin + if Current_Format = Four_By_1 then + Set_Soft_Label_Key (8, ""); + else + Get_Options (M, O); + if O.Row_Major_Order then + Set_Soft_Label_Key (8, "O-Col"); + else + Set_Soft_Label_Key (8, "O-Row"); + end if; + end if; + Refresh_Soft_Label_Keys_Without_Update; + end Set_Option_Key; + + procedure Set_Select_Key + is + O : Menu_Option_Set; + begin + Get_Options (M, O); + if O.One_Valued then + Set_Soft_Label_Key (9, "Multi"); + else + Set_Soft_Label_Key (9, "Singl"); + end if; + Refresh_Soft_Label_Keys_Without_Update; + end Set_Select_Key; + + procedure Set_Description_Key + is + O : Menu_Option_Set; + begin + if Current_Format = Four_By_3 then + Set_Soft_Label_Key (10, ""); + else + Get_Options (M, O); + if O.Show_Descriptions then + Set_Soft_Label_Key (10, "-Desc"); + else + Set_Soft_Label_Key (10, "+Desc"); + end if; + end if; + Refresh_Soft_Label_Keys_Without_Update; + end Set_Description_Key; + + procedure Set_Hide_Key + is + begin + if Hide_Long then + Set_Soft_Label_Key (11, "Enab"); + else + Set_Soft_Label_Key (11, "Disab"); + end if; + Refresh_Soft_Label_Keys_Without_Update; + end Set_Hide_Key; + + begin + Push_Environment ("MENU01"); + Notepad ("MENU-PAD01"); + Default_Labels; + Set_Soft_Label_Key (4, "Flip"); + Set_Soft_Label_Key (5, "4x1"); + Set_Soft_Label_Key (6, "4x2"); + Set_Soft_Label_Key (7, "4x3"); + Set_Option_Key; + Set_Select_Key; + Set_Description_Key; + Set_Hide_Key; + + Set_Format (M, 4, 1); + loop + Mh.Drive_Me (M); + exit when To_Change = No_Change; + if To_Change (Flip) then + if Flip_State then + Flip_State := False; + Set_Spacing (M, 3, 2, 0); + else + Flip_State := True; + Set_Spacing (M); + end if; + elsif To_Change (Reformat) then + case Current_Format is + when Four_By_1 => Set_Format (M, 4, 1); + when Four_By_2 => Set_Format (M, 4, 2); + when Four_By_3 => + declare + O : Menu_Option_Set; + begin + Get_Options (M, O); + O.Show_Descriptions := False; + Set_Options (M, O); + Set_Format (M, 4, 3); + end; + end case; + Set_Option_Key; + Set_Description_Key; + elsif To_Change (Reorder) then + declare + O : Menu_Option_Set; + begin + Get_Options (M, O); + O.Row_Major_Order := not O.Row_Major_Order; + Set_Options (M, O); + Set_Option_Key; + end; + elsif To_Change (Reselect) then + declare + O : Menu_Option_Set; + begin + Get_Options (M, O); + O.One_Valued := not O.One_Valued; + Set_Options (M, O); + Set_Select_Key; + end; + elsif To_Change (Describe) then + declare + O : Menu_Option_Set; + begin + Get_Options (M, O); + O.Show_Descriptions := not O.Show_Descriptions; + Set_Options (M, O); + Set_Description_Key; + end; + else + null; + end if; + end loop; + Set_Spacing (M); + + Pop_Environment; + pragma Assert (Get_Index (Items (M, 1)) = Get_Index (I (1))); + Delete (M); + Free (I, True); + end Spacing_Test; + end Spacing_Demo; + + procedure Demo + is + -- We use this datatype only to test the instantiation of + -- the Menu_User_Data generic package. No functionality + -- behind it. + type User_Data is new Integer; + type User_Data_Access is access User_Data; + + -- Those packages are only instantiated to test the usability. + -- No real functionality is shown in the demo. + package MUD is new Menu_User_Data (User_Data, User_Data_Access); + package IUD is new Item_User_Data (User_Data, User_Data_Access); + + function My_Driver (M : Menu; + K : Key_Code; + P : Panel) return Boolean; + + package Mh is new Sample.Menu_Demo.Handler (My_Driver); + + Itm : Item_Array_Access := new Item_Array' + (New_Item ("Menu Layout Options"), + New_Item ("Demo of Hook functions"), + Null_Item); + M : Menu := New_Menu (Itm); + + U1 : constant User_Data_Access := new User_Data'(4711); + U2 : User_Data_Access; + U3 : constant User_Data_Access := new User_Data'(4712); + U4 : User_Data_Access; + + function My_Driver (M : Menu; + K : Key_Code; + P : Panel) return Boolean + is + Idx : constant Positive := Get_Index (Current (M)); + begin + if K in User_Key_Code'Range then + if K = QUIT then + return True; + elsif K = SELECT_ITEM then + if Idx in Itm'Range then + Hide (P); + Update_Panels; + end if; + case Idx is + when 1 => Spacing_Demo.Spacing_Test; + when others => Not_Implemented; + end case; + if Idx in Itm'Range then + Top (P); + Show (P); + Update_Panels; + Update_Screen; + end if; + end if; + end if; + return False; + end My_Driver; + begin + Push_Environment ("MENU00"); + Notepad ("MENU-PAD00"); + Default_Labels; + Refresh_Soft_Label_Keys_Without_Update; + Set_Pad_Character (M, '|'); + + MUD.Set_User_Data (M, U1); + IUD.Set_User_Data (Itm.all (1), U3); + + Mh.Drive_Me (M); + + MUD.Get_User_Data (M, U2); + pragma Assert (U1 = U2 and U1.all = 4711); + + IUD.Get_User_Data (Itm.all (1), U4); + pragma Assert (U3 = U4 and U3.all = 4712); + + Pop_Environment; + Delete (M); + Free (Itm, True); + end Demo; + +end Sample.Menu_Demo; diff --git a/Ada95/samples/sample-menu_demo.ads b/Ada95/samples/sample-menu_demo.ads new file mode 100644 index 000000000000..b071afc8277d --- /dev/null +++ b/Ada95/samples/sample-menu_demo.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Menu_Demo -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +package Sample.Menu_Demo is + + procedure Demo; + +end Sample.Menu_Demo; diff --git a/Ada95/samples/sample-my_field_type.adb b/Ada95/samples/sample-my_field_type.adb new file mode 100644 index 000000000000..e0d6f6732d12 --- /dev/null +++ b/Ada95/samples/sample-my_field_type.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.My_Field_Type -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2006,2008 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.16 $ +-- $Date: 2008/07/26 18:47:58 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ + +-- This is a very simple user defined field type. It accepts only a +-- defined character as input into the field. +-- +package body Sample.My_Field_Type is + + -- That's simple. There are minimal field validity checks. + function Field_Check (Fld : Field; + Typ : My_Data) return Boolean + is + begin + if Fld = Null_Field or Typ.Ch = Character'Val (0) then + return False; + end if; + return True; + end Field_Check; + + -- Check exactly against the specified character. + function Character_Check (Ch : Character; + Typ : My_Data) return Boolean + is + C : constant Character := Typ.Ch; + begin + return Ch = C; + end Character_Check; + +end Sample.My_Field_Type; diff --git a/Ada95/samples/sample-my_field_type.ads b/Ada95/samples/sample-my_field_type.ads new file mode 100644 index 000000000000..b8f3653c1d0a --- /dev/null +++ b/Ada95/samples/sample-my_field_type.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.My_Field_Type -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998,2006 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Terminal_Interface.Curses.Forms; use Terminal_Interface.Curses.Forms; +with Terminal_Interface.Curses.Forms.Field_Types.User; +use Terminal_Interface.Curses.Forms.Field_Types.User; + +-- This is a very simple user defined field type. It accepts only a +-- defined character as input into the field. +-- +package Sample.My_Field_Type is + + type My_Data is new User_Defined_Field_Type with + record + Ch : Character; + end record; + + function Field_Check (Fld : Field; + Typ : My_Data) return Boolean; + + function Character_Check (Ch : Character; + Typ : My_Data) return Boolean; + +end Sample.My_Field_Type; diff --git a/Ada95/samples/sample-text_io_demo.adb b/Ada95/samples/sample-text_io_demo.adb new file mode 100644 index 000000000000..a458a37cdbd9 --- /dev/null +++ b/Ada95/samples/sample-text_io_demo.adb @@ -0,0 +1,195 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Text_IO_Demo -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2006,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.17 $ +-- $Date: 2011/03/23 00:44:12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Ada.Numerics.Generic_Elementary_Functions; + +with Ada.Numerics.Complex_Types; +use Ada.Numerics.Complex_Types; + +with Terminal_Interface.Curses; +use Terminal_Interface.Curses; + +with Terminal_Interface.Curses.Panels; +use Terminal_Interface.Curses.Panels; + +with Terminal_Interface.Curses.Text_IO; +use Terminal_Interface.Curses.Text_IO; + +with Terminal_Interface.Curses.Text_IO.Integer_IO; +with Terminal_Interface.Curses.Text_IO.Float_IO; +with Terminal_Interface.Curses.Text_IO.Enumeration_IO; +with Terminal_Interface.Curses.Text_IO.Complex_IO; +with Terminal_Interface.Curses.Text_IO.Fixed_IO; +with Terminal_Interface.Curses.Text_IO.Decimal_IO; +with Terminal_Interface.Curses.Text_IO.Modular_IO; + +with Sample.Manifest; use Sample.Manifest; +with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; +with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; +with Sample.Explanation; use Sample.Explanation; + +pragma Elaborate_All (Terminal_Interface.Curses.Text_Io.Complex_IO); +pragma Elaborate_All (Terminal_Interface.Curses.Text_Io.Decimal_IO); +pragma Elaborate_All (Terminal_Interface.Curses.Text_Io.Enumeration_IO); +pragma Elaborate_All (Terminal_Interface.Curses.Text_Io.Fixed_IO); +pragma Elaborate_All (Terminal_Interface.Curses.Text_Io.Float_IO); +pragma Elaborate_All (Terminal_Interface.Curses.Text_Io.Integer_IO); +pragma Elaborate_All (Terminal_Interface.Curses.Text_Io.Modular_IO); + +package body Sample.Text_IO_Demo is + + type Weekday is (Sunday, + Monday, + Tuesday, + Wednesday, + Thursday, + Friday, + Saturday); + + type Fix is delta 0.1 range 0.0 .. 4.0; + type Dec is delta 0.01 digits 5 range 0.0 .. 4.0; + type Md is mod 5; + + package Math is new + Ada.Numerics.Generic_Elementary_Functions (Float); + + package Int_IO is new + Terminal_Interface.Curses.Text_IO.Integer_IO (Integer); + use Int_IO; + + package Real_IO is new + Terminal_Interface.Curses.Text_IO.Float_IO (Float); + use Real_IO; + + package Enum_IO is new + Terminal_Interface.Curses.Text_IO.Enumeration_IO (Weekday); + use Enum_IO; + + package C_IO is new + Terminal_Interface.Curses.Text_IO.Complex_IO (Ada.Numerics.Complex_Types); + use C_IO; + + package F_IO is new + Terminal_Interface.Curses.Text_IO.Fixed_IO (Fix); + use F_IO; + + package D_IO is new + Terminal_Interface.Curses.Text_IO.Decimal_IO (Dec); + use D_IO; + + package M_IO is new + Terminal_Interface.Curses.Text_IO.Modular_IO (Md); + use M_IO; + + procedure Demo + is + W : Window; + P : Panel := Create (Standard_Window); + K : Real_Key_Code; + Im : constant Complex := (0.0, 1.0); + Fx : constant Dec := 3.14; + Dc : constant Dec := 2.72; + L : Md; + + begin + Push_Environment ("TEXTIO"); + Default_Labels; + Notepad ("TEXTIO-PAD00"); + + Set_Echo_Mode (False); + Set_Meta_Mode; + Set_KeyPad_Mode; + W := Sub_Window (Standard_Window, Lines - 2, Columns - 2, 1, 1); + Box; + Refresh_Without_Update; + Set_Meta_Mode (W); + Set_KeyPad_Mode (W); + Immediate_Update_Mode (W, True); + + Set_Window (W); + + for I in 1 .. 10 loop + Put ("Square root of "); + Put (Item => I, Width => 5); + Put (" is "); + Put (Item => Math.Sqrt (Float (I)), Exp => 0, Aft => 7); + New_Line; + end loop; + + for W in Weekday loop + Put (Item => W); Put (' '); + end loop; + New_Line; + + L := Md'First; + for I in 1 .. 2 loop + for J in Md'Range loop + Put (L); Put (' '); + L := L + 1; + end loop; + end loop; + New_Line; + + Put (Im); New_Line; + Put (Fx); New_Line; + Put (Dc); New_Line; + + loop + K := Get_Key; + if K in Special_Key_Code'Range then + case K is + when QUIT_CODE => exit; + when HELP_CODE => Explain_Context; + when EXPLAIN_CODE => Explain ("TEXTIOKEYS"); + when others => null; + end case; + end if; + end loop; + + Set_Window (Null_Window); + Erase; Refresh_Without_Update; + Delete (P); + Delete (W); + + Pop_Environment; + end Demo; + +end Sample.Text_IO_Demo; diff --git a/Ada95/samples/sample-text_io_demo.ads b/Ada95/samples/sample-text_io_demo.ads new file mode 100644 index 000000000000..d3f5a188baf0 --- /dev/null +++ b/Ada95/samples/sample-text_io_demo.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample.Text_IO_Demo -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +package Sample.Text_IO_Demo is + + procedure Demo; + +end Sample.Text_IO_Demo; diff --git a/Ada95/samples/sample.adb b/Ada95/samples/sample.adb new file mode 100644 index 000000000000..9b3759f0c53a --- /dev/null +++ b/Ada95/samples/sample.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998-2008,2011 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.18 $ +-- $Date: 2011/03/23 00:44:12 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Text_IO; + +with Ada.Exceptions; use Ada.Exceptions; + +with Terminal_Interface.Curses; use Terminal_Interface.Curses; +with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; +with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus; +with Terminal_Interface.Curses.Menus.Menu_User_Data; +with Terminal_Interface.Curses.Menus.Item_User_Data; + +with Sample.Manifest; use Sample.Manifest; +with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; +with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; +with Sample.Header_Handler; use Sample.Header_Handler; +with Sample.Explanation; use Sample.Explanation; + +with Sample.Menu_Demo.Handler; +with Sample.Curses_Demo; +with Sample.Form_Demo; +with Sample.Menu_Demo; +with Sample.Text_IO_Demo; + +with GNAT.OS_Lib; + +package body Sample is + + type User_Data is + record + Data : Integer; + end record; + type User_Access is access User_Data; + + package Ud is new + Terminal_Interface.Curses.Menus.Menu_User_Data + (User_Data, User_Access); + + package Id is new + Terminal_Interface.Curses.Menus.Item_User_Data + (User_Data, User_Access); + + procedure Whow is + procedure Main_Menu; + procedure Main_Menu + is + function My_Driver (M : Menu; + K : Key_Code; + Pan : Panel) return Boolean; + + package Mh is new Sample.Menu_Demo.Handler (My_Driver); + + I : Item_Array_Access := new Item_Array' + (New_Item ("Curses Core Demo"), + New_Item ("Menu Demo"), + New_Item ("Form Demo"), + New_Item ("Text IO Demo"), + Null_Item); + + M : Menu := New_Menu (I); + + D1, D2 : User_Access; + I1, I2 : User_Access; + + function My_Driver (M : Menu; + K : Key_Code; + Pan : Panel) return Boolean + is + Idx : constant Positive := Get_Index (Current (M)); + begin + if K in User_Key_Code'Range then + if K = QUIT then + return True; + elsif K = SELECT_ITEM then + if Idx <= 4 then + Hide (Pan); + Update_Panels; + end if; + case Idx is + when 1 => Sample.Curses_Demo.Demo; + when 2 => Sample.Menu_Demo.Demo; + when 3 => Sample.Form_Demo.Demo; + when 4 => Sample.Text_IO_Demo.Demo; + when others => null; + end case; + if Idx <= 4 then + Top (Pan); + Show (Pan); + Update_Panels; + Update_Screen; + end if; + end if; + end if; + return False; + end My_Driver; + + begin + + if (1 + Item_Count (M)) /= I'Length then + raise Constraint_Error; + end if; + + D1 := new User_Data'(Data => 4711); + Ud.Set_User_Data (M, D1); + + I1 := new User_Data'(Data => 1174); + Id.Set_User_Data (I.all (1), I1); + + Set_Spacing (Men => M, Row => 2); + + Default_Labels; + Notepad ("MAINPAD"); + + Mh.Drive_Me (M, " Demo "); + + Ud.Get_User_Data (M, D2); + pragma Assert (D1 = D2); + pragma Assert (D1.Data = D2.Data); + + Id.Get_User_Data (I.all (1), I2); + pragma Assert (I1 = I2); + pragma Assert (I1.Data = I2.Data); + + Delete (M); + Free (I, True); + end Main_Menu; + + begin + Initialize (PC_Style_With_Index); + Init_Header_Handler; + Init_Screen; + + if Has_Colors then + Start_Color; + + Init_Pair (Pair => Default_Colors, Fore => Black, Back => White); + Init_Pair (Pair => Menu_Back_Color, Fore => Black, Back => Cyan); + Init_Pair (Pair => Menu_Fore_Color, Fore => Red, Back => Cyan); + Init_Pair (Pair => Menu_Grey_Color, Fore => White, Back => Cyan); + Init_Pair (Pair => Notepad_Color, Fore => Black, Back => Yellow); + Init_Pair (Pair => Help_Color, Fore => Blue, Back => Cyan); + Init_Pair (Pair => Form_Back_Color, Fore => Black, Back => Cyan); + Init_Pair (Pair => Form_Fore_Color, Fore => Red, Back => Cyan); + Init_Pair (Pair => Header_Color, Fore => Black, Back => Green); + + Set_Background (Ch => (Color => Default_Colors, + Attr => Normal_Video, + Ch => ' ')); + Set_Character_Attributes (Attr => Normal_Video, + Color => Default_Colors); + Erase; + + Set_Soft_Label_Key_Attributes (Color => Header_Color); + -- This propagates the attributes to the label window + Refresh_Soft_Label_Keys; + end if; + + Init_Keyboard_Handler; + + Set_Echo_Mode (False); + Set_Raw_Mode; + Set_Meta_Mode; + Set_KeyPad_Mode; + + -- Initialize the Function Key Environment + -- We have some fixed key throughout this sample + Main_Menu; + End_Windows; + Curses_Free_All; + + exception + when Event : others => + Terminal_Interface.Curses.End_Windows; + Text_IO.Put ("Exception: "); + Text_IO.Put (Exception_Name (Event)); + Text_IO.New_Line; + GNAT.OS_Lib.OS_Exit (1); + + end Whow; + +end Sample; diff --git a/Ada95/samples/sample.ads b/Ada95/samples/sample.ads new file mode 100644 index 000000000000..9d0647dad78d --- /dev/null +++ b/Ada95/samples/sample.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Sample -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +package Sample is + procedure Whow; +end Sample; diff --git a/Ada95/samples/status.adb b/Ada95/samples/status.adb new file mode 100644 index 000000000000..e6581317f401 --- /dev/null +++ b/Ada95/samples/status.adb @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Status -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Laurent Pautet <pautet@gnat.com> +-- Modified by: Juergen Pfeifer, 1997 +-- Version Control +-- $Revision: 1.7 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- This package has been contributed by Laurent Pautet <pautet@gnat.com> -- +-- -- +package body Status is + + protected body Process is + procedure Stop is + begin + Done := True; + end Stop; + function Continue return Boolean is + begin + return not Done; + end Continue; + end Process; + +end Status; diff --git a/Ada95/samples/status.ads b/Ada95/samples/status.ads new file mode 100644 index 000000000000..e9e3ee8b3501 --- /dev/null +++ b/Ada95/samples/status.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Status -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Laurent Pautet <pautet@gnat.com> +-- Modified by: Juergen Pfeifer, 1997 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +-- This package has been contributed by Laurent Pautet <pautet@gnat.com> -- +-- -- +with Ada.Interrupts.Names; + +package Status is + + pragma Warnings (Off); -- the next pragma exists since 3.11p + pragma Unreserve_All_Interrupts; + pragma Warnings (On); + + protected Process is + procedure Stop; + function Continue return Boolean; + pragma Attach_Handler (Stop, Ada.Interrupts.Names.SIGINT); + private + Done : Boolean := False; + end Process; + +end Status; diff --git a/Ada95/samples/tour.adb b/Ada95/samples/tour.adb new file mode 100644 index 000000000000..1cc91c15d740 --- /dev/null +++ b/Ada95/samples/tour.adb @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- tour -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Sample; use Sample; + +procedure Tour is +begin + Whow; +end Tour; diff --git a/Ada95/samples/tour.ads b/Ada95/samples/tour.ads new file mode 100644 index 000000000000..8888169160a4 --- /dev/null +++ b/Ada95/samples/tour.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- Tour -- +-- -- +-- S P E C -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- +-- -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- +-- -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- +------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer, 1996 +-- Version Control +-- $Revision: 1.9 $ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +procedure Tour; |