::
x72_tui.ada
-- The TUI
-- To compile using the GNAT Compiler on Linux, Windows 95/NT
--
-- gnatchop -w x72_tui.ada -- Split into units
-- gcc -c io.c -- Compile C interface
-- gnatmake main.adb -largs io.o -- Compile program
--
-- Notes:
-- The file io.c is the commented out C code before Raw_io.adb
-- The current I/O system with Windows 95 can not cope with
-- the fast reception of characters
-- ^C Will Kill the program use ^E to exit
-- ^D Will cause the program to terminate do not use
package Pack_constants is
VDT_MAX_X : CONSTANT := 79; -- Columns on VDT
VDT_MAX_Y : CONSTANT := 25; -- Lines on VDT
WINDOW_MAX_X : CONSTANT := 79; -- MAX columns window
WINDOW_MAX_Y : CONSTANT := 25; -- MAX lines window
C_CURSor : CONSTANT Character := '*';
C_BLANK : CONSTANT Character := ' ';
C_WIN_A : CONSTANT Character := '#';
C_WIN_PAS : CONSTANT Character := '+';
C_exit : CONSTANT Character := Character'val(05); --^E
C_WHERE : CONSTANT Character := Character'Val(255);
C_ACTION : CONSTANT Character := Character'Val(13); --cr
C_SWITCH : CONSTANT Character := Character'Val(09); --ht
C_MENU : CONSTANT Character := Character'Val(27); --esc
C_DEL : CONSTANT Character := Character'Val(08); --^B
C_NO_CHAR : CONSTANT Character := Character'Val(00);
C_LEFT : CONSTANT Character := Character'Val(12); --^L
C_RIGHT : CONSTANT Character := Character'Val(18); --^R
C_UP : CONSTANT Character := Character'Val(21); --^U
C_DOWN : CONSTANT Character := Character'Val(04); --^D
end Pack_constants;
-- All I/O is RAW
-- Write :chs are immediately written to the terminal
-- Read :chs are immediately available to the program
-- Unfortunately input characters are echoed using
-- get_immediate in Ada.Text_IO
package Raw_io is
procedure get_immediate( ch:out Character );
procedure put( ch:in Character );
procedure put( str:in String );
private
first_time : Boolean := TRUE;
end Raw_io;
-- begin file io.c
-- /*
-- * The C function to turn of echoing
-- *
-- * Works with the GNAT implementation on Linux, Win95
-- * Note:
-- * Uses Unix API call to turn of echoing
-- * Compile: gcc -c io.c
-- */
--
--
-- #include <termios.h>
-- #include <unistd.h>
--
-- void c_no_echo()
-- {
-- static tcflag_t c_lflag;
-- static int fd = STDIN_FILENO;
-- static struct termios termios_data;
-- tcgetattr( fd, &termios_data );
-- c_lflag = termios_data.c_lflag;
-- termios_data.c_lflag = termios_data.c_lflag & (~ECHO);
-- tcsetattr( fd, TCSANOW, &termios_data );
-- }
-- end file io.c
-- Alternative body for Raw_io
-- All the I/O is performed by code written in C
-- Implemented in io.c
--
-- with Interfaces.C;
-- use Interfaces.C;
-- package body raw_io is
--
-- procedure get_immediate( ch:out Character ) is
-- function c_get_char return Char;
-- pragma import (C, c_get_char, "c_get_char");
-- begin
-- ch := to_ada( c_get_char );
-- end get_immediate;
--
-- procedure put( ch:in Character ) is
-- procedure c_put_char( ch:in Char );
-- pragma import (C, c_put_char, "c_put_char");
-- begin
-- c_put_char( to_c( ch ) );
-- end put;
--
-- procedure put( str:in String ) is
-- procedure c_put_str( str:in Char_array );
-- pragma import (C, c_put_str, "c_put_str");
-- begin
-- c_put_str( to_c( str, append_nul=>TRUE ) );
-- end put;
--
-- end raw_io;
with Interfaces.C, Ada.Text_io;
use Interfaces.C, Ada.Text_io;
package body Raw_io is
procedure get_immediate( ch:out Character) is
procedure c_no_echo;
pragma import (C, c_no_echo, "c_no_echo"); -- Turn off echo
begin
if first_time then
c_no_echo; first_time := false;
end if;
Ada.Text_io.get_immediate(ch);
if Character'Pos(ch) = 10 then -- Real Return ch
ch := Character'Val(13);
end if;
end get_immediate;
procedure put( ch:in Character ) is -- Raw write
begin
Ada.Text_io.put( ch ); Ada.Text_io.flush;
end put;
procedure put( str:in String ) is -- Raw write
begin
Ada.Text_io.put( str ); Ada.Text_io.flush;
end put;
end Raw_io;
-- Machine dependent I/O
-- Currently assume input is from a terminal supporting
-- input of ANSI escape sequences
package Pack_md_io is
procedure put( ch :in Character ); -- Put char
procedure put( str:in String ); -- Put string
procedure get_immediate( ch:out Character ); -- no echo
end Pack_md_io;
with Raw_io, Pack_constants;
use Raw_io, Pack_constants;
package body Pack_md_io is
procedure put( ch:in Character ) is
begin
Raw_io.put( ch );
end put;
procedure put( str:in String ) is
begin
Raw_io.put( str );
end put;
procedure get_immediate( ch:out Character) is
ESC: CONSTANT Character := Character'Val(27);
begin
Raw_io.get_immediate( ch );
if ch = ESC then -- ESC
Raw_io.get_immediate( ch ); -- [
if ch = '[' then
Raw_io.get_immediate( ch );
case ch is
when 'A' => ch := C_UP; -- A - Up arrow
when 'B' => ch := C_DOWN; -- B - Down arrow
when 'C' => ch := C_RIGHT; -- C - Right arrow
when 'D' => ch := C_LEFT; -- D - Left arrow
when others => ch := '?'; -- ? - Unknown
end case;
end if;
end if;
end get_immediate;
end Pack_md_io;
package Class_screen is
procedure put( ch :in Character ); -- Put char
procedure put( str:in String ); -- Put string
procedure clear_screen; -- Clear screen
procedure position_cursor(col:in Positive; row:in Positive);
private
end Class_screen;
with Pack_md_io; use Pack_md_io;
package body Class_screen is
PREFIX: CONSTANT String := Character'Val(27) & "[";
procedure put( n:in Positive ); -- Write decimal number
procedure put( ch :in Character ) is
begin
Pack_md_io.put( ch );
end put;
procedure put( str:in String ) is
begin
Pack_md_io.put( str );
end put;
procedure clear_screen is -- Clear screen
begin
put( PREFIX & "2J");
end clear_screen;
procedure position_cursor(col:in Positive; row:in Positive) is
begin
put( PREFIX ); put(row); put(";"); put(col); put("H");
end position_cursor;
procedure put( n:in Positive ) is -- Write decimal number
begin
if n >= 10 then put( n / 10 ); end if;
put( Character'Val(n rem 10 + Character'Pos('0') ) );
end put;
end Class_screen;
-------------------------------------------------------------------
with Pack_constants, Ada.Finalization;
use Pack_constants, Ada.Finalization;
package Class_root_window is
type Root_window is abstract tagged limited private;
type P_Root_window is access all Root_window'Class;
type Attribute is ( TOP, BOTTOM, LEFT, RIGHT, abs_X, abs_Y );
procedure send_to( the:in out Root_window;
ch:in Character) is abstract;
procedure switch_to( the:in out Root_window ) is abstract;
procedure switch_away( the:in out Root_window ) is abstract;
function about( the:in Root_window;
b:in Attribute) return Natural is abstract;
private
type Root_window is
abstract new Limited_controlled with null record;
end Class_root_window;
-------------------------------------------------------------
with Ada.Finalization;
use Ada.Finalization;
package Class_input_manager is
type Input_manager is abstract tagged limited private;
procedure window_prologue; -- Initialize window system
procedure window_start; -- Start taking user input
procedure window_epilogue; -- Clean up
private
type Input_manager is
abstract new Limited_controlled with null record;
end Class_input_manager;
with Ada.Finalization, Class_root_window;
use Ada.Finalization, Class_root_window;
package Class_window_control is
type Window_control is abstract tagged limited private;
procedure add_to_list(p_w:in P_Root_window; ch:in Character);
procedure remove_from_list( p_w:in P_Root_window );
procedure top( p_w:in P_Root_window );
procedure find( p_w:out P_Root_window; ch:in Character );
procedure send_to_top( ch:in Character );
procedure switch_to_top;
procedure switch_away_from_top;
procedure write_to( p_w:in P_Root_window;
x,y:in Positive; mes:in String );
procedure hide_win( p_w:in P_Root_window );
procedure window_fatal( mes:in String );
private
type Window_control is
abstract new Limited_controlled with null record;
MAX_ITEMS : CONSTANT := 10;
type Active_window is record -- Active window
p_w : P_Root_window; -- Window
a_ch: Character; -- Activate character
end record;
subtype Window_index is Natural range 0 .. MAX_ITEMS;
subtype Window_range is Window_index range 1 .. MAX_ITEMS;
type Window_array is array (Window_range) of Active_window;
the_last_win: Window_index := 0; -- Last active window
the_windows : Window_array; -- All windows
end Class_window_control;
-------------------------------------------------------------
with Pack_constants, Pack_md_io, Class_screen,
Class_window_control, Class_root_window;
use Pack_constants, Pack_md_io, Class_screen,
Class_window_control, Class_root_window;
package body Class_input_manager is
procedure window_prologue is
begin
clear_screen;
end window_prologue;
procedure window_start is
p_w : P_Root_window; -- A window
ch : Character; -- Current Char
begin
loop
get_immediate( ch ); -- From Keyboard
exit when ch = C_exit;
find( p_w, ch ); -- Active window
if p_w /= null then -- Window activation
switch_away_from_top; -- No longer active
top( p_w ); -- Make p_w top
switch_to_top; -- & make active
send_to_top( C_WHERE ); -- In selected window
else --
send_to_top( ch ); -- Give to top window
end if;
end loop;
Pack_md_io.put( Character'Val(0) ); -- Capture output
end window_start;
procedure window_epilogue is
begin
null;
end window_epilogue;
end Class_input_manager;
-------------------------------------------------------------------
with Class_screen;
use Class_screen;
package body Class_window_control is
procedure add_to_list(p_w:in P_Root_window; ch:in Character) is
begin
if the_last_win < MAX_ITEMS then
the_last_win := the_last_win + 1;
the_windows( the_last_win ) := ( p_w, ch );
else
window_fatal("Cannot register window");
end if;
end add_to_list;
procedure remove_from_list( p_w:in P_Root_window ) is
begin
for i in 1 .. the_last_win loop -- Look at
if the_windows( i ).p_w = p_w then -- Found
for j in i .. the_last_win-1 loop -- Delete
the_windows( j ) := the_windows( j+1 ); -- move up
end loop;
the_last_win := the_last_win - 1; exit; -- Finish
end if;
end loop;
end remove_from_list;
procedure top( p_w:in P_Root_window ) is
begin
for i in 1 .. the_last_win loop --
if the_windows( i ).p_w = p_w then -- Found
declare
tmp : Active_window := the_windows( i );
begin
for j in i .. the_last_win-1 loop -- Move down
the_windows( j ) := the_windows( j+1 );
end loop;
the_windows( the_last_win ) := tmp; -- New top
end;
exit;
end if;
end loop;
end top;
procedure find( p_w:out P_Root_window; ch:in Character ) is
begin
p_w := null;
for i in 1 .. the_last_win loop
if the_windows( i ).a_ch = ch then
p_w := the_windows( i ).p_w;
exit;
end if;
end loop;
end find;
procedure send_to_top( ch:in Character ) is
begin
if the_last_win >= 1 then
send_to( the_windows(the_last_win).p_w.all, ch );
end if;
end send_to_top;
procedure switch_to_top is
begin
if the_last_win >= 1 then
switch_to( the_windows(the_last_win).p_w.all );
end if;
end switch_to_top;
procedure switch_away_from_top is
begin
if the_last_win >= 1 then
switch_away( the_windows(the_last_win).p_w.all );
end if;
end switch_away_from_top;
-- Of course this allow overlapping wondows
procedure write_to( p_w:in P_Root_window;
x,y:in Positive; mes:in String ) is
abs_x_crd : Positive := about( p_w.all, abs_X );
abs_y_crd : Positive := about( p_w.all, abs_Y );
begin
position_cursor( abs_x_crd+x-1, abs_y_crd+y-1 );
Class_screen.put( mes );
end write_to;
-- Of course this allow overlapping wondows
procedure hide_win( p_w:in P_Root_window ) is
abs_x_crd : Positive := about( p_w.all, abs_X );
abs_y_crd : Positive := about( p_w.all, abs_Y );
width : Positive := about( p_w.all, TOP );
height : Positive := about( p_w.all, LEFT );
spaces : String( 1 .. width ) := ( others => ' ' );
begin
for h in 1 .. height loop
position_cursor( abs_x_crd, abs_y_crd+h-1 );
Class_screen.put( spaces );
end loop;
end hide_win;
procedure window_fatal( mes:in String ) is
begin
position_cursor( 1, 1 );
put( "Window fatal error: "& mes );
end window_fatal;
end Class_window_control;
-------------------------------------------------------------
with Pack_constants, Class_root_window,
Class_input_manager, Class_window_control;
use Pack_constants, Class_root_window,
Class_input_manager, Class_window_control;
package Class_window is
type Window is new Root_window with private;
type P_Window is access all Window;
type Mode is ( VisIBLE, INVisIBLE );
type P_cbf is access function(str:in String) return String;
procedure initialize( the:in out Window );
procedure finalize( the:in out Window );
-- Basic construction
procedure framework( the:in out Window;
abs_x_crd, abs_y_crd: Positive;
max_x_crd, max_y_crd: Positive;
cb:in P_cbf := null );
procedure create ( the:in out Window;
abs_x_crd, abs_y_crd: Positive;
max_x_crd, max_y_crd: Positive );
-- Call back function processing
procedure set_call_back( the:in out Window; cb:in P_cbf );
function call_call_back( the:in Window;
str:in String ) return String;
-- I/O to a window
procedure put( the:in out Window; mes:in String );
procedure put( the:in out Window; ch:in Character );
procedure put( the:in out Window; n:in Integer );
procedure position( the:in out Window; x,y:in Positive );
procedure clear( the:in out Window );
procedure new_line( the:in out Window );
procedure refresh( the:in out Window );
-- Look and Feel
procedure make_window( the:in out Window; mo:in Mode );
procedure mark_border( the:in out Window;
a_border:in Attribute;
pos:in Positive; ch:in Character );
function about(the:in Window; b:in Attribute) return Natural;
-- When window selected do
procedure switch_away( the:in out Window );
procedure switch_to( the:in out Window );
procedure send_to( the:in out Window; ch:in Character );
-- Register window with poling system
procedure register( p_w:in P_Root_window; ch:in Character );
procedure de_register( p_w:in P_Root_window );
private
subtype Y_Cord is Positive range 1 .. VDT_MAX_Y;
subtype X_Cord is Positive range 1 .. VDT_MAX_X;
subtype Line_index is X_Cord range 1 .. WINDOW_MAX_X;
subtype Line_range is Line_index;
subtype Line is String( Line_range );
subtype Pane_index is Y_Cord range 1 .. WINDOW_MAX_Y;
subtype Pane_range is Pane_index;
type Pane_array is array ( Pane_range ) of Line;
type Window is new Root_window with record
abs_x : X_Cord := 1; -- The position on the vdt
abs_y : Y_Cord := 1; -- The position on the vdt
c_x : X_Cord := 1; -- Current position in window
c_y : Y_Cord := 1; -- Current position in window
max_x : X_Cord := 5; -- X size of window (+Border)
max_y : Y_Cord := 5; -- Y size of window (+Border)
pane : Pane_array; -- Copy of window in memory
mode_of : Mode := INVisIBLE;-- Invisible window by default
call_back: P_cbf := null; -- Call back function
end record;
end Class_window;
package body Class_window is
procedure put( the:in out Window;
x,y:in Positive; mes:in String );
procedure initialize( the:in out Window ) is
begin
null;
end initialize;
procedure finalize( the:in out Window ) is
begin
make_window( the, INVisIBLE );
de_register( the'Unchecked_Access );
end finalize;
procedure create( the:in out Window;
abs_x_crd, abs_y_crd: Positive;
max_x_crd, max_y_crd: Positive ) is
begin
if max_x_crd < 3 or else max_x_crd > WINDOW_MAX_X or else
max_y_crd < 3 or else max_y_crd > WINDOW_MAX_Y or else
abs_x_crd + max_x_crd - 1 > VDT_MAX_X or else
abs_y_crd + max_y_crd - 1 > VDT_MAX_Y then
window_fatal("Creation window parameter error");
end if;
declare
top_bottom: String(1..max_x_crd) := (others => '-');
spaces : String(2 .. max_x_crd-1) := (others => ' ');
begin
top_bottom(1) := '+'; top_bottom(max_x_crd) := '+';
the.max_x := max_x_crd - 2; -- For border
the.max_y := max_y_crd - 2; -- For border
the.abs_y := abs_y_crd; -- Abs position screen
the.abs_x := abs_x_crd; --
the.pane(1)(1..max_x_crd) := top_bottom; -- Clear / set up
for y in 2 .. max_y_crd-1 loop
the.pane(y)(1..max_x_crd):= '|'&spaces&'|';
end loop;
the.pane(max_y_crd)(1..max_x_crd) := top_bottom;
position( the, 1, 1 ); -- Top left hand corner
end;
end create;
-- The window co-ordinates of 1 .. n , 1 .. m are
-- stored into an array in position 2 .. n+1, 2 .. m+1
-- this allows the border to be stored
procedure framework( the:in out Window;
abs_x_crd, abs_y_crd: Positive;
max_x_crd, max_y_crd: Positive;
cb:in P_cbf := null ) is
begin
create( the, abs_x_crd, abs_y_crd, max_x_crd, max_y_crd );
make_window( the, VisIBLE );
if cb /= null then
set_call_back( the, cb );
register( the'Unchecked_Access, C_SWITCH );
else
register( the'Unchecked_Access, C_NO_CHAR );
end if;
end framework;
procedure set_call_back( the:in out Window; cb:in P_cbf ) is
begin
the.call_back := cb;
end set_call_back;
function call_call_back( the:in Window;
str:in String ) return String is
begin
if the.call_back /= null then
return the.call_back(str);
end if;
return "No call back function";
end;
procedure put( the:in out Window; mes:in String ) is
add : Natural;
begin
add := mes'Length; -- Length
if add + the.c_x > the.max_x then -- Actual characters
add := the.max_x - the.c_x + 1; -- to add
end if;
if add >= 1 then -- There are some
the.pane(the.c_y+1)(the.c_x+1 .. the.c_x+add)
:= mes( 1 .. add );
if the.mode_of = VisIBLE then -- Add to screen
put(the, the.c_x+1, the.c_y+1, mes( 1 .. add) );
end if;
the.c_x := the.c_x + add;
else
put(the, the.c_x+1, the.c_y+1, "" );
end if;
end put;
procedure put( the:in out Window; ch:in Character ) is
begin
put( the, "" & ch ); -- Convert to string
end put;
procedure put( the:in out Window; n:in Integer ) is
begin
put( the, Integer'Image(n) ); -- Convert to string
end put;
procedure position( the:in out Window; x,y:in Positive ) is
begin
if x <= the.max_x and y <= the.max_y then
the.c_x := x; the.c_y := y;
end if;
end position;
procedure clear( the:in out Window ) is
empty : String( 1 .. the.max_x ) := (others => ' ');
begin
position(the, 1, 1); -- Top right hand corner
for y in 1 .. the.max_y loop -- Clear text
put( the, empty ); new_line(the);
end loop;
end clear;
procedure new_line( the:in out Window ) is
begin
if the.c_y >= the.max_y then -- Scroll text
for y in 2 .. the.max_y loop -- Copy up
the.pane(y) := the.pane(y+1);
end loop;
the.pane(the.max_y+1)(2..the.max_x+1):= (others=>' ');
refresh(the); -- refresh
else
the.c_y := the.c_y + 1; -- Next line
end if;
the.c_x := 1; -- At start
end new_line;
procedure refresh( the:in out Window ) is
begin
if the.mode_of = VisIBLE then -- Visible
for y in 1 .. the.max_y+2 loop -- Text
put( the, 1, y,
the.pane(y)(1 .. the.max_x+2) ); -- include border
end loop;
put( the, "" ); -- Cursor
end if;
end refresh;
procedure make_window( the:in out Window; mo:in Mode ) is
begin
if the.mode_of /= mo then -- Change so
the.mode_of := mo; -- Set new mode_of
case mo is
when INVisIBLE => -- Clear from screen
hide_win( the'Unchecked_Access );-- Hide window
when VisIBLE => -- Redraw on screen
refresh( the );
end case;
end if;
end make_window;
procedure mark_border( the:in out Window;
a_border:in Attribute;
pos:in Positive; ch:in Character ) is
a_y, a_x : Positive;
begin
case a_border is
when TOP => a_x := pos; a_y := 1;
when BOTTOM => a_x := pos; a_y := the.max_y+2;
when LEFT => a_x := 1; a_y := pos;
when RIGHT => a_x := the.max_x+2; a_y := pos;
when others => null;
end case;
if a_x <= the.max_x+2 and then a_y <= the.max_y+2 then
the.pane(a_y)(a_x) := ch; -- Store
if the.mode_of = VisIBLE then -- Update on screen
put( the, a_x, a_y, ch & "" );
put( the, "" );
end if;
end if;
end mark_border;
function about(the:in Window; b:in Attribute) return Natural is
begin
case b is
when TOP | BOTTOM => return the.max_x+2;
when LEFT | RIGHT => return the.max_y+2;
when abs_X => return the.abs_x;
when abs_Y => return the.abs_y;
when others => return 0;
end case;
end;
procedure switch_away( the:in out Window ) is
begin
mark_border( the, TOP, 1, C_WIN_PAS );
end switch_away;
procedure switch_to( the:in out Window ) is
begin
mark_border( the, TOP, 1, C_WIN_A );
end switch_to;
procedure send_to( the:in out Window; ch:in Character ) is
begin
null;
end send_to;
procedure register( p_w:in P_Root_window;
ch:in Character ) is
begin
switch_away_from_top; -- Register window focus
add_to_list( p_w, ch ); -- Register window
switch_to_top; -- Make focus
end register;
procedure de_register( p_w:in P_Root_window ) is
begin
top( p_w ); -- Make top
switch_away_from_top; -- prepare for demise
remove_from_list( p_w ); -- De register window
switch_to_top; -- Make focus
end de_register;
-- Write to Physical Screen
procedure put( the:in out Window;
x,y:in Positive; mes:in String ) is
begin
write_to( the'Unchecked_Access, x, y, mes );
end put;
end Class_window;
--------------------------------------------------------------------
with Pack_constants, Class_root_window, Class_window;
use Pack_constants, Class_root_window, Class_window;
package Class_dialog is
type Dialog is new Window with private;
procedure framework ( the:in out Dialog;
abs_x, abs_y:in Positive;
max_x: in Positive;
name:in String; cb:in P_cbf );
procedure send_to( the:in out Dialog; ch:in Character );
private
subtype Message is String( 1 .. WINDOW_MAX_X );
type Dialog is new Window with record
dialog_pos: Positive := 1; -- Position in input message
dialog_len: Positive := 1; -- Length of dialogue message
dialog_mes: Message := ( others => ' '); -- Input message
end record;
end Class_dialog;
package body Class_dialog is
procedure framework( the:in out Dialog;
abs_x, abs_y:in Positive;
max_x:in Positive;
name:in String; cb:in P_cbf ) is
dashes : String( 1 .. max_x ) := (others=>'-');
begin
create( the, abs_x, abs_y, max_x, 5 );
the.dialog_len := max_x-2; -- User input
the.dialog_pos := 1; -- In Dialog
set_call_back( the, cb ); -- Call back fun
put( the, "Dialog| " ); put( the, name ); -- Dialog title
position( the, 1, 2 ); put( the, dashes ); -- Line
position( the, 1, 3 ); put( the, C_CURSor );-- Cursor
make_window( the, VisIBLE );
register( the'Unchecked_Access, C_SWITCH ); -- Activation Chr
end framework;
procedure send_to( the:in out Dialog; ch:in Character ) is
spaces : String(1 .. about(Window(the),TOP)) := (others => ' ');
res : String(1..0);
begin
case ch is
when C_WHERE =>
put( the, "" );
when C_ACTION =>
res := call_call_back( the,
the.dialog_mes(1..the.dialog_pos-1) )(1..0);
the.dialog_pos := 1;
the.dialog_mes := ( others => ' ' );
position( the, 1, 3 ); -- Start
put( the, C_CURSor & spaces ); -- Clear
position( the, 2, 3 ); -- Cursor
put( the, "" ); -- Cursor
when C_DEL =>
if the.dialog_pos > 1 then -- Can delete
the.dialog_pos := the.dialog_pos - 1; -- Make avail.
the.dialog_mes(the.dialog_pos):= ' '; -- Remove
position( the, the.dialog_pos, 3 );
put( the, C_CURSor & " " ); -- Overwrite
position( the, the.dialog_pos, 3 );
put( the, "" ); -- Cursor
end if;
when others =>
if the.dialog_pos <= the.dialog_len then
if ch in ' ' .. '~' then -- Add to
the.dialog_mes( the.dialog_pos ) := ch; -- Save ch
position( the, the.dialog_pos, 3 );
put( the, the.dialog_mes(the.dialog_pos) );
put( the, C_CURSor );
the.dialog_pos := the.dialog_pos + 1;
end if;
end if;
end case;
end send_to;
end Class_dialog;
--------------------------------------------------------------------
with Class_root_window, Class_window;
use Class_root_window, Class_window;
package Class_menu is
type Menu is new Window with private;
type P_Menu is access all Menu;
procedure framework( the:in out Menu'Class;
m1:in String:=""; w1:in P_Menu:=null; cb1:in P_cbf:=null;
m2:in String:=""; w2:in P_Menu:=null; cb2:in P_cbf:=null;
m3:in String:=""; w3:in P_Menu:=null; cb3:in P_cbf:=null;
m4:in String:=""; w4:in P_Menu:=null; cb4:in P_cbf:=null;
m5:in String:=""; w5:in P_Menu:=null; cb5:in P_cbf:=null;
m6:in String:=""; w6:in P_Menu:=null; cb6:in P_cbf:=null );
procedure set_up( the:in out Menu; active:in Positive);
procedure menu_spot( the:in out Menu; ch:in Character );
procedure send_to( the:in out Menu; ch:in Character );
MAX_MENU : CONSTANT Positive := 10;
subtype Menu_item is String( 1 .. MAX_MENU );
procedure get_menu_name( the:in Menu; i:in Positive;
n:out Menu_item );
procedure get_cur_selected_details( the:in P_Menu;
w:out P_Menu; cb:out P_cbf );
private
type Direction is (D_reverse, D_forWARD);
procedure next( the:in out Menu; dir:in Direction );
type Menu_desc is record -- A menu is:
name: Menu_item; -- Name of menu item
p_m : P_Menu; -- Menu window
fun : P_cbf; -- Call back function
end record;
MAX_MENU_ITEMS : CONSTANT := 6; -- Maximum menu items
type Menus_index is range 0 .. MAX_MENU_ITEMS;
subtype Menus_range is Menus_index range 1 .. MAX_MENU_ITEMS;
type Menus is array ( Menus_range ) of Menu_desc;
type Menu is new Window with record
number : Menus_index := 0; -- Number of menu items
cur_men : Menus_index := 1; -- Currently selected item
menu_set : Menus; -- Components of a menu
end record;
end Class_menu;
with Pack_constants;
use Pack_constants;
package body Class_menu is
-- The type is Menu'Class so a run time dispatch will
-- take place when set_up is called
procedure framework( the:in out Menu'Class;
m1:in String:=""; w1:in P_Menu:=null; cb1:in P_cbf:=null;
m2:in String:=""; w2:in P_Menu:=null; cb2:in P_cbf:=null;
m3:in String:=""; w3:in P_Menu:=null; cb3:in P_cbf:=null;
m4:in String:=""; w4:in P_Menu:=null; cb4:in P_cbf:=null;
m5:in String:=""; w5:in P_Menu:=null; cb5:in P_cbf:=null;
m6:in String:=""; w6:in P_Menu:=null; cb6:in P_cbf:=null
) is
spaces : Menu_item := ( others => ' ' );
active : Menus_index := 1;
procedure set_up( mi:in String; wi:in P_Menu;
cb:in P_cbf; n:in Menus_index ) is
begin
if mi /= "" then active := n; end if; -- A menu item
the.menu_set( n ) :=
(" "&mi&spaces(1 .. MAX_MENU-1-mi'Length), wi, cb);
end set_up;
begin
set_up( m1, w1, cb1, 1 ); set_up( m2, w2, cb2, 2 );
set_up( m3, w3, cb3, 3 ); set_up( m4, w4, cb4, 4 );
set_up( m5, w5, cb5, 5 ); set_up( m6, w6, cb6, 6 );
the.number := active;
set_up( the, Positive(active) );
end framework;
procedure set_up( the:in out Menu;
active:in Positive ) is
me: Menu_item;
begin
create( the, 1, 1, (1+MAX_MENU)*active+1, 3 );
for I in 1 .. active loop -- Display menu names
get_menu_name( the, i, me );
put( the, me ); put( the, "|" );
null;
end loop;
menu_spot( the, C_CURSor ); -- Mark current
end set_up;
procedure menu_spot( the:in out Menu; ch:in Character ) is
begin
position( the, (MAX_MENU+1)*(Positive(the.cur_men)-1)+1, 1 );
put( the, ch );
end menu_spot;
procedure send_to( the:in out Menu; ch:in Character ) is
begin
menu_spot( the, C_BLANK );
case ch is
when C_RIGHT => next( the, D_forWARD );
when C_LEFT => next( the, D_reverse );
when others => null;
end case;
menu_spot( the, C_CURSor );
end send_to;
procedure next( the:in out Menu; dir:in Direction ) is
begin
case dir is
when D_forWARD =>
the.cur_men := the.cur_men rem the.number + 1;
when D_reverse =>
if the.cur_men = 1
then the.cur_men := the.number;
else the.cur_men := the.cur_men-1;
end if;
end case;
end next;
procedure get_menu_name( the:in Menu; i:in Positive;
n:out Menu_item ) is
begin
n := the.menu_set( Menus_index(i) ).name;
end get_menu_name;
procedure get_cur_selected_details( the:in P_Menu;
w:out P_Menu; cb:out P_cbf ) is
begin
w := the.menu_set( the.cur_men ).p_m;
cb := the.menu_set( the.cur_men ).fun;
end get_cur_selected_details;
end Class_menu;
--------------------------------------------------------------------
with Class_root_window, Class_window, Class_menu;
use Class_root_window, Class_window, Class_menu;
package Class_menu_title is
type Menu_title is new Menu with private;
type P_Menu_title is access all Menu_title;
procedure set_up( the:in out Menu_title; active:in Positive );
procedure send_to( the:in out Menu_title; ch:in Character );
procedure switch_away( the:in out Menu_title );
private
MAX_ACT_MENU : CONSTANT := 6; -- Maximum depth of menus
type Act_index is range 0 .. MAX_ACT_MENU;
subtype Act_range is Act_index range 1 .. MAX_ACT_MENU;
type Act_menus is array ( Act_range ) of P_Menu;
type Menu_title is new Menu with record
act_menu : Act_menus; -- Stack of displayed menus
menu_index: Act_index := 0; -- Top of menu stack
end record;
end Class_menu_title;
with Pack_constants;
use Pack_constants;
package body Class_menu_title is
procedure set_up( the:in out Menu_title; active:in Positive ) is
me: Menu_item;
begin
create( the, 1, 1, (1+MAX_MENU)*active+1, 3 ); -- Fixed size
make_window( the, VisIBLE );
the.act_menu( 1 ) := Menu(the)'Unchecked_Access;-- Title menu
the.menu_index := 1;
for i in 1 .. active loop -- Get menu
get_menu_name( the, i, me ); -- name
put( the, me ); put( the, "|" ); -- write
end loop;
register( the'Unchecked_Access, C_MENU ); -- Register
menu_spot( the, C_CURSor ); -- Cursor on
end set_up;
procedure send_to( the:in out Menu_title; ch:in Character ) is
current, next : P_Menu;
proc : P_cbf;
res : String( 1..0 );
begin
current := the.act_menu( the.menu_index ); -- Active menu
get_cur_selected_details( current, next, proc );
case ch is
when C_WHERE =>
put( current.all, "" );
when C_ACTION =>
if next /= null and the.menu_index < MAX_ACT_MENU then
make_window( current.all, INVisIBLE ); -- Hide cur.
the.menu_index := the.menu_index + 1; --
the.act_menu( the.menu_index ) := next; -- New menu
make_window( next.all, VisIBLE ); -- Reveal
else
if proc /= null then -- Call
res := proc("Action")(1 .. 0 );
end if;
end if;
when others =>
send_to( current.all , ch ); -- Treat as normal menu
end case;
end send_to;
procedure switch_away( the:in out Menu_title ) is
begin
mark_border( the, TOP, 1, C_WIN_PAS ); -- Now inactive
if the.menu_index > 1 then -- Not top level menu
make_window( the.act_menu(the.menu_index).all, INVisIBLE );
the.menu_index := 1;
make_window( the.act_menu( 1 ).all, VisIBLE ); -- Top level
end if;
end switch_away;
end Class_menu_title;
--------------------------------------------------------------------
with Class_window;
use Class_window;
package Pack_globals is
p_w1 : P_Window; -- Window 1
p_w2 : P_Window; -- Window 2
end Pack_globals;
with Class_window, Pack_globals;
use Class_window, Pack_globals;
function execute_call_back(cb_mes:in String) return String is
win : Window;
begin
put( p_w1.all, "Start [" & cb_mes & "]" ); new_line( p_w1.all );
framework( win, 1, 17, 16, 5 );
for i in 1 .. 10 loop
put( win, i ); put( win, " " );
put( win, cb_mes ); new_line( win );
end loop;
put( p_w1.all, "End [" & cb_mes & "]" ); new_line( p_w1.all );
return "";
end execute_call_back;
with Class_window, Pack_globals;
use Class_window, Pack_globals;
function write_name( cb_mes:in String ) return String is
begin
put( p_w1.all, "Written by Mike Smith" ); new_line( p_w1.all );
put( p_w1.all, "University of Brighton" ); new_line( p_w1.all );
new_line( p_w2.all ); put( p_w2.all, "Written by Mike Smith" );
new_line( p_w2.all ); put( p_w2.all, "University of Brighton" );
return "";
end write_name;
with Class_window, Pack_globals;
use Class_window, Pack_globals;
function no_help( cb_mes:in String ) return String is
begin
put( p_w1.all, " +------------------+" ); new_line( p_w1.all );
put( p_w1.all, " | There is no Help |" ); new_line( p_w1.all );
put( p_w1.all, " +------------------+" ); new_line( p_w1.all );
return "";
end no_help;
with Class_window, Pack_globals;
use Class_window, Pack_globals;
function echo_mess( cb_mes:in String ) return String is
begin
clear( p_w1.all );
put( p_w1.all, cb_mes ); new_line( p_w1.all );
return "";
end echo_mess;
with Class_root_window, Class_input_manager, Class_window,
Class_dialog, Class_menu, Class_menu_title, Pack_globals,
execute_call_back, write_name, no_help, echo_mess;
use Class_root_window, Class_input_manager, Class_window,
Class_dialog, Class_menu, Class_menu_title, Pack_globals;
procedure main is
begin
window_prologue;
declare
e,f : Dialog;
w1,w2 : aliased Window;
m1 : aliased Menu_title;
m2,m3,m4,m5 : aliased Menu;
begin
framework( w1, 1, 5, 30, 10 );
framework( w2, 70, 20, 10, 6 );
framework(m2, "Open", null, null,
"Close", null, null,
"Window", null, execute_call_back'Access,
"help", null, no_help'Access );
framework(m3, "up", null, null,
"down", null, null,
"left", null, null,
"right", null, null,
"loop", m4'Unchecked_Access, null,
"About", null, write_name'Access);
framework(m4, "Loop", m3'Unchecked_Access, null,
"Help", null, no_help'Access,
"About", null, write_name'Access,
"About", null, write_name'Access );
framework(m5, "Mike", null, write_name'Access,
"A", null, write_name'Access,
"Smith", null, write_name'Access,
"Next", m4'Unchecked_Access, null );
framework(m1, "PC", m2'Unchecked_Access, null,
"File", m3'Unchecked_Access, null,
"Trans", m5'Unchecked_Access, null );
for i in 1 .. 7 loop
put(w1,"Mike Smith"); new_line( w1 );
end loop;
for i in 1 .. 20 loop
for b in Attribute loop
mark_border( w2, b, i, ':' );
end loop;
end loop;
framework(e, 40, 6 , 20, "Diag 1", echo_mess'Access );
framework(f, 40, 18, 22, "Diag 2", execute_call_back'Access );
p_w1 := w1'Unchecked_Access;
p_w2 := w2'Unchecked_Access;
window_start;
end;
window_epilogue;
end main;
© M.A.Smith University of Brighton.
Created September 1995 last modified May 1997.
Comments, suggestions, etc.
M.A.Smith@brighton.ac.uk
*
[Home page]