Category : Miscellaneous Language Source Code
Archive   : ADAMENU2.ZIP
Filename : AM2.PKG

-- .asis
with TEXT_IO, STRINGS, VIDEO, MSDOS,
ADALIB, CALENDAR;
use TEXT_IO, STRINGS, VIDEO,
ADALIB;

-- By : Robert Monroe
-- Date : 02/16/88
--
-- A Menu system compiled under Janus/Ada 2.0.1
--
-- Note : Screen blanking and passwords are
-- currently disabled.
--
procedure ADAMENU2 is

pragma DEBUG (ON);

-- Input string lengths
PW_LEN : constant INTEGER := 32;
HEADER_LEN : constant INTEGER := 60;
NAME_LEN : constant INTEGER := 32;
DESC_LEN : constant INTEGER := 48;

-- These are the character equivalants of the scan
-- codes returned when a function key is pressed.
-- If a nul is found in the keyboard buffer,
-- check next character for one of these.
ZERO : constant CHARACTER := Ascii.Nul;
UP_ARROW : constant CHARACTER := 'H';
DOWN_ARROW : constant CHARACTER := 'P';
RIGHT_ARROW : constant CHARACTER := 'M';
LEFT_ARROW : constant CHARACTER := 'K';
PAGE_UP : constant CHARACTER := 'I';
PAGE_DOWN : constant CHARACTER := 'Q';
END_KEY : constant CHARACTER := 'O';
HOME_KEY : constant CHARACTER := 'G';

DEFAULT_HEADER : constant STRING :=
"Main Application MENU";
SELECT_MSG : constant STRING :=
"Use the Arrow keys to make "&
"a selection, or Press 1 to ";
BLNK_SCRN_MSG1 : constant STRING :=
" MENU has been erased to save screen";
BLNK_SCRN_MSG2 : Constant STRING :=
"Press the Space Bar to Restore the MENU";
BLNK_SCRN_MSG3 : LSTRING;
BLANKSCRNBoxLen : constant INTEGER := BLNK_SCRN_MSG2'LAST+4;
SCREEN_WIDTH : constant INTEGER := 80;

subtype COMMAND_TYPE is LSTRING (80);
subtype NAME_TYPE is LSTRING (NAME_LEN);
subtype DESC_TYPE is LSTRING (DESC_LEN);
subtype PASSWORD_TYPE is LSTRING (PW_LEN);

type BATCH_REC;
type BATCH_PTR is access BATCH_REC;
-- The batch lines for one menu entry.
type BATCH_REC is RECORD
COMMAND_LINE : COMMAND_TYPE;
NEXT_COMMAND : BATCH_PTR;
end RECORD;

type MENU_ENTRY_TYPE is RECORD
NAME : NAME_TYPE;
DESCRIPTION : DESC_TYPE;
PASSWORD : PASSWORD_TYPE;
BATCH_LINES : BATCH_PTR;
end RECORD;

type MENU_ARRAY_TYPE is array (1..8) of MENU_ENTRY_TYPE;
-- Maiximum 8 menu entries for now

type MENU_TYPE is RECORD
HEADER : LSTRING (HEADER_LEN);
ENTRIES : MENU_ARRAY_TYPE;
end RECORD;

ACTIVE_OPTIONS : INTEGER := 0;
LAST : INTEGER;
MENU : MENU_TYPE;
DEFINITION_FILE,
BATCH_FILE : TEXT_IO.FILE_TYPE;

procedure MOVETO (CURR_SELECT,
LAST_SELECT : in INTEGER) is
-- Move the highlight to the previous or next
-- selection on the menu.
NULLSTR : STRING (1..DESC_LEN) :=
(Others => ASCII.NUL);
DESC : LSTRING renames
MENU.ENTRIES (CURR_SELECT).DESCRIPTION;
SELECTION : LSTRING renames
MENU.ENTRIES (CURR_SELECT).NAME;
LAST_SELECTION : LSTRING renames
MENU.ENTRIES (LAST_SELECT).NAME;

begin
-- Restore the LAST selection to normal VIDEO.
TEXTCOLOR (GREEN);
SHOW_AT (30, 4+(LAST_SELECT*2),
STR (LAST_SELECT) + " " + LAST_SELECTION);

-- Highlight the current MENU selection
TEXTBACKGROUND (WHITE);
TEXTCOLOR (BLACK);
SHOW_AT (30, 4+(CURR_SELECT*2),
STR (CURR_SELECT) + " " + SELECTION);

-- Display the selection help line, if any,
-- at the bottom of the screen
if DESC.LEN > 0 then
SHOW_AT ((SCREEN_WIDTH-DESC_LEN)/2,21, DESC);
else
TEXTBACKGROUND (BLACK);
SHOW_AT ((SCREEN_WIDTH-DESC_LEN)/2,21, NULLSTR);
end if;

TEXTCOLOR (GREEN);
TEXTBACKGROUND (BLACK);
end MOVETO;

procedure SHOW_MENU (CURR, LAST : in INTEGER) is
-- Display the main MENU
X, Y : INTEGER;
HEADER : LSTRING renames MENU.HEADER;
PAD : LSTRING := (LENGTH => HEADER_LEN,
DATA => (others => ' '),
LEN => (HEADER_LEN - HEADER.LEN) / 2);
begin

CLRSCR;
TEXTCOLOR (LIGHTCYAN);
FRAME (1,1,80,24);

-- Top bar
GOTOXY (1,3);
WRITE (204);
for I in 2..SCREEN_WIDTH-1 loop WRITE (205); end loop;
WRITE (185);

-- Bottom bar
GOTOXY (1,22);
WRITE (204);
for I in 2..SCREEN_WIDTH-1 loop WRITE (205); end loop;
WRITE (185);

-- Print the header
TEXTCOLOR (WHITE);
TEXTBACKGROUND (RED);
SHOW_AT ((SCREEN_WIDTH - HEADER_LEN) / 2,
2, PAD+HEADER+PAD);
TEXTBACKGROUND (BLACK);
TEXTCOLOR (RED);

-- Show the date in the lower right hand corner
SHOW_AT (SCREEN_WIDTH - LENGTH (MSDOS.DATE) - 1,
23, MSDOS.DATE);
GOTOXY (1, 2);
X := 30; Y := 6;
-- Print the MENU OPTIONS
TEXTCOLOR (GREEN);

-- Show the menu selections
for I in 1..ACTIVE_OPTIONS loop
SHOW_AT (X, Y, STR (I) + " " + MENU.ENTRIES (I).NAME);
Y := Y+2;
end loop;

-- Display the selection prompt at the bottom of the screen
TEXTCOLOR (WHITE);
SHOW_AT ((SCREEN_WIDTH - SELECT_MSG'LAST) / 2,
25, SELECT_MSG);
WRITESTRING (STR (ACTIVE_OPTIONS));

-- Highlight the current selection
MOVETO (CURR, LAST);

end SHOW_MENU;


-- The screen blanking task is currently disabled because it
-- consistently locks up the machine and I haven't figured out why.
-- This being my first attempt to use tasking, and having no
-- particular guidance, my usage could possibly be totaly erroneous.
--
task SCREEN_SAVER is
entry BLANK_IT (C, L : in INTEGER);
end SCREEN_SAVER;

task body SCREEN_SAVER is
use CALENDAR;

-- Starting coordinates of the blank
-- screen message box
XLOC : constant INTEGER := 20;
YLOC : INTEGER := 2;
CURR,
LAST : INTEGER;

procedure MOVE_BOX is
begin
CLRSCR;
TEXTCOLOR (WHITE);
BLNK_SCRN_MSG3 := MSDOS.DATE + " " +
MSDOS.TIME (MSDOS.DEFAULT);

FRAME (XLOC, YLOC,
XLOC+BLANKSCRNBoxLen, YLOC+6);
SHOW_AT (XLOC+2, YLOC+2, BLNK_SCRN_MSG1);
SHOW_AT (XLOC+2, YLOC+4, BLNK_SCRN_MSG2);
SHOW_AT (XLOC+(BLANKSCRNBoxLen-
BLNK_SCRN_MSG3.LEN) / 2, YLOC+7,
BLNK_SCRN_MSG3);

if YLOC = 18 then
YLOC := 2;
else
YLOC := YLOC + 8;
end if;

end MOVE_BOX;


begin -- SCREEN_SAVER

loop

delay DAY_DURATION (60.0*60.0*24.0);
-- This shouldn't pop it's head up for a long time
select
accept BLANK_IT (C, L : in INTEGER) do
MOVE_BOX; -- The box won't move

while not MSDOS.KEYPRESSED loop
NULL;
end loop;

CURR := C;
LAST := L;
SHOW_MENU (CURR, LAST);
end BLANK_IT;
else
MOVE_BOX;

while not MSDOS.KEYPRESSED loop
NULL;
end loop;

SHOW_MENU (CURR, LAST);
end select;

end loop;

end SCREEN_SAVER;



task DISPLAY_TIME;

task body DISPLAY_TIME is
-- Update the time display.
-- This one seems to work just fine.
begin
loop
TEXTCOLOR (RED);
SHOW_AT (3, 23, MSDOS.TIME (MSDOS.DEFAULT));
delay 30.0;
end loop;
end DISPLAY_TIME;


procedure GET_BATCH (LINES : in out BATCH_PTR;
NEXT : in out STRING;
LAST : in out INTEGER) is
use TEXT_IO;
begin
if not END_OF_FILE (DEFINITION_FILE) then
GET_LINE (DEFINITION_FILE, NEXT, LAST);
end if;
case NEXT (1) is
when '~'
| '*'
| '?' => return;
when '+' => LINES := new BATCH_REC;
LINES.COMMAND_LINE.DATA (1..LAST-1) := NEXT (2..LAST);
LINES.COMMAND_LINE.LEN := LAST-1;
GET_BATCH (LINES.NEXT_COMMAND, NEXT, LAST);
when others => return;
end case;
end GET_BATCH;


procedure READ_DEFINITION_FILE is
use TEXT_IO;

NULLSTR : constant STRING (1..80) := (others => ASCII.NUL);
TXTLN : STRING (1..80) := NULLSTR;
LAST : INTEGER := 2;
I : INTEGER := 0;
HEADER : LSTRING renames MENU.HEADER;
ENTRIES : MENU_ARRAY_TYPE renames MENU.ENTRIES;

begin

OPEN_MDF:
begin
OPEN (DEFINITION_FILE, IN_FILE, "ADAMENU.MDF");
exception
when NAME_ERROR =>
PUT_LINE ("ADAMENU.MDF not found in current directory");
MSDOS.TERMCODE (10); -- DEFINITION FILE not found
end OPEN_MDF;

-- If no HEADER line is found in the DEFINITION FILE,
-- the default header defined in the global declarations
-- will be displayed.
HEADER.DATA (1..DEFAULT_HEADER'LAST) := Default_HEADER;
HEADER.LEN := DEFAULT_HEADER'LAST;

-- Read in the entries in the definition file
while not END_OF_FILE (DEFINITION_FILE) loop
if LAST > 1 then
case TXTLN (1) is
When '%' => HEADER.DATA (1..LAST-1) := TXTLN (2..LAST);
HEADER.LEN := LAST-1;
TXTLN := NULLSTR;
when '*' => If LAST+1 > NAME_LEN then
LAST := NAME_LEN+1;
end if;
ENTRIES (I+1).NAME.DATA (1..LAST-1) :=
TXTLN (2..LAST);
ENTRIES (I+1).NAME.LEN := LAST-1;
ENTRIES (I+1).DESCRIPTION.LEN := 0;
ACTIVE_OPTIONS := ACTIVE_OPTIONS + 1;
TXTLN := NULLSTR;
I := I+1;
ENTRIES (I).PASSWORD.LEN := 0;
when '?' => declare
DESC : LSTRING renames
ENTRIES(I).DESCRIPTION;
PAD : LSTRING (DESC_LEN);
begin
If LAST+1 > DESC_LEN then
LAST := NAME_LEN+1;
end if;
DESC.DATA (1..LAST-1) := TXTLN (2..LAST);
DESC.LEN := LAST-1;
PAD.DATA := (others => ' ');
PAD.LEN := (DESC_LEN-DESC.LEN)/2;
DESC := PAD+DESC+PAD;
end;
TXTLN := NULLSTR;
when '+' => ENTRIES(I).BATCH_LINES := new BATCH_REC;
declare
BATCH : BATCH_PTR renames
ENTRIES (I).BATCH_LINES;
begin
BATCH.COMMAND_LINE.DATA (1..LAST-1) :=
TXTLN (2..LAST);
BATCH.COMMAND_LINE.LEN := LAST-1;
GET_BATCH (BATCH.NEXT_COMMAND, TXTLN, LAST);
end;
when '^' => declare
PASSWORD : LSTRING renames
ENTRIES (I).PASSWORD;
begin
If LAST+1 > PW_LEN then
LAST := PW_LEN+1;
end if;
PASSWORD.DATA (1..LAST-1) := TXTLN (2..LAST);
PASSWORD.LEN := LAST-1;
end;
TXTLN := NULLSTR;
when others => GET_LINE (DEFINITION_FILE, TXTLN, LAST);
end case;
else GET_LINE (DEFINITION_FILE, TXTLN, LAST);
end if;
end loop;
CLOSE (DEFINITION_FILE);
end READ_DEFINITION_FILE;


procedure PUTLINE (LINE : LSTRING) is
-- WRITE one line to the system BATCH FILE
use TEXT_IO;
LAST : INTEGER := LINE.LEN;
begin
for I in 1..LAST loop
PUT (BATCH_FILE, LINE.DATA (I));
end loop;
NEW_LINE (BATCH_FILE);
end PUTLINE;


procedure WRITE_BATCH (LINES : in BATCH_PTR) is
B : BATCH_PTR;
begin
if LINES /= NULL then
PUTLINE (LINES.COMMAND_LINE);
B := LINES.NEXT_COMMAND;
WRITE_BATCH (B);
else return;
end if;
end WRITE_BATCH;


procedure GET_PASSWORD (PW : in out LSTRING) is
NullStr : STRING (1..SCREEN_WIDTH) :=
(others => ASCII.NUL);
begin
-- Clear the status line
GOTOXY (1,25);
PUT (NULLSTR);
PUT ("Enter the PASSWORD :");
READ_LINE (PW, PW.LEN);
end GET_PASSWORD;


procedure EXECUTE (OPTION : in INTEGER) is
-- Create the temporary BATCH FILE,
-- and exit to DOS to EXECUTE selected item

BATCH : BATCH_PTR renames
MENU.ENTRIES(OPTION).BATCH_LINES;
PASSWORD : LSTRING (PW_LEN);
PW : LSTRING renames
MENU.ENTRIES (OPTION).PASSWORD;
begin
-- The password feature is disabled
-- if PW.LEN /= 0 then
-- GET_PASSWORD (PASSWORD);
-- if PASSWORD /= PW then
-- TEXT_IO.PUT_LINE ("Incorrect PASSWORD");
-- delay 1.0;
-- SHOW_MENU (CURR_SELECT, LAST_SELECT);
-- return;
-- end if;
-- end if;
CREATE (BATCH_FILE, OUT_FILE, "ATEMP.BAT");
WRITE_BATCH (BATCH);
CLOSE (BATCH_FILE);
CLRSCR;
MSDOS.TERMCODE (0); -- Exit to DOS, no errors
end EXECUTE;


procedure DO_WAIT is
use MSDOS, CALENDAR;

OPTION : INTEGER;
INCHAR : CHARACTER;
CURR_SELECT,
LAST_SELECT : INTEGER := 1;

begin --Do_Wait

MAIN_WAIT:
loop

GOTOXY (26,80); -- Knock the cursor off of the screen
if KEYPRESSED then

INCHAR := MSDOS.KYBDCHAR;

case INCHAR is

when ASCII.CR => EXECUTE (CURR_SELECT);
-- EXECUTE the currently highlighted selection

when ZERO =>

-- A function key was pressed
-- Another character is waiting in the buffer
case MSDOS.KYBDCHAR is
when UP_ARROW =>
LAST_SELECT := CURR_SELECT;
if CURR_SELECT = 1 then
CURR_SELECT := ACTIVE_OPTIONS;
else
CURR_SELECT := CURR_SELECT-1;
end if;
MOVETO (CURR_SELECT, LAST_SELECT);
when DOWN_ARROW =>
LAST_SELECT := CURR_SELECT;
if CURR_SELECT = ACTIVE_OPTIONS then
CURR_SELECT := 1;
else
CURR_SELECT := CURR_SELECT+1;
end if;
MOVETO (CURR_SELECT, LAST_SELECT);
when others => NULL;
end case;

when '1'..'9' =>

OPTION := CHARACTER'POS (INCHAR)-48;
if OPTION <= ACTIVE_OPTIONS then
EXECUTE (OPTION);
end if;

when 'b'|'B' => select
SCREEN_SAVER.BLANK_IT
(CURR_SELECT, LAST_SELECT);
SHOW_MENU (CURR_SELECT, LAST_SELECT);
or
delay 0.0;
end select;


when others => NULL;

end case;

else

select

SCREEN_SAVER.BLANK_IT (CURR_SELECT, LAST_SELECT);
SHOW_MENU (CURR_SELECT, LAST_SELECT);
or
delay 0.0; -- A preempt for the time display
-- and a possible screen blank.
end select;

end if;

end loop MAIN_WAIT;

end DO_WAIT;

begin -- Ada/MENU
READ_DEFINITION_FILE;
SHOW_MENU (1,1);
DO_WAIT; -- forever
end ADAMENU2;