Ada 95 :: x80_ed.ada

-- The editor
--   To compile using the GNAT Ada 95 Compiler on Windows 95/NT, Linux
-- 
--   gnatchop -w x80_ed.ada          -- Split into units
--   gcc -c io.c                     -- Compile C interface
--   gnatmake ed.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
-- 
--   In the package Pack_constants
--     ANSI_IN_DEL currently must be set to FALSE for Windows 95/NT
--     as the ANSI escape sequences for Insert and Delete lines are
--     not supported.
--     Using this setting will slow down the refreshing of the screen.


package Pack_constants is
  MAX_ANSWER     : CONSTANT := 80;
  LINES_ON_SCREEN: CONSTANT := 25;
  PAGE_RACK      : CONSTANT := LINES_ON_SCREEN/2;

  C_LEFT         : CONSTANT Character := Character'Val(012);
  C_RIGHT        : CONSTANT Character := Character'Val(018);
  C_UP           : CONSTANT Character := Character'Val(021);
  C_DOWN         : CONSTANT Character := Character'Val(011);

  C_PAGE_UP      : CONSTANT Character := Character'Val(023);
  C_PAGE_DOWN    : CONSTANT Character := Character'Val(024);

  C_QUIT         : CONSTANT Character := Character'Val(005);
  C_DEBUG        : CONSTANT Character := Character'Val(020);
  C_REFRESH      : CONSTANT Character := Character'Val(025);
  C_DEL          : CONSTANT Character := Character'Val(008);

  C_OPEN         : CONSTANT Character := Character'Val(001);
  C_CLOSE        : CONSTANT Character := Character'Val(002);
  C_SET_FN       : CONSTANT Character := Character'Val(006);

  C_NEXT         : CONSTANT Character := Character'Val(007);

  ANSI_INS_DEL   : CONSTANT Boolean   := FALSE;
end Pack_constants;

----------------------------------------------------------------------

with Ada.Finalization;
use  Ada.Finalization;
package Class_line is
  type Line is new Controlled with private;

  procedure debug( the:in Line );
  procedure initialize( the:in out Line );
  procedure finalize( the:in out Line );
  procedure adjust( the:in out Line );
  procedure clear( the:in out Line );

  procedure start( the:in out Line );       -- Iterator for line
  function  end_of_line( the:in Line) return Boolean;
  function  get_char( the:in Line ) return Character;
  procedure next_ch( the:in out Line );

  procedure add(the:in out Line; where:in Natural; ch:in Character);
  procedure del( the:in out Line; where:in Natural );

  function  deliver_current_col( the:in Line ) return Natural;
  function  deliver_cur_len( the:in Line ) return Natural;
  function  deliver_max_line_size( the:in Line ) return Natural;

private
  MAX_CHS : CONSTANT := 79;
  type    Line_iter_index is range 0 .. MAX_CHS+1;
  subtype Line_index      is Line_iter_index range 0 .. MAX_CHS;
  subtype Line_range      is Line_iter_index range 1 .. MAX_CHS;
  type    Line_array      is array ( Line_range ) of Character;

  --type O_Line is record
  type Line is new Controlled with record
     chs        : Line_array;          -- Line of characters
     iter_pos   : Line_iter_index := 0;-- Iterator position
     cur_len    : Line_index := 0;     -- Position of last ch
     col        : Line_range := 1;     -- Last operation here
  end record;
  --type Line is access O_Line;          -- Pointer to a Line

end Class_line;

with Simple_io;
Use  Simple_io;
package body Class_line is

  procedure debug( the:in Line ) is
  begin
    put("Line    >");
    put("last ch      :"); put(Integer(the.cur_len),WIDTH=>2);
    put(" Iter pos    :"); put(Integer(the.iter_pos),WIDTH=>2);
    put(" Active col  :"); put(Integer(the.col), WIDTH=>2);
    new_line;
  end debug;

  procedure initialize( the:in out Line ) is
  begin
    --the := new O_Line;               -- Dynamic Store
    clear(the);
  end initialize;

  procedure finalize( the:in out Line ) is
  begin
    null;
  end finalize;

  procedure adjust( the:in out Line ) is
  begin
    null;
  end adjust;

  procedure clear( the:in out Line ) is
  begin
    the.iter_pos := 0;           -- Iterator
    the.cur_len := 0;            -- Empty Line
    the.col := 1;                -- Current position
  end clear;

  procedure start( the:in out Line ) is
  begin
    the.iter_pos := 1;
  end start;

  function  end_of_line( the:in Line) return Boolean is
  begin
    return the.iter_pos > the.cur_len;
  end end_of_line;

  function  get_char( the:in Line ) return Character is
  begin
    return the.chs( the.iter_pos );
  end get_char;

  procedure next_ch( the:in out Line ) is
  begin
    if the.iter_pos <= the.cur_len then
      the.iter_pos := the.iter_pos + 1;
    end if;
  end next_ch;

  procedure add(the:in out Line; where:in Natural;
                ch:in Character) is
  add_at : Line_index;
  begin
    add_at := Line_index( where );
    if the.cur_len < the.chs'Length and then
       add_at <= the.cur_len+1
    then
      for i in reverse add_at .. the.cur_len loop
        the.chs(i+1) := the.chs(i);       -- Make room
      end loop;
      the.cur_len := the.cur_len + 1;     -- Increase length
      the.chs( add_at ) := ch;            -- Insert character
      if add_at < the.chs'Length then     -- New column
        the.col := add_at + 1;
      end if;
    end if;
  end add;

  procedure del( the:in out Line; where:in Natural ) is
    del_at : Line_index;
  begin
    del_at := Line_index( where );
    if del_at <= the.cur_len then         -- Can delete
      the.cur_len := the.cur_len-1;       -- New length
      the.col     := del_at;              -- New current col
      for i in del_at .. the.cur_len loop
        the.chs(i) := the.chs(i+1);       -- Delete ch
      end loop;
    end if;
    if del_at > the.cur_len then          -- New column
      the.col := Line_index'Max(the.cur_len+1, 1 );
    end if;
  end del;

  function  deliver_current_col( the:in Line ) return Natural is
  begin
    return Natural( the.col );            -- Current position
  end deliver_current_col;

  function  deliver_cur_len( the:in Line ) return Natural is
  begin
    return Natural( the.cur_len );        -- Chars in line
  end deliver_cur_len;

  function  deliver_max_line_size( the:in Line ) return Natural is
  begin
    return MAX_CHS;                         -- Max size of line
  end deliver_max_line_size;

end Class_line;

----------------------------------------------------------------------

with Class_line; use Class_line;
with Ada.Finalization;
use  Ada.Finalization;
package Class_store is

  type Store is new Limited_Controlled with private;

  procedure debug( the:in Store );
  procedure initialize( the:in out Store );
  procedure finalize( the:in out Store );
  procedure clear( the:in out Store );

  procedure add( the:in out Store; row:in Natural;
                 column:in Natural; ch:in Character );
  procedure del( the:in out Store; row:in Natural;
                 column:in Natural );
  procedure add( the:in out Store; ch:in Character );
  procedure del( the:in out Store );

  procedure left_right( the:in out Store; dir:in Character );
  procedure up_down( the:in out Store; dir:in Character;
                     no_lines:in Natural );

  function  deliver_line(the:in Store; row:in Natural) return Line;

  function  no_lines( the:in Store ) return Natural;
  procedure set_position( the:in out Store; row:in Natural;
                          column:in Natural );
  procedure set_last_line( the:in out Store; row:in Natural );
  procedure deliver_row_column( the:in Store; row:out Natural;
                                column:out Natural );
  function  deliver_store_size( the:in Store ) return Natural;
  function  deliver_max_line_size
              ( the:in Store; row:in Natural ) return Natural;

private
  MAX_LINES : CONSTANT := 120;
  type    Store_index    is range 0 .. MAX_LINES;
  subtype Store_range    is Store_index range 1 .. MAX_LINES;
  type    Store_as_array is array ( Store_index ) of Line;

  type Store is new Limited_Controlled with record
     lines     : Store_as_array;    -- Store as array
     no_lines  : Store_index := 0;  -- Lines stores
     row       : Natural := 0;      -- Current row
     col       : Natural := 0;      -- Current column
  end record;
end Class_store;

with Pack_constants, Simple_io;
use  Pack_constants, Simple_io;
package body Class_store is

  procedure debug( the:in Store ) is
  begin
    put("Store   >");
    put("no_lines     :"); put(Integer(the.no_lines), WIDTH=>2);
    put(" active row  :"); put(Integer(the.row), WIDTH=>2);
    put(" active col  :"); put(Integer(the.col), WIDTH=>2);
    new_line;
    debug( the.lines( Store_index( the.row ) ) );
  end debug;

  procedure initialize( the:in out Store ) is
  begin
--O    for i in Store_range loop
--O      initialize( the.lines(i) );           -- Individual lines
--O    end loop;
    clear(the);                             -- clear Store
    set_last_line( the, 1 );                -- Set the last line
  end initialize;

  procedure finalize( the:in out Store ) is
  begin
    null;
  end finalize;

  procedure clear( the:in out Store ) is
  begin
    for i in Store_range loop
      clear( the.lines(i) );      -- Individual lines
    end loop;
    the.no_lines := 0;            -- Lines stored
    the.row      := 1;            -- Current Line
    the.col      := 1;            -- Current char in line
  end clear;

  procedure add( the:in out Store; row:in Natural;
                 column:in Natural; ch:in Character ) is
    row_is : Store_index := Store_index( row );
  begin
    if row_is > the.no_lines and then row <= MAX_LINES then
      the.no_lines := the.no_lines + 1;
    end if;
    add( the.lines( row_is ), column, ch );
  end add;

  procedure del( the:in out Store; row:in Natural;
                 column:in Natural ) is
  begin
    del( the.lines( Store_index(row) ), column );
  end del;

  procedure add( the:in out Store; ch:in Character ) is
  begin
    add( the, the.row, the.col, ch );
    the.col :=
      deliver_current_col( the.lines(Store_index(the.row)));
  end add;

  procedure del( the:in out Store ) is
  begin
    del( the, the.row, Natural'Max(the.col-1, 1) );    -- at position
    the.col :=
      deliver_current_col( the.lines(Store_index(the.row)));
  end del;

  procedure left_right( the:in out Store; dir:in Character ) is
    length  : Natural;
  begin
    if dir = C_LEFT then                -- move ->
      if the.col > 1 then               -- Can go left
        the.col := the.col-1;
      end if;
    else                                -- move ->
      length :=
        deliver_cur_len( the.lines(Store_index(the.row)) );
      if the.col <= length then         -- Can go right
        the.col := the.col+1;
      end if;
    end if;
  end left_right;

  procedure up_down( the:in out Store; dir:in Character;
                  no_lines:in Natural ) is
    length  : Natural;
  begin
    if dir = C_UP or else dir = C_PAGE_UP then
      if Integer(the.row) - no_lines >= 1 then
        the.row := the.row - no_lines;
      else
        the.row := 1;
      end if;
    else
      if Integer(the.row)+no_lines<=Integer(the.no_lines) then
        the.row := the.row + no_lines;
      else
        the.row := Natural(the.no_lines);
        if the.row < MAX_LINES and then dir = C_DOWN then
          the.row := the.row + 1;       -- Expand by 1 line
        end if;
      end if;
    end if;
    length := deliver_cur_len(the.lines(Store_index(the.row)));
    the.col := Natural'Max( Natural'Min( length, the.col ), 1 );
  end up_down;

  function deliver_line(the:in Store; row:in Natural) return Line is
  begin
    return the.lines( Store_index(row) );  -- The whole line
  end  deliver_line;

  function  no_lines( the:in Store ) return Natural is
  begin
    return Natural(the.no_lines);          -- Lines in buffer
  end no_lines;

  procedure set_position( the:in out Store; row:in Natural;
                          column:in Natural ) is
  begin
    the.col  := column;         -- The new col
    the.row  := row;            -- The new row
  end set_position;

  procedure set_last_line( the:in out Store; row:in Natural ) is
  begin
    the.no_lines := Store_index(row);  -- New last line
  end set_last_line;

  procedure deliver_row_column( the:in Store; row:out Natural;
                                column:out Natural ) is
  begin
    row    := the.row;           -- The current row
    column := the.col;           -- The current col
  end deliver_row_column;

  function  deliver_store_size( the:in Store ) return Natural is
  begin
    return MAX_LINES;            -- Max size of buffer
  end deliver_store_size;

  function  deliver_max_line_size
              ( the:in Store; row:in Natural ) return Natural is
  begin
    return deliver_max_line_size(the.lines(Store_index(row)));
  end deliver_max_line_size;

end Class_store;

-- 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 C code that following this Ada body
-- 

-- 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;
-- 
-- C Interface for above Ada body
-- 
-- #define UNIX     1       /* Using GNAT on a UNIX based system all IO in C*/
-- #define doS      2       /* Using GNAT on a doS based system */
-- #define WIN95    3       /* Using GNAT on a Win 95/NT system */
-- #define UNIXs    WIN95   /* Using GNAT on a UNIX based system */
-- 
-- /* Notes:
--  *  ENVIRONMENT = UNIX  - Uses Unix API for all I/O
--  *              = doS   - Uses doS API (Via DJGPP C) for all I/O
--  *              = GNAT  - Uses Ada95 Input & Output procedures +
--  *                             Unix API call to turn of echoing of input
--  *              = UNIXs - Uses Ada95 Input & Output procedures +
--  *                             Unix API call to turn of echoing of input
--  */
-- 
-- #define ENVIRONMENT	WIN95    /* Environment for program */
-- 
-- 
-- #define ESC	'\033'
-- 
-- 
-- #if ENVIRONMENT == doS
-- # include <pc.h>
-- # include <keys.h>
-- #endif
-- #include <stdio.h>
-- 
-- typedef enum { false, true } bool;
-- 
-- char c_get_char();
-- void c_put_char( char ch );
-- void c_put_str( char *str );
-- 
-- 
-- #if ENVIRONMENT == doS
-- /*
--  * Make function keys and arrow keys return two characters
--  * E.G. Right arrow returns (char) 0, 'M'
--  *      Left  arrow         (char) 0, 'K'
--  */
-- 
-- char c_get_char()
-- {
--   int c;
--   static char the_ch;                 /* Remembered character */
--   static bool prev_char = false;      /* There is remembered ch */
--   if ( prev_char ) {
--     prev_char = false; return the_ch;
--   }
--   c = getkey();                        /* Get char no echo */
--   if ( c & 0x100 ) {                   /* Function / Arrow key */
--     prev_char = true; 
--     the_ch = (char) ( c & 0xFF );
--     return (char) 0;                   /* Marker */
--   }
--   return (char) (c & 0xFF);            /* Ordinary character */
-- }
-- #endif
-- 
-- #if ENVIRONMENT == UNIX
-- /*
--  * Set the terminal mode to -echo -icanon on first read
--  * reset when get ^E
--  *
--  */
-- 
-- #include <termios.h>
-- #include <unistd.h>
-- 
-- char c_get_char()
-- {
--   static bool first_time = true;
--   static tcflag_t c_lflag;
--   static int fd = STDout_FILENO;
--   static struct termios termios_data;
--   char c;
-- 
--   if ( first_time )
--   {
--     tcgetattr( fd, &termios_data );
--     c_lflag = termios_data.c_lflag;
--     termios_data.c_lflag = termios_data.c_lflag & ( ~(ECHO|ICANON) );
--     tcsetattr( fd, TCSANOW, &termios_data );
--     first_time = false;
--   }
--   c = getchar();
--   if ( c == '\005')
--   {
--     termios_data.c_lflag = c_lflag;
--     tcsetattr( fd, TCSANOW, &termios_data );
--   }
--   return (char) (c & 0xFF);            /* Ordinary character */
-- }
-- 
-- #endif
-- 
-- #if ENVIRONMENT == WIN95
-- 
-- /*
--  * Uses the C function c_no_echo to turn of echoing of input
--  *
--  */
-- 
-- #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 );
-- }
-- 
-- #endif
-- 
-- #if ENVIRONMENT == UNIX || ENVIRONMENT == doS
-- 
-- /*
--  * C function to write characters immediately to the terminal
--  */
-- 
-- void c_put_char( char ch )
-- {
--   fputc(ch, stdout); fflush( stdout );  /* Output ch */
-- }
-- 
-- void c_put_str( char *str )
-- {
--   while (*str) fputc(*str++, stdout);  /* Output String */
--   fflush( stdout );                    /* Flush buffer */
-- }
-- 
-- #endif
-- 
-- ///////////////////////////////////////////////////////////////////////////

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 Pack_ansi_display is
  procedure clear;                        -- Clear screen
  procedure down ( n:in Natural );        -- Cursor Down
  procedure up   ( n:in Natural );        -- Cursor Up
  procedure left ( n:in Natural );        -- Cursor Left
  procedure right( n:in Natural );        -- Cursor Right
  procedure insert_line( n:in Natural );  -- Insert Line(s)
  procedure delete_line( n:in Natural );  -- Delete Line(s)
  procedure clear_to_end_of_line;         -- Clear to end of line
  procedure cursor_position (row:in Natural; column:in Natural);
  procedure put  ( n:in Natural );        -- Write decimal number
private
end Pack_ansi_display;

with Pack_md_io;
use  Pack_md_io;
package body Pack_ansi_display is
  PREFIX: CONSTANT String := Character'Val(27) & "[";

  procedure clear is                      -- Clear screen
  begin
    put( PREFIX & "2J");
  end clear;

  procedure down( n:in Natural ) is      -- Cursor Down
  begin
    put( PREFIX ); put( n );put("B");
  end down;

  procedure up( n:in Natural ) is        -- Cursor Up
  begin
    put( PREFIX ); put( n );put("A");
  end up;

  procedure left( n:in Natural ) is      -- Cursor Left
  begin
    put( PREFIX ); put( n );put("D");
  end left;

  procedure right( n:in Natural ) is      -- Cursor Right
  begin
    put( PREFIX ); put( n );put("C");
  end right;

  procedure insert_line( n:in Natural ) is
  begin
    put( PREFIX ); put( n ); put("L");
  end insert_line;

  procedure delete_line( n:in Natural ) is
  begin
    put( PREFIX ); put( n ); put("M");
  end delete_line;

  procedure cursor_position(row:in Natural; column:in Natural) is
  begin
    put( PREFIX ); put(row); put(";"); put(column); put("H");
  end cursor_position;

  procedure clear_to_end_of_line is    -- Clear to end of line
  begin
    put( PREFIX & "K");
  end clear_to_end_of_line;

  procedure put( n:in Natural ) 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 Pack_ansi_display;

----------------------------------------------------------------------

package Class_user is
  type User is Private;
  type Mode is ( NO_ECHO, ECHO );

  function get_command( the:in User ) return Character;
  function dialog(the:in User; mes:in String) return String;
  function get_character(the:in User; m:in Mode)return Character;

private
  type User is record null; end record;

end Class_user;

with Pack_constants, Pack_md_io, Pack_ansi_display;
use  Pack_constants, Pack_md_io, Pack_ansi_display;

package body Class_user is

  function get_command( the:in User ) return Character is
    ch : Character;
  begin
    get_immediate( ch );
    return ch;
  end get_command;

  function  dialog( the:in User;
                    mes:in String) return String is
    ch      : Character;
    reading : Boolean;
    str     : String( 1 .. MAX_ANSWER );
    str_len : Integer := 1;
  begin
    cursor_position( LINES_ON_SCREEN, 1 ); clear_to_end_of_line;
    put( mes ); reading := TRUE; str(1) := ' ';
    for i in str'Range loop
      ch := get_character( the, NO_ECHO );
      if ch = Ascii.cr or else ch = Ascii.lf then
        reading := FALSE;
        exit;
      else
        put( ch ); str(i) := ch; str_len := i;
      end if;
    end loop;
    return str( 1 .. str_len );
  end dialog;

  function get_character( the:in User; m:in Mode ) return Character is
    ch : Character;
  begin
    get_immediate( ch );
    if m = ECHO then put( ch ); end if;
    return ch;
  end get_character;

end Class_user;

----------------------------------------------------------------------

with Ada.Finalization, Pack_constants, Class_line, Class_store;
use  Ada.Finalization, Pack_constants, Class_line, Class_store;
package Class_display is

  type Mode    is ( NO_ECHO, ECHO );
  type Display is new Limited_Controlled with private;

  procedure debug( the:in Display );
  procedure initialize( the:in out Display );
  procedure finalize( the:in out Display );
  procedure clear( the:in out Display );

  procedure init( the:in out Display; s:in Store);
  procedure refresh( the:in out Display );

  procedure add( the:in out Display; b:in Store; ch:in Character );
  procedure del( the:in out Display; s:in Store );
  procedure position( the:in out Display; s:in Store );

  procedure status( the:in out Display; s:in Store );
  function  deliver_display_size( the:in Display ) return Natural;

private
  DisPLAY_LINES : CONSTANT := LINES_ON_SCREEN-1;
  type    Display_index is new Integer   range 0..DisPLAY_LINES;
  subtype Display_range is Display_index range 1..DisPLAY_LINES;

  procedure display_line( the:in out Display; i:in Display_index );
  procedure minimal_refresh( the:in out Display;
                             old_abs_line:in Natural );

  type Display_as_array is array ( Display_range ) of Line;
  type Display is new Limited_Controlled with record
     display       : Display_as_array;    -- Display
     no_lines      : Display_index := 0;  -- Active lines
     abs_line      : Natural := 0;        -- of 1st display line
     row           : Natural := 0;        -- current row
     col           : Natural := 0;        -- current column
  end record;

end Class_display;

with Pack_constants, Pack_md_io, Pack_ansi_display, Simple_io;
use  Pack_constants, Pack_md_io, Pack_ansi_display;
package body Class_display is

  procedure debug( the:in Display ) is
  begin
    Simple_io.put("Display >");
    Simple_io.put("no_lines     :");
    Simple_io.put(Integer(the.no_lines),WIDTH=>2);
    Simple_io.put(" current_row :");
    Simple_io.put(Integer(the.row),WIDTH=>2);
    Simple_io.put(" current_col :");
    Simple_io.put(Integer(the.col),WIDTH=>2);
    Simple_io.put(" abs_line    :");
    Simple_io.put(Integer(the.abs_line),WIDTH=>2);
    Simple_io.new_line;
  end debug;

  procedure initialize( the:in out Display ) is
  begin
    the.row := 1;      the.col := 1;
    the.abs_line := 1; the.no_lines := 0;
--O    for i in Display_range loop
--O      initialize( the.display( i ) );    -- Individual lines
--O    end loop;
    clear(the);
  end initialize;

  procedure finalize( the:in out Display ) is
  begin
    null;
  end finalize;

  procedure clear( the:in out Display ) is
  begin
    clear;
  end clear;

  procedure init( the:in out Display; s:in Store) is
    store_row, store_col, lines : Natural;
  begin
    deliver_row_column( s, store_row, store_col );
    the.abs_line := store_row;         -- Shadowing screen from
    the.row := store_row;              --
    the.col := store_col;              -- Position on screen
    lines := no_lines(s)-store_row+1;  -- Current pos to end
    the.no_lines := Display_index(Natural'Min(lines, DisPLAY_LINES));

    for i in 1 .. the.no_lines loop
      the.display(i) := deliver_line( s, Natural(i) );
    end loop;
  end init;

  procedure refresh( the:in out Display ) is
  begin
    clear( the );
    for i in 1 .. the.no_lines loop
      cursor_position( Natural(i), 1 );
      display_line( the, i );
    end loop;
    cursor_position( the.row, the.col );
  end refresh;

  procedure display_line(the:in out Display; i:in Display_index) is
  begin
    start( the.display(i) );
    while not end_of_line( the.display(i) ) loop
      put( get_char( the.display(i) ) );
      next_ch( the.display(i) );
    end loop;
    clear_to_end_of_line;
  end display_line;

  -- Add the character to the current position in the display

  procedure add(the:in out Display; b:in Store; ch:in Character) is
    i : Display_index;
  begin
    i := Display_index( the.row );
    if i > the.no_lines then      -- Insert on empty line
      the.no_lines := i;          --  the first time
    end if;
    the.display(i):=deliver_line(b,Natural(i)+the.abs_line-1);
    cursor_position( Natural(i), 1 );
    display_line( the, i );
    the.col := deliver_current_col( the.display(i) );

    cursor_position( Natural(i), the.col );
  end add;

  -- Delete the char at the current position from the display

  procedure del( the:in out Display; s:in Store ) is
    i : Display_index;
  begin
    i := Display_index( the.row );
    the.display(i) :=
        deliver_line(s, Natural(i)+the.abs_line-1 );
    cursor_position( Natural(i), 1 );
    display_line( the, i );
    position( the, s );
  end del;

  -- Position the cursor in the correct position on the display

  procedure position( the:in out Display; s:in Store ) is
    row,column   : Natural;     -- In store
    change       : Boolean;     -- Change display
    old_abs_line : Natural;     -- Old abs line at top of screen
  begin
    deliver_row_column( s, row, column );
    change := FALSE;
    if row < the.abs_line then                     -- Rack Down
      old_abs_line := the.abs_line;
      the.abs_line := row;
      change := TRUE;
    end if;

    if row > the.abs_line + (DisPLAY_LINES-1) then  -- Rack up
      old_abs_line := the.abs_line;
      the.abs_line := row - (DisPLAY_LINES-1);
      change := TRUE;
    end if;

    if change then                            -- change display
      declare
        remaining_lines : Natural;
      begin
        remaining_lines := no_lines(s) - the.abs_line+1;
        remaining_lines := Natural'Min(remaining_lines, DisPLAY_LINES);
        the.no_lines := Display_range( remaining_lines );

        for i in 1 .. the.no_lines loop
          the.display(i) :=
              deliver_line(s, Natural(i) + the.abs_line-1 );
        end loop;

        row := row - the.abs_line + 1;
        minimal_refresh( the, old_abs_line );    -- try and do
      end;
    else
      row := row - the.abs_line + 1;
    end if;

    the.row := row; the.col := column;
    cursor_position( the.row, the.col );
  end position;

  -- Do a minimal refresh of the screen

  procedure minimal_refresh( the:in out Display;
                             old_abs_line:in Natural ) is
    diff : Natural;
  begin
    if ANSI_INS_DEL and then
       ( old_abs_line-(DisPLAY_LINES-1) <= the.abs_line and
         old_abs_line+(DisPLAY_LINES-1) >= the.abs_line )
    then
      -- Some of the lines on the screen OK
      if the.abs_line < old_abs_line then
        -- Rack display down, Insert new lines at top
        diff := old_abs_line-the.abs_line;
        cursor_position( 1, 1 );
        insert_line( diff );
        for i in 1 .. Display_index(diff) loop
          cursor_position( Natural(i), 1 );
          display_line( the, i );
        end loop;
      else
        -- Rack display up, Insert new lines at bottom of display
        diff := the.abs_line - old_abs_line;
        cursor_position(1,1); delete_line( diff );   -- Rack up
        cursor_position( DisPLAY_LINES-(diff)+1, 1);
        for i in the.no_lines-Display_index(diff)+1
                 .. the.no_lines loop
          cursor_position( Natural(i), 1 );
          display_line( the, i );
        end loop;
        for i in the.no_lines+1 .. DisPLAY_LINES loop
          cursor_position( Natural(i), 1 );      -- Clear left
          clear_to_end_of_line;                  -- on screen
        end loop;
      end if;
    else -- No lines on display valid do a total refresh
      refresh(the);
    end if;
  end minimal_refresh;

  procedure status( the:in out Display; s:in Store ) is
    row,column : Natural;
  begin
    deliver_row_column( s, row, column );
    cursor_position( LINES_ON_SCREEN, 1 ); clear_to_end_of_line;
    cursor_position( LINES_ON_SCREEN, 58 );
    put("Line "); put( row ); put("    ");
    cursor_position( LINES_ON_SCREEN, 68 );
    put("column "); put( column ); put("  ");
    cursor_position( the.row, the.col);
  end status;

  function deliver_display_size(the:in Display) return Natural is
  begin
    return DisPLAY_LINES;
  end deliver_display_size;

end Class_display;

----------------------------------------------------------------------

with Ada.Finalization, Class_store, Pack_constants, Class_user, Class_display;
use  Ada.Finalization, Class_store, Pack_constants, Class_user, Class_display;
package Class_file is

  type File is new Limited_Controlled with private;

  procedure initialize( the:in out File );
  procedure finalize( the:in out File );
  procedure register( the:in out File; str:in String );
  function  is_active( the:in File ) return Boolean;
  procedure set_active( the:in out File );
  procedure set_not_active( the:in out File );
  procedure read ( the:in out File; s:in out Store );
  procedure write( the:in out File; s:in out Store; u:in User );

private
  type    File_index  is range 0 .. MAX_ANSWER;
  subtype File_range  is File_index  range 1 .. MAX_ANSWER;
  type    State_file  is ( ACTIVE, not_ACTIVE );
  type File is new Limited_Controlled with record
    state         : State_file := not_ACTIVE;
    lines_in_file : Natural := 0;
    file          : String( 1 .. MAX_ANSWER );
    file_length   : File_index := 0;
  end record;
end Class_file;

with Text_io, Class_line;
use  Text_io, Class_line;
package body Class_file is

  procedure initialize( the:in out File ) is
  begin
    the.state       := not_ACTIVE;    -- Not active
    the.file_length := 0;             -- No file registered
    the.file        := (others=>' '); -- Blank file name
  end initialize;

  procedure finalize( the:in out File ) is
  begin
    if the.state = ACTIVE then
      null;                      -- Dilemma should do something
    end if;
  end finalize;

  procedure register( the:in out File; str:in String ) is
  begin
    the.file( 1 .. str'Length ) := str;
    the.file_length             := str'Length;
    the.state                   := ACTIVE;
  end register;

  function  is_active( the:in File ) return Boolean is
  begin
    return the.state = ACTIVE;
  end is_active;

  procedure set_active( the:in out File ) is
  begin
    the.state := ACTIVE;
  end set_active;

  procedure set_not_active( the:in out File ) is
  begin
    the.state := not_ACTIVE;
  end set_not_active;

  procedure read( the:in out File; s:in out Store ) is
    file_in : Text_io.FILE_type;   -- File handle
    row     : Natural;             -- Processing row
    max_size: Natural;             -- Max lines in store
  begin
    open( File => file_in, Mode => IN_FILE,
          Name => the.file(1 .. Integer(the.file_length)));
    row := 1; max_size := deliver_store_size(s);
    while not End_of_file( file_in ) and row <= max_size loop
      set_position( s, row, 1 );
      declare
        ch       : Character;    -- Character read from file
        col      : Natural;      -- Current col position in line
        line_size: Natural;      -- Maximum line size
      begin
        col := 1; line_size := deliver_max_line_size( s, row );
        while not End_of_line( file_in ) loop
          get( file_in, ch );
          if col <= line_size then
            add( s, ch ); col := col + 1;
          end if;
        end loop;
      end;
      skip_line( file_in ); row := row + 1;
    end loop;
    close( file_in );
    set_position( s, 1, 1 ); set_last_line( s, row-1 );
    the.lines_in_file := row-1;
    the.state := not_ACTIVE;              -- Not changed
  end read;

  procedure write( the:in out File; s:in out Store;
                   u:in User ) is
    file_out : Text_io.FILE_type;   -- File handle
    row      : Natural := 1;
  begin
    if the.state = ACTIVE then
      if the.file(1) = ' ' then
        register( the, dialog( u, "File name: ") );
      end if;
      create( File=> file_out, Mode => out_FILE,
              Name => the.file(1..Integer(the.file_length)));
      row := 1;
      while row <= no_lines(s) loop
        declare
          l  : Class_Line.Line;             -- Line to output
          ch : Character;                  -- current character
        begin
          l := deliver_line( s, row ); start(l);
          while not end_of_line(l) loop
            ch := get_char( l ); put( file_out, ch );
            next_ch( l );
          end loop;
        end;
        new_line( file_out ); row := row + 1;
      end loop;
      close( file_out );
      the.state := not_ACTIVE;
 -- else
 --   raise Name_error;
    end if;
  end write;

end Class_file;

----------------------------------------------------------------------

with Simple_io,
     Ada.Io_exceptions, Class_store, Class_file, Class_display, Pack_constants,
     Pack_ansi_display, Class_user;
use  
     Ada.Io_exceptions, Class_store, Class_file, Class_display, Pack_constants,
     Pack_ansi_display, Class_user;
procedure ed is
  MAX_OPEN  : CONSTANT := 3;           -- Maximum open files
  type Open is range 1 .. MAX_OPEN;

  c       : Open;                      -- Current screen/file
  in_store: array(Open) of Store;      -- In store copy of file
  on_disk : array(Open) of File;       -- Disk file access
  screen  : array(Open) of Display;    -- The Display
  person  : User;                      -- The editors user


function yes( str:in String ) return Boolean is
begin
  return ( str'Length = 1  and then
           (str = "y" or  else str = "Y") ) or else
         ( str'Length = 3  and then
           (str = "yes" or else str = "YES") );
end yes;

function no( str:in String ) return Boolean is
begin
  return ( str'Length = 1  and then
          (str = "n" or  else str = "N") ) or else
         ( str'Length = 2  and then
          (str = "no" or else str = "NO") );
end no;

procedure open_file( the:in Open ) is      -- Read file into buffer
  fail : Boolean := FALSE;               -- Result of read
begin
  loop                                   -- Repeat until read
    begin
      if is_active( on_disk(c) ) and then -- Deleting current
         not yes(dialog( person,
                 "Delete this buffer [y/n] : ")) then
        exit;                            -- No
      end if;
      clear( in_store(c) );              -- Clear store
      register(on_disk(c),
               dialog(person, "File name: "));
      read( on_disk(c), in_store(c) );   -- Read file into store
      init( screen(c), in_store(c) );    -- Initialize screen
      refresh( screen(c) );              -- Display
      set_not_active( on_disk(c) );      -- File not active
      exit;
    exception
      when Name_error => fail := TRUE;   -- Could not read
      when others     => fail := TRUE;   -- Anything else
    end;
  end loop;
  if fail then                           -- If failed to read
    clear( in_store(c) );                --  clear changes
  end if;
end open_file;                           --

procedure close_file( the:in Open ) is     -- Write buffer
begin
  loop
    begin
      if not no(dialog(person, "Save file [y/n] : ")) then
        write( on_disk(c), in_store(c),
               person );                 -- Write file back
        clear( in_store(c) );            -- clear data
        init( screen(c), in_store(c) );  -- Set to empty
        position(screen(c), in_store(c));-- set to start position
        refresh( screen(c) );            -- Blank screen
        set_not_active( on_disk(c) );    -- Now non active
      end if;
      exit;
    exception
      when Name_error =>
        register( on_disk(c), " " );      -- Could not write
      when others     =>
        register( on_disk(c), " " );      -- Could not write
    end;
  end loop;
end close_file;

procedure commands is
begin
  Simple_io.new_line;
  Simple_io.put(" Left      ^L         Right       ^R"); Simple_io.new_line;
  Simple_io.put(" Up        ^U         Down        ^K"); Simple_io.new_line;
  Simple_io.put(" Page Up   ^W         Page Down   ^X"); Simple_io.new_line;
  Simple_io.put(" Quit      ^E         Debug info  ^T"); Simple_io.new_line;
  Simple_io.put(" Refresh   ^Y         Del         ^H"); Simple_io.new_line;
  Simple_io.put(" Opem file ^A         Close File  ^B"); Simple_io.new_line;
  Simple_io.put(" Set file  ^F         Next Buffer ^G"); Simple_io.new_line;
end commands;


procedure process_command(action:in Character) is
begin
  case action is
    when C_OPEN   => open_file(c);       -- read file
    when C_CLOSE  => close_file(c);      -- write
    when C_SET_FN =>
      register(on_disk(c),
               dialog( person, "Set file name: "));
    when C_NEXT   =>                     -- next screen
      c := c rem MAX_OPEN + 1;
      refresh( screen(c) );
    when C_LEFT | C_RIGHT =>             -- Move   -> <-
      left_right( in_store(c), action );
      position( screen(c), in_store(c) );
    when C_UP | C_DOWN =>                -- Move   up down
      up_down( in_store(c), action, 1 );
      position( screen(c), in_store(c) );
    when C_PAGE_UP | C_PAGE_DOWN =>      -- Move   page up down
      up_down(in_store(c), action, PAGE_RACK);
      position( screen(c), in_store(c) );
    when C_DEBUG =>
      clear; debug( in_store(c) ); debug( screen(c) );
      commands;
    when C_REFRESH =>                    -- Refresh screen
      refresh( screen(c) );
    when C_DEL =>                        -- Delete Character
      del(in_store(c));
      del(screen(c), in_store(c) );
      set_active( on_disk(c) );
    when Character'Val(32) .. Character'Val(127) =>
      add(in_store(c), action);
      add(screen(c), in_store(c), action);
      set_active( on_disk(c) );
    when Ascii.cr | Ascii.lf =>          -- Ignore
      null;
    when others =>                       -- Insert ?
      add(in_store(c), '?');
      add(screen(c), in_store(c), '?');
      set_active( on_disk(c) );
  end case;
end process_command;

begin                                    -- Editor is
  for c in Open loop                     -- In each current ...
    init( screen(c), in_store(c) );      -- Initialize
  end loop;

  c := 1;                                -- Current screen #1
  refresh( screen(c) );                  -- Display cur screen
  status( screen(c), in_store(c) );      -- Display status

  loop                                   -- Main loop
    declare
      action : Character;
    begin
      action := get_command( person );   -- Editing command
      exit when action = C_QUIT;         -- Quit
      process_command( action );         -- Do action
      status( screen(c), in_store(c) );  -- Display status
    end;
  end loop;

  for c in Open loop                     -- Write changes
    if is_active( on_disk(c) ) then      -- if needed
      refresh( screen(c) );              -- display file
      close_file(c);                     -- Save file
    end if;
  end loop;

end ed;


© M.A.Smith University of Brighton. Created September 1995 last modified May 1997.
Comments, suggestions, etc. M.A.Smith@brighton.ac.uk * [Home page]