Source Code 1994 March/Source_Code_CD-ROM_Walnut_Creek_March_1994.iso/compsrcs/games/vmsnet/reflex/part01

Internet Message Format | 1993-04-08 | 40KB

Path: uunet!elroy.jpl.nasa.gov!decwrl!waikato.ac.nz!cguthrey
From: [e-mail]
Newsgroups: vmsnet.sources.games
Subject: Reflex - Test your, [1/2]
Message-ID: <[e-mail]>
Date: 9 Apr 93 21:12:17 +1200
Organization: University of Waikato, Hamilton, New Zealand
Lines: 1356
Xref: uunet vmsnet.sources.games:678

Hello VMS Game Players,

Here's a simple little game in VAX Pascal for VT100 compatable terminals.

The files included are

$README.TXT   (this one)
REFLEX.PAS   Game source
REFLEX.PIC   Introduction screen
MISC.PAS     Usefull routines extracted from Paul Denize's INTERACT Library.
VT100_ESC_SEQS.PAS  Terminal Escape Codes used in INTERACT.


This isn't a very impressive game at all, but it was quick and easy to
write.  You may enjoy it.  It may inspire you to write your own games for
the VAX. If you do, let me know!

The game REFLEX will create a score file called REFLEX.ACN.

Many thanks to Paul Denize for providing the source to his INTERACT library.

No warranty of any kind is provided with this software. This software is
copyright of the University Of Waikato, Hamilton, New Zealand.
You may distribute these files provided you retain the headers and credits.


Have fun,
Chris Guthrey
[e-mail]


$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 7.2-007  22-FEB-1990
$!   On  9-APR-1993 20:52:07.44   By user CGUTHREY (Chris R. Guthrey)
$!
$! This VMS_SHARE Written by:
$!    Andy Harper, Kings College London UK
$!
$! Acknowledgements to:
$!    James Gray       - Original VMS_SHARE
$!    Michael Bednarek - Original Concept and implementation
$!
$!+ THIS PACKAGE DISTRIBUTED IN 2 PARTS, TO KEEP EACH PART
$!  BELOW 80 BLOCKS
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. $README.TXT;1
$!       2. MAKE.COM;1
$!       3. MISC.PAS;19
$!       4. REFLEX.PAS;39
$!       5. REFLEX.PIC;9
$!       6. VT100_ESC_SEQS.PAS;12
$!
$set="set"
$set symbol/scope=(nolocal,noglobal)
$f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
$e="write sys$error  ""%UNPACK"", "
$w="write sys$output ""%UNPACK"", "
$ if f$trnlnm("SHARE_LOG") then $ w = "!"
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$UNPACK: SUBROUTINE ! P1=filename, P2=checksum
$ if f$search(P1) .eqs. "" then $ goto file_absent
$ e "-W-EXISTS, File ''P1' exists. Skipped."
$ delete 'f'*
$ exit
$file_absent:
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'."
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
$ delete 'f'*
$ exit
$dirok:
$ w "-I-PROCESS, Processing file ''P1'."
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
"output_file"));ENDPROCEDURE;Unpacker;QUIT;
$ delete/nolog 'f'*
$ CHECKSUM 'P1'
$ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
$ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ ENDSUBROUTINE
$START:
$ create 'f'
XREFLEX `20
X
XSingle Player game for VT100 compatable terminals.
X
XWritten in VAX Pascal, under VMS A5.2.
X
XThe files included are
X
X$README.TXT   (this one)
XREFLEX.PAS   Game source
XREFLEX.PIC   Introduction screen`20
XMISC.PAS     Usefull routines extracted from Paul Denize's INTERACT Library.
XVT100_ESC_SEQS.PAS  Terminal Escape Codes used in INTERACT.
X
XThe game REFLEX will create a score file called REFLEX.ACN.
X
XThis isn't a very impressive game at all, but it was quick and easy to
Xwrite.  You may enjoy it.  It may inspire you to write your own games for
Xthe VAX. If you do, let me know!
X
XMany thanks to Paul Denize for providing the source to his INTERACT library.
X
XNo warranty of any kind is provided with this software. This software is
Xcopyright of the University Of Waikato, Hamilton, New Zealand.
XYou may distribute these files provided you retain the headers and credits.
X
XHere is the header of the file MISC.PAS:
X
X(****************** This file is a collection of routines from  ************
V**
X ******************    the INTERACT Pascal Games Library...     ************
V**
X *****************                                               ***********
V**
X ****************  (c) Waikato University, Hamilton, NEW ZEALAND  **********
V**
X *
X *  The INTERACT Library was written by Paul Denize   [e-mail]`
V20
X *
X *  Contributing authors: Rex Croft                   [e-mail]
X *                        Lawrence D'Oliviero         [e-mail]
X *                        Chris Guthrey               [e-mail]
X *
X *  Several improvements to the TOPTEN Score Table System`20
X *  contributed by:
X *                        Bill Brenessel      [e-mail]
X *
X * You are granted permission to use the routines in this file or any other
X * routines from any INTERACT Library File on condition that this header is
X * retained and credit given where due.
X *
X * Note of course that there is no warranty of any kind whatsoever.
X *
X *)
X
X
XHave fun,
XChris Guthrey
[e-mail]
$ CALL UNPACK $README.TXT;1 1163196366
$ create 'f'
X$ write sys$output "Compiling..."
X$ pascal/opt/nodebug misc, reflex
X$ write sys$output "Linking..."
X$ link/nodebug reflex, misc
X$ write sys$output "Finished!"
$ CALL UNPACK MAKE.COM;1 1560878412
$ create 'f'
X(****************** This file is a collection of routines from  ************
V**
X ******************    the INTERACT Pascal Games Library...     ************
V**
X *****************                                               ***********
V**
X ****************  (c) Waikato University, Hamilton, NEW ZEALAND  **********
V**
X *
X *  The INTERACT Library was written by Paul Denize   [e-mail]`
V20
X *
X *  Contributing authors: Rex Croft                   [e-mail]
X *                        Lawrence D'Oliviero         [e-mail]
X *                        Chris Guthrey               [e-mail]
X *
X *  Several improvements to the TOPTEN Score Table System`20
X *  contributed by:
X *                        Bill Brenessel      [e-mail]
X *
X * You are granted permission to use the routines in this file or any other
X * routines from any INTERACT Library File on condition that this header is
X * retained and credit given where due.
X *
X * Note of course that there is no warranty of any kind whatsoever.
X *
X *)
X`5B
X  Inherit(
X    (*'GEN$:`5BPAS`5DVAXTYPES', *)
X    'SYS$LIBRARY:PASCAL$LIB_ROUTINES',
X    'SYS$LIBRARY:STARLET'`20
X    (* 'GEN$:`5BPAS`5DVMSRTL' *)`20
X  ),
X  Environment
X    ('MISC.PEN')
X`5D
XMODULE MISC( OUTPUT );
X
X(*****************************************************************
X ** THIS FILE IS MERELY A CONCISE COMPILATION OF ROUTINES TAKEN **
X ** FROM A NUMBER OF INTERACT GAMES LIBRARY SOURCE FILES. ONLY  **
X ** THE ROUTINES NEEDED BY THIS PARTICULAR GAME ARE INCLUDED.   **
X *****************************************************************)
X
X%INCLUDE 'VT100_ESC_SEQS.PAS'
X
XTYPE
X      `7B signed integer types `7D
X`09$byte = `5BBYTE`5D -128..127;
X`09$word = `5BWORD`5D -32768..32767;
X`09$quad = `5BQUAD,UNSAFE`5D RECORD
X`09`09l0:UNSIGNED; l1:INTEGER; END;
X`09$octa = `5BOCTA,UNSAFE`5D RECORD
X`09`09l0,l1,l2:UNSIGNED; l3:INTEGER; END;
X
X      `7B unsigned integer types `7D
X`09$ubyte = `5BBYTE`5D 0..255;
X`09$uword = `5BWORD`5D 0..65535;
X`09$uquad = `5BQUAD,UNSAFE`5D RECORD
X`09`09l0,l1:UNSIGNED; END;
X`09$uocta = `5BOCTA,UNSAFE`5D RECORD
X`09`09l0,l1,l2,l3:UNSIGNED; END;
X
X      `7B miscellaneous types `7D
X`09$packed_dec = `5BBIT(4),UNSAFE`5D 0..15;
X`09$deftyp = `5BUNSAFE`5D INTEGER;
X`09$defptr = `5BUNSAFE`5D `5E$DEFTYP;
X
X
X`5BHIDDEN`5D
XTYPE
X  v_array = varying `5B256`5D of char;
X
X`5BGLOBAL`5D
XFUNCTION System_Call ( ret_status : integer ) : Boolean;
XBEGIN
X  IF not odd(ret_status) then
X    LIB$SIGNAL(ret_status);
X  System_Call := odd(ret_status);
XEND;
X
X`5BGLOBAL`5D
XPROCEDURE  TERMINATE ( code : integer := 1 );
XBEGIN
X  $EXIT ( code );
XEND;
X
X`5BGLOBAL`5D
XPROCEDURE  KILL ( PID : `5BTRUNCATE`5D UNSIGNED );
XBEGIN
X  IF PRESENT(PID) then
X    System_Call ($DELPRC(pidadr:=PID))
X  ELSE
X    System_Call ($DELPRC);
XEND;
X
XVAR
X  terminal_input_channel    : $UWORD;
X  terminal_output_channel   : $UWORD;
X  channel_initialized : Boolean := False;
X
X
X`5BGLOBAL`5D
XPROCEDURE  initialize_channel( input_device : v_array := 'TT:';
X                               output_device : v_array := 'TT:' );
XBEGIN
X  IF not channel_initialized then
X    BEGIN `20
X      System_Call ($assign ( chan := terminal_output_channel , devnam := out
Vput_device));
X      IF input_device = output_device THEN     `7Bare in and out devices sam
Ve?`7D
X        terminal_input_channel := terminal_output_channel `7Bsame channel`7D
X      ELSE
X        System_Call ($assign ( chan := terminal_input_channel ,devnam := inp
Vut_device ));
X    END;
XEND;
X
X`5BGLOBAL`5D
XFUNCTION  QIO_1_char_now : char;
XVAR
X  buffer : packed array `5B1..1`5D of char;
XBEGIN
X  buffer`5B1`5D := chr(-1);
X  System_Call ($qiow ( chan:= terminal_input_channel,
X                        func:= io$_readvblk+io$m_timed+io$m_noecho+io$m_nofi
Vltr,
X                        p1:= buffer,
X                        p2:= 1, `7B bufferlength `7D
X                        p3:= 0 ));
X   Qio_1_char_now := buffer`5B1`5D;
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  QIO_readln ( characters : integer ) : v_array;
XTYPE
X  iosb_type = `5BQUAD`5D Record
X                       Status : $uword;
X                       Nrbytes : $uword;
X                       Terminator : char;
X                       Reserved : $ubyte;
X                       Terminator_length : $ubyte;
X                       Cursor_offset : $ubyte
X                     End;
XVAR
X  temp : v_array;
X  Read_iosb : iosb_type;
XBEGIN
X  system_Call ( $qiow ( chan:= terminal_input_channel,
X                        func:= io$m_timed+io$_readvblk+io$m_noecho+io$m_nofi
Vltr+io$m_escape,
X                        iosb:= read_iosb,
X                          p1:= temp.body,
X                          p2:= characters,
X                          p3:= 0 ));
X   temp.length := ( read_iosb.Nrbytes );
X   qio_readln := temp;
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  QIO_1_char : char;
XVAR
X  buffer : packed array `5B1..1`5D of char;
XBEGIN
X  System_Call ($qiow ( chan:= terminal_input_channel,
X                        func:= io$_readvblk+io$m_noecho+io$m_nofiltr,
X                          p1:= buffer,
X                          p2:= 1 ));
X  Qio_1_char := buffer`5B1`5D;
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE  QIO_purge;
XBEGIN
X  System_Call ($qiow ( chan:= terminal_input_channel,
X                        func:= io$_readvblk+io$m_purge ));
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  QIO_1_char_timed ( delay : integer ) : char;
XVAR
X  buffer : packed array `5B1..1`5D of char;
XBEGIN
X  buffer`5B1`5D := chr(255);
X  System_Call ($qiow ( chan:= terminal_input_channel,
X                        func:=io$m_timed+io$_readvblk+io$m_noecho+io$m_nofil
Vtr+io$m_escape,
X                          p1:= buffer,
X                          p2:= 1,
X                          p3:= delay ));
X  Qio_1_char_timed := buffer`5B1`5D;
XEND;
X
X`5BGLOBAL`5D
XPROCEDURE  QIO_write ( text : v_array );
XBEGIN
X  System_Call ($qiow (chan:= terminal_output_channel,
X                       func:= io$_writevblk,
X                         p1:= text.body,
X                         p2:= text.length ));
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE  QIO_writeln ( text : `5BTRUNCATE`5D v_array );
XVAR
X  outline     : v_array;
XBEGIN
X  IF present(text) then
X    BEGIN
X      outline := text + VT100_cr + VT100_lf;
X      System_Call ($qiow (chan:= terminal_output_channel,
X                           func:= io$_writevblk,
X                             p1:= outline.body,
X                             p2:= outline.length  ));
X    END
X  ELSE
X    BEGIN
X      outline := VT100_cr + VT100_lf;
X      System_Call ($qiow (chan:= terminal_output_channel,
X                           func:= io$_writevblk,
X                             p1:= outline.body,
X                             p2:= outline.length  ));
X    END;
XEND;
X
X`5BGLOBAL`5D
XPROCEDURE  Sleep ( sec : integer := 0; frac : `5BTRUNCATE`5D real );
XVAR
X  Hundredths : integer;
X  delta_wake_time : $quad;
XBEGIN
X  Hundredths := sec*100;
X  IF PRESENT(frac) then
X    Hundredths := Hundredths + round(frac*100);
X  IF ( hundredths > 0 ) then
X    BEGIN
X      System_Call (LIB$EMUL (Hundredths, -100000, 0, delta_wake_time));
X      IF System_Call ($Schdwk ( daytim := delta_wake_time )) then
X        System_Call ($Hiber);
X    END;
XEND;
X
XTYPE
X  portiontype = (The_Screen,The_Line);
X  cleartype   = (Wholething, To_Start, To_End);
X `20
X`5BHIDDEN`5D
XVAR
X  desblk : Record
X             findlink   : integer;
X             proc       : integer;
X             arglist    : array `5B0..1`5D of integer;
X             exitreason : integer;
X           End;
X
X
X`5BHIDDEN`5D
XPROCEDURE  ctrlc_ast;
XBEGIN
X  $exit ( code := ss$_clifrcext );
XEND;
X
X`5BGLOBAL`5D
XPROCEDURE  Force;
XBEGIN
X  System_Call ($qiow ( chan := terminal_output_channel,
X                        func := io$_setmode + io$m_ctrlcast,
X                        p1   := %immed iaddress (ctrlc_ast)));
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE Setup_handler ( handler_address : integer );
XBEGIN
X  WITH desblk do
X    BEGIN
X      proc       := handler_address;
X      arglist`5B0`5D := 1;
X      arglist`5B1`5D := iaddress(exitreason);
X    END;
X
X  System_Call ($DCLEXH (desblk));
XEND;`20
X
X
X`5BGLOBAL`5D
XPROCEDURE  No_handler;
XBEGIN
X  System_Call ($CANEXH (desblk));
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  Upper_case ( c : char ) : char;
XBEGIN
X  IF ( c in `5B'a'..'z'`5D ) then
X    c := chr ( ord(c) - ord('a') + ord('A') );
X  upper_case := c;
XEND;
X
X`5BGLOBAL`5D
XPROCEDURE  Clear ( portion : portiontype := The_Screen;
X                   clear   : cleartype   := Wholething );
XVAR
X  outline : v_array;
XBEGIN
X  outline := VT100_ESC + '`5B';
X
X  IF ( clear = Wholething ) then
X    outline := outline + '2'
X  ELSE
X  IF ( clear = To_Start ) then
X    outline := outline + '1';
X
X  IF ( portion = The_Screen ) then
X    outline := outline + 'J'
X  ELSE
X  IF ( portion = The_Line ) then
X    outline := outline + 'K';
X
X  qio_write (outline);
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE  ERROR ( text : `5BTRUNCATE`5D v_array );
XBEGIN
X  writeln ( VT100 + VT100_graphics_off + VT100_normal + VT100_normal_scroll
V + VT100_no_application_keypad + VT100_ESC + '`5BJ' );
X  IF present(text) then
X    writeln (text)
X  else
X    writeln ('No Message');
X  $EXIT;
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  Get_Posn ( x , y : integer ) : v_array;
XVAR
X  outline,sx,sy : v_array;
XBEGIN
X  outline := VT100_ESC + '`5B';
X
X  IF ( y > 1 ) then
X    BEGIN
X      writev (sy,y:1);
X      outline := outline + sy;
X    END;
X
X  IF ( x > 1 ) then
X    BEGIN
X      writev (sx,x:1);
X      outline := outline + ';' + sx;
X    END;
X
X  get_posn := outline + 'H';
XEND;
X
X`5BGLOBAL`5D
XPROCEDURE  Posn ( x , y : integer );
XBEGIN
X  qio_write (get_posn(x,y));
XEND;
X
X
X`5BHIDDEN`5D
XVAR
X  seed : integer;
X  seed_initialized : boolean;
X
X
X`5BGLOBAL`5D
XPROCEDURE  Seed_initialize ( users_seed : `5BTRUNCATE`5D integer );
XVAR
X  time : packed array `5B0..1`5D of integer;
XBEGIN
X  seed_initialized := true;
X  IF present(users_seed) then
X    seed := users_seed
X  ELSE
X    BEGIN
X      $gettim(time);
X      seed := time`5B0`5D;
X    END;
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  Random ( ub : integer ) : integer;
X`7B Produce random integer between 1 & ub inclusive `7D
X
X        FUNCTION  Mth$Random ( VAR seed : integer ) : real;
X          extern;
X
XBEGIN
X  If not seed_initialized then
X    seed_initialize;
X  Random := Trunc (( Mth$Random ( seed ) * ub ) + 1);
XEND; `7B Random `7D
X
X
X`5BGLOBAL`5D
XFUNCTION  Rnd ( lb, ub : integer ) : integer;
X`7B Produce random integer between lb & ub `7D
X
X        FUNCTION  Mth$Random ( VAR seed : integer ) : real;
X          extern;
X
XBEGIN
X  If not seed_initialized then
X    seed_initialize;
X  rnd := Trunc (( Mth$Random ( seed ) * (ub-lb+1) ) + lb );
XEND; `7B Random `7D
X
X
X`5BGLOBAL`5D
XFUNCTION  _Dec ( number    : integer;
X                pad_char  : char := ' ';
X                pad_len   : integer := 0
X              ) : v_array;
XVAR
X  Result : v_array;
XBEGIN
X  Writev (result,number:0);
X  WHILE ( result.length < abs(pad_len) ) do
X    IF ( pad_len < 0 ) then
X      result := result + pad_char
X    ELSE
X      result := pad_char + result;
X  _dec := result;
XEND;
X
X`5BGLOBAL`5D
XFUNCTION  Get_jpi_Str ( jpicode , retlen : integer ) : v_array;
XVAR
X  itemlist    : record
X                  item : array `5B1..1`5D of`20
X                    record
X                      bufsize : $uword;
X                      code    : $uword;
X                      bufadr  : integer;
X                      lenadr  : integer
X                    end;
X                  no_more : integer;
X                end;
X  name : packed array `5B1..256`5D of char;
X  retname : v_array;
XBEGIN
X  WITH itemlist do
X   BEGIN
X     WITH item`5B1`5D do
X       BEGIN
X         Bufsize := retlen;
X         Code := jpicode;
X         Bufadr := iaddress(name);
X         Lenadr := 0
X       END;
X     No_more := 0
X   END;
X  System_Call ($Getjpiw(itmlst := itemlist));
X  retname := name;
X  retname.length := retlen;
X  get_jpi_str := retname;
XEND;
X
XFUNCTION  Get_jpi_Val ( jpicode : INTEGER ) : UNSIGNED;
XVAR
X  itemlist    : record
X                  item : array `5B1..1`5D of`20
X                    record
X                      bufsize : $uword;
X                      code    : $uword;
X                      bufadr  : integer;
X                      lenadr  : integer
X                    end;
X                  no_more : integer;
X                end;
X  resulting_value : UNSIGNED;
X  retname : v_array;
XBEGIN
X  WITH itemlist do
X   BEGIN
X     WITH item`5B1`5D do
X       BEGIN
X         Bufsize := 4;
X         Code := jpicode;
X         Bufadr := iaddress(resulting_value);
X         Lenadr := 0
X       END;
X     No_more := 0
X   END;
X  System_Call ($Getjpiw(itmlst := itemlist));
X  get_jpi_val := resulting_value;
XEND;
X
X`5BHIDDEN`5DVAR
X  image_dir_done : boolean;
X
X
X`5BGLOBAL`5D
XPROCEDURE  Image_dir;
XVAR
X  itemlist    : record
X                  item : array `5B1..1`5D of`20
X                    record
X                      bufsize : $uword;
X                      code    : $uword;
X                      bufadr  : integer;
X                      lenadr  : integer
X                    end;
X                  no_more : integer;
X                end;
X  the_name : v_array;
X  name_str : packed array `5B1..256`5D of char;
XBEGIN
X  IF not image_dir_done then
X    BEGIN
X      image_dir_done := true;
X      the_name := Get_jpi_str(jpi$_imagname,100);
X   `20
X      WHILE ( index(the_name,'`5D`5B') <> 0 ) do
X        BEGIN
X          the_name := substr(the_name,1,index(the_name,'`5D`5B')-1) + substr
V(the_name,index(the_name,'`5D`5B')+2,length(the_name)-(index(the_name,'`5D`5
VB')+2));
X        END;
X   `20
X      the_name := substr(the_name,1,index(the_name,'`5D'));
X      name_str := the_name;
X   `20
X      WITH itemlist do
X       BEGIN
X         WITH item`5B1`5D do
X           BEGIN
X             Bufsize := length(the_name);
X             Code := lnm$_string;
X             Bufadr := iaddress(name_str);
X             Lenadr := 0
X           END;
X         No_more := 0
X       END;
X
X      System_Call ($Crelnm (tabnam:='LNM$PROCESS_TABLE',
X                             lognam:='IMAGE_DIR',
X                             itmlst:=itemlist ));
X    END;
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE  Square ( x1 , y1 , x2 , y2 : integer );
XVAR
X  i : integer;
X  sx : v_array;
X  buffer : v_array;
XBEGIN
X  IF ( x1 > x2 - 1 ) or ( y1 > y2 - 1 ) then
X    ERROR ('%INTERACT-SQUARE, Top Corner Bottom Corner Overlap');
X  IF ( abs(x2-x1) > 132 ) then
X    ERROR ('%INTERACT-SQUARE, Size Error delta x distance too large.');
X  IF ( abs(y2-y1) > 24 ) then
X    ERROR ('%INTERACT-SQUARE, Size Error delta y distance too large.');
X
X  buffer := get_posn (x1,y1) + VT100_graphics_on + 'l';
X  FOR i := x1+1 to x2-1 do
X    buffer := buffer + 'q';
X  buffer := buffer + 'k';
X  qio_write (buffer);
X  writev(sx,x2-x1-1:1);
X  sx := 'x' + VT100_ESC + '`5B' + sx + 'C' + 'x';
X  FOR i := y1+1 to y2-1 do
X    qio_write ( get_posn(x1,i)+ sx );
X  buffer := get_posn (x1,y2) + 'm';
X  IF ( x1 < x2 - 1 ) then
X    FOR i := x1+1 to x2-1 do
X      buffer := buffer + 'q';
X  buffer := buffer + 'j' + VT100_graphics_off;
X  qio_write (buffer);
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE  Reset_screen;
XBEGIN
X  qio_write ( VT100 + VT100_graphics_off + VT100_normal + VT100_normal_scrol
Vl + VT100_no_application_keypad );
XEND;
X
X`5BHIDDEN`5D
XVAR
X  ingraphedt     : text;
X
X`5BGLOBAL`5D
XFUNCTION Show_graphedt ( filename : v_array; wait : boolean := true ) : CHAR
V;
X(*`20
X  IF wait is true then the character that is pressed is returned, otherwise
X   chr(255) is returned
X*)
XVAR
X  line : v_array;
X  rep : char := chr(255);
X  ret_val : char;
XBEGIN
X  IF not image_dir_done then
X    Image_dir;
X  IF ( wait ) then
X    rep := qio_1_char_now;
X  OPEN (ingraphedt,'image_dir:'+filename,history:=readonly,error:=continue);
X  IF status(ingraphedt) = 0 then
X    BEGIN
X      reset (ingraphedt);
X      WHILE not eof(ingraphedt) and (( rep = chr(-1)) or ( not wait )) do
X        BEGIN
X          IF wait then
X            rep := qio_1_char_now;
X          readln (ingraphedt,line);
X          qio_writeln(line);
X        END;
X      close (ingraphedt);
X      posn (1,1);
X      IF wait and ( rep = chr(-1) ) then
X        rep := qio_1_char;
X    END
X  ELSE
X    BEGIN
X      clear;
X      posn (18,10);
X      qio_write ('couldn''t find filename .... '+filename);
X      posn (28,20);
X      qio_write (VT100_Bright+'Press  <'+VT100_Flash+'Return'+VT100_normal+V
VT100_bright+'>'+VT100_normal);
X      posn (1,1);
X      IF ( rep  = chr(-1) ) then
X        rep := qio_1_char;
X    END;
X  reset_screen;
X  Show_GraphEdt := rep;
XEND;
X
X`5BGLOBAL`5D
XFUNCTION  Full_char ( character : char ) : v_array;
XVAR
X  c : integer;
XBEGIN
X  c := ord(character);
X  IF ( c in `5B0..31,127`5D ) then
X    full_char := VT100_inverse + chr(64+c) + VT100_normal
X  ELSE
X  IF ( c < 128 ) then
X    full_char := character
X  ELSE
X  IF ( (c-128) in `5B0..31,127`5D ) then
X    full_char := VT100_inverse + VT100_bright + chr(c-64) + VT100_normal
X  ELSE
X    full_char := VT100_bright + character;
XEND;
X
X
X`5BGlobal`5D
XPROCEDURE  Formated_read
X (VAR return_value   : v_array;
X      picture_clause : v_array;
X      x_posn         : integer;
X      y_posn         : integer;
X      default_value  : v_array := '';
X      field_full_terminate : boolean := false;
X      begin_brace    : v_array := '';
X      end_brace      : v_array := ''
X );
XVAR
X  i : integer;
X  ch : char;
X  outline : v_array;
X
X
X    PROCEDURE  Go_left;
X    BEGIN
X      IF ( i <> 1 ) then
X        BEGIN
X          REPEAT
X            i := i - 1;
X          UNTIL ( i = 1 ) or ( picture_clause`5Bi`5D in `5B'9','X'`5D );
X          IF not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) then
X            BEGIN
X              WHILE not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) do
X                i := i + 1;
X            END;
X        END;
X    END;
X
X
X    PROCEDURE  Go_right;
X    BEGIN
X      IF ( i <> length(picture_clause) ) then
X        BEGIN
X          REPEAT
X            i := i + 1;
X          UNTIL ( i = length(picture_clause) ) or ( picture_clause`5Bi`5D in
V `5B'9','X'`5D );
X          IF not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) then
X            BEGIN
X              WHILE not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) do
X                i := i - 1;
X            END;
X        END;
X    END;
X
X
X    PROCEDURE  Escape_sequence;
X    BEGIN
X      ch := qio_1_char;
X      IF ( ch = '`5B' ) then
X        BEGIN
X          ch := qio_1_char;
X          CASE ch of
X            'C' : go_right;
X            'D' : go_left;
X            Otherwise
X             qio_write (chr(7));               `20
X          End;
X        END
X      ELSE
X        qio_write (chr(7));               `20
X    END;
X
X
X    PROCEDURE  Delete;
X    VAR
X      last : integer;
X    BEGIN
X      IF ( i <> 1 ) then
X        BEGIN
X          last := length(picture_clause)+1;
X          REPEAT
X            last := last - 1;
X          UNTIL ( last = 1 ) or ( picture_clause`5Blast`5D in `5B'9','X'`5D
V );
X
X          IF ( i <> last ) or ( return_value`5Bi`5D = ' ' ) then
X            REPEAT
X              i := i - 1;
X            UNTIL ( i = 1 ) or ( picture_clause`5Bi`5D in `5B'9','X'`5D );
X
X          IF not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) then
X            BEGIN
X              WHILE not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) do
X                i := i + 1;
X            END
X          ELSE
X            BEGIN
X              posn (x_posn+i-1,y_posn);
X               qio_write (' '+VT100_bs);
X              return_value`5Bi`5D := ' ';
X            END;
X        END;
X    END;
X
X
X    PROCEDURE  Key_control;
X    BEGIN
X      IF ( ch = chr(13) ) then
X        BEGIN
X          field_full_terminate := true;
X          i := length(picture_clause) + 1;
X        END
X      ELSE
X      IF ( ch = chr(27) ) then
X        escape_sequence
X      ELSE
X      IF ( ch = chr(127) ) then
X        delete
X      ELSE
X        qio_write (chr(7));               `20
X    END;
X
X
XBEGIN
X  return_value := '';
X
X`7B get x & y if left out `7D
X
X  FOR i := 1 to length(picture_clause) do
X      CASE picture_clause`5Bi`5D of
X        '9' : IF length(default_value) < i then
X                return_value := return_value + ' '
X              ELSE
X              IF ( default_value`5Bi`5D in `5B' ','0'..'9'`5D ) then
X                return_value := return_value + default_value`5Bi`5D
X              ELSE
X                ERROR ('DEFAULT VALUE /'+default_value`5Bi`5D+'/ DOES NOT MA
VTCH PICTURE CLAUSE /'+picture_clause`5Bi`5D+'/');
X        'X' : IF length(default_value) < i then
X                return_value := return_value + ' '
X              ELSE
X              IF ( default_value`5Bi`5D in `5B' '..'`7E'`5D ) then
X                return_value := return_value + default_value`5Bi`5D
X              ELSE
X                ERROR ('%INTERACT-F-DVMM, DEFAULT VALUE /'+full_char(default
V_value`5Bi`5D)+'/ DOES NOT MATCH PICTURE CLAUSE /'+picture_clause`5Bi`5D+'/'
V);
X       otherwise`20
X          return_value := return_value + picture_clause`5Bi`5D;
X      End;
X
X  outline := '';
X
X  posn (x_posn,y_posn);
X  IF length(begin_brace) > 0 then
X    outline := outline + begin_brace;
X  outline := outline + return_value;
X  IF length(end_brace) > 0 then
X    outline := outline + end_brace;
X
X  qio_write (outline);
X
X  IF length(begin_brace) > 0 then
X    x_posn := x_posn + length(begin_brace);
X
X  i := 1;
X  REPEAT
X    WHILE ( i <= length(picture_clause) ) do
X      BEGIN
X        posn (x_posn+i-1,y_posn);
X        CASE picture_clause`5Bi`5D of
X          '9' : BEGIN
X                  ch := qio_1_char;
X                  IF ( ch in `5B' ','0'..'9'`5D ) then
X                    BEGIN
X                      return_value`5Bi`5D := ch;
X                      qio_write (ch);
X                      i := i + 1;
X                    END
X                  ELSE
X                    key_control;
X                END;
X          'X' : BEGIN
X                  ch := qio_1_char;
X                  IF ( ch in `5B' '..'`7E'`5D ) then
X                    BEGIN
X                      return_value`5Bi`5D := ch;
X                      qio_write (ch);
X                      i := i + 1;
X                    END
X                  ELSE
X                    key_control;
X                END;
X         otherwise`20
X            i := i + 1;
X        End;
X      END;
X    IF ( i > length(picture_clause) ) and ( not field_full_terminate ) then
X      i := length(picture_clause);
X  UNTIL ( i > length(picture_clause) );
XEND;
X
X
X`5BASYNCHRONOUS, EXTERNAL(STR$TRIM)`5D
XFUNCTION  $Trim
X  ( VAR destination_str : `5BCLASS_S`5D PACKED ARRAY `5B$L1 .. $U1 : INTEGER
V`5D OF CHAR;
X        source_str      : `5BCLASS_S`5D PACKED ARRAY `5B$L2 .. $U2 : INTEGER
V`5D OF CHAR;
X    VAR return_length   : $UWORD
X  ) : integer;
XExtern;
X
X`5BGLOBAL`5D
XFUNCTION  Trim ( text : v_array ) : v_array;
XBEGIN
X  System_Call ($trim (text.body,text,text.length));
X  trim := text;
XEND;
X
XTYPE
X  date_time_type = array `5B1..7`5D of $uword;
X
X
X`5BASYNCHRONOUS, EXTERNAL(LIB$DAY_OF_WEEK)`5D
XFUNCTION  $Day_of_week
X    (
X        time     : $quad := %IMMED 0;
X    VAR day_num  : integer
X    ) : integer;
XExtern;
X
X
X`5BGLOBAL`5D
XFUNCTION  Get_Date_time : date_time_type;
XVAR
X  Date_time : date_time_type;
XBEGIN
X  System_Call ($numtim (date_time));
X  get_date_time := date_time;
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  Day_num ( Date_Time : date_time_type ) : integer;
XVAR
X  temp : integer;
X  q : $quad;
XBEGIN
X  System_Call ($gettim(q));
X  System_Call ($day_of_week(q,temp));
X  day_num := temp;
XEND;
X
X
X`5BHIDDEN`5D
XCONST
X(* These values are returned by the predefined STATUS function. *)
X
X    PAS$K_SUCCESS    =    0;    (* last operation successful *)
X    PAS$K_FILNOTFOU  =    3;    (* file not found *)
X    PAS$K_ACCMETINC  =    5;    (* ACCESS_METHOD specified is incompatible w
Vith this file *)
X    PAS$K_RECLENINC  =    6;    (* RECORD_LENGTH specified is inconsistent w
Vith this file *)
X
X`5BHIDDEN`5D
XTYPE
X  u_array = varying `5B8`5D of char;
X  s_array = varying `5B12`5D of char;
X  everything = Record
X                 tot_games : integer;
X                 month     : integer;
X                 m_user    : array `5B1..12`5D of u_array;
X                 m_name    : array `5B1..12`5D of s_array;
X                 m_score   : array `5B1..12`5D of integer;
X                 user      : array `5B0..19`5D of u_array;
X                 name      : array `5B0..19`5D of s_array;
X                 score     : array `5B0..19`5D of integer;
X                 games     : array `5B0..19`5D of integer;
X               End;
X`5BHIDDEN`5D
XVAR
X  infile  : File of everything;
X  newfile : File of everything;
X  game_count_incremented : boolean := false;
X
X`5BHIDDEN`5D
XPROCEDURE  Get_Image_dir_and_ACN_name ( VAR directory, gamename : v_array );
XVAR
X  the_name : v_array;
XBEGIN
X  the_name := Get_jpi_str(jpi$_imagname,100);
X  WHILE ( index(the_name,'`5D`5B') <> 0 ) do
X    BEGIN
X      the_name := substr(the_name,1,index(the_name,'`5D`5B')-1) + substr(the
V_name,index(the_name,'`5D`5B')+2,length(the_name)-(index(the_name,'`5D`5B')+
V2));
X    END;
X  directory := substr(the_name,1,index(the_name,'`5D'));
X  the_name := substr(the_name,index(the_name,'`5D')+1,the_name.length-index(
Vthe_name,'`5D'));
X  gamename := substr(the_name,1,index(the_name,'.')-1);
XEND;
X
X`5BHIDDEN`5D
XFUNCTION  month_of_year ( i : integer ) : v_array;
XBEGIN
X  month_of_year := substr('JanFebMarAprMayJunJulAugSepOctNovDec',(i*3)-2,3);
XEND;
X
X`5BHIDDEN`5D
XPROCEDURE  Display_Screen ( current_state : everything; date_time : date_tim
Ve_type; me : integer; gamename : v_array; last_score : integer );
XVAR
X  i : integer;
X  year_now  : integer;
X  month_now : integer;
XBEGIN
X  year_now  := date_time`5B1`5D;
X  month_now := date_time`5B2`5D;
X  clear;
X  posn (1,1);
X  qio_write ('Immortal Players For '+_dec(year_now-1)+' - '+_dec(year_now)+'
V               Top Players For '+month_of_year(month_now)+' ');
X  qio_writeln (VT100_bright+_dec(current_state.tot_games,,6)+' Games'+VT100_
Vnormal);
X  qio_writeln (VT100_graphics_on+'oooooooooooooooooooooooooooooooo
V               ooooooooooooooooooo'+VT100_graphics_off);
X  qio_writeln ('Month  Username  Name         Score     Num Username  Name
V         Score   Games');
X  qio_writeln;
X
X  For i := month_now-1 downto 1 do
X    IF ( current_state.m_score`5Bi`5D <> -maxint-1 ) then
X      qio_writeln (' '+month_of_year(i)+'   '+current_state.m_user`5Bi`5D+'
V  '+current_state.m_name`5Bi`5D+' '+_dec(current_state.m_score`5Bi`5D,,5))
X    ELSE
X      qio_writeln;
X  For i := 12 downto month_now do
X    IF ( current_state.m_score`5Bi`5D <> -maxint-1 ) then
X      qio_writeln (' '+month_of_year(i)+'   '+current_state.m_user`5Bi`5D+'
V  '+current_state.m_name`5Bi`5D+' '+_dec(current_state.m_score`5Bi`5D,,5))
X    ELSE
X      qio_writeln;
X
X  For i := 0 to 11 do
X    IF ( current_state.score`5Bi`5D <> -maxint-1 ) then
X      qio_write (get_posn(41,5+i)+_dec(i+1,,3)+' '+current_state.user`5Bi`5D
V+'  '+current_state.name`5Bi`5D+' '+_dec(current_state.score`5Bi`5D,,5)+'
V   '+_dec(current_state.games`5Bi`5D,,3));
X
X  posn (5,18);
X  qio_write ('You Are Seated At '+_dec(me+1)+' In '+gamename);
X
X  IF ( last_score <> -maxint-1 ) THEN
X    BEGIN
X        `7B doing worse on or off board or better but still off board `7D
X      posn (42,18);
X      qio_writeln ('Previous Score '+_dec(last_score));
X    END;
XEND;
X
X`5BHIDDEN`5D
XPROCEDURE  Display_Current_Score (last_score : integer; this_score : integer
V );
XBEGIN
X  posn (42,20);
X  qio_writeln ('Current Score '+_dec(this_score));
XEND;
X
X`5BHIDDEN`5D
XPROCEDURE  Display_Update_Prompts (me : integer; last_score : integer; this_
Vscore : integer );
XBEGIN
X  IF ( me < 12 ) THEN
X    BEGIN
X      posn (5,20);
X      qio_writeln (VT100_bright+'Enter Your Name `5B Return to Leave `5D'+VT
V100_normal);
X    END;
XEND;
X
X`5BHIDDEN`5D
XPROCEDURE  Create_new_score_file ( directory : v_array; gamename : v_array;
V date_time : date_time_type );
XVAR
X  i : integer;
X  month_now : integer;
XBEGIN
X  month_now := date_time`5B2`5D;
X  OPEN(newfile,directory+gamename+'.ACN',new,,direct,error:=continue);
X  IF status(newfile) <> PAS$K_SUCCESS THEN
X    BEGIN
X      qio_writeln ('Can''t Create '+gamename+'.ACN Insufficient priviledge.'
V);
X      $exit(1);
X    END;
X  rewrite (newfile);
X  newfile`5E.tot_games := 0;
X  newfile`5E.month     := month_now;
X  FOR i := 1 to 12 do
X    BEGIN
X      newfile`5E.m_user`5Bi`5D := '        ';
X      newfile`5E.m_name`5Bi`5D := '            ';
X      newfile`5E.m_score`5Bi`5D := -maxint-1;
X    END;
X  FOR i := 0 to 19 do
X    BEGIN
X      newfile`5E.user`5Bi`5D := '        ';
X      newfile`5E.name`5Bi`5D := '            ';
X      newfile`5E.score`5Bi`5D := -maxint-1;
X    END;
X  newfile`5E.games := zero;
X  put (newfile);
X  close (newfile);
XEND;
X
X`5BHIDDEN`5D
XPROCEDURE  Update_Topten ( VAR current_state : everything;`20
X                            date_time : date_time_type;`20
X                            username : v_array;`20
X                            this_score : integer;`20
X                        VAR me : integer;`20
X                        VAR last_score : integer;`20
X                            newname : `5BTRUNCATE`5D s_array );
XVAR
X  i, j, k : integer;
X  old_name  : s_array;
X  old_games : integer;
X  month_now : integer;
XBEGIN
X  `7B high score for the month `7D
X  month_now := date_time`5B2`5D;
X
X  if not game_count_incremented then
X    current_state.tot_games := current_state.tot_games + 1;
X  IF ( current_state.month <> month_now ) and ( current_state.month <> 0 ) t
Vhen
X    BEGIN
X      if month_now > current_state.month then
X        FOR i := current_state.month to month_now-1 do
X          BEGIN
X            newfile`5E.m_user`5Bi`5D := '        ';
X            newfile`5E.m_name`5Bi`5D := '            ';
X            newfile`5E.m_score`5Bi`5D := -maxint-1;
X          END
X      else
X        BEGIN
X          FOR i := current_state.month to 12 do
X            BEGIN
X              newfile`5E.m_user`5Bi`5D := '        ';
X              newfile`5E.m_name`5Bi`5D := '            ';
X              newfile`5E.m_score`5Bi`5D := -maxint-1;
X            END;
X          IF month_now-1 >= 1 THEN
X            FOR i := 1 to month_now-1 do
X              BEGIN
X                newfile`5E.m_user`5Bi`5D := '        ';
X                newfile`5E.m_name`5Bi`5D := '            ';
X                newfile`5E.m_score`5Bi`5D := -maxint-1;
X              END;
X        END;
X      current_state.m_user`5Bcurrent_state.month`5D := current_state.user`5B
V0`5D;
X      current_state.m_name`5Bcurrent_state.month`5D := current_state.name`5B
V0`5D;
X      current_state.m_score`5Bcurrent_state.month`5D := current_state.score`
V5B0`5D;
X      FOR i := 0 to 19 do
X        BEGIN
X          current_state.user`5Bi`5D := '        ';
X          current_state.name`5Bi`5D := '            ';
X          current_state.score`5Bi`5D := -maxint-1;
X        END;
X      current_state.games := zero;
X    END;
X  current_state.month := month_now;
X
X`7B insert/find user somewhere `7D
X
X  i := 0;
X  WHILE ( i<19 ) and ( current_state.user`5Bi`5D<>username ) do
X    i := i + 1;
X  IF ( current_state.user`5Bi`5D<>username ) then
X    BEGIN
X      current_state.user`5Bi`5D := username;
X      current_state.name`5Bi`5D := '            ';
X      current_state.score`5Bi`5D := -maxint-1;
X      current_state.games`5Bi`5D := 1;
X    END
X  ELSE
X    if not game_count_incremented then
X      current_state.games`5Bi`5D := current_state.games`5Bi`5D + 1;
X  last_score := current_state.score`5Bi`5D;
X  me := i;
X
X`7B move user up `7D
X
X  IF this_score > current_state.score`5Bi`5D then
X    BEGIN
X      j := 0;
X      WHILE this_score <= current_state.score`5Bj`5D do
X        j := j + 1;
X      IF j < i then
X        BEGIN
X          old_name := current_state.name`5Bi`5D;
X          old_games := current_state.games`5Bi`5D;
X          FOR k := i downto j+1 do
X            BEGIN
X              current_state.user`5Bk`5D := current_state.user`5Bk-1`5D;
X              current_state.name`5Bk`5D := current_state.name`5Bk-1`5D;
X              current_state.score`5Bk`5D := current_state.score`5Bk-1`5D;
X              current_state.games`5Bk`5D := current_state.games`5Bk-1`5D;
X            END;
X          current_state.user`5Bj`5D := username;
X          current_state.name`5Bj`5D := old_name;
+-+-+-+-+-+-+-+-  END  OF PART 1 +-+-+-+-+-+-+-+-