-+-+-+-+-+-+-+-+ START OF PART 4 -+-+-+-+-+-+-+-+
X`5BEXTERNAL`5D
XPROCEDURE  Swap ( VAR i, j : integer );
XExtern;
X
X`5BEXTERNAL`5D
XPROCEDURE  TERMINATE ( code : integer := 1 );
XExtern;
X
X`5BEXTERNAL`5D
XPROCEDURE  Top_ten ( this_score : integer );
XExtern;
X
X`5BEXTERNAL`5D
XFUNCTION  Trim ( text : v_array ) : v_array;
XExtern;
X
X`5BEXTERNAL`5D
XFUNCTION  Upper_case ( c : char ) : char;
XExtern;
X   `20
X`5BEXTERNAL`5D
XFUNCTION  Upper_string ( text : v_array ) : v_array;
XExtern;
X
XEND.
$ CALL UNPACK INTERACT.PAS;1 543656189
$ create 'f'
X`09.title`09map`09map a file into memory
X
X`09$secdef
X
X
X`09.psect`09$$rwdata rd, wrt, noexe, rel, pic, con, noshr, long
X
X`09.align`09long
Xfab:
X`09$fab`09fac=<GET>, shr=<GET>, fop=<UFO>
X
X
X`09.psect`09$$code`09rd, nowrt, exe, rel, pic, con, shr, long
X
X`09.align`09long
Xinadr:
X`09.long`091, 1`09`09`09; map file into p0 space
X
X
X`09.entry`09-
Xmap_file, `5Em<r2, r3>
X;+
X;`09status = map_file ( file-name.descr, start-addr, end-addr )
X;
X;`09"status" is TRUE if operation was successful
X;`09"start-addr" and "end-addr" are LONGWORD integers
X;
X;`09Maps the specified file onto the end of virtual memory
X;-
X`09moval`09fab, r3
X`09movq`09@4(ap), r0`09`09; r0 = length, r1 = address
X`09movb`09r0, fab$b_fns(r3)`09; set file name size
X`09movl`09r1, fab$l_fna(r3)`09; set file name address
X`09$open`09fab=(r3)
X`09blbc`09r0, 100$`09`09; br if error
X
X`09subl2`09#8, sp`09`09`09; make room for retadr
X`09movl`09sp, r2`09`09`09; save address of retadr
X
X`09$crmpsc_s inadr=inadr, retadr=(r2), flags=#sec$m_expreg, -
X`09`09chan=fab$l_stv(r3)
X`09blbc`09r0, 100$`09`09; br if error
X
X`09movl`09(r2), @8(ap)`09`09; return start address
X`09movl`094(r2), @12(ap)`09`09; return end address
X100$:
X`09ret`09`09`09`09; with error in r0
X
X`09.end
$ CALL UNPACK MAP.MAR;1 1376456753
$ create 'f'
X`5B
X  Inherit
X    ('VT100','QIO_WRITE'),
X  Environment
X    ('POSN.PEN')
X`5D
X
XMODULE POSN;
X
X`5BHIDDEN`5D
XTYPE
X  v_array = varying `5B256`5D of char;
X
X`5BGLOBAL`5D
XPROCEDURE  Posn ( x , y : integer );
XVAR
X  sx,sy : v_array;
XBEGIN
X  IF ( x < 2 ) then
X    IF ( y < 2 ) then
X      qio_write ( VT100_ESC + '`5BH' )
X    ELSE
X      BEGIN
X        writev (sy,y:1);
X        qio_write ( VT100_ESC + '`5B' + sy + 'H' );
X      END
X  ELSE
X  IF ( y < 2 ) then
X    BEGIN
X      writev (sx,x:1);
X      qio_write ( VT100_ESC + '`5B;' + sx + 'H' );
X    END
X  ELSE
X    BEGIN
X      writev (sx,x:1);
X      writev (sy,y:1);
X      qio_write ( VT100_ESC + '`5B' + sy + ';' + sx + 'H' );
X    END;
XEND;
X
XEND.
$ CALL UNPACK POSN.PAS;1 1479307461
$ create 'f'
X`5B
X  Inherit
X    ('SYS$LIBRARY:STARLET','SYS$LIBRARY:PASCAL$LIB_ROUTINES','ERROR','DEBUG'
V),
X  Environment
X    ('QIO_READ.PEN')
X`5D
X
XMODULE QIO_READ;
X
X`5BHIDDEN`5D
XTYPE
X  $UWORD = `5BWORD`5D 0..65535;
X  $UBYTE = `5BBYTE`5D 0..255;
X  v_array = varying `5B256`5D of char;
X
X`5BHIDDEN`5DVAR
X`7BQIO`7D
X  efn                : `5BVOLATILE`5D unsigned;
X  channel            : $UWORD;
X  channel_initialized : Boolean;
X
X
X`5BHIDDEN`5D
XPROCEDURE  initialize_channel;
XVAR
X  ret_status : integer;
XBEGIN
X  if not debugger_initialized then
X    DBG_init;
X  channel_initialized := true;
X  lib$get_ef (efn);
X  IF efn = -1 then
X    ERROR ('%QIO-F-INITIALIZE, No Event Flag Avaliable.');
X  ret_status := $assign ( chan := channel , devnam := 'tt:' );
X  IF not odd(ret_status) then
X    LIB$SIGNAL(ret_status);
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  QIO_1_char_now : char;
XVAR
X  buffer : packed array `5B1..1`5D of char;
X  ret_status : integer;
XBEGIN
X  IF not channel_initialized then
X    initialize_channel;
X  IF debugger_on and not debugger_alone then
X    BEGIN
X      dbg`5E.request := 3;
X      dbg_call;
X      Qio_1_char_now := dbg`5E.dbg_qio_1_char_now;
X    END
X  ELSE
X    BEGIN
X      buffer`5B1`5D := chr(-1);
X      ret_status := $qiow ( efn:= efn,
X                           chan:= channel,
X                           func:= io$_readvblk+io$m_timed+io$m_noecho+io$m_n
Vofiltr,
X                             p1:= buffer,
X                             p2:= 1, `7B bufferlength `7D
X                             p3:= 0
X                           );
X      IF not odd(ret_status) then
X        LIB$SIGNAL(ret_status);
X      Qio_1_char_now := buffer`5B1`5D;
X    END;
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;
X  ret_status : integer;
XBEGIN
X  IF not channel_initialized then
X    initialize_channel;
X  IF debugger_on and not debugger_alone then
X    BEGIN
X      dbg`5E.request := 4;
X      dbg`5E.dbg_qio_readln_characters := characters;
X      dbg_call;
X      qio_readln := dbg`5E.dbg_qio_readln;
X    END
X  ELSE
X    BEGIN
X      ret_status := $qiow ( efn:= efn,
X                           chan:= channel,
X                           func:= io$m_timed+io$_readvblk+io$m_noecho+io$m_n
Vofiltr+io$m_escape,
X                           iosb:= read_iosb,
X                             p1:= temp.body,
X                             p2:= characters,
X                             p3:= 0
X                          );
X   `20
X      IF not odd(ret_status) then
X        LIB$SIGNAL(ret_status);
X   `20
X      temp.length := ( read_iosb.Nrbytes );
X      qio_readln := temp;
X    END;
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  QIO_1_char : char;
XVAR
X  buffer : packed array `5B1..1`5D of char;
X  ret_status : integer;
XBEGIN
X  IF not channel_initialized then
X    initialize_channel;
X  IF debugger_on and not debugger_alone then
X    BEGIN
X      dbg`5E.request := 1;
X      dbg_call;
X      Qio_1_char := dbg`5E.dbg_qio_1_char;
X    END
X  ELSE
X    BEGIN
X      ret_status := $qiow ( efn:= efn,
X                           chan:= channel,
X                           func:= io$_readvblk+io$m_noecho+io$m_nofiltr,
X                             p1:= buffer,
X                             p2:= 1
X                          );
X      IF not odd(ret_status) then
X        LIB$SIGNAL(ret_status);
X      Qio_1_char := buffer`5B1`5D;
X    END;
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE  QIO_purge;
XVAR
X  ret_status : integer;
XBEGIN
X  IF channel_initialized then
X    IF debugger_on and not debugger_alone then
X      BEGIN
X        dbg`5E.request := 5;
X        dbg_call;
X      END
X    ELSE
X      BEGIN
X        ret_status := $qiow ( efn:= efn,
X                             chan:= channel,
X                             func:= io$_readvblk+io$m_purge
X                            );
X        IF not odd(ret_status) then
X          LIB$SIGNAL(ret_status);
X      END;
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  QIO_1_char_timed ( delay : integer ) : char;
XVAR
X  buffer : packed array `5B1..1`5D of char;
X  ret_status : integer;
XBEGIN
X  IF not channel_initialized then
X    initialize_channel;
X  IF debugger_on and not debugger_alone then
X    BEGIN
X      dbg`5E.request := 6;
X      dbg`5E.dbg_qio_1_char_timed_delay := delay;
X      dbg_call;
X      Qio_1_char_timed := dbg`5E.dbg_qio_1_char_timed;
X    END
X  ELSE
X    BEGIN
X      buffer`5B1`5D := chr(255);
X      ret_status := $qiow ( efn:= efn,
X                           chan:= channel,
X                           func:=io$m_timed+io$_readvblk+io$m_noecho+io$m_no
Vfiltr+io$m_escape,
X                             p1:= buffer,
X                             p2:= 1,
X                             p3:= delay
X                           );
X      IF not odd(ret_status) then
X        LIB$SIGNAL(ret_status);
X      Qio_1_char_timed := buffer`5B1`5D;
X    END;
XEND;
X
XEND.
$ CALL UNPACK QIO_READ.PAS;1 108372840
$ create 'f'
X`5B
X  Inherit
X    ('QIO_WRITE','QIO_READ','VT100'),
X  Environment
X    ('QIO_READ_INTEGER.PEN')
X`5D
X
XMODULE QIO_READ_INTEGER;
X
X`5BHIDDEN`5D
XTYPE
X  $BIT8 = `5BBIT(8),UNSAFE`5D 0..255;
X  v_array = varying `5B256`5D of char;
X
X
X`5BHIDDEN`5D
XFUNCTION Digit ( ch : char ) : boolean;
XBEGIN
X  Digit := (ch >= '0') and (ch <= '9')
XEND;
X
X
X`5BHIDDEN`5D
XFUNCTION  Number ( str : v_array ) : integer;
XVAR
X  n : integer;
X  i : integer;
XBEGIN
X  n := 0;
X  IF str.length > 0 then
X    BEGIN
X      FOR i := 1+(str`5B1`5D='-')::$bit8 to str.length do
X        n := n * 10 + ord(str`5Bi`5D) - ord('0');
X      IF str`5B1`5D='-' then
X        n := -n;
X    END;
X  number := n;
XEND;
X
X
X`5BGLOBAL`5D
XFUNCTION  qio_read_integer : integer;
XVAR
X  n : integer;
X  c : char;
X  negative : boolean;
X  temp : v_array;
XBEGIN
X  temp := '';
X  n := number(temp);
X
X  c := qio_1_char;
X  REPEAT
X    IF ( c='-' ) then
X      BEGIN
X        qio_write (c);
X        temp := '-';
X        c := qio_1_char;
X      END;
X
X    REPEAT
X      IF Digit(c) and`20
X        ((( n <= (MAXINT-number(c)) div 10 ) and ( n >=0 )) or
X         (( n >= (-MAXINT+number(c)-1) div 10 ) and ( n < 0 ))) then
X        BEGIN
X          qio_write (c);
X          temp := temp + c;
X          n := number(temp);
X        END
X      ELSE
X      IF ( c = chr(127) ) and ( temp <> '' ) then
X        BEGIN
X          qio_write (VT100_bs+' '+VT100_bs);
X          temp.length := temp.length - 1;
X          n := number(temp);
X        END
X      ELSE
X        qio_write (VT100_bell);
X      c := qio_1_char;
X    UNTIL ( temp = '' ) or ( c = vt100_cr );
X  UNTIL ( temp <> '' );
X  qio_read_integer := number(temp);
X  qio_writeln;
XEND;
X
XEND.
$ CALL UNPACK QIO_READ_INTEGER.PAS;1 1042267000
$ create 'f'
X`5B
X  Inherit
X    ('QIO_WRITE','QIO_READ','VT100'),
X  Environment
X    ('QIO_READ_VARYING.PEN')
X`5D
X
XMODULE QIO_READ_VARYING;
X
X`5BHIDDEN`5D
XTYPE
X  v_array = varying `5B256`5D of char;
X
X`5BGLOBAL`5D
XFUNCTION  qio_read_varying ( chars : integer := 80 ) : v_array;
XVAR
X  c : char;
X  temp : v_array;
XBEGIN
X  temp := '';
X
X  c := qio_1_char;
X  IF c <> chr(13) then
X    REPEAT
X      IF ( c in `5B' '..'`7E'`5D ) and ( temp.length < chars ) then
X        BEGIN
X          qio_write (c);
X          temp := temp + c;
X        END
X      ELSE
X      IF ( c = chr(127) ) and ( temp.length <> 0 ) then
X        BEGIN
X          qio_write (VT100_bs+' '+VT100_bs);
X          temp.length := temp.length - 1;
X        END
X      ELSE
X        qio_write (VT100_bell);
X      c := qio_1_char;
X    UNTIL ( c = vt100_cr );
X  qio_read_varying := temp;
X  qio_writeln;
XEND;
X
XEND.
$ CALL UNPACK QIO_READ_VARYING.PAS;1 54537752
$ create 'f'
X`5B
X  Inherit
X    ('SYS$LIBRARY:STARLET','SYS$LIBRARY:PASCAL$LIB_ROUTINES','VT100','DEBUG'
V),
X  Environment
X    ('QIO_WRITE.PEN')
X`5D
X
XMODULE QIO_WRITE;
X
X`5BHIDDEN`5D
XTYPE
X  $UWORD = `5BWORD`5D 0..65535;
X  v_array = varying `5B256`5D of char;
X
X`5BHIDDEN`5D
XVAR
X  channel               : $UWORD;
X  channel_initialized    : boolean;
X
XVAR
X  qio_write_speed : integer := 0;   `7B never changed set with the debugger
V `7D
X
X`5BHIDDEN`5D
XPROCEDURE  initialize_channel;
XVAR
X  ret_status            : integer;
XBEGIN
X  if not debugger_initialized then
X    DBG_init;
X  channel_initialized := true;
X  ret_status := $assign ( chan := channel , devnam := 'tt:' );
X  IF not odd(ret_status) then
X    LIB$SIGNAL(ret_status);
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE  QIO_write ( text : v_array );
XVAR
X  ret_status            : integer;
XBEGIN
X  IF not channel_initialized then
X    initialize_channel;
X  IF debugger_on and not debugger_alone then
X    BEGIN
X      dbg`5E.request := 2;
X      dbg`5E.dbg_qio_write_speed := qio_write_speed;
X      dbg`5E.dbg_qio_write := text;
X      dbg_call;
X    END
X  ELSE
X    BEGIN
X      ret_status := $qiow (chan:= channel,
X                           func:= io$_writevblk,
X                             p1:= text.body,
X                             p2:= text.length
X                          );
X      IF not odd(ret_status) then
X        LIB$SIGNAL(ret_status);
X    END;
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE  QIO_writeln ( text : `5BTRUNCATE`5D v_array );
XBEGIN
X  IF present(text) then
X    QIO_write ( text );
X  QIO_write ( VT100_cr  + VT100_lf );
XEND;
X
XEND.
$ CALL UNPACK QIO_WRITE.PAS;1 138291532
$ create 'f'
X`5B
X  Inherit
X    ('SYS$LIBRARY:STARLET'),
X  Environment
X    ('RANDOM.PEN')
X`5D
X
XMODULE RANDOM;
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
XEND.
$ CALL UNPACK RANDOM.PAS;1 1059345098
$ create 'f'
X`5B
X  Inherit
X    ('SYS$LIBRARY:STARLET','RANDOM'),
X  Environment
X    ('RANDOMIZE.PEN')
X`5D
X
XMODULE RANDOMIZE;
X
X`5BHIDDEN`5D
XTYPE
X  r_number_pointer = `5Er_numbers;
X  r_numbers        = Record
X                       Number : integer;
X                       Next   : r_number_pointer;
X                     End;
X`5BHIDDEN`5D
XVAR
X  random_number_ub : integer;
+-+-+-+-+-+-+-+-  END  OF PART 4 +-+-+-+-+-+-+-+-