`L i=L\Ʃx ? N'i  ͭЅ?0ȱ Ѕ?iȱi lԠԠ͠ԠϠŠͮŠ SYSTEM.APPLE   L$JN^5npCHSET2r=vgprCHSET3r=vgrtCHSET4r=vgDtARTILLERY.TEXTg蠖 FORMAT.TEXTvg FORMAT.1.TEXTvgFORMAT.1.TEXTvgDPTH2.2 DATE.TEXTr=vg5 CONSOLE.TEXTvg( READVTOC.TEXTvg(:MICROMODEM.TEXTf:R TERMINAL.TEXTvg}RX LCFIX.TEXT=vgX\LCA.TEXTr=vg\l CHED.TEXTr=vglnCHSET1r=vg&꽌ɪɖ'*&%&,E'зЮ꽌ɪФ`+*xH&x'8*7Ixix&&  ') + &п x) ++`FG8`0($ p,&") (jJJ>L+ "?I>  N `  ` x V Nx .x- z `V0^*^*>` aI꽌ɪVɭ&Y&&Y& 꽌ɪ\8`& (********************************************) (* Listing #1: Demonstration of GETDATE *)  (* *)  (* Written by: David Geddes and Ron DeGroat *)  (* May, 1981 *)  (**********E); %DONE:=(LENGTH(CHANGE)=0); %IF NOT DONE THEN CHANGEDATE; #UNTIL DONE; #GETVOLDATE(DATE); !END; {getdate} ! !BEGIN {datedemo} #GETDATE(DATE); #WRITELN; #WRITELN(DATE); !END. {datedemo} &STR(DD,DAY); &STR(YY,YEAR); &DATE:=CONCAT(DAY,'-',COPY(MONTHS,3*MM,3),'-',YEAR); $END;  END; {getvoldate} ! !BEGIN {The heart of GETDATE} #REPEAT %GETVOLDATE(DATE); %WRITELN('Today is: ',DATE); {Volume Date} %WRITE('New date? '); %READLN(CHANGSKBLK2.VOLDATE.YY #ELSE NEWDATE.YY:=YY; # #SETDATE; {on disk and in memory} !  END; {changedate} ! !  PROCEDURE GETVOLDATE(VAR DATE:STRING);   VAR DAY,YEAR:STRING;   BEGIN "UNITREAD(4,DISKBLK2,512,2,0); "WITH DISKBLK2.VOLDATE DO $BEGIN TE.MM:=DISKBLK2.VOLDATE.MM #ELSE NEWDATE.MM:=MM; #  { Change year? }  #IF (DASH>0) AND (LENGTH(CHANGE)>DASH) THEN %BEGIN 'DELETE(CHANGE,1,DASH); 'YY:=INT(CHANGE) %END #ELSE YY:=DISKBLK2.VOLDATE.YY; ! IF (YY<0) OR (YY>99) #THEN NEWDATE.YY:=DI MONPART:=CHANGE (ELSE MONPART:=''; ! CASE LENGTH(MONPART) OF %0:MM:=DISKBLK2.VOLDATE.MM; %1,2:MM:=INT(MONPART); %3:MM:=POS(MONPART,MONTHS) DIV 3+POS(MONPART,UCMONTHS) +DIV 3+POS(MONPART,LCMONTHS) DIV 3; #END; ! IF (MM<1) OR (MM>12) #THEN NEWDA#THEN NEWDATE.DD:=DISKBLK2.VOLDATE.DD #ELSE NEWDATE.DD:=DD; ! IF DASH=0 THEN CHANGE:='' #ELSE DELETE(CHANGE,1,DASH); #  { Change month? } # #DASH:=POS('-',CHANGE); ! IF DASH>0 THEN MONPART:=COPY(CHANGE,1,(DASH-1)) #ELSE IF LENGTH(CHANGE)>0 THEN:=NEWDATE;  END; {setdate} # #  BEGIN {changedate} "  { Change day? }  #DASH:=POS('-',CHANGE); #CASE DASH OF %0:DD:=INT(CHANGE); %1:DD:=DISKBLK2.VOLDATE.DD; %2,3:DD:=INT(COPY(CHANGE,1,DASH-1)); #END; #IF (DD<1) OR (DD>31) OR (DASH>3) augsepoctnovdec'; &  VAR DASH:INTEGER; $MONPART:STRING; $NEWDATE:DATEREC; #  PROCEDURE SETDATE;   { Sets date on disk and in memory. }   BEGIN "DISKBLK2.VOLDATE:=NEWDATE; "UNITWRITE(4,DISKBLK2,512,2,0); "MEMDATE.LOC:=DATELOC; "MEMDATE.DATE^R I:=1 TO LENGTH(NUM) DO $X:=10*X+(ORD(NUM[I])-ORD('0')); "INT:=X;  END; {int} ! !  PROCEDURE CHANGEDATE;   { Changes date to user's specification }   CONST UCMONTHS='**JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'; &LCMONTHS ='**janfebmaraprmayjunjul$MEMDATE :MEMDATEREC; $DD,MM,YY :INTEGER; $CHANGE :STRING; $DONE :BOOLEAN; $ $  FUNCTION INT(NUM:STRING):INTEGER;   { Converts string to integer, works only for pos. values. }   VAR I,X:INTEGER; "  BEGIN {int} "X:=0; "FO= RECORD CASE INTEGER OF 41:(DATE:^DATEREC); 42:(LOC : INTEGER); 2END; {memdaterec} &  VAR DISKBLK2:RECORD /XXX : PACKED ARRAY[0..19] OF CHAR; /VOLDATE : DATEREC; /ZZZ : PACKED ARRAY[22..511] OF CHAR; -END; ( $NEWDATE :DATEREC; in the variable parameter. }   CONST MONTHS='**JanFebMarAprMayJunJulAugSepOctNovDec';  &DATELOC=-21992; { -22254 for version 1.0 } &  TYPE DATEREC = PACKED RECORD 1MM : 0..12; 1DD : 0..31; 1YY : 0..99; /END; {daterec} / %MEMDATEREC **********************************)   PROGRAM DATEDEMO;   VAR DATE:STRING;   PROCEDURE GETDATE(VAR DATE:STRING);   { Gets date and allows for update similar to the }  { D(ate option in the Filer. The date (in string }  { form) is returned N^ )BNE GET   STATUS ;Code for status )LDY #43.   GET LDA RETURN+1 ;Fix up stack so that standard driver )PHA ;routine returns directly to caller )LDA RETURN )PHA   GET1 ;ACJVAFLD contains a pointer to the copy T )INY )LDA @ACJVAFLD,Y )STA INDIRECT+1  LDY #0 )LDA #08 ;PHP )STA @INDIRECT,Y )INY )LDA #48 ;PHA )STA @INDIRECT,Y )INY )LDA #8A ;TXA )STA @INDIRECT,Y )LDA 0C083 ;Fold in bios  )LDY #7 )JSR FIXUP ;Status  );Now undo the patch to the standard CONCK routine (made by );SYSTEM.ATTACH) which causes it to branch to the start of  ;this driver )LDY #55. ;Get address of original CONCK )LDA @ACJVAFLD,Y )STA INDIRECde for init  );First patch bios jump vector so that write, init, and );status calls go direct to the standard console routines )LDA 0C08B ;Fold in interpreter )LDY #4 )JSR FIXUP ;Write )LDY #7 )JSR FIXUP ;Init )LDY #43. RDRTN ;keyboard characters )PHA )LDY #1 ;offset to address of the standard read routine )BNE GET1 ;in the copy of the jump vector made by 8;SYSTEM.ATTACH   WRITE ;Code for a write )LDY #4 )BNE GET   INIT ;Co ;No such I/O command )JMP RET   RETURN .WORD 0  TEMP1 .WORD 0  ROUTINE .WORD 0   READ ;Code for a read )LDA RDRTN+1 ;Fix up stack so that the standard read routine )PHA ;returns to READRTN so that we can filter )LDA )PLA ;Save caller's return address )STA RETURN )PLA )STA RETURN+1 )TXA ;Use X-reg to determine the type of call )BEQ READ )CMP #1 )BEQ WRITE )CMP #2 )BEQ INIT )CMP #4 )BEQ STATUS  LDX #3 D .EQU 0EE  ACJVAFLD .EQU 0E2  ).PROC CONSOLE  )JMP CONCKHDL ;SYSTEM.ATTACH will patch the start of CONCK 8;to jump here )STA TEMP1 ;All read, write, init, and stat calls will 8;jump here )STY TEMP1+1 {chr(92)}  ; ESC -> ESC  ; ESC ESC -> {caps-lock toggle}  ; ESC a -> A  ; : : -> :  ; ESC z -> Z  ;  ; The SYSTEM.ATTACH program is used to  ; install this driver.  ;  ;   INDIRECT .EQU 002  JVAFOLl {chr(127)}  ; ESC 7 or ' -> ` {chr(96)}  ; ESC 8 or ( -> { {chr(123)}  ; ESC 9 or ) -> } {chr(125)}  ; ESC , or < -> [ {chr(91)}  ; ESC . or > -> ] {chr(93)}  ; ESC - or = -> _ {chr(95)}  ; ESC / or ? -> \  ; Copyright (c) 1982 by Chris Wilson  ;  ; The special escape sequences supported  ; by this enhanced console driver are  ; listed in the table below:  ;  ; ESC 1 or ! -> | {chr(124)} ; ESC 2 or " -> ~ {chr(126)}  ; ESC 3 or # -> deof the );jump vector made by SYSTEM.ATTACH before );it was modified to attach this driver )LDA @ACJVAFLD,Y )STA ROUTINE )INY )LDA @ACJVAFLD,Y )STA ROUTINE+1 )LDY TEMP1+1 ;Restore registers )LDA TEMP1 )JMP @ROUTINE ;Go to the standard driver routine   FIXUP LDA @ACJVAFLD,Y )STA @JVAFOLD,Y )INY )LDA @ACJVAFLD,Y )STA @JVAFOLD,Y )RTS   RDRTN .WORD READRTN-1  ESRTN .WORD ESCRTN-1  CAPSLOCK .BYTE 0   TABLE1 .ASCII "12378O^)ADC #0 )STA ROUTINE+1 )JMP @ROUTINE  ).END ;Save state of machine )PHA )TXA )PHA )TYA )PHA )CLC ;Get address of CONCK )LDY #55. )LDA @ACJVAFLD,Y )ADC #6 ;Bump by 6 because of the patch made by 8;SYSTEM.ATTACH )STA ROUTINE )INY )LDA @ACJVAFLD,Y )AND #0DF ;Yes, shift to upper case   RET TAY ;Save A-reg )LDA RETURN+1 ;Fix up stack so that we can return to )PHA ;original caller )LDA RETURN )PHA )TYA ;Restore A-reg )RTS   CONCKHDL PHP RET ;in TABLE2  NOTSPCL CMP #01B ;ESC? )BNE NOTESC )LDA CAPSLOCK ;Yes, toggle capslock )EOR #0FF )STA CAPSLOCK )JMP READ ;Get next character   NOTESC CMP #061 ;Lower case? )BCC RET )CMP #07A+1 )BCS RET  ESCRTN LDY #TBLSIZE  CONVLOOP CMP TABLE1,Y ;Check character after ESC to see if it's  BEQ CHANGE ;one of the magic ones )DEY )BPL CONVLOOP )JMP NOTSPCL  CHANGE LDA TABLE2,Y ;Yes, substitute corresponding character )JMP case? )BCC RET )CMP #07A+1 )BCS RET )AND #0DF ;Yes, force to upper case )JMP RET  ESCKEY LDA ESRTN+1 ;Fix up stack so that standard read )PHA ;routine returns to ESCRTN )LDA ESRTN )PHA )LDY #1 )JMP GET1 TN CMP #01B ;ESC? )BEQ ESCKEY  LDY CAPSLOCK ;Capslock set? )BNE CHKLC )CMP #041 ;No, upper case? )BCC RET )CMP #05A+1 )BCS RET )ORA #020 ;Yes, force to lower case )JMP RET  CHKLC CMP #061 ;Lower 9,.-/"  .ASCII "!" ).BYTE 022 ).ASCII "#'()<>=?"  .ASCII " "  TABLE2 .BYTE 07C,07E,07F,060,07B,07D,05B,05D,05F,05C .BYTE 07C,07E,07F,060,07B,07D,05B,05D,05F,05C  .BYTE 01B  TBLSIZE .EQU *-TABLE2   READRProgram VTOC_READ;   CONST "VTOC_block = 136; (* Lower half of this block is VTOC sector *) "  TYPE "Sector = 0..15; "Track = 0..34;  Byte = 0..255; "Sector_bit = (In_use, free); "Track_bit_map = Packed Array[0.  -------------------------------------------------------------------- *) "Free_spaces := 0; "For Trk_num := 0 to 34 do $for Sec_num := 0 to 15 do &if VTOC.bit_map[Trk_num, Sec_num] = free (then Free_spaces := Free_spaces + 1; "Writeln (' F('*'); 'Writeln; $end; (* For sec_num loop *) "Write(' ');For Trk_num := 0 to 34 do write (Trk_num MOD 10);Writeln; "  (* -------------------------------------------------------------------- #Compute number of free sectors on disk and print it out#-------------------------------------------------------------------- *) "For Sec_num := 0 to 15 do # begin %Write(Sec_num:2,': '); %For Trk_num := 0 to 34 do 'If VTOC.bit_map[ Trk_num, Mapping_of(Sec_num) ] = free +then write('.') +else write); "Writeln; "Write(' << press any key for disk map and free space >>'); "Read(Dummy); Writeln; " "  (* -------------------------------------------------------------------- #Draw a map of disk showing sectors in use ); "Writeln('Number of tracks on disk :', VTOC.Tracks_on_disk); "Writeln('Number of sectors per track:', VTOC.Secs_per_track); "Writeln('Number of bytes per sector :', VTOC.Bytes_per_sec ); "Writeln('SIZE OF "VTOC" variable :', SIZEOF(VTOC) ); "Writeln('Directory starts at track :', VTOC.Dir_trk_start ); "Writeln('DOS release number is :', VTOC.DOS_release ); "Writeln('DISKETTE volume number :', VTOC.Volume_number ); "Writeln('Maximum T/S pairs in sector:', VTOC.Max_TS_pairs  (* -------------------------------------------------------------------- #Print out some information about the VTOC " -------------------------------------------------------------------- *) "Writeln('Directory starts at sector :', VTOC.Dir_sec_start rst 256 bytes of the input buffer into the VTOC variable #-------------------------------------------------------------------- *) "Unitread (Unit_num, Input_buffer, 512, Block); "Moveleft (Input_buffer[0], VTOC, 256); " " t_num := 5; (* I used drive 2, slot 6 for the DOS 3.3 disk *) "Block := VTOC_block; "  (* -------------------------------------------------------------------- #Read the block containing the VTOC sector into the Input Buffer and then #move the fi Sector; "Trk_num : Track; " $Function Mapping_of (To_be_mapped : Sector) : Sector; (Begin *If To_be_mapped < 8 -then Mapping_of := To_be_mapped + 8 -else Mapping_of := To_be_mapped - 8 (End; ( ( $  Begin (* MAIN PROGRAM *)  "Uni-Unused_G : Packed array [196..255] of byte; #End; (* VTOC structure *) #   VAR "Unit_num, "Block, "Free_spaces : Integer; "Dummy : Char; "VTOC : VTOC_structure; "Input_buffer : Block_buffer; "Sec_num : : Byte; -Unused_F : Packed array [40..47] of byte; -Mask_bytes : Track_bit_map; -Tracks_on_disk: Byte; -Secs_per_track: Byte; -Bytes_per_sec : Integer; -Bit_map : Disk_bit_map; yte; -Dir_Trk_start : Byte; -Dos_Release : Byte; -Unused_B : Packed Array [4..5] of byte; -Volume_number : Byte; -Unused_C : Byte; -Unused_D : Packed array [8..37] of byte; -Unused_E : Byte; -Max_TS_Pairs .31] of Sector_bit; "Disk_bit_map = Packed Array[0..34] of Track_bit_map; "Blockbuffer = Packed Array[0..511] of byte; " " "VTOC_structure= Packed Record -Unused_A : Byte; -Dir_sec_start : Bree Space on Disk = ', Free_spaces, ' Sectors'); "  End. N^FfNSMIT DATA REGISTER EMPTY *)  "BEGIN "TRANSEMPTY := MODEM.STATUS^.TDRE; "END;  "FUNCTION DCERROR; )(*=======*)  "(* TEST FOR DATA-COMM ERROR *)  "VAR $CH: CHAR; $COPY: STATUSWORD; " "BEGIN "COPY := MODEM.STATUS^; "WITH COPY DO $IF PE "BEGIN "CARRIER := NOT MODEM.STATUS^.DCDNOT; "END;  "FUNCTION RCVRFULL; " (*========*)  "(* TEST RECEIVE DATA REGISTER FULL *)  "BEGIN "RCVRFULL := MODEM.STATUS^.RDRF; "END;  "FUNCTION TRANSEMPTY; )(*==========*)  "(* TEST TRA&2: (STATUS: ^ STATUSWORD; *DATAIN: ^ WORD) &END;  "FUNCTION RINGING; )(*=======*)  "(* TEST RING INDICATION *)  "BEGIN "RINGING := NOT MODEM.STATUS^.RINOT; "END;  "FUNCTION CARRIER; )(*=======*)  "(* TEST FOR PRESENCE OF CARRIER *) MIT CONTROL *) &RIE: BOOLEAN (* RECEIVE INTERRUPT ENABLE *) &END; & "VAR  CONTROL: CONTROLWORD; $MODEM: PACKED RECORD &CASE INTEGER OF &0: (ADDRESS1: INTEGER; *ADDRESS2: INTEGER); &1: (CONTROL: ^ CONTROLWORD; *DATAOUT: ^ WORD); CT; 1 = ORIGINATE *) &CTS: BOOLEAN; (* CONTROLS CTS *) &ST: BOOLEAN; (* SELF TEST *) &FILLER1: 0..3; &OH: BOOLEAN; (* OFF HOOK *) &CDS: 0..3; (* COUNTER DIVIDE SELECT *) &WS: 0..7; (* WORD SELECT *) &TC: 0..3; (* TRANSRRUN *) &PE: BOOLEAN; (* PARITY ERROR *) &IRQ: BOOLEAN (* INTERRUPT REQUEST *) &END; $CONTROLWORD = PACKED RECORD &BRS: BAUDRATE; (* BIT RATE SELECT; 1 = 300 BAUD *) &TXE: BOOLEAN; (* TRANSMITTER ENABLE *) &MODES: MODE; (* MODE SELE&RDRF: BOOLEAN; (* RECEIVE DATA REGISTER FULL *) &TDRE: BOOLEAN; (* TRANSMIT DATA REGISTER EMPTY *) &DCDNOT: BOOLEAN; (* CARRIER DETECT NOT *) &CTSNOT: BOOLEAN; (* CTS NOT *) &FE: BOOLEAN; (* FRAMING ERROR *) &OVRN: BOOLEAN; (* RECEIVER OVEROCEDURE PUTREM(CH: CHAR); "PROCEDURE GETREM(VAR CH: CHAR);   IMPLEMENTATION " "TYPE $WORD = PACKED ARRAY [0..1] OF CHAR; $STATUSWORD = PACKED RECORD &FILLER1: 0..127; &RINOT: BOOLEAN; (* RING INDICATOR *) E SETRATE(BR: BAUDRATE); "PROCEDURE SETWORD(WORDSELECT: INTEGER); "PROCEDURE ENABLETRANSMIT; "PROCEDURE DISABLETRANSMIT; "PROCEDURE DISCONNECT; "PROCEDURE WAITFORCARRIER; "PROCEDURE DIAL(NUMBER: STRING); "PROCEDURE AUTOANSWER; "PROCEDURE BREAK; "PRIER: BOOLEAN; "FUNCTION RCVRFULL: BOOLEAN; "FUNCTION TRANSEMPTY: BOOLEAN; "FUNCTION DCERROR: BOOLEAN;  FUNCTION ESCAPE: BOOLEAN;  "PROCEDURE WAIT(TIME: INTEGER); "PROCEDURE INITCOMM(WORDSELECT: INTEGER); "PROCEDURE SETMODE(MD: MODE); "PROCEDUR(*$S+,I-,R-*)   (*$C COPYRIGHT 1981 BY CHRIS WILSON *)   UNIT MICROMODEM; INTRINSIC CODE 23 DATA 24;   INTERFACE  "USES APPLESTUFF; " "TYPE $BAUDRATE = (LOW, HIGH); $MODE = (ANSWER, ORIGINATE);  "FUNCTION RINGING: BOOLEAN; "FUNCTION CAROR OVRN OR FE OR CTSNOT OR DCDNOT THEN " BEGIN &DCERROR := TRUE; &(* CLEAR RECEIVER *) &CH := MODEM.DATAIN^[0]; &END $ELSE &DCERROR := FALSE; "END;  "FUNCTION ESCAPE; )(*======*) " "(* TEST FOR KEYBOARD ESCAPE *)  "CONST $ESC = 27; " "VAR $CH: CHAR; " "BEGIN "IF KEYPRESS THEN $BEGIN $READ(KEYBOARD,CH); $ESCAPE := (CH = CHR(ESC)); $END "ELSE $ESCAPE := FALSE; "END;  "PROCEDURE INITCOMM; (* WORDSELECT: INTEGER *) *(*========*)  "(* RESET AND INITIALIZE ACIA *)  "==*)  "(* WAIT FOR RING & THEN ANSWER THE PHONE *)  "BEGIN "IF NOT CONTROL.OH THEN $BEGIN $WRITELN(' ABORTS AUTO ANSWER'); $REPEAT &WRITE('WAITING FOR RING...'); &REPEAT (IF ESCAPE THEN *BEGIN *WRITELN; *WRITELN('>>> ABORTED <<<'); *DT := 10; (WAIT(600); (FOR J := 1 TO DIGIT DO *BEGIN *HANGUP; *WAIT(61); *PICKUP; *WAIT(39); *END; (END &ELSE IF NUMBER[I] = '*' THEN (WAIT(2000); &END; $WRITELN; " WAITFORCARRIER; $END; "END; "PROCEDURE AUTOANSWER;  (*========$FOR I := 1 TO LENGTH(NUMBER) DO &BEGIN &IF ESCAPE THEN (BEGIN (WRITELN('>>> ABORTED <<<'); (DISCONNECT; (EXIT(DIAL); (END; &WRITE(NUMBER[I]); &IF NUMBER[I] IN ['0'..'9'] THEN (BEGIN (DIGIT := ORD(NUMBER[I])-ORD('0'); (IF DIGIT = 0 THEN *DIGIIGIT: INTEGER;  "BEGIN "IF NOT(CONTROL.OH) AND (LENGTH(NUMBER) <> 0) THEN $BEGIN $WRITELN(' ABORTS AUTO DIAL'); $WRITE('PREPARING TO DIAL...'); $SETMODE(ORIGINATE); $PICKUP; $WAIT(1400); $WRITELN('OK'); $WRITE('DIALING...'); ); " CH := MODEM.DATAIN^[0] "UNTIL CARRIER OR ESCAPE OR (WAIT > 30000); "IF NOT CARRIER THEN $DISCONNECT; "END; " "PROCEDURE DIAL; (* NUMBER: STRING *)  (*====*)  "(* DIAL THE INDICATED NUMBER *)  "VAR  CH: CHAR; $I, $J, $D $DUMMY := 2; $END; "END;  "PROCEDURE WAITFORCARRIER; *(*==============*)  "(* WAIT FOR CARRIER *)  "VAR $CH: CHAR; $WAIT: INTEGER;  "BEGIN "WRITELN('WAITING FOR CARRIER...'); "ENABLETRANSMIT; "WAIT := 0; "REPEAT " WAIT := SUCC(WAIT$WAIT := SUCC(WAIT); " CH := MODEM.DATAIN^[0]; $END; "END; " "PROCEDURE WAIT; (* TIME: INTEGER *) *(*====*) " "(* WAIT "TIME" MILLISECONDS *) " "VAR $I, $DUMMY: INTEGER; " "BEGIN "FOR I := 1 TO TIME DO " BEGIN $DUMMY := 0; $DUMMY := 1;DEM.CONTROL^ := CONTROL; "END;  "PROCEDURE DISCONNECT; *(*==========*)   (* BREAK CONNECTION *)  "VAR $CH: CHAR; $WAIT: INTEGER; " "BEGIN "DISABLETRANSMIT; "HANGUP; "WAIT := 0; "WHILE CARRIER AND (WAIT < 5000) DO $BEGIN ROL; "END;  "PROCEDURE PICKUP; *(*======*)   (* PLACE PHONE OFF-HOOK *) " "BEGIN "CONTROL.OH := TRUE; "MODEM.CONTROL^ := CONTROL; "END; "PROCEDURE HANGUP; *(*======*)   (* PLACE PHONE ON-HOOK *) " "BEGIN "CONTROL.OH := FALSE; "MOTURN ON THE MODEM TRANSMITTER *)  "BEGIN "CONTROL.TXE := TRUE; "MODEM.CONTROL^ := CONTROL; "END; "PROCEDURE DISABLETRANSMIT; *(*===============*)  "(* TURN OFF THE MODEM TRANSMITTER *)  "BEGIN "CONTROL.TXE := FALSE; "MODEM.CONTROL^ := CONT"PROCEDURE SETWORD; (* WORDSELECT: INTEGER *) *(*=======*)  "(* SET THE WORD LENGTH, PARITY, AND STOP BITS *)  "BEGIN "CONTROL.WS := WORDSELECT MOD 8; "MODEM.CONTROL^ := CONTROL; "END; " "PROCEDURE ENABLETRANSMIT; *(*==============*)  "(* "BEGIN "CONTROL.MODES := MD; "MODEM.CONTROL^ := CONTROL; "END; "PROCEDURE SETRATE; (* BR: BAUDRATE *) *(*=======*)  "(* SET THE BAUD RATE *)  "BEGIN "CONTROL.BRS := BR; "MODEM.CONTROL^ := CONTROL; "END;  NATE; $CTS := TRUE; $ST := FALSE; $FILLER1 := 0; $OH := FALSE; $CDS := 1; $WS := WORDSELECT MOD 8; $TC := 0; $RIE := FALSE; " END; "MODEM.CONTROL^ := CONTROL; "END;  "PROCEDURE SETMODE; (* MD: MODE *) *(*=======*)  "(* SET THE MODE *)  VAR $WAIT: INTEGER;  "BEGIN "CONTROL.CDS := 3; (* MASTER RESET *) "MODEM.CONTROL^ := CONTROL; "WAIT := 0; "REPEAT $WAIT := SUCC(WAIT) "UNTIL NOT(CARRIER) OR (WAIT > 5000); "WITH CONTROL DO $BEGIN $BRS := HIGH; $TXE := FALSE; $MODES := ORIGIISCONNECT; *EXIT(AUTOANSWER); *END &UNTIL RINGING; &WRITELN('OK'); &SETMODE(ANSWER); &PICKUP; &WAITFORCARRIER $UNTIL CARRIER; " END; "END;  "PROCEDURE BREAK; *(*=====*) " "(* SENDS BREAK FOR 250 MILLISECONDS *) " "VAR $CH: CHAR; " "BEGIN "CONTROL.TC := 3; "MODEM.CONTROL^ := CONTROL; "WAIT(250); "CONTROL.TC := 0; "MODEM.CONTROL^ := CONTROL; "(* NOW CLEAR ERRORS *) "WAIT(10); "CH := MODEM.DATAIN^[0]; "END;  "PROCEDURE PUTREM; (* CH: CHAR *) *(*======*)   (* SEND CHAITE('^',CHR(ORD('@')+ORD(CH))) ELSE WRITE(BADCH); END; PROCEDURE TEACH; (*=====*) BEGIN GOTOXY(0,3); WRITELN('THIS PROGRAM TURNS THE APPLE ][ INTO'); WRITELN('A SMART TERMINAL. WHILE YOU ARE CON-'); WRITELN('NECTED TO THE REMOTE COMPUTER, ALL *====*) BEGIN (* SHORT BELL TO AVOID MISSING ANYTHING *) NOTE(24,2); END; PROCEDURE DISPLAY(CH: CHAR); (*=======*) BEGIN IF CH = BEL THEN BELL ELSE IF CH = CR THEN WRITELN ELSE IF CH IN DISPLAYABLE THEN WRITE(CH) ELSE IF CH < ' ' THEN WR VAR I: INTEGER; FUNCTION UPCHAR(CH: CHAR): CHAR; BEGIN IF CH IN ['a'..'z'] THEN UPCHAR := CHR(ORD('A')+(ORD(CH)-ORD('a'))) ELSE UPCHAR := CH; END; BEGIN FOR I := 1 TO LENGTH(S) DO S[I] := UPCHAR(S[I]); END; PROCEDURE BELL; ( (*======*) BEGIN IF CH IN ['a'..'z'] THEN CH := CHR(ORD('A')+(ORD(CH)-ORD('a'))); END; PROCEDURE UPSTRING(VAR S: STRING); (*========*) PACKED ARRAY [0..1] OF 0..255; FREEUNION = RECORD CASE INTEGER OF 0: (ADDR: INTEGER); 1: (VALUE: ^ WORD) END; VAR MEMORY: FREEUNION; BEGIN MEMORY.ADDR := ADDRESS; PEEK := MEMORY.VALUE^[0]; END; PROCEDURE UPCHAR(VAR CH: CHAR); NUL, BEL, BS, LF, CR, ESC, DEL, ANSWR: CHAR; XMITDELAY, WORDSELECT: INTEGER; BR: BAUDRATE; WAITFORLF, HALFDUPLEX: BOOLEAN; DISPLAYABLE: PACKED SET OF CHAR; FUNCTION PEEK(ADDRESS: INTEGER): INTEGER; (*====*) TYPE WORD = (*$S+*) (*$C COPYRIGHT 1981 BY CHRIS WILSON *) (* NUMEROUS IMPROVEMENTS MADE AT THE SUGGESTION OF BILL GORD *) PROGRAM TERMINAL; USES APPLESTUFF, MICROMODEM; CONST BADCH = '?'; DCERRORCH = '!'; TYPE LINE = STRING[100]; VAR CTRLB, CTRLX, NOT(RCVRFULL) AND (WAIT < 5000) DO &WAIT := SUCC(WAIT); $IF RCVRFULL THEN &CH := MODEM.DATAIN^[0]; " END; "END;  "(* ========== INITIALIZATION ========== *)  "BEGIN "MODEM.ADDRESS1 := -16219; "MODEM.ADDRESS2 := -16217; "END. ] := CH; " END; "END;  "PROCEDURE GETREM; (* VAR CH: CHAR *) *(*======*)  " "(* GET CHAR FROM THE MODEM *)  "VAR $WAIT: INTEGER; $ "BEGIN "IF MODEM.STATUS^.RDRF THEN $CH := MODEM.DATAIN^[0] "ELSE $BEGIN $WAIT := 0; $WHILE CARRIER ANDR TO THE MODEM *)  "VAR $WAIT: INTEGER; $ "BEGIN "IF MODEM.STATUS^.TDRE THEN $MODEM.DATAOUT^[0] := CH "ELSE $BEGIN $WAIT := 0; $WHILE CARRIER AND NOT(TRANSEMPTY) AND (WAIT < 5000) DO &WAIT := SUCC(WAIT); $IF TRANSEMPTY THEN &MODEM.DATAOUT^[0OF'); WRITELN('THE STANDARD PASCAL CONTROL COMMANDS'); WRITELN('(E.G. CTRL-A, CTRL-@, CTRL-F) WILL WORK'); WRITELN('AS THEY NORMALLY DO, INCLUDING THE'); WRITELN('LOWERCASE COMMANDS.'); WRITELN; WRITELN('SPECIAL KEYS IN TERMINAL MODE:'); WRITELN; WRITELN(' SENDS BREAK TO THE REMOTE'); WRITELN(' COMPUTER.'); WRITELN; WRITELN(' SENDS DEL (RUBOUT) TO THE'); WRITELN(' REMOTE COMPIALUP; (*======*) VAR NUMBER: STRING; BEGIN PAGE(OUTPUT); GOTOXY(0,5); WRITELN('ENTER THE PHONE NUMBER.'); WRITELN; WRITE(' --> '); READLN(NUMBER); IF LENGTH(NUMBER) = 0 THEN EXIT(TERMINAL); PAGE(OUTPUT); GOTOXY(0,5); INITCOMM(WORDSELECT) READ(CH); UPCHAR(CH); PAGE(OUTPUT); IF NOT(CH IN ['B','D','R','T','W']) THEN HELP ELSE CASE CH OF 'B': SETBAUDRATE; 'D': SETDELAY; 'T': SETTOGGLES; 'W': SETWORDSELECT; END; (* CASE *) UNTIL CH = 'R'; END; PROCEDURE DWRITELN; WRITELN('W(ORD SELECTS CHARACTER LENGTH,'); WRITELN(' PARITY, AND NUMBER OF STOP'); WRITELN(' BITS.'); END; BEGIN (* SETUP *) PAGE(OUTPUT); HELP; REPEAT GOTOXY(0,0); WRITE('SETUP: B(AUD, D(ELAY, R(ETURN, T(OGGLES, W(ORD '); (WHICH IMPLIES THE APPLE IS'); WRITELN(' TREATED AS A TELETYPE DEVICE).'); WRITELN; WRITELN('R(ETURN EXITS SETUP MODE.'); LAY SELECTS TRANSMIT DELAY.'); WRITELN; WRITELN('T(OGGLES SELECTS HALF OR FULL DUPLEX'); WRITELN(' AND WHETHER THE REMOTE COMPUTER'); WRITELN(' SENDS LINEFEED AFTER SENDING OR'); WRITELN(' RECEIVING A CARRIAGE RETURN'); WRITELN(' ); WRITELN; WRITE('WORD SELECTION: '); READLN(WS); IF WS IN [0..7] THEN BEGIN WORDSELECT := WS; SETWORD(WORDSELECT); END; END; PROCEDURE HELP; (*====*) BEGIN GOTOXY(0,3); WRITELN('B(AUD SELECTS 110 OR 300 BAUD.'); WRITELN; WRITELN('D(EWRITELN(' 7 ODD 2 1'); WRITELN(' 7 EVEN 1 2'); WRITELN(' 7 ODD 1 3'); WRITELN(' 8 NONE 2 4'); WRITELN(' 8 NONE 1 5'); WRITELN(' 8 EVEN 1 6'); WRITELN(' 8 ODD 1 7'P WORD '); WRITELN('LENGTH BIT BITS SELECT'); WRITELN('---------------------------'); WRITELN(' 7 EVEN 2 0'); /N): '); READ(CH); UPCHAR(CH); WRITELN; WAITFORLF := CH = 'Y'; END; PROCEDURE SETWORDSELECT; (*=============*) VAR WS: INTEGER; BEGIN GOTOXY(0,1); WRITELN('CURRENT WORD SELECTION: ', WORDSELECT:1); WRITELN; WRITELN; WRITELN('CHAR PARITY STOELN('FULL DUPLEX'); IF WAITFORLF THEN WRITELN('WAIT FOR LINEFEED AFTER RETURN') ELSE WRITELN('NO LINEFEED AFTER RETURN'); WRITELN; WRITE('HALF DUPLEX (Y/N): '); READ(CH); UPCHAR(CH); WRITELN; HALFDUPLEX := CH = 'Y'; WRITELN; WRITE('WAIT FOR LINEFEED (YWRITELN; WRITE('TRANSMIT DELAY: '); READLN(XMITDELAY); END; PROCEDURE SETTOGGLES; (*==========*) VAR CH: CHAR; BEGIN GOTOXY(0,5); WRITELN('CURRENT TOGGLES:'); WRITELN('----------------'); IF HALFDUPLEX THEN WRITELN('HALF DUPLEX') ELSE WRITLSE BR := LOW; SETRATE(BR); END; END; PROCEDURE SETDELAY; (*========*) BEGIN GOTOXY(0,5); WRITELN('CURRENT TRANSMIT DELAY: ', XMITDELAY:1); VAR RATE: INTEGER; BEGIN GOTOXY(0,5); IF BR = HIGH THEN WRITELN('CURRENT BAUD RATE: 300') ELSE WRITELN('CURRENT BAUD RATE: 110'); WRITELN; WRITE('BAUD RATE: '); READLN(RATE); IF RATE IN [110, 300] THEN BEGIN IF RATE = 300 THEN BR := HIGH EUTER.'); WRITELN; WRITELN(' ENTERS ESCAPE MODE WHICH'); WRITELN(' ALLOWS PROGRAM OPTIONS TO BE'); WRITELN(' CHANGED, ETC.'); END; PROCEDURE SETUP; (*=====*) VAR CH: CHAR; PROCEDURE SETBAUDRATE; (*===========*) ; SETRATE(BR); DIAL(NUMBER); END; PROCEDURE TELETYPE; (*========*) VAR CH: CHAR; PROCEDURE ESCAPE; (*======*) TYPE PAGEP = ^TEXTPAGE; TEXTPAGE = PACKED ARRAY [0..1023] OF CHAR; FREEUNION = RECORD CASE INTEGER OF 1: (ADDR: INTEGER); 2: (P: PAGEP) END; VAR CH: CHAR; SAVEX, SAVEY: INTEGER; PAGE1, PAGE2, SAVE1, SAVE2: PAGEP; MEM IF CARRIER THEN BEGIN GOTOXY(0,5); WRITELN('CARRIER OK, RESUME COMMUNICATIONS.'); TELETYPE; END ELSE BEGIN GOTOXY(0,5); WRITE('DEFAULT SETUP (Y/N): '); READ(ANSWR); UPCHAR(ANSWR); WRITELN; IF ANSWR <> 'Y' ITFORLF := TRUE; HALFDUPLEX := TRUE; DISPLAYABLE := [BEL,BS,LF,CR,' '..CHR(126)]; PAGE(OUTPUT); WRITELN('TERMINAL (6/25/81, 5:45 PM)'); WRITELN('COPYRIGHT 1981 BY CHRIS WILSON'); WRITELN; WRITELN('"T" WHEN CONNECTED FOR USEFUL INFORMATION.'); REPEAT PAGE(OUTPUT); END; (* ========== MAIN BODY ========== *) BEGIN CTRLB := CHR(2); CTRLX := CHR(24); NUL := CHR(0); BEL := CHR(7); BS := CHR(8); LF := CHR(10); CR := CHR(13); ESC := CHR(27); DEL := CHR(127); WORDSELECT := 5; BR := HIGH; XMITDELAY := 250; WAWRITE('NO CARRIER. TRY AGAIN (Y/N): '); READ(ANSWR); UPCHAR(ANSWR); WRITELN; TRYAGAIN := ANSWR = 'Y'; UNTIL ANSWR IN ['Y', 'N']; THEN REPEAT GETREM(CH) UNTIL (CH = LF) OR NOT CARRIER; END; END; END; DISCONNECT; UNITCLEAR(1); END; FUNCTION TRYAGAIN: BOOLEAN; (*========*) VAR ANSWR: CHAR; BEGIN REPEAT PAGE(OUTPUT); GOTOXY(0,5); BREAK ELSE IF CH = ESC THEN ESCAPE ELSE BEGIN IF HALFDUPLEX THEN BEGIN IF CH = BS THEN WRITE(BS, ' ', BS) ELSE DISPLAY(CH) END; PUTREM(CH); IF (CH = CR) AND WAITFORLF REPEAT GETREM(CH) UNTIL (CH = LF) OR NOT CARRIER; END; IF KEYPRESS THEN BEGIN READ(KEYBOARD, CH); IF EOLN(KEYBOARD) THEN CH := CR ELSE IF CH = CTRLX THEN CH := DEL; IF CH = CTRLB THEN GETREM(CH); IF CH = NUL THEN BEGIN (* IGNORE *) END ELSE DISPLAY(CH); IF (CH = CR) AND WAITFORLF THEN ONE & TWO *) PAGE1^ := SAVE1^; PAGE2^ := SAVE2^; (* DISPLAY CURSOR IN RIGHT PLACE *) WRITE(' ', BS); RELEASE(SAVE1); END; BEGIN (* TELETYPE *) WHILE CARRIER DO BEGIN IF RCVRFULL THEN IF DCERROR THEN WRITE(DCERRORCH) ELSE BEGIN OF 'H': BEGIN DISCONNECT; EXIT(TELETYPE); END; 'Q': EXIT(TERMINAL); 'S': SETUP; 'T': TEACH; END; (* CASE *) UNTIL CH = 'R'; (* FIRST GO TO OLD X & Y LOCATIONS *) GOTOXY(SAVEX,SAVEY); (* THEN RESTORE TEXT PAGESSAVEX := PEEK(244); SAVEY := PEEK(245); PAGE(OUTPUT); HELP; REPEAT GOTOXY(0,0); WRITE('ESCAPE: H(ANGUP, Q(UIT, R(ETURN, S(ETUP, T(EACH '); READ(CH); UPCHAR(CH); PAGE(OUTPUT); IF NOT(CH IN ['H','Q','R','S','T']) THEN HELP ELSE CASE CH PAGE2 := MEMORY.P; NEW(SAVE1); NEW(SAVE2); (* SAVE APPLE TEXT PAGES ONE & TWO *) SAVE1^ := PAGE1^; SAVE2^ := PAGE2^; (* SAVE CURRENT X & Y LOCATIONS *) WRITELN; WRITELN('S(ETUP ENTERS SETUP MODE WHICH ALLOWS'); WRITELN(' PROGRAM OPTIONS TO BE CHANGED.'); WRITELN; WRITELN('T(EACH DISPLAYS HELPFUL INFORMATION.'); END; BEGIN (* ESCAPE *) MEMORY.ADDR := 1024; PAGE1 := MEMORY.P; MEMORY.ADDR := 2048;ORY: FREEUNION; PROCEDURE HELP; (*====*) BEGIN GOTOXY(0,3); WRITELN('H(ANGUP BREAKS THE CONNECTION.'); WRITELN; WRITELN('Q(UIT EXITS THE PROGRAM LEAVING THE'); WRITELN(' PHONE CONNECTED.'); WRITELN; WRITELN('R(ETURN EXITS ESCAPE MODE.');THEN BEGIN PAGE(OUTPUT); SETUP; END; DIALUP; IF CARRIER THEN BEGIN PAGE(OUTPUT); GOTOXY(0,5); WRITELN('CARRIER OK, BEGIN COMMUNICATIONS.'); TELETYPE; END; END UNTIL NOT TRYAGAIN; DISCONNECT; END. 39. ( (LDA RAMCLR ;SELECT 1ST BANK (RTS ( (.END .EQU 0DAAB  RAMON .EQU 0C083  RAMCLR .EQU 0C088 ( (LDA RAMON ;SELECT 2ND 4K BANK (LDA RAMON ;WRITE-ENABLE ( (LDA #176. ;SUPPRESS UC CONVERSION (STA ADDR1 (LDA #02. (STA ADDR1+1 (LDA #0 ;DISABLE PSEUDO UC (STA ADDR1+2(RTS  ; (.PROC LCA (  ;THIS PROCEDURE MODIFIES PASCAL 1.1 BIOS IN  ;MEMORY SO THAT LOWERCASE CHARACTERS CAN BE  ;DISPLAYED WITH A LOWERCASE ADAPTER. THIS  ;FIX WILL ONLY WORK FOR PASCAL 1.1.   ;WRITTEN BY DAVE LIEBERMAN 12-JUN-81   ADDR1 FLASH ;NO PARAMETERS  ;  ;PROCEDURE FLASH;  -----------------  ;  ;FLASH DISPPLAYS CHARACTERS BLINKING  ;BETWEEN INVERSE AND NORMAL MODES.  ; (LDA 0C083 (LDA 0C083 (LDA #40 (STA 0DAB0 ;SET BIT 6 (LDA 0C088 ;NO PARAMETERS  ;  ;PROCEDURE NORMAL;  ;-----------------  ;  ;NORMAL DISPLAYS CHARACTERS IN WHITE ON BLACK  ;VIDEO  ;  LDA 0C083 (LDA 0C083 (LDA #80 (STA 0DAB0 ;SET BIT 7 (LDA 0C088 (RTS  ;  ; (.PROC DISPLAYS (;CHARACTERS IN BLACK ON WHITE VIDEO. (; 0LDA 0C083 ;SELECT 2ND 4K BANK 0LDA 0C083 ;WRITE ENABLE 0LDA #00 0STA 0DAB0 ;CLEAR BITS 6 & 7 0LDA 0C088 ;SELECT 1ST BANK & WRITE PROTECT 0RTS  ;  ; (.PROC NORMAL (.PROC INVERSE ;NO PARAMETERS ( (;PROCEDURE INVERSE; (;------------------ (; (;THE NEXT THREE SUBROUTINES PROVIDE PASCAL (;WITH THE ABILITY TO DISPLAY INVERSE, (;NORMAL, OR FLASHING CHARACTERS IN THE (;NORMAL APPLE TEXT WINDOW. INVERSE N^vN^ARSET= PACKED ARRAY[0..127] OF CHARIMAGE;   VAR CURRENTSET:CHARSET; %CURRENTCH :CHARIMAGE; %CHARFILE :FILE OF CHARSET; %DISKIO,I,OLD,H,V,OLDH,OLDV:INTEGER; %CHOICE:CHAR; %ONE:BOOLEAN; $  PROCEDURE PRINTAT(X,Y:INTEGER; S:STRING);  BEGIN "MOVET *)  (* BY... Dean Rosenhain *)  (* *)  (*************************************)   USES TURTLEGRAPHICS;   TYPE BITS = 0..7; %BYTE = SET OF BITS; %CHARIMAGE= PACKED ARRAY[0..7] OF BYTE; %CH PROGRAM CHARED;  (*************************************)  (* *)  (* HI-RES CHARACTER *)  (* EDITOR *)  (* VERSION 2.2.1 *)  (* N^fProgram LcaPatch;   Procedure Lca; External;   (* Lca must be linked in to LcaPatch *)   Begin "Lca; "Gotoxy(8,8); "Write('Pascal 1.1 with lowercase display');  End. O(X,Y); "WSTRING(S);  END; $  PROCEDURE INPUT(X,Y:INTEGER;VAR S:STRING);   (* This procedure allows input of *)  (* strings on the graphics screen. The *)  (* ability to backspace over mistakes *)  (* is supported. *)    VAR TEMP :STRING; $S1 :STRING[1]; $CH :CHAR;  BEGIN #TEMP:=''; #S1:=' '; #MOVETO(X,Y); #REPEAT &READ(KEYBOARD,CH); &IF CH IN ['!'..'Z'] THEN &BEGIN (WCHAR(CH); (S1[1]:=CH; (TEMP:=CONCAT(NCOLOR(WHITE); (MOVETO(268,79+J*10); (PENCOLOR(NONE); $END; $ $FOR J:= 1 TO 6 DO $BEGIN (MOVETO(199+J*10,79); (PENCOLOR(WHITE); (MOVETO(199+J*10,159); (PENCOLOR(NONE); $END; $ $CLEARFIELD; $ $H:=0; V:=0; $CROSSHAIR(H,V); $OLDH:=H; OLDV:=V;LD:=0; I:=0; $HILITE(I,WHITE); $ $MOVETO(199,79); (* DRAW SQUARE *) $PENCOLOR(WHITE); $MOVETO(268,79); $MOVETO(268,159); $MOVETO(199,159); $MOVETO(199,79); $PENCOLOR(NONE); $ $FOR J:= 1 TO 7 DO (* DRAW GRID *) $BEGIN (MOVETO(199,79+J*10); (PE"EXPAND(CURRENTCH);  END; "  PROCEDURE SETUP;  VAR J:INTEGER;  BEGIN $INITTURTLE; $ $PRINTAT(0,180,'Pascal SYSTEM.CHARSET Editor version 2'); $PRINTAT(155,170,'by D. Rosenhain'); $PRINTAT(0,160,'Current Set:'); (* NONE *) $ $DISPLAYSET; $ $OTO 7 DO #FOR DOT:= 0 TO 6 DO $BEGIN &MOVETO(200+DOT*10,80+ROW*10); &IF DOT IN CH[ROW] THEN WCHAR(CHR(1)) 'ELSE WCHAR(' '); $END;  END; (* EXPAND *) "  PROCEDURE CLEARFIELD;  VAR ROW:0..7;  BEGIN "FOR ROW:=0 TO 7 DO #CURRENTCH[ROW]:=[]; X*10,83+Y*10); "TURNTO(0); "PENCOLOR(REVERSE); "MOVE(4); "PENCOLOR(NONE); "MOVETO(203+X*10,81+Y*10); "TURNTO(90); "PENCOLOR(REVERSE); "MOVE(4); "PENCOLOR(NONE);  END;   PROCEDURE EXPAND(CH:CHARIMAGE);  VAR ROW,DOT:0..7;  BEGIN "FOR ROW:= 0 *(LETTER MOD 16)+3,149-(LETTER DIV 16)*10); "PENCOLOR(COLOR); "TURNTO(0); "FOR I:=1 TO 4 DO "BEGIN $MOVE(10); (*draw a square *) $TURN(90); "END; "PENCOLOR(NONE);  END; "  PROCEDURE CROSSHAIR(X,Y:INTEGER);  BEGIN "PENCOLOR(NONE); "MOVETO(201+%CLOSE(CHARFILE,LOCK); %PRINTAT(90,160,' '); %PRINTAT(90,160,FILENAME); #END "ELSE DISKERROR(DISKIO);  (*$I+*)  END;   PROCEDURE HILITE(LETTER:INTEGER; COLOR:SCREENCOLOR);  VAR I:INTEGER;  BEGIN "PENCOLOR(NONE); "MOVETO(10 '); "IF LENGTH(FILENAME)<1 THEN EXIT(FILEOUT); "IF FILENAME='*' THEN FILENAME:='SYSTEM.CHARSET';  (*$I-*) "REWRITE(CHARFILE,FILENAME); "DISKIO:=IORESULT; "IF DISKIO=0 THEN #BEGIN %CHARFILE^:=CURRENTSET; %PUT(CHARFILE); HARFILE^; &CLOSE(CHARFILE,LOCK); &DISPLAYSET; &PRINTAT(90,160,' '); &PRINTAT(90,160,FILENAME); $END;  (*$I+*)  END;   PROCEDURE FILEOUT;  VAR FILENAME:STRING;  BEGIN "INPUT(101,12,FILENAME); "PRINTAT(101,12,' AT(101,27,' '); $IF LENGTH(FILENAME)=0 THEN EXIT(FILEIN); $IF FILENAME='*' THEN FILENAME:='SYSTEM.CHARSET';  (*$I-*) $RESET(CHARFILE,FILENAME); $DISKIO:=IORESULT; $IF DISKIO<>0 THEN DISKERROR(DISKIO) $ELSE $BEGIN &CURRENTSET:= C"WRITELN(CHR(7)); "FOR TIME:= 1 TO 3000 DO (* nothing *); "CHARTYPE(10); (* Normal mode *) "WRITELN(CHR(7)); "PRINTAT(10,2,' ');  END; $  PROCEDURE FILEIN;  VAR FILENAME:STRING;  BEGIN $INPUT(101,27,FILENAME); $PRINTNTEGER);  VAR S:STRING; !TIME:INTEGER;  BEGIN "CHARTYPE(5); (* INVERSE MODE *) "IF ERR IN [6,7,10] THEN #PRINTAT(10,2,'bad filename, not available.') "ELSE $BEGIN &STR(ERR,S); &S:=CONCAT('disk error # ',S); &PRINTAT(10,2,S); $END; " Y:INTEGER;  BEGIN "X:=10*(NUM MOD 16)+5; "Y:=150-(NUM DIV 16)*10; "DRAWBLOCK(CURRENTSET[NUM],1,0,0,7,8,X,Y,10);  END;   PROCEDURE DISPLAYSET;  VAR NUM:INTEGER;  BEGIN $FOR NUM:= 0 TO 127 DO $ SHOWCHAR(NUM);  END;   PROCEDURE DISKERROR(ERR:ITEMP,S1); &END &ELSE (IF (ORD(CH)=8) AND (LENGTH(TEMP)>0) THEN (BEGIN *DELETE(TEMP,LENGTH(TEMP),1); *MOVETO(TURTLEX-7,Y); *WCHAR(' '); *MOVETO(TURTLEX-7,Y); (END; #UNTIL CH=CHR(32); #S:=TEMP;  END; $  PROCEDURE SHOWCHAR(NUM:INTEGER);  VAR X, $ONE:=TRUE; $ $CHARTYPE(5); $PRINTAT(0,60,'Commands:'); $CHARTYPE(10); $PRINTAT(90,60,' for more....');  END;   PROCEDURE MENU1;  BEGIN $VIEWPORT(0,279,0,59); $FILLSCREEN(BLACK); $ $CHARTYPE(5); $PRINTAT(0,44,'select char:'); $ $CHARTYPE(10); $PRINTAT(0,30,'W: up'); $PRINTAT(0,20,'Z: down'); $PRINTAT(0,10,'A: left'); $PRINTAT(0, 0,'S: right'); $ $CHARTYPE(5); $PRINTAT(100,44,'To edit:'); $ $CHARTYPE(10); $PRINTAT(100,30,'I: up'); $PRINTAT(100,20,'M: down'); $PRINTAT(<5)"!!!?! """"!!"""""???!!9!!!!?!!!8!  !?!!!--3!!!1)%#!!!!!!!!.)!!!! !!! !>!!!!!! !!!!3--!!!!! !!"""?  ? "??( <12#.) *>*> ?  !#-1!> ? !!  !? ?!!!?!!!! >!!   !AAAAAA@@@@@@@@@@@@@@UUUUUUUU66[[66[[66mm66mmI$I$II$I$I$A]]]]AOOOAAAyyyAAAAAA>6>>*>**}yqaAACGO_>cUIIUc>>A]kIUA>wwcwwAUwcwU>>>>>>*? ><>{:> .#!#.1!1. ?!$ .11.!!!#    ****"""""""## .11.# >$.1!!! !!!6**""! ! .1!!? ?0I<5)"!!!?! """"!!"""""???!!9!!!!?!!!8!  !?!!!--3!!!1)%#!!!!!!!!.)!!!! !!! !>!!!!!! !!!!3--!!!!! !!"""?  ? "??( <12#.) *>*> ? !#-1!> ? !!  !? ?!!!?!!!! >!!  !F))F""" '@    <: $$$% !?!! "R  ! . "#   !! ((*|"" !!| > #***b#***I6IIIA"c""AA"|  *>~0~0I0IIF CHOICE IN ['I','J','K','M'] THEN &BEGIN (CROSSHAIR(OLDH,OLDV); (CROSSHAIR(H,V); (OLDH:=H; OLDV:=V; &END; & &IF CHOICE IN ['W','A','S','Z'] THEN &BEGIN (HILITE(OLD,BLACK); (HILITE(I,WHITE); (OLD:=I; &END; ( $UNTIL CHOICE='Q';  END. V); +END; + ''N':BEGIN -CURRENTCH[V]:=CURRENTCH[V]-[H]; -MOVETO(200+H*10,80+V*10); -WCHAR(' '); -CROSSHAIR(H,V); +END; + ''I':V:=(V+1) MOD 8; ' ''M':V:=(V+8-1) MOD 8; ' ''J':H:=(H+7-1) MOD 7; ' ''K':H:=(H+1) MOD 7; + &END(* CASE *); & &I); +END; ' ''R':BEGIN -IF ONE THEN MENU2; -FILEIN; -ONE:=FALSE; +END; ' ''T':BEGIN -IF ONE THEN MENU2; -FILEOUT; -ONE:=FALSE; +END; ' ''Y':BEGIN -CURRENTCH[V]:=CURRENTCH[V]+[H]; + MOVETO(200+H*10,80+V*10); -WCHAR(CHR(1)); -CROSSHAIR(H,''Z':I:= (I+16) MOD 128; + ''W':I:= (I+128-16) MOD 128; + ''G':BEGIN -CURRENTCH:=CURRENTSET[I]; -EXPAND(CURRENTCH); -CROSSHAIR(H,V); +END; + ''C':BEGIN -CLEARFIELD; -CROSSHAIR(H,V); +END; ' ''P':BEGIN -CURRENTSET[I]:=CURRENTCH; -SHOWCHAR(  BEGIN (* MAIN PROGRAM *) $SETUP; $MENU1; $REPEAT 'READ(KEYBOARD,CHOICE); 'CASE CHOICE OF '' ':BEGIN -IF ONE THEN MENU2 4ELSE MENU1; -ONE:= NOT ONE; +END; , ''A':I:= (I+128-1) MOD 128; + ''S':I:= (I+1) MOD 128; + GIN $VIEWPORT(0,279,0,59); $FILLSCREEN(BLACK); $MOVETO(0,40); $PRINTAT(0,40,'Q:exit T:save set R:load set'); $PRINTAT(10,24,'File to load:....................'); $PRINTAT(10,9,'File to save:....................'); $VIEWPORT(0,279,0,191);  END;  100,10,'J: left'); $PRINTAT(100, 0,'K: right'); $PRINTAT(175,40,'Y: plot'); $PRINTAT(175,30,'N: no plot'); $PRINTAT(175,20,'C: clear'); $PRINTAT(175,10,'G: grab'); $PRINTAT(175, 0,'P: push'); $VIEWPORT(0,279,0,191);  END; $  PROCEDURE MENU2;  BE.#!#.1!1. ?!$ .11.!!!#    ****"""""""## .11.# >$.1!!! !!!6**""! ! .1!!? ? 6>60HH06>>*>**"*6">""> $88>>>>>>*? ><>{:> VAR (CH : CHAR; (LEFT_PLAYER, (RIGHT_PLAYER : STRING[10]; (WIND_DIRECTION : STRING[12]; (HIT,LEFT_SHOT, (RIGHT_SHOT, (CONTACT : BOOLEAN;  DIFFICULTY : LEVEL_OF_PLAY; (WIND, (LEFT_SCORE, (RIGHT_SCORE, (HILL_POS159; (BOTTOM = 32; (WINDOW = -16301;  TYPE (BYTE = 0..255; (PAB = PACKED ARRAY[0..1] OF BYTE; (MULTITYPE = RECORD 1CASE INTEGER OF 41 : (INT:INTEGER); 42 : (PTR:^PAB); 43 : (DPTR:^INTEGER) 1END;  LEVEL_OF_PLAY = (EASY,HARD); {$S+}   PROGRAM ARTILLERY;   {$C Copyright 1981 by David Miller }  {$C 79 Hawley Ave, Port Chester, }  {$C N.Y. 10573 (914)-939-8955 }   USES TURTLEGRAPHICS, APPLESTUFF, TRANSCEND;    CONST (GRAVITY = 32.2 ; (PI = 3.14N^V8 ?'''??999? ?#?$<> ?99?####?    ++++7####??###??''? ?99?#??0?? ?####33!!7++##3 3> ?###?8?   0yO<5)"111?!!??####???#####????##;?###?!!! 3331!?333--3!333+%#!?333!!??!!?/+#!!?3?!!??00??~?###!!!33!!!!3--33333  >"""? 0?>>p8> 66666h 37;s/+ 80 0 I>>>>I ? ??8p?###!!? >0000?0000 ??##!!?000>"">   0 < !?6>60HH0~>>>( @`PP`@  @@((*|>6>>*>**"*6">""> $88>>>>>>*? ><>{:>      **    **  ((        ""*6"    **""  >>          ITION, (HILL_HEIGHT, (HILL_WIDTH, (HILL_LEFT, (HILL_RIGHT, (LEFTEL, (RIGHTEL, (LEFT_POSITION, (RIGHT_POSITION : INTEGER; (SINE, COSINE, (VELOCITY, (WIND_FACTOR, (ANGLE : REAL;    PROCEDURE POKE(ADDR:INTEGER;VALUE:BYTE);  VAR LOCAL:MULTITYPE;  BEGIN "LOCAL.INT := ADDR; "LOCAL.PTR^[0] := VALUE  END; { POKE }    FUNCTION RAND(LOW, HIGH:INTEGER):INTEGER;  VAR MX, Z, D:INTEGER;  BEGIN "Z := HIGH - LOW+1; "MX := (MAXINT-HIGH+LOW) DIV Z+1; "MX := MX*(HIGH-LOW)ne on each side of'); "WRITELN('the hill.'); "WRITELN; "WRITE ('Hit any key to go on to the next page.'); "READ(CH);  END; { HELP1 }    PROCEDURE HELP2;  BEGIN "PAGE(OUTPUT); "WRITELN('Each of you will shoot by entering the'); "WRITELN('velo near'); "WRITELN('the middle of the screen. The height of'); "WRITELN('the terrain on each side of the hill'); "WRITELN('will fluctuate. Each player is a small,'); "WRITELN('bitten apple which magically falls some-'); "WRITELN('where on the screen, o"WRITELN('antagonist will alternate taking shots'); "WRITELN('at each other, hampered by the various'); "WRITELN('randomly generated terrains. The Apple'); "WRITELN('will produce hills of varying heights'); "WRITELN('and widths, placing them somewhere the screen !!! That sounds like fun,'); "WRITELN('doesn''t it? Please read on...');  WRITELN; "WRITELN('Each game consists of a number of diff-'); "WRITELN('ferent "rounds", in which you and your'); ure (1200 bytes) }    PROCEDURE HELP1;  BEGIN "TEXTMODE; "PAGE(OUTPUT); "WRITELN('Welcome to ARTILLERY, a battle to the'); "WRITELN('death between two ferocious players. The'); "WRITELN('object is simple: to blast your opponent'); "WRITELN('offPOSITION(11,29);WCHAR(CHR(1)); "POSITION(9,15); WSTRING('Do you want'); "POSITION(10,14); WSTRING('Instructions ?'); "READ(CH);  END; { SPLASHPAGE }    { Instructions are split into 2 procedures because of }  { limitations on the size of a proced"POSITION(5,16); WSTRING('ARTILLERY'); "POSITION(6,19); WSTRING('by:'); "POSITION(7,15); WSTRING('David Miller'); "{ Draw 4 Apples in display corners. } "POSITION(4,11); WCHAR(CHR(1)); POSITION(4,29); WCHAR(CHR(1));  POSITION(11,11);WCHAR(CHR(1)); ;BOTY:=0; "FOR I:=1 TO 11 DO $BEGIN &FOR J:=1 TO 2 DO (BEGIN *BOX(BLUE,TOPX,TOPY,BOTX,BOTY); *TOPX:=TOPX+1; BOTX:=BOTX-1; *TOPY:=TOPY-1; BOTY:=BOTY+1; (END; { J LOOP } &TOPX:=TOPX+2; BOTX:=BOTX-2; &TOPY:=TOPY-2; BOTY:=BOTY+2; $END; { I LOOP } "BEGIN $PENCOLOR(NONE); TURNTO(0); MOVETO(UPPERX,UPPERY); $PENCOLOR(COLOR); $MOVETO(LOWERX,UPPERY);MOVETO(LOWERX,LOWERY); $MOVETO(UPPERX,LOWERY);MOVETO(UPPERX,UPPERY); "END; { BOX }   BEGIN { SPLASHPAGE } "INITTURTLE; "TOPX:=0;TOPY:=191;BOTX:=279GE;  VAR TOPX,TOPY,BOTX,BOTY, $I, J : INTEGER;  "PROCEDURE POSITION(ROW,COLUMN:INTEGER); "BEGIN $PENCOLOR(NONE); $MOVETO(COLUMN*7-2,184-ROW*12); "END; { HI-RES POSITION } " "PROCEDURE BOX(COLOR:SCREENCOLOR;UPPERX,UPPERY,LOWERX,LOWERY:INTEGER); "VELOCITY := VELOCITY * FACTOR; "SINE := SIN(ANGLE*PI/180); "COSINE := COS(ANGLE*PI/180);  END; { CONVERT }    { Draw a fancy opening page for the program }  { on the hi-res screen. Prompt for instructions. }    PROCEDURE SPLASHPA',OPER)); %CH:=OPER[1]; %IF CH='-' THEN VL:=-VL;VAL:=VL;  END; { VAL }    FUNCTION AT(ROW, COL:INTEGER):CHAR;  BEGIN "GOTOXY(COL, ROW); "AT := CHR(4);  END; { AT }    PROCEDURE CONVERT;  CONST FACTOR=13;  BEGIN PER); VAL:=0; "IF IL=0 THEN EXIT(VAL); "FOR I:=1 TO IL DO "BEGIN $CH:=OPER[I]; %IF NOT (CH IN NUM) THEN I:=IL+1 %ELSE &IF (CH<>'.') AND (CH<>'-') AND (CH<>'+') &THEN VL:=VL*10+ORD(CH)-48; "END; "IF POS('.',OPER)>0 THEN %VL:=VL/PWROFTEN(IL-POS('.+(MX-1); "REPEAT $D := RANDOM "UNTIL D <= MX; "RAND := LOW+D MOD Z  END; { RAND }    FUNCTION VAL(OPER:STRING):REAL;  VAR IL,I:INTEGER;  NUM :SET OF CHAR; $VL :REAL; $CH :CHAR;  BEGIN "NUM:=['.','-','+','0'..'9']; "VL:=0; IL:=LENGTH(Ocity (1-16) and angle (0-140 deg) of'); "WRITELN('elevation of the shot as 2 numbers,to be'); "WRITELN('separated by a comma. They may have dec-'); "WRITELN('imal values. Hopefully, your shot will'); "WRITELN('soar over the hill and destroy your'); "WRITELN('opponent. But there are other problems..'); "WRITELN; "WRITELN('A random wind is generated for each new'); "WRITELN('round. It varies in intensity from 0 to'); "WRITELN('40 and in direction from left to right.'); "WRITELN('You''ll need to lSIN(ANGLE+INCREMENT);  PRESENT_HEIGHT := HILL_HEIGHT*SIN(ANGLE); &DELTA := NEXT_HEIGHT - PRESENT_HEIGHT;  LEFT := TRUNC(HILL_LEFT + I); &RIGHT:= TRUNC(HILL_RIGHT - I);  IF PRESENT_HEIGHT < LEFTEL THEN LEFT := 0; &IF PRESENT_HEIGHT '; "HILL_HEIGHT := RAND(50,140); "HILL_POSITION := RAND(100,170); "HILL_WIDTH := RAND(45,140); "HILL_LEFT := HILL_POSITION - (HILL_WIDTH DIV 2); "HILL_RIGHT := HILL_POSITION + (HILL_WIDTH DIV 2);  LEFTEL := RAND(10,al preference. }    PROCEDURE SETUP;  BEGIN "PAGE(OUTPUT); "HIT := FALSE; "RANDOMIZE; "WIND := RAND(0,40); "WIND_FACTOR := WIND * 1.2; "IF RAND(0,10) <= 5 THEN #WIND_DIRECTION:= '<-To Left--' ELSE #WIND_DIRECTION:= '--To END; { ENDGAME }    { Set all random variables for the next round }  { of play, including wind, hill, and player }  { positions. The ranges for random numbers can }  { be altered, within limits, to fine-tune the }  { game to your own personT_SCORE>RIGHT_SCORE THEN WRITELN(AT(12,14),LEFT_PLAYER,' WINS!') ! ELSE ! IF RIGHT_SCORE>LEFT_SCORE THEN WRITELN(AT(12,14),RIGHT_PLAYER,' WINS!') #ELSE WRITELN(AT(12,14),'Tie Game!');  WRITE(AT(14,14),'Another game ? '); READ(CH); nents. }    PROCEDURE END_GAME;  BEGIN "TEXTMODE; "PAGE(OUTPUT); "WRITELN(AT(6,14),'Final Score:'); "WRITELN(AT(7,14),'============'); "WRITELN(AT(9,14),LEFT_PLAYER,':',LEFT_SCORE); "WRITELN(AT(10,14),RIGHT_PLAYER,':',RIGHT_SCORE); "IF LEF (CH='N') OR (CH='n') THEN DIFFICULTY:=EASY $ELSE DIFFICULTY:=HARD; "WRITE(AT(15,8),'[ Hit any key to start ]'); "GOTOXY(60,10); "READ(CH);  END; { GET_NAMES }    { Display final games stats, option to start }  { another game with different oppo$WRITE(AT(10,8),'Player 1 ? '); $READLN(LEFT_PLAYER); "UNTIL LENGTH(LEFT_PLAYER)>0; "REPEAT $WRITE(AT(11,8),'Player 2 ? '); $READLN(RIGHT_PLAYER); "UNTIL LENGTH(RIGHT_PLAYER)>0; "WRITE(AT(13,11),'Play with wind ?'); "GOTOXY(60,10); READ (CH); "IF screen. Makes sure that each }  { does something other than hitting RETURN. }    PROCEDURE GET_NAMES;  BEGIN "TEXTMODE; "PAGE(OUTPUT); "WRITELN(AT(7,8),'Please enter your names:'); "WRITELN(AT(8,8),'========================'); "REPEAT the game, enter -9 for the angle.'); "WRITELN('Good luck, & may the best Apple win !!!'); "WRITELN; "WRITE ('Hit any key to start the game...'); "READ(CH);  END; { HELP2 }    { Input the player names for display at the top }  { of the graphicsower your angle to'); "WRITELN('counterract a strong wind blowing in'); "WRITELN('your face, and raise your angle when the'); "WRITELN('wind is behind you. In fact, you might'); "WRITELN('even have to shoot backwards !!!'); "WRITELN; "WRITELN('To end RIGHTEL THEN RIGHT := 279; &FOR J := 0 TO TRUNC (DELTA) DO (BEGIN *PENCOLOR(NONE); *MOVETO(LEFT,TRUNC(PRESENT_HEIGHT)+J+BOTTOM); *PENCOLOR(GREEN); *MOVETO(RIGHT,TRUNC(PRESENT_HEIGHT)+J+BOTTOM); (END; &ANGLE := ANGLE + INCREMENT; $END;  END; { DRAW_SCREEN }    { Display player names, scores, and wind data }  { at the top of the screen. A little Apple is }  { dropped on each side of the hill. }    PROCEDURE SET_DISPLAY;  CONST (DELAY =20;  VAR (WIND_STR, (SCORE(1); (TURNTO(180); MOVE(1); (TURNTO(270); MOVE(1); (TURNTO(360); MOVE(1); &END; $NOTE(1,1); $TIME := TIME + DELTA; "UNTIL CONTACT; "IF ((LEFT_SHOT) AND (X>=RIGHT_POSITION-1) AND &(X<=RIGHT_POSITION+8) AND (Y<=RIGHTEL+9) AND &(Y>=RIGHTEL)) "OR ( (X > SCREEN_RIGHT) &THEN EXIT (PLOT_TRAJECTORY); $IF (SCREENBIT(X,Y) OR SCREENBIT(X+1,Y)) & AND (Y<175) THEN CONTACT := TRUE; $FOR I := 0 TO 1 DO &BEGIN (PENCOLOR(NONE); (MOVETO(X,Y); (PENCOLOR(REVERSE); (TURNTO( 0); MOVE(1); (TURNTO( 90); MOVE&INITIAL_Y := RIGHTEL + HEIGHT_ADJUST; &INITIAL_X := RIGHT_POSITION; &XVELOCITY := - ABS(VELOCITY); $END; "TIME := 0; "CONTACT := FALSE; "REPEAT $X := TRUNC(X_POSITION(TIME)); $Y := TRUNC(Y_POSITION(TIME)); $IF (X < SCREEN_LEFT) ORLOT_TRAJECTORY } "IF WIND_DIRECTION = '<-To Left--' THEN WIND_FACTOR := - ABS(WIND_FACTOR); "IF LEFT_SHOT THEN $BEGIN &INITIAL_Y := LEFTEL + HEIGHT_ADJUST; &INITIAL_X := LEFT_POSITION; $ XVELOCITY := VELOCITY; $END "ELSE $BEGIN ION := INITIAL_Y + (VELOCITY * SINE $* TIME - (GRAVITY*SQR(TIME)/2)); "END; { Y_POSITION } " "FUNCTION X_POSITION (TIME:REAL):REAL; "BEGIN $X_POSITION := INITIAL_X+3+((XVELOCITY * COSINE $+ WIND_FACTOR ) * TIME); "END; { X_POSITION }   BEGIN { PLEFT = 0; (SCREEN_RIGHT = 279; (DELTA = 0.04; (HEIGHT_ADJUST = 9;  VAR (X, Y, I, CLICK,  INITIAL_Y, (INITIAL_X : INTEGER;  TIME, XVELOCITY : REAL;  "FUNCTION Y_POSITION (TIME:REAL):REAL; "BEGIN $Y_POSIT { indicates we've hit something. Then check to }  { see what we've hit. If it's ground, make a }  { crater and redraw the Apple. If it's a hit, }  { set HIT to true so PLAY will explode it. }    PROCEDURE PLOT_TRAJECTORY;  CONST (SCREEN_EGIN &MOVETO(XPOS,YPOS); &TURNTO(RAND(0,359)); &MOVE(RADIUS); &NOTE(1,1); $END;  END; { CRATER }    { Calculate the trajectory points using a pair }  { of functions, until the SCREENBIT function } ke a little crater where a missed shot has }  { hit the ground, clicking to sound the blast. }    PROCEDURE CRATER(XPOS,YPOS,RADIUS:INTEGER);  VAR I : INTEGER;  BEGIN "PENCOLOR(NONE); "MOVETO(XPOS,YPOS); "PENCOLOR(BLACK); "FOR I:=1 TO 17 DO $BEFT_SCORE,SCORE_STR); "MOVETO(0,183); WSTRING(CONCAT(LEFT_PLAYER,':',SCORE_STR)); "STR(RIGHT_SCORE,SCORE_STR); "MOVETO(255-LENGTH(RIGHT_PLAYER)*7,183); "WSTRING(CONCAT(RIGHT_PLAYER,':',SCORE_STR)); "POKE (WINDOW,0);  END; { SET DISPLAY }    { Ma"WCHAR(CHR(1)); "FOR J:=1 TO 5 DO $BEGIN &NOTE(1,1); $ FOR K:=1 TO 60 DO; $END; "IF DIFFICULTY=HARD THEN $BEGIN &STR(WIND,WIND_STR); &MOVETO(112,183); WSTRING(CONCAT('WIND ',WIND_STR)); &MOVETO(98,175); WSTRING(WIND_DIRECTION); " END; "STR(LON,I-1) AND (NOT SCREENBIT(RIGHT_POSITION+1,I-1) DO $BEGIN &I := I-1; &MOVETO(RIGHT_POSITION,I); &WCHAR(CHR(1)); &FOR J := 1 TO DELAY DO; &MOVETO(RIGHT_POSITION,I); &WCHAR(CHR(1)); $END; "MOVETO(RIGHT_POSITION,I); "RIGHTEL := I; )); &FOR J := 1 TO DELAY DO; &MOVETO(LEFT_POSITION,I); &WCHAR(CHR(1)); $END; "MOVETO(LEFT_POSITION,I); "LEFTEL := I; "WCHAR(CHR(1)); "FOR J:=1 TO 5 DO $BEGIN &NOTE(1,1); $ FOR K:=1 TO 60 DO; $END; "I := 184; "WHILE NOT SCREENBIT(RIGHT_POSITI_STR : STRING;  I,J,K : INTEGER;  BEGIN "I := 184; "PENCOLOR(NONE); "CHARTYPE(6); "WHILE NOT SCREENBIT(LEFT_POSITION,I-1) AND (NOT SCREENBIT(LEFT_POSITION+1,I-1) DO $BEGIN &I := I-1; &MOVETO(LEFT_POSITION,I); &WCHAR(CHR(1(RIGHT_SHOT) AND (X>=LEFT_POSITION-1) AND &(X<=LEFT_POSITION+8) AND (Y<=LEFTEL+9) AND &(Y>=LEFTEL)) "THEN HIT := TRUE;  IF NOT HIT THEN $BEGIN &CRATER(X,Y+2,5);  PENCOLOR(NONE); CHARTYPE(10); &IF LEFT_SHOT THEN MOVETO(RIGHT_POSITION,RIGHTEL) (ELSE MOVETO(LEFT_POSITION,LEFTEL); &WCHAR(CHR(1)); { Redraw the Apple if slightly damaged }  END;  END; { PLOT_TRAJECTORY }    { Explode by flashing the Apple between inverse }  { and normalN^P; (IF DIFFICULTY=EASY THEN WIND_FACTOR:=0; (DRAW_SCREEN; (SET_DISPLAY; (PLAY; &UNTIL ANGLE = -9; { END GAME } " END_GAME; "UNTIL (CH = 'N') OR (CH = 'n'); { END PROGRAM }  PAGE(OUTPUT);  END.  PLAY }     BEGIN { Main ARTILLERY Controller } "SPLASHPAGE; "IF (CH = 'Y') OR (CH = 'y') THEN $BEGIN &HELP1; &HELP2; $END; "REPEAT $LEFT_SCORE := 0; $RIGHT_SCORE:= 0; $LEFT_SHOT := FALSE; $RIGHT_SHOT := TRUE; $GET_NAMES; &REPEAT (SETU(VELOCITY := VAL(VEL_STR); ANGLE := VAL(ANG_STR); (IF ANGLE = -9 THEN EXIT(PLAY); &UNTIL (VELOCITY>0) AND (ANGLE>0) AND ,(VELOCITY<16) AND (ANGLE<140); &CONVERT; &PLOT_TRAJECTORY; $END; "UNTIL HIT; "EXPLODE; "UPDATE_SCORE; "COUNTDOWN;  END; { T:= NOT RIGHT_SHOT; &IF LEFT_SHOT THEN LEFT := 0 ELSE LEFT := 26; &REPEAT (WRITE(AT(23,LEFT),'V,A> '); (READLN(INPUT); (COMMA:=POS(',',INPUT); (VEL_STR:=COPY(INPUT,1,COMMA-1); (ANG_STR:=COPY(INPUT,COMMA+1,LENGTH(INPUT)-COMMA); someone enters an angle of }  { -9 to end the game and possibly start again }    PROCEDURE PLAY;  VAR (LEFT, (COMMA : INTEGER;  INPUT, (VEL_STR, (ANG_STR : STRING;  BEGIN "REPEAT $BEGIN &LEFT_SHOT := NOT LEFT_SHOT; &RIGHT_SHO  VIEWPORT(0,279,0,191);  END; { COUNTDOWN }    PROCEDURE UPDATE_SCORE;  BEGIN "IF LEFT_SHOT THEN LEFT_SCORE := LEFT_SCORE +1 "ELSE RIGHT_SCORE := RIGHT_SCORE+1;  END;    { Controls all procedures for play of a game. }  { Continues until BEGIN "VIEWPORT(0,279,170,191); "FILLSCREEN(BLACK); "PENCOLOR(NONE); CHARTYPE(10); "MOVETO(98,183); WSTRING('COUNTDOWN:'); "FOR I := 50 DOWNTO 0 DO $BEGIN &STR(I,NUM); NUM := CONCAT(NUM,' '); &MOVETO(168,183); WSTRING(NUM); $ NOTE(I,2); $END;); $ FOR J:= 1 TO DELAY DO; $END;  CHARTYPE(10); $MOVETO(X,Y); $WCHAR(CHR(32));  END; { EXPLODE }    { Do a musical countdown at the top of the screen }    PROCEDURE COUNTDOWN;  VAR I, CLICK : INTEGER; $NUM : STRING; $END "ELSE $BEGIN &X := LEFT_POSITION; &Y := LEFTEL; $END; "FOR I := 1 TO 20 DO $BEGIN &CHARTYPE(5); &MOVETO(X,Y); &WCHAR(CHR(1)); &NOTE(RAND(1,50),2); &FOR J:= 1 TO DELAY DO; &CHARTYPE(10); &MOVETO(X,Y); &WCHAR(CHR(1)); &NOTE(RAND(1,50),2 character modes. Include some }  { random notes for an interesting sound effect. }    PROCEDURE EXPLODE;  CONST DELAY = 50;  VAR X,Y,I,J : INTEGER;  BEGIN  PENCOLOR(NONE); "IF LEFT_SHOT THEN $BEGIN &X := RIGHT_POSTION; &Y := RIGHTEL;  (*$S+*)   (*$C Copyright (c) 1981 by Chris Wilson *)   PROGRAM FORMAT;  CONST "HUGE = 1000; "MAXDEFPOOL = 5000; "PAGEWIDTH = 80; "PAGELENGTH = 66;  TYPE STRING255 = STRING[255]; ARGTYPE = (DEFAULTED,RELPLUS,RELMINUS,ABSOLUTE); "CMDTYPE$Q^.LLINK := P "ELSE $P := Q; (* REDEFINE *) "END;  P^.TYP := CT;  ENTERCMD := P;  END;   FUNCTION LOOKUP(VAR TOKEN: STRING255): ENTRYP; '(*======*)   (* LOOK FOR COMMAND IN TABLE *)   VAR "P: ENTRYP;  NAM: PACKED ARRAY [1..8] OF CHAR;EW(P);  WITH P^ DO "BEGIN "NAME := ' '; "MOVELEFT(CMD[1],NAME[1],2); "LLINK := NIL; "RLINK := NIL; "END;  IF ROOT = NIL THEN "ROOT := P  ELSE "BEGIN "I := TREESEARCH(ROOT,Q,P^.NAME); "IF I = 1 THEN $Q^.RLINK := P "ELSE IF I = -1 THEN  FUNCTION ENTERCMD(CMD: STRING255; CT: CMDTYPE): ENTRYP; '(*========*)  (* ENTER COMMAND INTO TABLE *)   VAR "P, "Q: ENTRYP;  I: INTEGER;   BEGIN  UPSTRING(CMD);  IF LENGTH(CMD) < 2 THEN "ERROR(CONCAT('Command name too short: ',CMD));  N);  IF NONCONSOLE THEN "BEGIN "DOTCOUNT := SUCC(DOTCOUNT); "WRITE('.'); "IF DOTCOUNT >= 50 THEN $BEGIN $WRITELN; $WRITE('<',LINECOUNT:4,'>'); $DOTCOUNT := 0; $END; "END;  GETLINE := TRUE;  END; FALSE; $GETLINE := GETLINE(INBUF); $EXIT(GETLINE); $END "ELSE $READLN(INCLUDEFILE,INBUF)  ELSE IF EOF(SOURCEFILE) THEN "BEGIN "INBUF := ''; "GETLINE := FALSE; "EXIT(GETLINE); "END  ELSE "READLN(SOURCEFILE,INBUF);  LINECOUNT := SUCC(LINECOUNT,' <<<'); CLOSE(DESTFILE,LOCK);  WRITELN(LINECOUNT,' lines');  EXIT(FORMAT);  END;   FUNCTION GETLINE(VAR INBUF: STRING255): BOOLEAN; '(*=======*)   BEGIN  IF INCLUDING THEN "IF EOF(INCLUDEFILE) THEN $BEGIN $CLOSE(INCLUDEFILE); $INCLUDING := IF A < B THEN "MIN := A  ELSE "MIN := B;  END;   FUNCTION MAX(A, B: INTEGER): INTEGER; '(*===*)   BEGIN  IF A < B THEN "MAX := B  ELSE "MAX := A;  END;  PROCEDURE ERROR(S: STRING255); ((*=====*)   BEGIN  WRITELN;  WRITELN('>>> ',SG(VAR S: STRING); ((*========*)   VAR "I: INTEGER;   BEGIN  FOR I := 1 TO LENGTH(S) DO "IF S[I] IN ['a'..'z'] THEN $S[I] := CHR(ORD('A')+(ORD(S[I])-ORD('a')));  END;   FUNCTION MIN(A, B: INTEGER): INTEGER; '(*===*)   BEGIN ICARG: SET OF CMDTYPE; "INBUF, "OUTBUF, "BLANKS255: STRING255;  UNDERLINE: STRING[2];  ROOT: ENTRYP; "POOLINX: INTEGER; "DEFPOOL: PACKED ARRAY [0..MAXDEFPOOL] OF CHAR;  PROCEDURE COMMAND(VAR BUF: STRING255);  FORWARD;   PROCEDURE UPSTRINR LAST TEXT LINE *) "M4VAL, (* BOTTOM MARGIN, INCLUDING FOOTER *) "BOTTOM, (* LAST LIVE LINE ON PAGE *) "OUTW, (* WIDTH OF TEXT CURRENTLY IN OUTBUF *) "OUTWDS, (* NUMBER OF WORDS IN OUTBUF *) "DIR: INTEGER; "HEADER, "FOOTER: TITLEINFO; "HASNUMER"CURPAGE, (* OUTPUT PAGE NUMBER *) "NEWPAGE, (* NEXT PAGE NUMBER *) "LINENO, (* NEXT LINE TO BE PRINTED *) "PLVAL, (* PAGE LENGTH IN LINES *) "M1VAL, (* TOP MARGIN, INCLUDING HEADER *) "M2VAL, (* MARGIN AFTER HEADER *)  M3VAL, (* MARGIN AFTE"DESTNAME: STRING;  FILL: BOOLEAN; "LSVAL, (* LINE SPACING *) "INVAL, (* INDENT *) "RMVAL, (* RIGHT MARGIN *) "TIVAL, (* TEMPORARY INDENT *) "CEVAL, (* # OF LINES TO CENTER *) "ULVAL, (* # OF LINES TO UNDERLINE *) 8] OF CHAR; $LLINK, $RLINK: ENTRYP; $TYP: CMDTYPE; $START, $LINES: INTEGER $END;  VAR "BACKSPACE: CHAR; "DOTCOUNT, "LINECOUNT: INTEGER; "EMITPAGE, "INCLUDING, "NONCONSOLE: BOOLEAN; "INCLUDEFILE, "SOURCEFILE, "DESTFILE: TEXT; "SOURCENAME, = (UNKNOWN,DEFINED,BP,BR,CE,DE,EN,FI,FO, $HE,IND,LS,NE,NF,PL,RM,SO,SP,TI,UL); "TITLEINFO = RECORD $EMPTY: BOOLEAN; $LEFTM, $RIGHTM: INTEGER; $LEFTS, $CENTERS, $RIGHTS: STRING255 $END; "ENTRYP = ^ ENTRY; "ENTRY = RECORD $NAME: PACKED ARRAY [1..   BEGIN  LOOKUP := NIL;  IF LENGTH(TOKEN) >= 2 THEN "BEGIN "NAM := ' '; "MOVELEFT(TOKEN[1],NAM[1],2); "IF TREESEARCH(ROOT,P,NAM) = 0 THEN $LOOKUP := P;  END;  END;   PROCEDURE SETVAL(VAR PARAM: INTEGER; VAL: INTEGER; TYP: ARGTYPE; ((*======*) DEFVAL, MINVAL, MAXVAL: INTEGER);   (* SETUP PARAMETER AND CHECK RANGE *)   BEGIN  CASE TYP OF  DEFAULTED: "PARAM := DEFVAL;  RELPLUS: "PARAM := PARAM+VAL;  RELMIBUF) > 0 THEN $BEGIN $DELIM := COPY(BUF,1,1); $DELETE(BUF,1,1); $I := POS(DELIM,BUF); $IF I = 0 THEN &BEGIN &S := BUF; &BUF := ''; &END $ELSE &BEGIN &I := PRED(I); &S := COPY(BUF,1,I); &DELETE(BUF,1,I); &END; $END "ELSE $S := ''; "END;  $CONTINUE := FALSE;  GETVAL := I;  END;  PROCEDURE GETTL(VAR BUF: STRING255; VAR TITLE: TITLEINFO); ' (*=====*)   (* SETUP TITLE FROM BUF *)   PROCEDURE GETPART(VAR BUF, S: STRING255); "VAR I: INTEGER; $DELIM: STRING[1]; "BEGIN "IF LENGTH("TYP := ABSOLUTE;  IF TYP IN [RELPLUS,RELMINUS] THEN "DELETE(BUF,1,1);  I := 0;  CONTINUE := TRUE;  WHILE CONTINUE AND (LENGTH(BUF) > 0) DO  IF BUF[1] IN ['0'..'9'] THEN $BEGIN $I := (I*10)+(ORD(BUF[1])-ORD('0')); $DELETE(BUF,1,1); $END "ELSEEVALUATE OPTIONAL NUMERIC ARGUMENT *)  VAR "I: INTEGER;  CONTINUE: BOOLEAN;   BEGIN  IF LENGTH(BUF) = 0 THEN "TYP := DEFAULTED  ELSE IF POS('+',BUF) = 1 THEN "TYP := RELPLUS  ELSE IF POS('-',BUF) = 1 THEN "TYP := RELMINUS  ELSE DEFPOOL[J])); (J := J+1+LENGTH(S); (IF POS('$',S) <> 0 THEN *HANDLEARGS(S,BUF); (IF POS('.',S) = 1 THEN *COMMAND(S) (ELSE *TXT(S); (END; &END; $END;  END;   FUNCTION GETVAL(VAR BUF: STRING255; VAR TYP: ARGTYPE): INTEGER; '(*======*)   (* ;  IF P = NIL THEN "COMTYPE := UNKNOWN  ELSE "WITH P^ DO $BEGIN $COMTYPE := TYP; $IF (TYP = DEFINED) AND EXPAND THEN &BEGIN &J := START; &FOR I := 1 TO LINES DO (BEGIN ((* TRICKY CODE INVOLVING LENGTH BYTE OF S *) (MOVELEFT(DEFPOOL[J],S,1+ORD(I := SCAN(LENGTH(BUF),=' ',BUF[1]);  CMDBUF := COPY(BUF,1,I);  DELETE(BUF,1,I);  IF LENGTH(BUF) > 0 THEN "BEGIN "I := SCAN(LENGTH(BUF),<>' ',BUF[1]); "DELETE(BUF,1,I);  END;  DELETE(CMDBUF,1,1); (* '.' *)  UPSTRING(CMDBUF);  P := LOOKUP(CMDBUF)CC(I) "ELSE $I := SUCC(I); "END;  END;   FUNCTION COMTYPE(VAR BUF: STRING255; EXPAND: BOOLEAN): CMDTYPE; '(*=======*)   (* DECODE COMMAND, DELETE FROM BUF *)   VAR "I, "J: INTEGER; "P: ENTRYP;  S, "CMDBUF: STRING255;   BEGIN S[I+1] IN ['1'..'9'] THEN &BEGIN &GETARG(ORD(S[I+1])-ORD('0'),ARG); &DELETE(S,I,2); &IF LENGTH(S)+LENGTH(ARG) <= 255 THEN (INSERT(ARG,S,I) &ELSE (ERROR('Overflow in define argument substitution');  I := I+LENGTH(ARG); &END $ELSE % I := SUI := SCAN(LENGTH(A),<>' ',A[1]); &DELETE(A,1,I); &END; $N := PRED(N); $END; "IF N <> 0 THEN $ARG := ''; "END;   BEGIN (* HANDLEARGS *)  I := 1;  WHILE I < LENGTH(S) DO "BEGIN "I := I+SCAN(LENGTH(S)+1-I,='$',S[I]); "IF I < LENGTH(S) THEN $IF&I := SCAN(LENGTH(A),='"',A[1]); &ARG := COPY(A,1,I); &DELETE(A,1,I); $ IF POS('"',A) = 1 THEN (DELETE(A,1,1); $ END $ELSE &BEGIN &I := SCAN(LENGTH(A),=' ',A[1]); &ARG := COPY(A,1,I); &DELETE(A,1,I); $ END; $IF LENGTH(A) > 0 THEN &BEGIN &) THEN &BEGIN &DELETE(A,1,1); &I := SCAN(LENGTH(A),='''',A[1]); &ARG := COPY(A,1,I); &DELETE(A,1,I); $ IF POS('''',A) = 1 THEN (DELETE(A,1,1); &END ELSE IF (A[1] = '"') AND (LENGTH(A) > 1) THEN &BEGIN &DELETE(A,1,1); ATION ARGUMENTS *)   VAR "I: INTEGER; "ARG: STRING255;   PROCEDURE GETARG(N: INTEGER; VAR ARG: STRING255); "VAR I: INTEGER; " A: STRING255; "BEGIN "A := ARGS; "WHILE (N > 0) AND (LENGTH(A) > 0) DO $BEGIN $IF (A[1] = '''') AND (LENGTH(A) > 1NUS: "PARAM := PARAM-VAL;  ABSOLUTE: "PARAM := VAL  END; (* CASE *)  PARAM := MIN(PARAM,MAXVAL);  PARAM := MAX(PARAM,MINVAL);  END;   (*$I FORMAT.1 *)   PROCEDURE HANDLEARGS(VAR S, ARGS: STRING255); ((*==========*)   (* HANDLE DEFINE INVOC  BEGIN (* GETTL *)  WITH TITLE DO "BEGIN "LEFTM := INVAL; "RIGHTM := RMVAL; "GETPART(BUF,LEFTS); "GETPART(BUF,CENTERS); "GETPART(BUF,RIGHTS); "EMPTY := (LEFTS = '') AND (CENTERS = '') AND (RIGHTS = ''); "END;  END;  PROCEDURE DEFINE(VAR BUF: STRING255); ' (*======*)   (* DEFINE MACRO *)   VAR "P: ENTRYP; "CT: CMDTYPE; "INBUF: STRING255;   BEGIN  P := ENTERCMD(BUF,DEFINED);  WITH P^ DO "BEGIN "START := POOLINX; "LINES := 0; "WHILE GETLINE(INBUF) DOENTERCMD('LS',LS); P := ENTERCMD('NE',NE); P := ENTERCMD('NF',NF); P := ENTERCMD('PL',PL); P := ENTERCMD('RM',RM); P := ENTERCMD('SO',SO);  P := ENTERCMD('SP',SP); P := ENTERCMD('TI',TI); P := ENTERCMD('UL',UL);  END;  (* ========== MAIN BODY =========  ROOT := NIL;  POOLINX := 0; P := ENTERCMD('BP',BP);  P := ENTERCMD('BR',BR); P := ENTERCMD('CE',CE); P := ENTERCMD('DE',DE); P := ENTERCMD('EN',EN); P := ENTERCMD('FI',FI); P := ENTERCMD('FO',FO); P := ENTERCMD('HE',HE); P := ENTERCMD('IN',IND); P :=  DIR := 0; HEADER.EMPTY := TRUE; FOOTER.EMPTY := TRUE;  HASNUMERICARG := [BP,CE,IND,LS,NE,PL,RM,SP,TI,UL];  OUTBUF := '';  (*$R-*)  BLANKS255[0] := CHR(255);  (*$R+*)  FILLCHAR(BLANKS255[1],255,' ');  UNDERLINE := '_ ';  UNDERLINE[2] := BACKSPACE;= 0;  RMVAL := PAGEWIDTH;  TIVAL := 0;  CEVAL := 0;  ULVAL := 0;  CURPAGE := 0;  NEWPAGE := 1;  LINENO := 0;  PLVAL := PAGELENGTH;  M1VAL := 2;  M2VAL := 2;  M3VAL := 2;  M4VAL := 2;  BOTTOM := PLVAL-M3VAL-M4VAL;  OUTW := 0;  OUTWDS := 0; ); "END;  UL: "SETVAL(ULVAL,VAL,TYP,1,0,HUGE)  END; (* CASE *)  END;   PROCEDURE INIT; ((*====*)   VAR "P: ENTRYP;   BEGIN  BACKSPACE := CHR(8);  DOTCOUNT := 0;  LINECOUNT := 0; INCLUDING := FALSE;  FILL := TRUE;  LSVAL := 1;  INVAL :t allowed') "ELSE $BEGIN $INCLUDING := TRUE; $RESET(INCLUDEFILE,BUF); $END; "END;  SP: "BEGIN "SPVAL := 1; (* IN CASE VAL IS RELATIVE *) "SETVAL(SPVAL,VAL,TYP,1,0,HUGE); "SPACE(SPVAL); "END;  TI: "BEGIN "BRK; "SETVAL(TIVAL,VAL,TYP,0,0,RMVAL"IF BUF = '' THEN $EXIT(COMMAND) "ELSE IF POS('.TEXT',BUF) = 0 THEN $IF BUF[LENGTH(BUF)] <> ':' THEN &IF BUF[LENGTH(BUF)] <> '.' THEN (BUF := CONCAT(BUF,'.TEXT') &ELSE (DELETE(BUF,LENGTH(BUF),1); "IF INCLUDING THEN $ERROR('Nested include files noF: "BEGIN "BRK; "FILL := FALSE; "END;  PL: "BEGIN "SETVAL(PLVAL,VAL,TYP,PAGELENGTH,M1VAL+M2VAL+M3VAL+M4VAL+1,HUGE); "BOTTOM := PLVAL-M3VAL-M4VAL; "END;  RM: "SETVAL(RMVAL,VAL,TYP,PAGEWIDTH,SUCC(TIVAL),255);  SO: "BEGIN "UPSTRING(BUF); L)); "TIVAL := INVAL; "END;  LS: "SETVAL(LSVAL,VAL,TYP,1,1,HUGE);  NE: "BEGIN "BRK; "NEVAL := 1; (* IN CASE VAL IS RELATIVE *) "SETVAL(NEVAL,VAL,TYP,1,0,HUGE); "NEVAL := NEVAL*LSVAL; "IF LINENO+PRED(NEVAL) > BOTTOM THEN $SPACE(HUGE); "END;  NL,TYP,1,0,HUGE); "END;  DE: "BEGIN "BRK; "DEFINE(BUF); "END;  EN: "ERROR('.en outside of define');  FI: "BEGIN "BRK; "FILL := TRUE; "END;  FO: "GETTL(BUF,FOOTER);  HE: "GETTL(BUF,HEADER);  IND: "BEGIN "SETVAL(INVAL,VAL,TYP,0,0,PRED(RMVA"VAL := GETVAL(BUF,TYP);  CASE CT OF  UNKNOWN, DEFINED: "BEGIN "END;  BP: "BEGIN "IF LINENO > 0 THEN $SPACE(HUGE); "SETVAL(CURPAGE,VAL,TYP,SUCC(CURPAGE),-HUGE,HUGE); "NEWPAGE := CURPAGE; "END;  BR: "BRK;  CE: "BEGIN "BRK; "SETVAL(CEVAL,VA END;   PROCEDURE COMMAND; (* VAR BUF: STRING255 *) ((*=======*)   (* PERFORM FORMATTING COMMAND *)   VAR "VAL, "NEVAL, "SPVAL: INTEGER; "CT: CMDTYPE; "TYP: ARGTYPE;   BEGIN  CT := COMTYPE(BUF,TRUE);  IF CT IN HASNUMERICARG THEN IN (CT := COMTYPE(INBUF,FALSE); (IF CT = DE THEN *ERROR(CONCAT('Nested defines not allowed: ',BUF)) (ELSE IF CT = EN THEN *BEGIN *LINES := PRED(LINES); *EXIT(DEFINE); *END; (END $ END $ELSE &ERROR(CONCAT('Define pool overflow: ',BUF)); "END; $IF POOLINX+1+LENGTH(INBUF) <= MAXDEFPOOL THEN &BEGIN &(* TRICKY CODE INVOLVING LENGTH BYTE OF INBUF *) &MOVELEFT(INBUF,DEFPOOL[POOLINX],1+LENGTH(INBUF)); &POOLINX := POOLINX+1+LENGTH(INBUF); &LINES := SUCC(LINES); &IF POS('.',INBUF) = 1 THEN (BEG= *)  BEGIN  INIT;  PAGE(OUTPUT);  WRITELN('Format (7/27/81, 7:37 PM)');  WRITELN('Copyright (c) 1981 by Chris Wilson');  WRITELN;  WRITE('Source file: ');  READLN(SOURCENAME);  UPSTRING(SOURCENAME);  IF SOURCENAME = '' THEN "EXIT(FORMAT)  ELSE IF POS('.TEXT',SOURCENAME) = 0 THEN "IF SOURCENAME[LENGTH(SOURCENAME)] <> ':' THEN $IF SOURCENAME[LENGTH(SOURCENAME)] <> '.' THEN &SOURCENAME := CONCAT(SOURCENAME,'.TEXT') $ELSE &DELETE(SOURCENAME,LENGTH(SOURCENAME),1); WRITE('Destination file:"VAL := ABS(VAL); "S := ' '; "I := 6; "REPEAT $D := VAL MOD 10; $VAL := VAL DIV 10; $S[I] := CHR(ORD('0')+D); " I := PRED(I) "UNTIL VAL = 0; "IF MINUS THEN $BEGIN $S[I] := '-'; $I := PRED(I); $END; "DELETE(S,1,I); "END;  PROCEDURE REGER); ((*=====*)   (* PUT OUT TITLE LINE WITH OPTIONAL PAGE NUMBER *)   VAR "I, "J: INTEGER;  S: STRING255; "PAGES: STRING;   PROCEDURE STR(VAL: INTEGER; VAR S: STRING); "VAR D, I: INTEGER; " MINUS: BOOLEAN; "BEGIN "MINUS := VAL < 0;  (* Copyright (c) 1981 by Chris Wilson *)   PROCEDURE SKIP(N: INTEGER); ((*====*)   (* OUTPUT N BLANK LINES *)   VAR "I: INTEGER;   BEGIN  FOR I := 1 TO N DO "WRITELN(DESTFILE);  END;   PROCEDURE PUTTL(VAR TITLE: TITLEINFO; PAGENO: INTN^ IF LINENO > 0 THEN "SPACE(HUGE);  CLOSE(DESTFILE,LOCK);  IF NONCONSOLE THEN "WRITELN;  WRITELN(LINECOUNT,' lines');  END. S('#6:',DESTNAME) = 1) "OR NOT NONCONSOLE;  RESET(SOURCEFILE,SOURCENAME);  REWRITE(DESTFILE,DESTNAME);  IF NONCONSOLE THEN "WRITE('<',LINECOUNT:4,'>');  WHILE GETLINE(INBUF) DO "IF POS('.',INBUF) = 1 THEN $COMMAND(INBUF) "ELSE $TXT(INBUF); .TEXT') $ELSE &DELETE(DESTNAME,LENGTH(DESTNAME),1);  NONCONSOLE := (POS('CONSOLE:',DESTNAME) = 0)  AND (POS('SYSTERM:',DESTNAME) = 0) "AND (POS('#1:',DESTNAME) = 0) "AND (POS('#2:',DESTNAME) = 0); EMITPAGE := (POS('PRINTER:',DESTNAME) = 1) "OR (PO ');  READLN(DESTNAME);  UPSTRING(DESTNAME);  IF DESTNAME = '' THEN "DESTNAME := 'PRINTER:'  ELSE IF POS('.TEXT',DESTNAME) = 0 THEN "IF DESTNAME[LENGTH(DESTNAME)] <> ':' THEN $IF DESTNAME[LENGTH(DESTNAME)] <> '.' THEN &DESTNAME := CONCAT(DESTNAME,'EPLACE(VAR S: STRING255); "VAR I: INTEGER; "BEGIN "REPEAT $I := POS('#',S); $IF I <> 0 THEN &BEGIN &DELETE(S,I,1); &INSERT(PAGES,S,I); &END "UNTIL I = 0;  END;   BEGIN (* PUTTL *)  WITH TITLE DO "IF NOT EMPTY THEN $BEGIN $STR(PAGENO,PAGES); $IF LEFTM > 0 THEN &WRITE(DESTFILE,' ':LEFTM); $I := LEFTM; $IF LENGTH(LEFTS) > 0 THEN &BEGIN &S := LEFTS; &REPLACE(S); &WRITE(DESTFILE,S); &I := I+LENGTH(S); $ END; $IF LENGTH(CENTERS) > 0 THEN &BEGIN &S := CENTERS; &REW := WIDTH(WRDBUF);  LLVAL := RMVAL-TIVAL;  IF LENGTH(OUTBUF) > 0 THEN  BEGIN "LAST := LENGTH(OUTBUF)+1+LENGTH(WRDBUF); "IF (OUTW+1+W > LLVAL) OR (LAST > 255) THEN " BEGIN $SPREAD(OUTBUF,LLVAL-OUTW,OUTWDS); $BRK; " END; "END;  IF LENGTH(OUTBES); $INSERT(COPY(BLANKS255,1,NB),BUF,I); $I := I+NB+1; $END;  END;  END;   PROCEDURE PUTWRD(VAR WRDBUF: STRING255); ((*======*)   (* PUT A WORD IN OUTBUF; INCLUDES MARGIN JUSTIFICATION *)   VAR "W, "LAST, "LLVAL: INTEGER;   BEGIN  "DIR := 1-DIR; "NE := NEXTRA; "NHOLES := PRED(OUTWDS); "I := 1; "WHILE NE > 0 DO $BEGIN $I := I+SCAN((LENGTH(BUF)+1)-I,=' ',BUF[I]); $IF DIR = 0 THEN &NB := (PRED(NE) DIV NHOLES)+1 $ELSE &NB := NE DIV NHOLES; $NE := NE-NB; $NHOLES := PRED(NHOL  PROCEDURE SPREAD(VAR BUF: STRING255; NEXTRA, OUTWDS: INTEGER);  (*======*)   (* SPREAD WORDS TO JUSTIFY RIGHT MARGIN *)   VAR "I, "NB, "NE, "NHOLES: INTEGER;   BEGIN  IF (NEXTRA > 0) AND (OUTWDS > 1) THEN "BEGIN > 0 DO &BEGIN &I := I+SCAN(COUNT,=BACKSPACE,BUF[I]); &COUNT := (LENGTH(BUF)+1)-I; &IF COUNT <> 0 THEN (BEGIN (BS := SUCC(BS); (I := SUCC(I); (COUNT := PRED(COUNT); (END; &END; $WIDTH := LENGTH(BUF)-BS; $END;  END  ELSE "WIDTH := 0;  END; NG *)   VAR "I, "BS, "COUNT: INTEGER;   BEGIN  IF LENGTH(BUF) > 0 THEN  BEGIN "I := SCAN(LENGTH(BUF),=BACKSPACE,BUF[1]); "IF I = LENGTH(BUF) THEN $WIDTH := I "ELSE $BEGIN $BS := 1; $I := I+2; $COUNT := (LENGTH(BUF)+1)-I; $WHILE COUNT  BRK;  IF LENGTH(BUF) > 0 THEN "BEGIN "I := SCAN(LENGTH(BUF),<>' ',BUF[1]); "DELETE(BUF,1,I); "IF LENGTH(BUF) > 0 THEN $TIVAL := I;  END;  END;   FUNCTION WIDTH(VAR BUF: STRING255): INTEGER; '(*=====*)   (* COMPUTE WIDTH OF CHARACTER STRI $PHEAD; "SKIP(MIN(N,(BOTTOM+1)-LINENO)); "LINENO := LINENO+N; "IF LINENO > BOTTOM THEN $PFOOT; "END;  END;   PROCEDURE LEADBL(VAR BUF: STRING255); ((*======*)   (* DELETE LEADING BLANKS, SETUP TIVAL *)   VAR "I: INTEGER;   BEGIN LENGTH(OUTBUF) > 0 THEN "PUT(OUTBUF);  OUTW := 0;  OUTWDS := 0;  OUTBUF := '';  END;   PROCEDURE SPACE(N: INTEGER); ((*=====*)   (* SPACE N LINES OR TO BOTTOM OF PAGE *)   BEGIN  BRK;  IF LINENO <= BOTTOM THEN "BEGIN "IF LINENO = 0 THENITE(DESTFILE,' ':TIVAL);  TIVAL := INVAL;  WRITELN(DESTFILE,BUF);  SKIP(MIN(PRED(LSVAL),BOTTOM-LINENO));  LINENO := LINENO+LSVAL;  IF LINENO > BOTTOM THEN "PFOOT;  END;   PROCEDURE BRK; ((*===*)   (* END CURRENT FILLED LINE *)   BEGIN  IF"PUTTL(FOOTER,CURPAGE); "SKIP(PRED(M4VAL)); "END;  END;   PROCEDURE PUT(VAR BUF: STRING255); ((*===*)   (* PUT OUT LINE WITH PROPER SPACING AND INDENTING *)   BEGIN  IF (LINENO = 0) OR (LINENO > BOTTOM) THEN "PHEAD;  IF TIVAL > 0 THEN "WRLE);  IF M1VAL > 0 THEN "BEGIN "SKIP(PRED(M1VAL)); "PUTTL(HEADER,CURPAGE); "END;  SKIP(M2VAL);  LINENO := M1VAL+M2VAL+1;  END;   PROCEDURE PFOOT; ((*=====*)   (* PUT OUT PAGE FOOTER *)   BEGIN  SKIP(M3VAL);  IF M4VAL > 0 THEN "BEGIN HEN (WRITE(DESTFILE,' ':(J-I)); &WRITE(DESTFILE,S); $ END; $END;  WRITELN(DESTFILE);  END;   PROCEDURE PHEAD; ((*=====*)   (* PUT OUT PAGE HEADER *)   BEGIN  CURPAGE := NEWPAGE;  NEWPAGE := SUCC(NEWPAGE);  IF EMITPAGE THEN "PAGE(DESTFIPLACE(S); &J := MAX(((LEFTM+RIGHTM)-LENGTH(S)) DIV 2,0); &IF I < J THEN (WRITE(DESTFILE,' ':(J-I)); &WRITE(DESTFILE,S); &I := J+LENGTH(S); $ END; $IF LENGTH(RIGHTS) > 0 THEN &BEGIN &S := RIGHTS; &REPLACE(S); &J := RIGHTM-LENGTH(S); &IF I < J TUF) = 0 THEN "BEGIN "OUTBUF := WRDBUF; "OUTW := W; "END  ELSE "BEGIN "INSERT(' ',OUTBUF,LENGTH(OUTBUF)+1); "INSERT(WRDBUF,OUTBUF,LENGTH(OUTBUF)+1); "OUTW := OUTW+1+W; "END;  OUTWDS := SUCC(OUTWDS);  END;   PROCEDURE CENTER(VAR BUF: STRING255); ((*======*)   (* CENTER A LINE BY SETTING TIVAL *)   BEGIN  TIVAL := MAX(((RMVAL+TIVAL)-WIDTH(BUF)) DIV 2,0);  END;   PROCEDURE UNDERL(VAR BUF: STRING255); ((*======*)   (* UNDERLINE A LINE *)   VAP; (IF DIFFICULTY=EASY THEN WIND_FACTOR:=0; (DRAW_SCREEN; (SET_DISPLAY; (PLAY; &UNTIL ANGLE = -9; { END GAME } " END_GAME; "UNTIL (CH = 'N') OR (CH = 'n'); { END PROGRAM }  PAGE(OUTPUT);  END.  PLAY }     BEGIN { Main ARTILLERY Controller } "SPLASHPAGE; "IF (CH = 'Y') OR (CH = 'y') THEN $BEGIN &HELP1; &HELP2; $END; "REPEAT $LEFT_SCORE := 0; $RIGHT_SCORE:= 0; $LEFT_SHOT := FALSE; $RIGHT_SHOT := TRUE; $GET_NAMES; &REPEAT (SETU(VELOCITY := VAL(VEL_STR); ANGLE := VAL(ANG_STR); (IF ANGLE = -9 THEN EXIT(PLAY); &UNTIL (VELOCITY>0) AND (ANGLE>0) AND ,(VELOCITY<16) AND (ANGLE<140); &CONVERT; &PLOT_TRAJECTORY; $END; "UNTIL HIT; "EXPLODE; "UPDATE_SCORE; "COUNTDOWN;  END; { T:= NOT RIGHT_SHOT; &IF LEFT_SHOT THEN LEFT := 0 ELSE LEFT := 26; &REPEAT (WRITE(AT(23,LEFT),'V,A> '); (READLN(INPUT); (COMMA:=POS(',',INPUT); (VEL_STR:=COPY(INPUT,1,COMMA-1); (ANG_STR:=COPY(INPUT,COMMA+1,LENGTH(INPUT)-COMMA); someone enters an angle of }  { -9 to end the game and possibly start again }    PROCEDURE PLAY;  VAR (LEFT, (COMMA : INTEGER;  INPUT, (VEL_STR, (ANG_STR : STRING;  BEGIN "REPEAT $BEGIN &LEFT_SHOT := NOT LEFT_SHOT; &RIGHT_SHO  VIEWPORT(0,279,0,191);  END; { COUNTDOWN }    PROCEDURE UPDATE_SCORE;  BEGIN "IF LEFT_SHOT THEN LEFT_SCORE := LEFT_SCORE +1 "ELSE RIGHT_SCORE := RIGHT_SCORE+1;  END;    { Controls all procedures for play of a game. }  { Continues until BEGIN "VIEWPORT(0,279,170,191); "FILLSCREEN(BLACK); "PENCOLOR(NONE); CHARTYPE(10); "MOVETO(98,183); WSTRING('COUNTDOWN:'); "FOR I := 50 DOWNTO 0 DO $BEGIN &STR(I,NUM); NUM := CONCAT(NUM,' '); &MOVETO(168,183); WSTRING(NUM); $ NOTE(I,2); $END;INBUF); "CEVAL := PRED(CEVAL); "END  ELSE IF LENGTH(INBUF) = 0 THEN "PUT(INBUF)  ELSE IF NOT FILL THEN "PUT(INBUF)  ELSE "WHILE GETWRD(INBUF,WRDBUF) > 0 DO $PUTWRD(WRDBUF);  END;  VAR "WRDBUF: STRING255;   BEGIN  IF LENGTH(INBUF) = 0 THEN "LEADBL(INBUF)  ELSE IF INBUF[1] = ' ' THEN "LEADBL(INBUF);  IF ULVAL > 0 THEN "BEGIN "UNDERL(INBUF); "ULVAL := PRED(ULVAL); "END;  IF CEVAL > 0 THEN "BEGIN "CENTER(INBUF); "PUT( "I := SCAN(LENGTH(INBUF),=' ',INBUF[1]); "OUT := COPY(INBUF,1,I); "DELETE(INBUF,1,I); "GETWRD := I;  END  ELSE "BEGIN "OUT := ''; "GETWRD := 0; "END;  END;   PROCEDURE TXT(VAR INBUF: STRING255); ((*===*)   (* PROCESS TEXT LINES *)  (*======*)   (* GET NON-BLANK WORD FROM INBUF INTO OUT, DELETE FROM INBUF *)   VAR "I: INTEGER;   BEGIN  IF LENGTH(INBUF) > 0 THEN "BEGIN "I := SCAN(LENGTH(INBUF),<>' ',INBUF[1]); "DELETE(INBUF,1,I); END;  IF LENGTH(INBUF) > 0 THEN "BEGINR "I: INTEGER;   BEGIN  I := 1;  WHILE (I < LENGTH(BUF)) AND (I < 254) DO "BEGIN "IF BUF[I] <> ' ' THEN $BEGIN $INSERT(UNDERLINE,BUF,I); $I := I+2; $END; "I := SUCC(I); "END;  END;   FUNCTION GETWRD(VAR INBUF, OUT: STRING255): INTEGER; 'N^ FALSE; $GETLINE := GETLINE(INBUF); $EXIT(GETLINE); $END "ELSE $READLN(INCLUDEFILE,INBUF)  ELSE IF EOF(SOURCEFILE) THEN "BEGIN "INBUF := ''; "GETLINE := FALSE; "EXIT(GETLINE); "END  ELSE "READLN(SOURCEFILE,INBUF);  LINECOUNT := SUCC(LINECOUNT,' <<<'); CLOSE(DESTFILE,LOCK);  WRITELN(LINECOUNT,' lines');  EXIT(FORMAT);  END;   FUNCTION GETLINE(VAR INBUF: STRING255): BOOLEAN; '(*=======*)   BEGIN  IF INCLUDING THEN "IF EOF(INCLUDEFILE) THEN $BEGIN $CLOSE(INCLUDEFILE); $INCLUDING := IF A < B THEN "MIN := A  ELSE "MIN := B;  END;   FUNCTION MAX(A, B: INTEGER): INTEGER; '(*===*)   BEGIN  IF A < B THEN "MAX := B  ELSE "MAX := A;  END;  PROCEDURE ERROR(S: STRING255); ((*=====*)   BEGIN  WRITELN;  WRITELN('>>> ',SG(VAR S: STRING); ((*========*)   VAR "I: INTEGER;   BEGIN  FOR I := 1 TO LENGTH(S) DO "IF S[I] IN ['a'..'z'] THEN $S[I] := CHR(ORD('A')+(ORD(S[I])-ORD('a')));  END;   FUNCTION MIN(A, B: INTEGER): INTEGER; '(*===*)   BEGIN ICARG: SET OF CMDTYPE; "INBUF, "OUTBUF, "BLANKS255: STRING255;  UNDERLINE: STRING[2];  ROOT: ENTRYP; "POOLINX: INTEGER; "DEFPOOL: PACKED ARRAY [0..MAXDEFPOOL] OF CHAR;  PROCEDURE COMMAND(VAR BUF: STRING255);  FORWARD;   PROCEDURE UPSTRINR LAST TEXT LINE *) "M4VAL, (* BOTTOM MARGIN, INCLUDING FOOTER *) "BOTTOM, (* LAST LIVE LINE ON PAGE *) "OUTW, (* WIDTH OF TEXT CURRENTLY IN OUTBUF *) "OUTWDS, (* NUMBER OF WORDS IN OUTBUF *) "DIR: INTEGER; "HEADER, "FOOTER: TITLEINFO; "HASNUMER"CURPAGE, (* OUTPUT PAGE NUMBER *) "NEWPAGE, (* NEXT PAGE NUMBER *) "LINENO, (* NEXT LINE TO BE PRINTED *) "PLVAL, (* PAGE LENGTH IN LINES *) "M1VAL, (* TOP MARGIN, INCLUDING HEADER *) "M2VAL, (* MARGIN AFTER HEADER *)  M3VAL, (* MARGIN AFTE"DESTNAME: STRING;  FILL: BOOLEAN; "LSVAL, (* LINE SPACING *) "INVAL, (* INDENT *) "RMVAL, (* RIGHT MARGIN *) "TIVAL, (* TEMPORARY INDENT *) "CEVAL, (* # OF LINES TO CENTER *) "ULVAL, (* # OF LINES TO UNDERLINE *) 8] OF CHAR; $LLINK, $RLINK: ENTRYP; $TYP: CMDTYPE; $START, $LINES: INTEGER $END;  VAR "BACKSPACE: CHAR; "DOTCOUNT, "LINECOUNT: INTEGER; "EMITPAGE, "INCLUDING, "NONCONSOLE: BOOLEAN; "INCLUDEFILE, "SOURCEFILE, "DESTFILE: TEXT; "SOURCENAME, = (UNKNOWN,DEFINED,BP,BR,CE,DE,EN,FI,FO, $HE,IND,LS,NE,NF,PL,RM,SO,SP,TI,UL); "TITLEINFO = RECORD $EMPTY: BOOLEAN; $LEFTM, $RIGHTM: INTEGER; $LEFTS, $CENTERS, $RIGHTS: STRING255 $END; "ENTRYP = ^ ENTRY; "ENTRY = RECORD $NAME: PACKED ARRAY [1.. (*$S+*)   (*$C Copyright (c) 1981 by Chris Wilson *)   PROGRAM FORMAT;  CONST "HUGE = 1000; "MAXDEFPOOL = 5000; "PAGEWIDTH = 80; "PAGELENGTH = 66;  TYPE STRING255 = STRING[255]; ARGTYPE = (DEFAULTED,RELPLUS,RELMINUS,ABSOLUTE); "CMDTYPE);  IF NONCONSOLE THEN "BEGIN "DOTCOUNT := SUCC(DOTCOUNT); "WRITE('.'); "IF DOTCOUNT >= 50 THEN $BEGIN $WRITELN; $WRITE('<',LINECOUNT:4,'>'); $DOTCOUNT := 0; $END; "END;  GETLINE := TRUE;  END;  FUNCTION ENTERCMD(CMD: STRING255; CT: CMDTYPE): ENTRYP; '(*========*)  (* ENTER COMMAND INTO TABLE *)   VAR "P, "Q: ENTRYP;  I: INTEGER;   BEGIN  UPSTRING(CMD);  IF LENGTH(CMD) < 2 THEN "ERROR(CONCAT('Command name too short: ',CMD));  NDEFPOOL[J])); (J := J+1+LENGTH(S); (IF POS('$',S) <> 0 THEN *HANDLEARGS(S,BUF); (IF POS('.',S) = 1 THEN *COMMAND(S) (ELSE *TXT(S); (END; &END; $END;  END;   FUNCTION GETVAL(VAR BUF: STRING255; VAR TYP: ARGTYPE): INTEGER; '(*======*)   (* ;  IF P = NIL THEN "COMTYPE := UNKNOWN  ELSE "WITH P^ DO $BEGIN $COMTYPE := TYP; $IF (TYP = DEFINED) AND EXPAND THEN &BEGIN &J := START; &FOR I := 1 TO LINES DO (BEGIN ((* TRICKY CODE INVOLVING LENGTH BYTE OF S *) (MOVELEFT(DEFPOOL[J],S,1+ORD(I := SCAN(LENGTH(BUF),=' ',BUF[1]);  CMDBUF := COPY(BUF,1,I);  DELETE(BUF,1,I);  IF LENGTH(BUF) > 0 THEN "BEGIN "I := SCAN(LENGTH(BUF),<>' ',BUF[1]); "DELETE(BUF,1,I);  END;  DELETE(CMDBUF,1,1); (* '.' *)  UPSTRING(CMDBUF);  P := LOOKUP(CMDBUF)CC(I) "ELSE $I := SUCC(I); "END;  END;   FUNCTION COMTYPE(VAR BUF: STRING255; EXPAND: BOOLEAN): CMDTYPE; '(*=======*)   (* DECODE COMMAND, DELETE FROM BUF *)   VAR "I, "J: INTEGER; "P: ENTRYP;  S, "CMDBUF: STRING255;   BEGIN S[I+1] IN ['1'..'9'] THEN &BEGIN &GETARG(ORD(S[I+1])-ORD('0'),ARG); &DELETE(S,I,2); &IF LENGTH(S)+LENGTH(ARG) <= 255 THEN (INSERT(ARG,S,I) &ELSE (ERROR('Overflow in define argument substitution');  I := I+LENGTH(ARG); &END $ELSE % I := SUI := SCAN(LENGTH(A),<>' ',A[1]); &DELETE(A,1,I); &END; $N := PRED(N); $END; "IF N <> 0 THEN $ARG := ''; "END;   BEGIN (* HANDLEARGS *)  I := 1;  WHILE I < LENGTH(S) DO "BEGIN "I := I+SCAN(LENGTH(S)+1-I,='$',S[I]); "IF I < LENGTH(S) THEN $IF&I := SCAN(LENGTH(A),='"',A[1]); &ARG := COPY(A,1,I); &DELETE(A,1,I); $ IF POS('"',A) = 1 THEN (DELETE(A,1,1); $ END $ELSE &BEGIN &I := SCAN(LENGTH(A),=' ',A[1]); &ARG := COPY(A,1,I); &DELETE(A,1,I); $ END; $IF LENGTH(A) > 0 THEN &BEGIN &) THEN &BEGIN &DELETE(A,1,1); &I := SCAN(LENGTH(A),='''',A[1]); &ARG := COPY(A,1,I); &DELETE(A,1,I); $ IF POS('''',A) = 1 THEN (DELETE(A,1,1); &END ELSE IF (A[1] = '"') AND (LENGTH(A) > 1) THEN &BEGIN &DELETE(A,1,1); ATION ARGUMENTS *)   VAR "I: INTEGER; "ARG: STRING255;   PROCEDURE GETARG(N: INTEGER; VAR ARG: STRING255); "VAR I: INTEGER; " A: STRING255; "BEGIN "A := ARGS; "WHILE (N > 0) AND (LENGTH(A) > 0) DO $BEGIN $IF (A[1] = '''') AND (LENGTH(A) > 1NUS: "PARAM := PARAM-VAL;  ABSOLUTE: "PARAM := VAL  END; (* CASE *)  PARAM := MIN(PARAM,MAXVAL);  PARAM := MAX(PARAM,MINVAL);  END;   (*$I FORMAT.1 *)   PROCEDURE HANDLEARGS(VAR S, ARGS: STRING255); ((*==========*)   (* HANDLE DEFINE INVOC PROCEDURE SETVAL(VAR PARAM: INTEGER; VAL: INTEGER; TYP: ARGTYPE; ((*======*) DEFVAL, MINVAL, MAXVAL: INTEGER);   (* SETUP PARAMETER AND CHECK RANGE *)   BEGIN  CASE TYP OF  DEFAULTED: "PARAM := DEFVAL;  RELPLUS: "PARAM := PARAM+VAL;  RELMI   BEGIN  LOOKUP := NIL;  IF LENGTH(TOKEN) >= 2 THEN "BEGIN "NAM := ' '; "MOVELEFT(TOKEN[1],NAM[1],2); "IF TREESEARCH(ROOT,P,NAM) = 0 THEN $LOOKUP := P;  END;  END;  $Q^.LLINK := P "ELSE $P := Q; (* REDEFINE *) "END;  P^.TYP := CT;  ENTERCMD := P;  END;   FUNCTION LOOKUP(VAR TOKEN: STRING255): ENTRYP; '(*======*)   (* LOOK FOR COMMAND IN TABLE *)   VAR "P: ENTRYP;  NAM: PACKED ARRAY [1..8] OF CHAR;EW(P);  WITH P^ DO "BEGIN "NAME := ' '; "MOVELEFT(CMD[1],NAME[1],2); "LLINK := NIL; "RLINK := NIL; "END;  IF ROOT = NIL THEN "ROOT := P  ELSE "BEGIN "I := TREESEARCH(ROOT,Q,P^.NAME); "IF I = 1 THEN $Q^.RLINK := P "ELSE IF I = -1 THEN EVALUATE OPTIONAL NUMERIC ARGUMENT *)  VAR "I: INTEGER;  CONTINUE: BOOLEAN;   BEGIN  IF LENGTH(BUF) = 0 THEN "TYP := DEFAULTED  ELSE IF POS('+',BUF) = 1 THEN "TYP := RELPLUS  ELSE IF POS('-',BUF) = 1 THEN "TYP := RELMINUS  ELSE "TYP := ABSOLUTE;  IF TYP IN [RELPLUS,RELMINUS] THEN "DELETE(BUF,1,1);  I := 0;  CONTINUE := TRUE;  WHILE CONTINUE AND (LENGTH(BUF) > 0) DO  IF BUF[1] IN ['0'..'9'] THEN $BEGIN $I := (I*10)+(ORD(BUF[1])-ORD('0')); $DELETE(BUF,1,1); $END "ELSE); "END;  UL: "SETVAL(ULVAL,VAL,TYP,1,0,HUGE)  END; (* CASE *)  END;   PROCEDURE INIT; ((*====*)   VAR "P: ENTRYP;   BEGIN  BACKSPACE := CHR(8);  DOTCOUNT := 0;  LINECOUNT := 0; INCLUDING := FALSE;  FILL := TRUE;  LSVAL := 1;  INVAL :t allowed') "ELSE $BEGIN $INCLUDING := TRUE; $RESET(INCLUDEFILE,BUF); $END; "END;  SP: "BEGIN "SPVAL := 1; (* IN CASE VAL IS RELATIVE *) "SETVAL(SPVAL,VAL,TYP,1,0,HUGE); "SPACE(SPVAL); "END;  TI: "BEGIN "BRK; "SETVAL(TIVAL,VAL,TYP,0,0,RMVAL"IF BUF = '' THEN $EXIT(COMMAND) "ELSE IF POS('.TEXT',BUF) = 0 THEN $IF BUF[LENGTH(BUF)] <> ':' THEN &IF BUF[LENGTH(BUF)] <> '.' THEN (BUF := CONCAT(BUF,'.TEXT') &ELSE (DELETE(BUF,LENGTH(BUF),1); "IF INCLUDING THEN $ERROR('Nested include files noF: "BEGIN "BRK; "FILL := FALSE; "END;  PL: "BEGIN "SETVAL(PLVAL,VAL,TYP,PAGELENGTH,M1VAL+M2VAL+M3VAL+M4VAL+1,HUGE); "BOTTOM := PLVAL-M3VAL-M4VAL; "END;  RM: "SETVAL(RMVAL,VAL,TYP,PAGEWIDTH,SUCC(TIVAL),255);  SO: "BEGIN "UPSTRING(BUF); L)); "TIVAL := INVAL; "END;  LS: "SETVAL(LSVAL,VAL,TYP,1,1,HUGE);  NE: "BEGIN "BRK; "NEVAL := 1; (* IN CASE VAL IS RELATIVE *) "SETVAL(NEVAL,VAL,TYP,1,0,HUGE); "NEVAL := NEVAL*LSVAL; "IF LINENO+PRED(NEVAL) > BOTTOM THEN $SPACE(HUGE); "END;  NL,TYP,1,0,HUGE); "END;  DE: "BEGIN "BRK; "DEFINE(BUF); "END;  EN: "ERROR('.en outside of define');  FI: "BEGIN "BRK; "FILL := TRUE; "END;  FO: "GETTL(BUF,FOOTER);  HE: "GETTL(BUF,HEADER);  IND: "BEGIN "SETVAL(INVAL,VAL,TYP,0,0,PRED(RMVA"VAL := GETVAL(BUF,TYP);  CASE CT OF  UNKNOWN, DEFINED: "BEGIN "END;  BP: "BEGIN "IF LINENO > 0 THEN $SPACE(HUGE); "SETVAL(CURPAGE,VAL,TYP,SUCC(CURPAGE),-HUGE,HUGE); "NEWPAGE := CURPAGE; "END;  BR: "BRK;  CE: "BEGIN "BRK; "SETVAL(CEVAL,VA END;   PROCEDURE COMMAND; (* VAR BUF: STRING255 *) ((*=======*)   (* PERFORM FORMATTING COMMAND *)   VAR "VAL, "NEVAL, "SPVAL: INTEGER; "CT: CMDTYPE; "TYP: ARGTYPE;   BEGIN  CT := COMTYPE(BUF,TRUE);  IF CT IN HASNUMERICARG THEN IN (CT := COMTYPE(INBUF,FALSE); (IF CT = DE THEN *ERROR(CONCAT('Nested defines not allowed: ',BUF)) (ELSE IF CT = EN THEN *BEGIN *LINES := PRED(LINES); *EXIT(DEFINE); *END; (END $ END $ELSE &ERROR(CONCAT('Define pool overflow: ',BUF)); "END; $IF POOLINX+1+LENGTH(INBUF) <= MAXDEFPOOL THEN &BEGIN &(* TRICKY CODE INVOLVING LENGTH BYTE OF INBUF *) &MOVELEFT(INBUF,DEFPOOL[POOLINX],1+LENGTH(INBUF)); &POOLINX := POOLINX+1+LENGTH(INBUF); &LINES := SUCC(LINES); &IF POS('.',INBUF) = 1 THEN (BEG PROCEDURE DEFINE(VAR BUF: STRING255); ' (*======*)   (* DEFINE MACRO *)   VAR "P: ENTRYP; "CT: CMDTYPE; "INBUF: STRING255;   BEGIN  P := ENTERCMD(BUF,DEFINED);  WITH P^ DO "BEGIN "START := POOLINX; "LINES := 0; "WHILE GETLINE(INBUF) DO  BEGIN (* GETTL *)  WITH TITLE DO "BEGIN "LEFTM := INVAL; "RIGHTM := RMVAL; "GETPART(BUF,LEFTS); "GETPART(BUF,CENTERS); "GETPART(BUF,RIGHTS); "EMPTY := (LEFTS = '') AND (CENTERS = '') AND (RIGHTS = ''); "END;  END; BUF) > 0 THEN $BEGIN $DELIM := COPY(BUF,1,1); $DELETE(BUF,1,1); $I := POS(DELIM,BUF); $IF I = 0 THEN &BEGIN &S := BUF; &BUF := ''; &END $ELSE &BEGIN &I := PRED(I); &S := COPY(BUF,1,I); &DELETE(BUF,1,I); &END; $END "ELSE $S := ''; "END;  $CONTINUE := FALSE;  GETVAL := I;  END;  PROCEDURE GETTL(VAR BUF: STRING255; VAR TITLE: TITLEINFO); ' (*=====*)   (* SETUP TITLE FROM BUF *)   PROCEDURE GETPART(VAR BUF, S: STRING255); "VAR I: INTEGER; $DELIM: STRING[1]; "BEGIN "IF LENGTH(= 0;  RMVAL := PAGEWIDTH;  TIVAL := 0;  CEVAL := 0;  ULVAL := 0;  CURPAGE := 0;  NEWPAGE := 1;  LINENO := 0;  PLVAL := PAGELENGTH;  M1VAL := 2;  M2VAL := 2;  M3VAL := 2;  M4VAL := 2;  BOTTOM := PLVAL-M3VAL-M4VAL;  OUTW := 0;  OUTWDS := 0;  DIR := 0; HEADER.EMPTY := TRUE; FOOTER.EMPTY := TRUE;  HASNUMERICARG := [BP,CE,IND,LS,NE,PL,RM,SP,TI,UL];  OUTBUF := '';  (*$R-*)  BLANKS255[0] := CHR(255);  (*$R+*)  FILLCHAR(BLANKS255[1],255,' ');  UNDERLINE := '_ ';  UNDERLINE[2] := BACKSPACE;N^ IF LINENO > 0 THEN "SPACE(HUGE);  CLOSE(DESTFILE,LOCK);  IF NONCONSOLE THEN "WRITELN;  WRITELN(LINECOUNT,' lines');  END. S('#6:',DESTNAME) = 1) "OR NOT NONCONSOLE;  RESET(SOURCEFILE,SOURCENAME);  REWRITE(DESTFILE,DESTNAME);  IF NONCONSOLE THEN "WRITE('<',LINECOUNT:4,'>');  WHILE GETLINE(INBUF) DO "IF POS('.',INBUF) = 1 THEN $COMMAND(INBUF) "ELSE $TXT(INBUF); .TEXT') $ELSE &DELETE(DESTNAME,LENGTH(DESTNAME),1);  NONCONSOLE := (POS('CONSOLE:',DESTNAME) = 0)  AND (POS('SYSTERM:',DESTNAME) = 0) "AND (POS('#1:',DESTNAME) = 0) "AND (POS('#2:',DESTNAME) = 0); EMITPAGE := (POS('PRINTER:',DESTNAME) = 1) "OR (PO ');  READLN(DESTNAME);  UPSTRING(DESTNAME);  IF DESTNAME = '' THEN "DESTNAME := 'PRINTER:'  ELSE IF POS('.TEXT',DESTNAME) = 0 THEN "IF DESTNAME[LENGTH(DESTNAME)] <> ':' THEN $IF DESTNAME[LENGTH(DESTNAME)] <> '.' THEN &DESTNAME := CONCAT(DESTNAME,' ELSE IF POS('.TEXT',SOURCENAME) = 0 THEN "IF SOURCENAME[LENGTH(SOURCENAME)] <> ':' THEN $IF SOURCENAME[LENGTH(SOURCENAME)] <> '.' THEN &SOURCENAME := CONCAT(SOURCENAME,'.TEXT') $ELSE &DELETE(SOURCENAME,LENGTH(SOURCENAME),1); WRITE('Destination file:= *)  BEGIN  INIT;  PAGE(OUTPUT);  WRITELN('Format (7/27/81, 7:37 PM)');  WRITELN('Copyright (c) 1981 by Chris Wilson');  WRITELN;  WRITE('Source file: ');  READLN(SOURCENAME);  UPSTRING(SOURCENAME);  IF SOURCENAME = '' THEN "EXIT(FORMAT) ENTERCMD('LS',LS); P := ENTERCMD('NE',NE); P := ENTERCMD('NF',NF); P := ENTERCMD('PL',PL); P := ENTERCMD('RM',RM); P := ENTERCMD('SO',SO);  P := ENTERCMD('SP',SP); P := ENTERCMD('TI',TI); P := ENTERCMD('UL',UL);  END;  (* ========== MAIN BODY =========  ROOT := NIL;  POOLINX := 0; P := ENTERCMD('BP',BP);  P := ENTERCMD('BR',BR); P := ENTERCMD('CE',CE); P := ENTERCMD('DE',DE); P := ENTERCMD('EN',EN); P := ENTERCMD('FI',FI); P := ENTERCMD('FO',FO); P := ENTERCMD('HE',HE); P := ENTERCMD('IN',IND); P :=  (* Copyright (c) 1981 by Chris Wilson *)   PROCEDURE SKIP(N: INTEGER); ((*====*)   (* OUTPUT N BLANK LINES *)   VAR "I: INTEGER;   BEGIN  FOR I := 1 TO N DO "WRITELN(DESTFILE);  END;   PROCEDURE PUTTL(VAR TITLE: TITLEINFO; PAGENO: INT> 0 DO &BEGIN &I := I+SCAN(COUNT,=BACKSPACE,BUF[I]); &COUNT := (LENGTH(BUF)+1)-I; &IF COUNT <> 0 THEN (BEGIN (BS := SUCC(BS); (I := SUCC(I); (COUNT := PRED(COUNT); (END; &END; $WIDTH := LENGTH(BUF)-BS; $END;  END  ELSE "WIDTH := 0;  END; NG *)   VAR "I, "BS, "COUNT: INTEGER;   BEGIN  IF LENGTH(BUF) > 0 THEN  BEGIN "I := SCAN(LENGTH(BUF),=BACKSPACE,BUF[1]); "IF I = LENGTH(BUF) THEN $WIDTH := I "ELSE $BEGIN $BS := 1; $I := I+2; $COUNT := (LENGTH(BUF)+1)-I; $WHILE COUNT  BRK;  IF LENGTH(BUF) > 0 THEN "BEGIN "I := SCAN(LENGTH(BUF),<>' ',BUF[1]); "DELETE(BUF,1,I); "IF LENGTH(BUF) > 0 THEN $TIVAL := I;  END;  END;   FUNCTION WIDTH(VAR BUF: STRING255): INTEGER; '(*=====*)   (* COMPUTE WIDTH OF CHARACTER STRI $PHEAD; "SKIP(MIN(N,(BOTTOM+1)-LINENO)); "LINENO := LINENO+N; "IF LINENO > BOTTOM THEN $PFOOT; "END;  END;   PROCEDURE LEADBL(VAR BUF: STRING255); ((*======*)   (* DELETE LEADING BLANKS, SETUP TIVAL *)   VAR "I: INTEGER;   BEGIN LENGTH(OUTBUF) > 0 THEN "PUT(OUTBUF);  OUTW := 0;  OUTWDS := 0;  OUTBUF := '';  END;   PROCEDURE SPACE(N: INTEGER); ((*=====*)   (* SPACE N LINES OR TO BOTTOM OF PAGE *)   BEGIN  BRK;  IF LINENO <= BOTTOM THEN "BEGIN "IF LINENO = 0 THENITE(DESTFILE,' ':TIVAL);  TIVAL := INVAL;  WRITELN(DESTFILE,BUF);  SKIP(MIN(PRED(LSVAL),BOTTOM-LINENO));  LINENO := LINENO+LSVAL;  IF LINENO > BOTTOM THEN "PFOOT;  END;   PROCEDURE BRK; ((*===*)   (* END CURRENT FILLED LINE *)   BEGIN  IF"PUTTL(FOOTER,CURPAGE); "SKIP(PRED(M4VAL)); "END;  END;   PROCEDURE PUT(VAR BUF: STRING255); ((*===*)   (* PUT OUT LINE WITH PROPER SPACING AND INDENTING *)   BEGIN  IF (LINENO = 0) OR (LINENO > BOTTOM) THEN "PHEAD;  IF TIVAL > 0 THEN "WRLE);  IF M1VAL > 0 THEN "BEGIN "SKIP(PRED(M1VAL)); "PUTTL(HEADER,CURPAGE); "END;  SKIP(M2VAL);  LINENO := M1VAL+M2VAL+1;  END;   PROCEDURE PFOOT; ((*=====*)   (* PUT OUT PAGE FOOTER *)   BEGIN  SKIP(M3VAL);  IF M4VAL > 0 THEN "BEGIN HEN (WRITE(DESTFILE,' ':(J-I)); &WRITE(DESTFILE,S); $ END; $END;  WRITELN(DESTFILE);  END;   PROCEDURE PHEAD; ((*=====*)   (* PUT OUT PAGE HEADER *)   BEGIN  CURPAGE := NEWPAGE;  NEWPAGE := SUCC(NEWPAGE);  IF EMITPAGE THEN "PAGE(DESTFIPLACE(S); &J := MAX(((LEFTM+RIGHTM)-LENGTH(S)) DIV 2,0); &IF I < J THEN (WRITE(DESTFILE,' ':(J-I)); &WRITE(DESTFILE,S); &I := J+LENGTH(S); $ END; $IF LENGTH(RIGHTS) > 0 THEN &BEGIN &S := RIGHTS; &REPLACE(S); &J := RIGHTM-LENGTH(S); &IF I < J T$STR(PAGENO,PAGES); $IF LEFTM > 0 THEN &WRITE(DESTFILE,' ':LEFTM); $I := LEFTM; $IF LENGTH(LEFTS) > 0 THEN &BEGIN &S := LEFTS; &REPLACE(S); &WRITE(DESTFILE,S); &I := I+LENGTH(S); $ END; $IF LENGTH(CENTERS) > 0 THEN &BEGIN &S := CENTERS; &REEPLACE(VAR S: STRING255); "VAR I: INTEGER; "BEGIN "REPEAT $I := POS('#',S); $IF I <> 0 THEN &BEGIN &DELETE(S,I,1); &INSERT(PAGES,S,I); &END "UNTIL I = 0;  END;   BEGIN (* PUTTL *)  WITH TITLE DO "IF NOT EMPTY THEN $BEGIN "VAL := ABS(VAL); "S := ' '; "I := 6; "REPEAT $D := VAL MOD 10; $VAL := VAL DIV 10; $S[I] := CHR(ORD('0')+D); " I := PRED(I) "UNTIL VAL = 0; "IF MINUS THEN $BEGIN $S[I] := '-'; $I := PRED(I); $END; "DELETE(S,1,I); "END;  PROCEDURE REGER); ((*=====*)   (* PUT OUT TITLE LINE WITH OPTIONAL PAGE NUMBER *)   VAR "I, "J: INTEGER;  S: STRING255; "PAGES: STRING;   PROCEDURE STR(VAL: INTEGER; VAR S: STRING); "VAR D, I: INTEGER; " MINUS: BOOLEAN; "BEGIN "MINUS := VAL < 0;   PROCEDURE SPREAD(VAR BUF: STRING255; NEXTRA, OUTWDS: INTEGER);  (*======*)   (* SPREAD WORDS TO JUSTIFY RIGHT MARGIN *)   VAR "I, "NB, "NE, "NHOLES: INTEGER;   BEGIN  IF (NEXTRA > 0) AND (OUTWDS > 1) THEN "BEGIN "DIR := 1-DIR; "NE := NEXTRA; "NHOLES := PRED(OUTWDS); "I := 1; "WHILE NE > 0 DO $BEGIN $I := I+SCAN((LENGTH(BUF)+1)-I,=' ',BUF[I]); $IF DIR = 0 THEN &NB := (PRED(NE) DIV NHOLES)+1 $ELSE &NB := NE DIV NHOLES; $NE := NE-NB; $NHOLES := PRED(NHOL<5)"!!!?! """"!!"""""???!!9!!!!?!!!8!  !?!!!--3!!!1)%#!!!!!!!!.)!!!! !!! !>!!!!!! !!!!3--!!!!! !!"""?  ? "??( <12#.) *>*> ? !#-1!> ? !!  !? ?!!!?!!!! >!!  !F))F""" '@    <: $$$% !?!! "R  ! . "#   !! ((*|"" !!| > #***b#***I6IIIA"c""AA"|  *>~0~0I0IINBUF); "CEVAL := PRED(CEVAL); "END  ELSE IF LENGTH(INBUF) = 0 THEN "PUT(INBUF)  ELSE IF NOT FILL THEN "PUT(INBUF)  ELSE "WHILE GETWRD(INBUF,WRDBUF) > 0 DO $PUTWRD(WRDBUF);  END;  VAR "WRDBUF: STRING255;   BEGIN  IF LENGTH(INBUF) = 0 THEN "LEADBL(INBUF)  ELSE IF INBUF[1] = ' ' THEN "LEADBL(INBUF);  IF ULVAL > 0 THEN "BEGIN "UNDERL(INBUF); "ULVAL := PRED(ULVAL); "END;  IF CEVAL > 0 THEN "BEGIN "CENTER(INBUF); "PUT( "I := SCAN(LENGTH(INBUF),=' ',INBUF[1]); "OUT := COPY(INBUF,1,I); "DELETE(INBUF,1,I); "GETWRD := I;  END  ELSE "BEGIN "OUT := ''; "GETWRD := 0; "END;  END;   PROCEDURE TXT(VAR INBUF: STRING255); ((*===*)   (* PROCESS TEXT LINES *)  (*======*)   (* GET NON-BLANK WORD FROM INBUF INTO OUT, DELETE FROM INBUF *)   VAR "I: INTEGER;   BEGIN  IF LENGTH(INBUF) > 0 THEN "BEGIN "I := SCAN(LENGTH(INBUF),<>' ',INBUF[1]); "DELETE(INBUF,1,I); END;  IF LENGTH(INBUF) > 0 THEN "BEGINR "I: INTEGER;   BEGIN  I := 1;  WHILE (I < LENGTH(BUF)) AND (I < 254) DO "BEGIN "IF BUF[I] <> ' ' THEN $BEGIN $INSERT(UNDERLINE,BUF,I); $I := I+2; $END; "I := SUCC(I); "END;  END;   FUNCTION GETWRD(VAR INBUF, OUT: STRING255): INTEGER; ' PROCEDURE CENTER(VAR BUF: STRING255); ((*======*)   (* CENTER A LINE BY SETTING TIVAL *)   BEGIN  TIVAL := MAX(((RMVAL+TIVAL)-WIDTH(BUF)) DIV 2,0);  END;   PROCEDURE UNDERL(VAR BUF: STRING255); ((*======*)   (* UNDERLINE A LINE *)   VAUF) = 0 THEN "BEGIN "OUTBUF := WRDBUF; "OUTW := W; "END  ELSE "BEGIN "INSERT(' ',OUTBUF,LENGTH(OUTBUF)+1); "INSERT(WRDBUF,OUTBUF,LENGTH(OUTBUF)+1); "OUTW := OUTW+1+W; "END;  OUTWDS := SUCC(OUTWDS);  END;  W := WIDTH(WRDBUF);  LLVAL := RMVAL-TIVAL;  IF LENGTH(OUTBUF) > 0 THEN  BEGIN "LAST := LENGTH(OUTBUF)+1+LENGTH(WRDBUF); "IF (OUTW+1+W > LLVAL) OR (LAST > 255) THEN " BEGIN $SPREAD(OUTBUF,LLVAL-OUTW,OUTWDS); $BRK; " END; "END;  IF LENGTH(OUTBES); $INSERT(COPY(BLANKS255,1,NB),BUF,I); $I := I+NB+1; $END;  END;  END;   PROCEDURE PUTWRD(VAR WRDBUF: STRING255); ((*======*)   (* PUT A WORD IN OUTBUF; INCLUDES MARGIN JUSTIFICATION *)   VAR "W, "LAST, "LLVAL: INTEGER;   BEGIN   .#!#.1!1. ?!$ .11.!!!#    ****"""""""## .11.# >$.1!!! !!!6**""! ! .1!!? ?0IAAAAAA@@@@@@@@@@@@@@UUUUUUUU66[[66[[66mm66mmI$I$II$I$I$A]]]]AOOOAAAyyyAAAAAA>6>>*>**}yqaAACGO_>cUIIUc>>A]kIUA>wwcwwAUwcwU>>>>>>*? ><>{:>N^V8 ?'''??999? ?#?$<> ?99?####?    ++++7####??###??''? ?99?#??0?? ?####33!!7++##3 3> ?###?8?   0yO<5)"111?!!??####???#####????##;?###?!!! 3331!?333--3!333+%#!?333!!??!!?/+#!!?3?!!??00??~?###!!!33!!!!3--33333  >"""? 0?>>p8> 66666h 37;s/+ 80 0 I>>>>I ? ??8p?###!!? >0000?0000 ??##!!?000>"">   0 < !?6>60HH0~>>>( @`PP`@  @@((*|>6>>*>**"*6">""> $88>>>>>>*? ><>{:>      **    **  ((        ""*6"    **""  >>          6>60HH06>>*>**"*6">""> $88>>>>>>*? ><>{:>.#!#.1!1. ?!$ .11.!!!#    ****"""""""## .11.# >$.1!!! !!!6**""! ! .1!!? ? <5)"!!!?! """"!!"""""???!!9!!!!?!!!8!  !?!!!--3!!!1)%#!!!!!!!!.)!!!! !!! !>!!!!!! !!!!3--!!!!! !!"""?  ? "??( <12#.) *>*> ?  !#-1!> ? !!  !? ?!!!?!!!! >!!