Ada 95 :: 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]