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