`L i=L\Ʃx ? N'i  ͭЅ?0ȱ Ѕ?iȱi lԠԠ͠ԠϠŠͮŠ SYSTEM.APPLE   L$JO^̡!vg README.TEXTvgâDISK.DUMP.TEXTg%DIRECTORY.TEXTg% README2.TEXTvgâdlFULLDUPLEX.TEXTlr SYSGEN.TEXTvgrv STUP.TEXTr=vgvNATIVECODE.TEXT" MCRMODEM.TEXTvg2 GENEPOOL.TEXTvgr DOSCAT.TEXTvgâ PILOT.TEXT=vgWPILOT.DOC.TEXTgW DEBTS.TEXT=PSCAL10cCCS.GETIME.TEXT! STRFORT.TEXTvga CLOCKUNIT.TEXTga $CLKUNT1.1.CODEg!$* CCS.DOC.TEXTXTgҢ*. STARTUP.TEXTvg.B PLOTTER.TEXTvgBL CASHREG.TEXTvgâLd CHAREDIT.TEXTvg&꽌ɪɖ'*&%&,E'зЮ꽌ɪФ`+*xH&x'8*7Ixix&&  ') + &п x) ++`FG8`0($ p,&") (jJJ>L+ "?I>  N `  ` x V Nx .x- z `V0^*^*>` aI꽌ɪVɭ&Y&&Y& 꽌ɪ\8`&;---------------------------------------------  ; Pascal / Fortran routines to use the  ; California Computer Systems model 7424  ; Calendar / Clock Module  ;  ; David N. Jones 1/3/81  ;  ;--------------------------------------------  ; set up .FUNC IDAY  ; FUNCTION IDAY:INTEGER  ; GETS THE DAY AS AN INTEGER  POP RETURN (PLA (PLA (PLA (PLA (LDA #00 (PHA ;PUT MSB=0 ON STACK (LDA #26 (STA ADDR (STA ADDR (LDA DATA ;GET DAY (AND #0F GETS THE DATE AS AN INTEGER  ; (DOIT #28,#0F  ;---------------------------------------------  .FUNC IYEAR  ; FUNCTION IYEAR:INTEGER  ; GETS THE YEAR AS AN INTEGER  ; (DOIT #2C,#0F  ;---------------------------------------------   ;---------------------------------------------  .FUNC IMON  ; FUNCTION IMON:INTEGER  ; GETS THE MONTH AS AN INTEGER  ; (DOIT #2A,#0F  ;---------------------------------------------  .FUNC IDATE  ; FUNCTION IDATE:INTEGER  ; FUNCTION IMIN:INTEGER  ; GETS THE MINUTES AS AN INTEGER  ; (DOIT #23,#0F  ;---------------------------------------------  .FUNC ISEC  ; FUNCTION ISEC:INTEGER  ; GETS THE SECONDS AS AN INTEGER  ; (DOIT #21,#0F ;GO BACK TO CALLER  ;--------------------------------------------- (.FUNC IHOUR  ; FUNCTION IHOUR:INTEGER  ; GETS THE HOURS AS AN INTEGER  ;  DOIT #25,#03  ;---------------------------------------------  .FUNC IMIN  ;0 (PHA ;PUSH MSB OF VALUE = 0 (LDA DATA ;GET RESULT FROM CLOCK (AND #0F ;MASK OFF 4 BITS (PHA ;PUSH RESULT TO STACK (PUSH RETURN ;RESTORE RETURN ADDRESS (RTS (PLA ;DISCARD STACK BIAS (PLA (PLA (PLA (PLA ;GET LSB OF PARAMETER (STA ADDR ;WRITE TO CLOCK (STA ADDR ;WRITE TO CLOCK (PLA ;DISCARD MSB OF PARAMETER (LDA #0----------------------------------------- (.FUNC GETIME,1  ; GET ONE DIGIT FROM CLOCK-  ;  ; FUNCTION GETIME(CODE:INTEGER):INTEGER  ;---------------------------------------------  ; (POP RETURN ;SAVE RETURN ADDRESS (PHA ;PUSH MSB OF VALUE = 0 (LDA TEMP ;GET RESULT (PHA ;PUSH RESULT TO STACK (PUSH RETURN ;RESTORE RETURN ADDRESS (RTS ;GO BACK TO CALLER  .ENDM   ;---- ;WRITE TO CLOCK (STA ADDR ;WRITE TO CLOCK (LDA DATA ;GET RESULT FROM CLOCK (AND #0F ;MASK OFF 4 BITS (ADC TEMP ;ADD ONES TO TENS (STA TEMP ;SAVE RESULT (LDA #00 (AND %2 ;MASK FORMAT FLAGS ETC. (STA TEMP ;SAVE IT (ASL A ;MULTIPLY X 10 (ASL A (ADC TEMP (ASL A (STA TEMP ;SAVE DIGIT TENS X 10 (LDA %1-1 ;GET DIGIT X 1 (STA ADDR ;DISCARD STACK BIAS (PLA (PLA (PLA (LDA %1 ;GET DIGIT X 10 (STA ADDR ;WRITE TO CLOCK (STA ADDR ;WRITE TO CLOCK (LDA DATA ;GET RESULT FROM CLOCK version 1.0  ;  ; macro definitions  ;  .MACRO POP (PLA (STA %1 (PLA (STA %1+1 (.ENDM  ;  .MACRO PUSH (LDA %1+1 (PHA (LDA %1 (PHA (.ENDM  ; (.MACRO DOIT (POP RETURN ;SAVE RETURN ADDRESS (PLA address for slot 4  ;  RETURN .EQU 00  TEMP .EQU 02  OLDT .EQU 04  ADDR .EQU 0C0C1  DATA .EQU 0C0C0  KEY .EQU 0C000 ;KEYBOARD ADDRESS  SYSDAY .EQU 0AA18 ; version 1.1  ;SYSDAY .EQU 0A912 ; ;MASK OFF 4 BITS (PHA ;PUT RESULT ON STACK (PUSH RETURN  RTS  ;---------------------------------------------  .FUNC UPDATE,3  ; FUNCTION UPDATE(IMON,IDATE,IYEAR)  ; UPDATES THE PASCAL SYSTEM DATE AND RETURNS  ; AN INTEGER REPRESENTING THE OLD DATE  ; warning-this routine may be version dependent  ; (POP RETURN (LDA SYSDAY ;SAVE OLD DATE (STA OLDT (LDA SYSDAY+1 (STA OLDT+1 (PLA W.EQ.2) DAY='Sunday' &IF (IW.EQ.3) DAY='Monday' &IF (IW.EQ.4) DAY='Tuesday' &IF (IW.EQ.5) DAY='Wednesday' &IF (IW.EQ.6) DAY='Thursday' &IF (IW.EQ.7) DAY='Friday' &WRITE(*,1000) &WRITE(*,1005) DAY &WRITE(*,1004) ID,MON,IY &IF (IH.GT.12) WRITE(*,100IM.EQ.4) MON='Apr' &IF (IM.EQ.5) MON='May' &IF (IM.EQ.6) MON='Jun' &IF (IM.EQ.7) MON='Jul' &IF (IM.EQ.8) MON='Aug' &IF (IM.EQ.9) MON='Sep' &IF (IM.EQ.10)MON='Oct' &IF (IM.EQ.11)MON='Nov' &IF (IM.EQ.12)MON='Dec' &IF (IW.EQ.1) DAY='Saturday' &IF (I $USES CLOCKSTUFF  C234567890 PROGRAM TIME &CHARACTER*3 MON &CHARACTER*9 DAY &IH=IHOUR() &IM=IMON() &ID=IDATE() &IY=IYEAR() &IW=IDAY() &IOLD =UPDATE(IM,ID,IY) &IF (IM.EQ.1) MON='Jan' &IF (IM.EQ.2) MON='Feb' &IF (IM.EQ.3) MON='Mar' &IF (O^aTURN (RTS '.END ETUP TO COMPARE TO 127  CMP KEY (BCC TRUE ; >127 GOTO TRUE (LDA #00 ;FALSE -RESULT =0 (JMP FINI  TRUE LDA #01 ;TRUE -RESULT =1  FINI PHA ;PUSH RESULT ON STACK (PUSH RE(PUSH RETURN (RTS  ;  ; (.FUNC PRESSKEY  ; FUNCTION PRESSKEY:BOOLEAN  ; version of keypress that works with 80 col. displays  ; (POP RETURN (PLA (PLA (PLA (PLA (LDA #00 (PHA ;PUSH MSB = 0 (LDA #7F ;SLSB MONTH (ADC TEMP ;ADD SHIFTED DATE TO MONTH (STA SYSDAY ;STICK DATE TO MEMORY (TXA (STA SYSDAY+1 (PLA ;DISCARD MSB OF MONTH (LDA OLDT ;RETURN OLD DATE (PHA (LDA OLDT+1 (PHA SL A (ASL A (ASL A (ROL TEMP ;SHIFT CARRY TO FIRST BIT OF YEAR (LDX TEMP ;SAVE RESULT IN X (STA TEMP ;SAVE SHIFTED DATE FOR LATER (PLA ;DISCARD MSB DATE (PLA ;GET ;DISCARD STACK BIAS (PLA (PLA (PLA (PLA ;GET LSB YEAR (STA TEMP ;SAVE IT (PLA ;DISCARD MSB YEAR (PLA ;GET LSB DATE (ASL A ;SHIFT BIT 5 TO CARRY (A2) IH-12,IMIN(),ISEC() &IF (IH.LE.12) WRITE(*,1003) IH ,IMIN(),ISEC()  1000 FORMAT(///' Welcome to U.C.S.D. Fortran')  1002 FORMAT(' time: ',I2,':',I2,':',I2,' PM')  1003 FORMAT(' time: ',I2,':',I2,':',I2,' AM')  1004 FORMAT(' date: ',I2,'-',A3,'-',I2)  1005 FORMAT(/' today is: ',A9) &STOP &END  ='Tuesday '; (4 : DOW :='Wednesday'; (5 : DOW :='Thursday '; (6 : DOW :='Friday '; &END; (* OF CASE *) $END; (* DAYOFWEEK *)   BEGIN {Main Program}  (* DUMMY MAIN *)  END. $ &END; (* OF CASE *) &STR(IDATE,DAYS); &STR(IYEAR,YEARS); &DATES := CONCAT(DAYS,'-',MON,'-',YEARS); $END; (* DATE *) ! !PROCEDURE DAYOFWEEK; $BEGIN &CASE IDAY OF (0 : DOW :='Saturday '; (1 : DOW :='Sunday '; (2 : DOW :='Monday '; (3 : DOW :IN &CASE IMON OF (1 : MON :='Jan'; (2 : MON :='Feb'; (3 : MON :='Mar'; (4 : MON :='Apr'; (5 : MON :='May'; (6 : MON :='Jun'; (7 : MON :='Jul'; (8 : MON :='Aug'; (9 : MON :='Sep'; (10: MON :='Oct'; (11: MON :='Nov'; (12: MON :='Dec'; ISEC ; EXTERNAL;  FUNCTION IMIN ; EXTERNAL;  FUNCTION IMON ; EXTERNAL;  FUNCTION IDATE ; EXTERNAL;  FUNCTION IYEAR ; EXTERNAL;  FUNCTION IDAY ; EXTERNAL;  FUNCTION UPDATE; EXTERNAL; $ !PROCEDURE DATE; $VAR DAYS,MON,YEARS : STRING; $ $BEGINTEGER;  FUNCTION IDAY :INTEGER;  FUNCTION UPDATE(IMON,IDATE,IYEAR:INTEGER):INTEGER; PROCEDURE DATE(VAR DATES:STRING);  PROCEDURE DAYOFWEEK (VAR DOW:STRING); $ $  IMPLEMENTATION  FUNCTION GETIME; EXTERNAL;  FUNCTION IHOUR ; EXTERNAL;  FUNCTION (*$S+*)  UNIT CLOCKSTUFF; INTRINSIC CODE 24; "  INTERFACE  FUNCTION GETIME(DIGIT:INTEGER):INTEGER;  FUNCTION IHOUR:INTEGER;  FUNCTION ISEC :INTEGER;  FUNCTION IMIN :INTEGER;  FUNCTION IMON :INTEGER;  FUNCTION IDATE:INTEGER;  FUNCTION IYEAR:O^a CLOCKSTU E.TEXT - This file is the source code for the assembly 9language routines. It is set up for the clock 9in slot 4 and version 1.1 of Pascal. The proper 9system date address for version 1.0 is commented 9out if you want to use 1.0. ADDR must be changed Apple Pascal I decided to take a stab at it as my first  assembly language project. Here is the result. The clock functions can  be installed into the system library and called via the USES statment.  The following files are involved:   '1) GETIMPascal Unit for the California Computer Systems Calendar/Clock module     David N. Jones  6964 Walling Ln.  Dallas Tx. 75231  348-0604   14-Feb-81   Since the CCS model 7424 clock card does not come with any software to  interface it withO^ҢҢEAN;  FUNCTION UPDATE(IMON,IDATE,IYEAR:INTEGER):INTEGER; PROCEDURE DATE(VAR DATES:STRING);  PROCEDURE DAYOFWEEK (VAR DOW:STRING); $ $  IMPLEMENTATION L E M.WRK.TEXT*SYSTEM.WRK.CODE[*]APPLE2:SYSTEM.SWAPDISKGETIME IHOUR IDATE IDAY ISEC IMIN IMON IYEAR PRESSKEY UPDATE  ;  FUNCTION IYEAR:INTEGER; FUNCTION IDAY :INTEGER;  FUNCTION PRESSKEY :BOOL}}PZ|   wئ Saturday תP{צ Sunday Pjئ Monday תPYצ Tuesday PHئ WednesdayתP7צ Thursday P&ئ Friday תP~o`QB3$  2:SYSTEM.SWAPDISK+צJanP+צFebP+צMarP+צAprP+צMayPt+צJunPh+צJulP\+צAugPP+צSepPD+צOctP8+צNovP,+צDecP  zpf\RH>4*TP P }}TP}צ-Q}+ǡ}צ-ǢEAN;  FUNCTION UPDATE(IMON,IDATE,IYEAR:INTEGER):INTEGER; PROCEDURE DATE(VAR DATES:STRING);  PROCEDURE DAYOFWEEK (VAR DOW:STRING); $ $  IMPLEMENTATION L E M.WRK.TEXT*SYSTEM.WRK.CODE[*]APPLE2:SYSTEM.SWAPDISK  FUNCTION GETIME(DIGIT:INTEGER):INTEGER;  FUNCTION IHOUR:INTEGER;  FUNCTION ISEC :INTEGER;  FUNCTION IMIN :INTEGER;  FUNCTION IMON :INTEGER;  FUNCTION IDATE:INTEGER;  FUNCTION IYEAR:INTEGER; FUNCTION IDAY :INTEGER;  FUNCTION PRESSKEY :BOOLBB9to the proper address if the clock is in any 9other slot. Comments in the code show the 9usage of the routines. 9 '2) CLOCKUNIT.TEXT - This file contains a file to create a unit of 9the clock routines that can be installed in the 9system library. Included are a couple of routines 9to return string values for the date and day of 9the week. 9 '3) START.TEXT - This file is a Pascal program that can be used 9as a SYSTEM.STARTUP program and demonstrates 9several of the clock r R MAIN MODIFY ROTATE HIDDEN DIVIDE SEND INITIALIMENU Oa fO^ğEC:2,' PM') #ELSE WRITE (IHOUR:2,':',IMIN:2,':',ISEC:2,' AM');  UNTIL KEYPRESS;   (* UPDATE SYSTEM DATE *)  IOLD:=UPDATE(IMON,IDATE,IYEAR);  (* WRITELN (' OLD DATE=',IOLD); *)  END. $ rtran'); "WRITELN; "WRITELN; "DAYOFWEEK(DOW); (WRITELN(' today is : ',DOW); "DATE(DATES); (WRITELN(' date : ',DATES); " WRITE (' time : '); "REPEAT "GOTOXY(15,8); "IF (IHOUR>12) " THEN WRITE (IHOUR-12:2,':',IMIN:2,':',ISPROGRAM CLOCK;  USES APPLESTUFF,CLOCKSTUFF;  VAR  #DATES,DOW : STRING; ! IOLD : INTEGER; "   BEGIN {Main Program} "PAGE(OUTPUT); "WRITELN; "WRITELN; "WRITELN; "WRITELN(' Welcome to U. C. S. D. Pascal/FoO^l try to help if you can't get them to work. " " ibrary using the 9LIBRARY program on APPLE3:. If you put the clock 9in slot 4 and use version 1.1 there is no reason 9to recompile and assemble the files. 9 9 9 "I have been using these programs for a couple of months now and had no "problems. I'loutines. 9 '4) STRFORT.TEXT - This file is an Apple Fortran version of the 9above program. Note that the string routines 9can't be used in fortran. 9 '5) CLKUNT1.1.CODE - This is a compiled and linked code file ready 9to be loaded into the system l (*$S+*)  (*$C(C) COPYWRITE SEPT,1979*)  PROGRAM PLOT3D;   USES TURTLEGRAPHICS,TRANSCEND,APPLESTUFF;   (* THE FOLLOWING VARIABLES ARE USED IN #THE MAIN AND INITIALIZATION PROGRAMS *)   VAR Q11,Q12,Q13,Q21,Q22,Q23,Q31,Q32,Q33, &A1,A2,A3,C1,C2,END; &PENCOLOR(COL); &MOVETO(ROUND(X),ROUND(Y)); &FILLIN; OLDX:=X; OLDY:=Y; $END;  END; (*SEND*)   PROCEDURE DIVIDE;   VAR L5L7,DELTAX,DELTAY,SAVX,SAVY, &L2,L4,L7,L8,S6:REAL;   BEGIN "DELTAX:=X-OLDX; DELTAY:=Y-OLDY; "L8:=SQRT(DELTAX*DELTAXDINTERSECT; .EXIT(SEND); ,END; (END; &IF (YB2[IX]) (THEN BEGIN *FINDINTERSECT; EXIT(SEND); (END; &U8:=1; &IF U9=LEFTSIDE THEN (BEGIN *OLDX:=X; OLDY:=Y; *PENCOLOR(NONE); *MOVETO(ROUND(X),ROUND(Y)); *U4:=0; U8:=1; EXIT(SEND); ($BEGIN OLDX:=X; OLDY:=Y; END "ELSE $BEGIN &U3:=0; &S9:=DELTAY/DELTAX; &IX:=ROUND(X); &IF U8=0 THEN (BEGIN *IF (Y>B2[IX]) AND (YX $END; $END  END; (*INTERSECT*)   PROCEDURE FILLIN;   VAR ITEMP:INTEGER; $RU7:REAL;  $PROCEDURE RANGECK; $VAR U7:INTEGER; $BEGIN &U7:=ROUND(RU7); &S8:=OLDY+S9*(RU7-OLDX); &IF B2[U7]>S8 THEN B2[U7]:=S8; &IF B1[U7]B1[IX] THEN ,BEGIN .IF Y7>B1[IX1] THEN BUMPUP := FALSE; .IF Y7B2[IX1] THEN BUMPUP := TRUE; ,END (END  IX1:=ROUND(X1); &Y7:=S9*(X1-OLDX)+OLDY; &IF U3=0 THEN (BEGIN *IF OLDY>B2[IX9] THEN ,BEGIN .IF Y7B1[IX1] THEN BUMPUP := TRUE; ,END *ELSE ,BEGIN .IF Y7>B2[IX1] THEN BUMPUP := FALSE; - IF Y7L9 THEN $BEGIN &L2:=OLDX; SAVX:=X; SAVY:=Y; &S6:=DELTAY/DELTAX; &L7:=DELTAX/(L8/L9); &L4:=OLDY-S6*OLDX; &X:=L2; L5L7:=SAVX-L7; &REPEAT (Y:=S6*X+L4; (SEND; (X:=X+L7; &UNTIL X>L5L7; $ X:=SAVX; Y:=SAVY; $END; "SEND;  END; (*DIVIDE*)   PROCEDURE HIDDEN;   VAR IX:INTEGER;   BEGIN "IF (X>279.0) OR (X<1.0) THEN $BEGIN U4:=1; EXIT(HIDDEN); END; "IX:=ROUND(X); "IF (U9=LEFTSIDE) AND (YB2[IX]) $ THEN BEGIN &U8:=0; OLDX:=X; OLDY:=Y; &EXIT(HIDDEA -SPACE- WILL STOP AND START');  WRITELN(' THE PLOT.');  END; (*MENU*)   BEGIN (* MAIN PROGRAM *)  REPEAT "MENU; "INITIALIZE; "INITTURTLE; "GRAFMODE; "STEP:=BREADTH/DIVISIONS; "CONX:=80/BREADTH; "CONY:=80/BREADTH; "STOP:=FALS2; & SETPARMS(2,20,30,-75,0,30); +END; &'E': EXIT(PLOT3D); $END; "UNTIL SELECTION>0;  MODIFY; "PAGE(OUTPUT); "FOR J := 1 TO 10 DO WRITELN; "WRITELN('WHILE PLOT IS BEING GENERATED');  WRITELN('A -RETURN- WILL EXIT THE PLOT');  WRITELN('$WRITELN(' E - EXIT BACK TO SYSTEM'); $WRITELN; $WRITELN; $WRITE('SELECT ITEM - '); $REPEAT UNTIL KEYPRESS; $READ(KEYBOARD,CH); $SELECTION:=0; $CASE CH OF &'1': BEGIN +SELECTION:=1; +SETPARMS(10,20,30,-75,0,30); +END; &'2': BEGIN +SELECTION:=C) COPYWRITE SEPT 1979'); $WRITELN; $WRITELN; $WRITELN(' PREDEFINED PLOT FUNCTIONS'); $WRITELN; $WRITELN(' 1 - R = SQRT(T^2+G^2)'); $WRITELN(' F = 8/(R+1)*COS(1.2*R)'); $WRITELN(' 2 - F = T*G*(T^2-G^2)/(T^2+G^2)'); $WRITELN; $5: YROT:=T1; $6: ZROT:=T1; "END;  UNTIL FALSE;  END; (*MODIFY*)   PROCEDURE MENU;   VAR J:INTEGER;   BEGIN "REPEAT; $PAGE(OUTPUT); $WRITELN(' THREE DIMENSIONAL PLOT PROGRAM'); $WRITELN(' BY MIKE LAUMER'); $WRITELN; $WRITELN('( $'3': J:=3; $'4': J:=4; $'5': J:=5; $'6': J:=6; $'P': EXIT(MODIFY); "END; "IF J>0 THEN $BEGIN &WRITELN; &WRITE('#',CH,' - INPUT VALUE -> '); &READLN(T1); $END; "CASE J OF $1: BREADTH:=T1; $2: DIVISIONS:=T1; $3: DISTANCE:=T1; $4: XROT:=T1;"WRITELN('6 - Z ROTATION (DEG) (',ZROT,') '); "WRITELN; "WRITELN('P - PLOT SELECTED FUNCTION'); "WRITELN; "WRITE('WHAT WILL IT BE? '); "REPEAT UNTIL KEYPRESS; "READ(KEYBOARD,CH); "WRITELN(OUTPUT,CH); "J:=0; "CASE CH OF " '1': J:=1; $'2': J:=2;,BREADTH,') '); "WRITELN('2 - NUMBER OF X/Y DIVISIONS (',DIVISIONS,') '); "WRITELN('3 - VIEWING DISTANCE (',DISTANCE,') '); "WRITELN('4 - X ROTATION (DEG) (',XROT,') '); "WRITELN('5 - Y ROTATION (DEG) (',YROT,') '); IONS := B; "DISTANCE := C; "XROT := D; YROT:= E; ZROT := F;  END; (*SETPARMS*)   PROCEDURE MODIFY;   VAR J:INTEGER;   BEGIN  REPEAT "PAGE(OUTPUT); "WRITELN('MODIFY PLOT PARAMETERS.'); "WRITELN; "WRITELN; "WRITELN('1 - BREADTH OF FIELD ('"LEFTSIDE:=-BREADTH; RIGHTSIDE:=BREADTH; "DELTA:=BREADTH/DIVISIONS/10.0; "FOR J:=0 TO 279 DO $BEGIN B1[J]:=0; $B2[J]:=191; END; "ROTATE;  COL:=WHITE;  END; (*INITIALIZE*)   PROCEDURE SETPARMS(A,B,C,D,E,F:REAL);   BEGIN "BREADTH := A; DIVIS"Q13:=COS(ZR)*COS(XR)*SIN(YR)+SIN(ZR)*SIN(XR); "Q23:=-SIN(ZR)*COS(XR)*SIN(YR)+COS(ZR)*SIN(XR); "Q33:=COS(XR)*COS(YR);  END; (*ROTATE*)   PROCEDURE INITIALIZE;   VAR J:INTEGER;   BEGIN "U4:=0; "FIRSTRIGHT:=TRUE; FIRSTLEFT:=TRUE; "L9:=75.0; OT*DEGTORAD; "YR:=YROT*DEGTORAD; "ZR:=ZROT*DEGTORAD; "Q11:=COS(ZR)*COS(YR); "Q21:=-SIN(ZR)*COS(YR);  Q31:=-SIN(YR); "Q12:=-COS(ZR)*SIN(XR)*SIN(YR)+SIN(ZR)*COS(XR); "Q22:=SIN(ZR)*SIN(XR)*SIN(YR)+COS(ZR)*COS(XR); "Q32:=-SIN(XR)*COS(YR); X-OLDX)=0 THEN $BEGIN &PENCOLOR(COL); &MOVETO(ROUND(X),ROUND(Y)); &FILLIN; &OLDX:=X; OLDY:=Y; EXIT(HIDDEN); $END; "DIVIDE; "SEND;  END; (*HIDDEN*)   PROCEDURE ROTATE;   VAR DEGTORAD,XR,YR,ZR:REAL;   BEGIN "DEGTORAD:=3.14159/180; "XR:=XRN); $END; "IF (U9=LEFTSIDE) OR (U4=1) THEN LEFTFILL; "IF U9=RIGHTSIDE THEN RIGHTFILL; "U3:=0; "IF (U9=LEFTSIDE) OR (U4=1) THEN $BEGIN &OLDX:=X; OLDY:=Y; &PENCOLOR(NONE); &MOVETO(ROUND(X),ROUND(Y)); &U4:=0; U8:=1; EXIT(HIDDEN); $END; "IF ROUND(E; "T:=LEFTSIDE; "REPEAT $IF (T>-DELTA) AND (T-DELTA) AND (G0 THEN $BEGIN &IF LINE<23 THEN LINE:=LINE+1; &IF ONES=1 THEN WRITELN(' 1 SUSAN B. ANTHONY DOLLAR') 3(OLLAR BILL') 4ELSE WRITELN(TWENTIES:5,' TWENTY DOLLAR BILLS'); $END; "IF TENS>0 THEN $BEGIN &IF LINE<23 THEN LINE:=LINE+1; &IF TENS=1 THEN WRITELN(' 1 TEN DOLLAR BILL') 0ELSE WRITELN(TENS:5,' TEN DOLLAR BILLS'); $END;  IF FIVES>0 THEN $BEGIN$BEGIN &IF LINE<23 THEN LINE:=LINE+1; &IF FIFTIES=1 THEN WRITELN(' 1 FIFTY DOLLAR BILL') 3ELSE WRITELN(FIFTIES:5,' FIFTY DOLLAR BILLS'); $END; "IF TWENTIES>0 THEN $BEGIN &IF LINE<23 THEN LINE:=LINE+1; &IF TWENTIES=1 THEN WRITELN(' 1 TWENTY DGE(AMT:INTEGER;VAR MONEY:INTEGER);  "BEGIN $MONEY:=0; $WHILE CHANGE>=AMT DO &BEGIN CHANGE:=CHANGE-AMT;MONEY:=MONEY+1;END; "END; " "  PROCEDURE DISPLAY;   BEGIN  IF LINE<23 THEN LINE:=LINE+1; "WRITELN('YOUR CHANGE IS:'); "IF FIFTIES>0 THEN $BEGIN &WRITE('>');READ(ITEM); &IF LINE<23 THEN LINE:=LINE+1; &PRICE:=ITEM/100; &GOTOXY( 0,LINE);WRITE ('>',ITEM,' '); &GOTOXY(20,LINE);WRITELN('$',(PRICE):6:2); &SUM:=SUM+ITEM; $END;  UNTIL EOLN; "WRITELN;  END;    PROCEDURE MAKECHANVAR LINE,SUM,AMTTEND,CHANGE:INTEGER;  AMTPAID,TOTAL:REAL;  FIFTIES,TWENTIES,TENS,FIVES,ONES:INTEGER;  HALVES,QUARTERS,DIMES,NICKELS,PENNIES:INTEGER;    PROCEDURE ENTER;   VAR PRICE:REAL;  ITEM:INTEGER;  BEGIN "SUM:=0; "REPEAT  { Program from Gary Boudreaux - Dallas Apple Corps }  { February 1981 }  { A couple of changes by Lee Meador (Susie B & no }  { half dollars) March 1981 }    PROGRAM CASHREGISTER;   N^âREAD(KEYBOARD,CH); ,END; (END; $UNTIL (G>RIGHTSIDE) OR STOP; $T:=T+STEP; "UNTIL (T>RIGHTSIDE) OR STOP;  TEXTMODE;  UNTIL FALSE;  END.  ON1:=DISTANCE-C3; &X:=140+DISTANCE*(C1*CONX)/CON1; &Y:= 96+DISTANCE*(C2*CONY)/CON1; &HIDDEN; &G:=G+STEP; $ IF KEYPRESS THEN (BEGIN READ(KEYBOARD,CH); *IF EOLN(KEYBOARD) THEN ,STOP:=TRUE; ( IF CH=' ' THEN ,BEGIN .REPEAT UNTIL KEYPRESS; ( * could be ONE DOLLAR BILL') *) 0ELSE WRITELN(ONES:5,' SUSAN B. ANTHONY DOLLARS'); 3(* could be ONE DOLLAR BILLS'); *) $END; "IF HALVES>0 THEN $BEGIN &(* could be IF LINE<23 THEN LINE:=LINE+1; &IF HALVES=1 THEN WRITELN(' 1 HALF DOLLAR') 2ELSE WRITELN(HALVES:5,' HALF DOLLARS');*) &QUARTERS := QUARTERS + 2*HALVES; $END; "IF QUARTERS>0 THEN $BEGIN &IF LINE<23 THEN LINE:=LINE+1; &IF QUARTERS=1 THEN WRITELN(' 1 QUARTER') & ELSE WRITELN(QUARTERS:5,' QUARTERS'); $END; "e used }  { by the WCHAR and WSTRING functions in the }  { TURTLEGRAPHICS unit. }   { Mods by Lee Meador - March 1981 }  { fix a few misc bugs plus add these features }  { V - comand to redisplay shapepe }  { display and allows cursor movement to add }  { and remove spots that are white. See pages }  { 98,99 in the (NEW) Apple Pascal Lang Ref }  { Manual for (a little) more information on }  { the character sets. These shapes ar  { Originally written by Glen Dower }  { From Gary Boudreaux -- Dallas Apple Corps }  { Feb 1981 }  { Allows you to modify the shapes in the }  { SYSTEM.CHARSET file on APPLE1:. Has shaLEFTOFF A B G$N^vâES); "MAKECHANGE(50,HALVES); "MAKECHANGE(25,QUARTERS); "MAKECHANGE(10,DIMES); "MAKECHANGE(5,NICKELS); "MAKECHANGE(1,PENNIES); "DISPLAY; "END.  2,LINE) ELSE GOTOXY(22,(LINE-1));  WRITELN('$',AMTPAID:6:2); "IF LINE<23 THEN LINE:=LINE+1; "WRITELN; "CHANGE:=AMTTEND-SUM; "MAKECHANGE(5000,FIFTIES); "MAKECHANGE(2000,TWENTIES); "MAKECHANGE(1000,TENS); "MAKECHANGE(500,FIVES); "MAKECHANGE(100,ON"IF LINE<23 THEN LINE:=LINE+1; "GOTOXY(20,LINE);WRITELN('$',(TOTAL):6:2); "IF LINE<23 THEN LINE:=LINE+1; "WRITELN;  IF LINE<23 THEN LINE:=LINE+1; "WRITE('AMOUNT TENDERED ');READLN(AMTTEND);  AMTPAID:=AMTTEND/100; "IF LINE<23 THEN GOTOXY(2LN('CASH REGISTER'); "WRITELN; "WRITELN('USE SPACE BAR TO ENTER ITEMS'); "WRITELN('USE INSTEAD OF SPACE BAR FOR LAST ITEM'); "LINE:=4; "WRITELN; "ENTER; "IF LINE<23 THEN LINE:=LINE+1; "GOTOXY(20,LINE);WRITELN('-------'); "TOTAL:=SUM/100; N(NICKELS:5,' NICKELS'); $END; "IF PENNIES>0 THEN $BEGIN &IF LINE<23 THEN LINE:=LINE+1; &IF PENNIES=1 THEN WRITELN(' 1 PENNY') 3ELSE WRITELN(PENNIES:5,' PENNIES'); $END;  END;    BEGIN (* MAIN PROGRAM *) "PAGE(OUTPUT); "GOTOXY(13,0);WRITEIF DIMES>0 THEN $BEGIN &IF LINE<23 THEN LINE:=LINE+1; &IF DIMES=1 THEN WRITELN(' 1 DIME') 1ELSE WRITELN(DIMES:5,' DIMES'); $END;  IF NICKELS>0 THEN $BEGIN &IF LINE<23 THEN LINE:=LINE+1; &IF NICKELS=1 THEN WRITELN(' 1 NICKEL') 3ELSE WRITEL in buffer }  { H - command to provide HELPful information }  { ? - same as H)elp }  { - move cursor to front of next line }  { C - copy line above current }  { D - draw shape on graphics screen }  { G,P - take char or $xx HEX to locate char }  { left and right arrow and ^O and ^L move cursr}   PROGRAM CHAREDIT;   USES TURTLEGRAPHICS;   TYPE "CHRANGE = 0..127; "BYTES = 0..7;CH <> ' ' THEN BEGIN )WRITE(CH); ) )IF CH IN ['0'..'9'] THEN +READHEX := ORD(CH) - ORD('0'); )IF CH IN ['A'..'F'] THEN +READHEX := ORD(CH) - ORD('A') + 10; )IF CH IN ['a'..'f'] THEN +READHEX := ORD(CH) - ORD('a') + 10; &END (* IF *) & &ELSE READ) #  PROCEDURE HEXIN(VAR NUM: INTEGER);  "VAR $DIG1, $DIG2 : INTEGER;  "FUNCTION READHEX: INTEGER;  $VAR &CH : CHAR;  $BEGIN (* READHEX *)  &REPEAT & READ(KEYBOARD, CH) &UNTIL CH IN ['0'..'9', 'A'..'F', ' ', 'a'..'f'];  &IF #WRITELN(' cursor be dark when displayed graphically. '); #WRITELN('H)elp- Displays this message.');  END; (* HELP2*)   PROCEDURE HELP_WAIT;   BEGIN #WRITELN; #write (' PUSH ANY KEY TO CONTINUE '); #READ(CH);  END; (* HELP_WAIT * down, and up, respectively.'); #WRITELN('X - Type an X at any point to make that spot white '); #WRITELN(' when displayed graphically. '); #WRITELN('space- Push the space bar to make the spot under the '); the'); #WRITELN(' cursor to the next line down.'); #WRITELN('return-Move the cursor to the front of the next line '); #WRITELN(' down. No dots are changed.'); #WRITELN('JKMI - These keys move the edit cursor left, right, '); #WRITELN(' any key to go back'); #WRITELN(' to editing.');  END; (* HELP1 *)   PROCEDURE HELP2;   BEGIN #PAGE(OUTPUT); #WRITELN('C)opy- Take a copy of the line above the current line');  WRITELN(' and move it to the current line. Then move #WRITELN('Q)uit- Stop running the program. Quit options are simi-'); #WRITELN(' lar to the Editor''s. ( S)ave, E)xit, R)eturn )');  WRITELN('D)raw- Shows the character in the edit buffer on the'); #WRITELN(' Hi-Res Graphics display. Pushuse'); #writeln(' the previous character again.'); #WRITELN('P)ut - Moves the shape in the edit buffer back to the'); #WRITELN(' char set holding area. Entry is like with G)et.'); )et - Brings a shape into the edit buffer (shown on'); #WRITELN(' the screen if any). You may enter either the'); #WRITELN(' character itself or "$xx" where the "xx" is a hex'); #writeln(' code for the character. Pushing will r to modify the SYSTEM.CHARSET file'); #WRITELN('from APPLE1:. This is the file of shapes that governs'); #WRITELN('what WCHAR and WSTRING write on the graphics display.'); #writeln('The modified file is stored as NEW.CHARSET.'); #WRITELN; #WRITELN('G (* lacking other ideas, I split it in two. LM *)   BEGIN #HELP1; #HELP_WAIT; #HELP2; #HELP_WAIT; #HEADER;  END;   PROCEDURE HELP1;   BEGIN #PAGE(OUTPUT); #WRITELN('CHARACTER EDIT'); #WRITELN; #WRITELN(' Allows the use FORWARD;   PROCEDURE HELP; (* NO PARAMETERS *)   (* Print out some helpful messages. Sorry but its set up for *)  (* an 80 column screen. You will have to use the ctrl-A key *)  (* to read the whole thing. This procedure was too long so *) : CHAR; "ch : char; "  PROCEDURE HELP1; FORWARD; (* FORWARD means definition is *)  PROCEDURE HELP2; FORWARD; (* found later in program *)  PROCEDURE HEADER; FORWARD;  PROCEDURE DISPLAY_SHAPE_BUFFER; FORWARD;  PROCEDURE HELP_WAIT; "BITS = 0..7; "EXPAND = PACKED ARRAY[BYTES] OF .SET OF BITS;   VAR "F, G : FILE OF ARRAY[CHRANGE] OF .EXPAND; "EXPANDED : EXPAND; "FNAME : STRING[40];  CHNUM : INTEGER; "BYTE,SBYTE: INTEGER; "BIT,SBIT : INTEGER; "OPTHEX := -1; + $END; (* READHEX *)    BEGIN (* HEXIN *)  "READ(CH); "IF CH <> '$' %THEN IF EOLN THEN NUM := CHNUM 2ELSE NUM := ORD(CH) MOD 128 " %ELSE BEGIN (DIG1 := READHEX; ( (IF DIG1 < 0 +THEN NUM := CHNUM +ELSE BEGIN -REPEAT /DIG2 := READHEX -UNTIL DIG2 >= 0; - -NUM := DIG1*16 + DIG2 - +END (* IF DIG1 < 0 ELSE *) ! %END; (*ELSE**) !  END; (* HEXIN *)    PROCEDURE GETCHNUM(MSG: STRING);  "BEGIN (* GETCHNUM *)  $GOTOXY(0,1); $WRITE(MSG, ' which characteBIT]; -ADVANCE +END; - )END; (* CASE ' ' *)  %'I', 'i': (* UP *) )BEGIN +BYTE := BYTE + 1; +IF BYTE > 7 THEN -BYTE := 0;  )END; (* CASE 'I' *) (******************) H(* CURSOR CONTROL *) %'M', 'm': (* DOWN *) ( (* TURN A BIT OFF *) )BEGIN +IF EOLN(KEYBOARD) THEN BEGIN (* go to front of next line *) -BYTE := BYTE - 1; -IF BYTE < 0 THEN BYTE := 7; -BIT := 0; +END + +ELSE BEGIN (* turn off this bit *) -WRITE(' '); -EXPANDED[BYTE] := EXPANDED[BYTE] - [)BEGIN +IF BYTE < 7 THEN BEGIN .EXPANDED[BYTE] := EXPANDED[BYTE+1]; .SBYTE := BYTE; (* SAVE BYTE VALUE *) .DISPLAY_SHAPE_BUFFER; .BYTE := SBYTE - 1; .IF BYTE<0 THEN BYTE := 7; .BIT := 0; +END; (* IF BYTE < 7 *) )END; (* CASE % *) ) %' ': M] := EXPANDED; +DISPLAY_SHAPE_BUFFER; + )END; (* CASE 'P' *)  %'X', 'x', '*': (* TURN A BIT ON *) )BEGIN +WRITE('*'); +EXPANDED[BYTE] := EXPANDED[BYTE] + [BIT]; +ADVANCE )END; (* CASE 'X' *)  %'C', 'c': (* COPY LINE ABOVE *) AND DISPLAY A CHARACTER *) )BEGIN ) GETCHNUM('Get'); +EXPANDED := F^[CHNUM]; +DISPLAY_SHAPE_BUFFER; )END; ) $ 'V', 'v': )DISPLAY_SHAPE_BUFFER; (* CASE 'G' *)  %'P', 'p': (* SAVE A CREATED CHARACTER *) )BEGIN +GETCHNUM('Put'); +F^[CHNUT ( OPT IN [' ','X','x','*','G','g','P','p', 5'J','j','K','k','I','i','M','m', 5'Q','q','V','v','H','h','?', 5'D','d','C','c' ]) 'THEN BEGIN /write(chr(7)); (*BEEP*) /OPT := 'V'; ,END; ' $ $CASE OPT OF  %'G', 'g': (* GET $READ(KEYBOARD, OPT);  $IF ORD(OPT)= 8 THEN OPT:= 'J'; (* LEFT ARROW = J *) $IF ORD(OPT)=21 THEN OPT:= 'K'; (* RIGHT ARROW = K *) $IF ORD(OPT)=12 THEN OPT:= 'M'; (* CTRL-L = M *) $IF ORD(OPT)=15 THEN OPT:= 'I'; (* CTRL-O = O *) $ $IF NOANDED[BYTE] -THEN DRAWBLOCK(DOT,1,0,0,1,1,138+BIT,90+BYTE,15) -ELSE DRAWBLOCK(DOT,1,0,0,1,1,138+BIT,90+BYTE,00);  END; (* DRAW SHAPE BUFFER *)   BEGIN (* CHAREDIT *)  "INIT; " "HEADER;  "REPEAT  $SETCURSOR(BYTE,BIT); # #WRITE(' ':15, '---------'); # #BYTE := 7; #BIT := 0; #SETCURSOR(BYTE, BIT);   END; (* DISPLAY_SHAPE_BUFFER *) "  PROCEDURE DRAW_SHAPE_BUFFER;   VAR DOT: BOOLEAN;   BEGIN "FOR BYTE := 7 DOWNTO 0 DO &FOR BIT := 0 TO 6 DO *IF BIT IN EXPis in the buffer *)   BEGIN #GOTOXY(15, 4); #WRITELN('---------');  #FOR BYTE := 7 DOWNTO 0 DO %BEGIN 'WRITE(' ':15, '!'); ' 'FOR BIT := 0 TO 6 DO )IF BIT IN EXPANDED[BYTE] THEN WRITE('*') BELSE WRITE(' '); ' 'WRITELN('!') %END; (* FOR *) $WRITE(' type for *SYSTEM.CHARSET '); $READLN(FNAME); " $IF LENGTH(FNAME) = 0 THEN &FNAME := '*SYSTEM.CHARSET'; & $RESET(F, FNAME); " WRITELN('Loading ',fname,'...'); "END; (* INIT *) " PROCEDURE DISPLAY_SHAPE_BUFFER;   (* Show what (* HEADER *) $PAGE(OUTPUT); $WRITE $('CEDIT: G)et P)ut Q)uit H)elp D)raw C)opy X)dots I,J,K,M: Move cursor'); " DISPLAY_SHAPE_BUFFER; "END; (* HEADER *) " "  PROCEDURE INIT;  "BEGIN (* INIT *) $WRITELN('Character set file name? '); SETCURSOR *)    PROCEDURE ADVANCE;  "BEGIN (* ADVANCE *)  $BIT := BIT + 1; $IF BIT > 6 THEN &BEGIN (BIT := 0; (BYTE := BYTE - 1; (IF BYTE < 0 THEN *BYTE := 7  &END; (* IF *)  "END; (* ADVANCE *)    PROCEDURE HEADER;  "BEGIN r? ');  $REPEAT &GOTOXY(29,1); &HEXIN(CHNUM); &IF CHNUM > 127 THEN (WRITE(CHR(7)) $UNTIL CHNUM <= 127  "END; (* GETCHNUM *)    PROCEDURE SETCURSOR(ROW, COL: INTEGER);  "BEGIN (* SETCURSOR *)  $GOTOXY(16 + COL, +12 - ROW)  "END; (** *) )BEGIN (* I *) +BYTE := BYTE - 1; (* J + K *) +IF BYTE < 0 THEN (* M *) -BYTE := 7; (* *)  (******************) )END; (* CASE 'M' *)  %'J', 'j': (* LEFT *) )BEGIN +BIT := BIT - 1; +IF BIT < 0 THEN -BEGIN /BIT := 6; /BYTE := BYTE + 1; /IF BYTE > 7 THEN 1BYTE := 0  -END; (* IF *)   2 5'); &WRITELN(' 7 EVEN 1 9'); &WRITELN(' 7 ODD 1 13'); &WRITELN(' 8 NONE 2 17'); &WRITELN(' 8 NONE 1 21'); &WRITELN(' 8 EVEN 1 25'); &WRITELN(' 8 ODD 1 29'); &WRITELN('SELECT THE ACIA CONTROL WORD:'); &WRITELN;WRITELN; &WRITELN('CHAR PARITY STOP CONTROL'); &WRITELN('LENGTH BIT BITS WORD '); &WRITELN('----------------------------'); &WRITELN(' 7 EVEN 2 1'); &WRITELN(' 7 ODD  PROGRAM FULLDUPLEX;   USES MICROMODEM;  "FUNCTION PEEK(LOCATION:INTEGER):INTEGER;EXTERNAL; " "PROCEDURE DIALUP; "VAR NUMBER:STRING; &WORD:INTEGER; & " PROCEDURE GETACIACNTRL(VAR WORD:INTEGER); $BEGIN %REPEAT &PAGE(OUTPUT); &GOTOXY(0,3);N^2REWRITE(G, '*NEW.CHARSET'); 2G^ := F^; 2PUT(G); 2CLOSE(G, LOCK); 2OPT := 'Q' 0END (* CASE 'S' *)  +END (* CASE *)  )END; (* CASE 'Q' *) ) )'H', 'h', '?': -HELP;  $END (* CASE *)  "UNTIL OPT IN ['Q', 'q']   END. (* CHAREDIT *) '); +WRITELN;  +REPEAT -READ(KEYBOARD, OPT) +UNTIL OPT IN ['E', 'R', 'S', 'e', 'r', 's'];  +CASE OPT OF ,'E', 'e': 0OPT := 'Q';  ,'R', 'r': 0BEGIN 2OPT := ' '; 2HEADER 0END; (* CASE 'R' *)  ,'S', 's': 0BEGIN ); + +TEXTMODE; ) HEADER; ) )END; (* CASE D *) ) %'Q', 'q': (* QUIT *) )BEGIN +PAGE(OUTPUT); +WRITELN('Quit...'); +WRITELN; +WRITELN('S)ave new character definitions file'); +WRITELN('R)eturn to editor'); +WRITELN('E)xit without saving )END; (* CASE 'J' *)  %'K', 'k': (* RIGHT *) )ADVANCE;  %'D', 'd': )BEGIN +GOTOXY(5,20); +WRITELN('Hi-res!'); + +INITTURTLE; +DRAW_SHAPE_BUFFER; + +MOVETO(30,10); +WSTRING('Push any key to continue '); +WCHAR (CHR(127)); +READ(ch &WRITELN; &WRITE('ACIA CONTROL WORD--> '); &READLN(WORD); %UNTIL WORD IN [1,5,9,13,17,21,25,29]; $END; (* GETCNTRLWORD *)  "BEGIN (* DIALUP *) #SETMODEM(RESETFLAG); #PAGE(OUTPUT); #GOTOXY(0,5); #WRITELN('ENTER THE PHONE NUMBER.'); #WRITELN; #WRITE(' --> '); #READLN(NUMBER); #GETACIACNTRL(WORD); #PAGE(OUTPUT); #GOTOXY(0,5); #WRITE('PREPARING TO DIAL, PLEASE WAIT...'); #INITACIA(WORD); #PICKUP; #SETMODE(ORIGINATE,HIGH); #WRITELN('OK'); #DIAL(NUMBER); #WRITELN; #WRITELN('WAITINGPY #03 *BCC XRINIT * *LDY #00  XICOM LDA PRG3,Y *STA ICOM,Y *INY *CPY #0A *BCC XICOM * *LDY #00  XRWRITE LDA PRG4,Y *STA RWRITE,Y *INY *CPY #06 *BCC XRWRITE * *LDY #00  XWCOM LDA PRG5,Y *STA WCOM,Y *INY *CPY #11 *BCC XWCOM  .EQU 0C0A5  OUTA .EQU 0C202  ICOM .EQU 0D7A3  RINIT .EQU 0D79C  RWRITE .EQU 0D809  WCOM .EQU 0D81F  RCOM .EQU 0D85D  RREAD .EQU 0D84E  *LDA BIOSIN *LDA BIOSIN * *LDY #00  XRINIT LDA PRG2,Y *STA RINIT,Y *INY *C  ;=======================================  ;  ).PROC SYSGEN  ;  ;  ;---------------------------------------  BIOSIN .EQU 0C083  BIOSOUT .EQU 0C08B  CONCHECK .EQU 0D681  ACIA .EQU 0C0A6  DATAOUT .EQU 0778  DATAIN .EQU 0C0A7  MODEM N^#UNTIL NOT TRYAGAIN; #HANGUP; "END.  IN #REPEAT $PAGE(OUTPUT); $GOTOXY(0,5); $WRITE('NO CARRIER. TRY AGAIN? (Y/N)->'); $READ(ANSWR); $WRITELN; $TRYAGAIN:=ANSWR IN ['Y']; #UNTIL ANSWR IN ['Y','N']; "END; " "BEGIN (* FULLDUPLEX *) #REPEAT $DIALUP; $IF CARRIER %THEN TERMINAL; +THEN BEGIN 1HANGUP; 1UNITCLEAR(1); 1EXIT(TERMINAL); 0END +ELSE BEGIN 1WRITE('#'); 1ERROR:=PEEK(DATAIN); 0END %ELSE IF RCVRFULL +THEN GETCHAR(CH) +ELSE SENDCHAR; #UNTIL NOT CARRIER; "END; " "FUNCTION TRYAGAIN:BOOLEAN; "VAR ANSWR:CHAR; "BEG FOR CARRIER...'); #WAITFORCARRIER; "END; " "PROCEDURE TERMINAL; "VAR CH:CHAR; &ERROR:INTEGER; & "BEGIN #PAGE(OUTPUT); #GOTOXY(0,5); #WRITELN('CARRIER OK. BEGIN COMMUNICATIONS.'); #ENABLETRANSMIT; #REPEAT $IF ACIAERROR %THEN IF NOT CARRIER * *LDY #00  XRREAD LDA PRG6,Y *STA RREAD,Y *INY *CPY #03 *BCC XRREAD * *LDY #00  XRCOM LDA PRG7,Y *STA RCOM,Y *INY *CPY #0F *BCC XRCOM * *LDA BIOSOUT *RTS   PRG2 .BYTE 4C,0A3,0D7 ;JMP ICOM   PRG3 .BYTE 0A9,03 ;LDA #03  .BYTE 8D,0A6,0C0 ;STA ACIA ).BYTE 0A9,15 ;LDA #15 ).BYTE 8D,0A6,0C0 ;STA ACIA )  PRG4 .BYTE 0A8 ;TAY ).BYTE 0A2,00 ;LDX #00 ).BYTE 4C,1F,0D8 ;JMP WCOM   PRG5 .BYTE 20,81,0D6 N^""N('MICROMODEM II IN SLOT 2.'); !WRITELN; !WRITELN('PLEASE SET THE DATE USING THE FILER.');  END.   PROGRAM STARTUP;   PROCEDURE SYSGEN;  EXTERNAL;   BEGIN !SYSGEN; !GOTOXY(0,5); !WRITELN('WELCOME TO SPECIAL APPLE PASCAL!'); !WRITELN; !WRITELN('THE SYSTEM HAS JUST BEEN MODIFIED TO'); !WRITELN('ENABLE COMMUNICATIONS THROUGH THE'); !WRITELN^ ;JSR CONCHECK ).BYTE 0AD,0A6,0C0;LDA ACIA ).BYTE 4A ;LSR A ).BYTE 90,0F7 ;BCC RCOM ).BYTE 0AD,0A7,0C0;LDA DATAIN ).BYTE 0A2,00 ;LDX #00 ).BYTE 60 ;RTS ) ).END  ;JSR CONCHECK ).BYTE 0AD,0A6,0C0;LDA ACIA ).BYTE 29,02 ;AND #02 ).BYTE 0F0,0F6 ;BEQ WCOM ).BYTE 8C,78,07 ;STY DATAOUT ).BYTE 20,02,0C2 ;JSR OUTA ).BYTE 60 ;RTS )  PRG6 .BYTE 4C,5D,0D8 ;JMP RCOM   PRG7 .BYTE 20,81,0D6  ;=======================================  ;  ; THESE ROUTINES ARE STORED IN THE  ; SYSTEM LIBRARY:  ;  ; POKE(VALUE,ADDRS:INTEGER);  ; PEEK(ADDRS:INTEGER):INTEGER;  ; CALL(ADDRS:INTEGER);  ; DIALIT(NUMBER:STRING);  ; NEWMO);POP THE MEMORY ADDRESS OF THE );TELEPHONE NUMBER )POP LOCATION ) );INITIALIZE LOCATIONS HANGUP );AND PICKUP FOR PROPER DIALING )LDA MODEMCOPY )AND #7F )STA HANGUP )LDA MODEMCOPY )ORA #80 )STA PICKUP );REMEMBER HOU MANY DIGITS IN );THE TELEPH ;---------------------------------------   MODEM .EQU 0C0A5  MODEMCOPY.EQU 067A  WAIT61 .EQU 99  WAIT39 .EQU 7A  LOCATION .EQU 02  LENGTH .EQU 04  HANGUP .EQU 06  PICKUP .EQU 07  );SAVE THE PASCAL RETURN ADDRESS )POP PASCAL )  ; DIAL(NUMBER:STRING)  ;  ; IN THE LIBRARY UNIT MICROMODEM.  ;  ; THIS ROUTINE ASSUMES THE MICROMODEM  ; IS IN SLOT 2 ON THE MOTHER BOARD.  ; IT SHARES "MODEMCOPY",  ; WHICH CONTAINS A COPY OF THE MODEM  ; CONTROL WORD, WITH LIBRARY UNIT.  ; 7;ROUTINE )JSR JUMP ) )PUSH PASCAL )RTS )  ;=======================================  ; ).PROC DIALIT,1  ;  ; A PROCEDURE TO DIAL THE PHONE USING  ; THE D.C. HAYES MICROMODEM II.  ;  ; THIS ROUTINE IS CALLED BY THE PROCEDURE  ; LL, THEN TO PASCAL.  ;  ;---------------------------------------  JUMP .EQU 02  ADDRS .EQU 03  ADDRSHI .EQU 04  DONE .EQU 05  )POP PASCAL ) )LDA #20 )STA JUMP )LDA #60 )STA DONE ) )POP ADDRS ;SAVES ADDRESS OF 7;DESTINATION . CALL THEN  ;EXECUTES A JSR TO THAT LOCATION THEREBY  ;TRANSFERRING CONTROL TO THE ROUTINE  ;LOCATED AT "ADDRS".  ;  ;WHEN THE RTS IN THE DESTINATION ROUTINE  ;IS ENCOUNTERED, CONTROL IS RETURNED TO  ;LOCATION "DONE", THEN TO THE MAIN BODY  ;OF CA ; AND RETURNS TO PASCAL  ;  ;USES A FORM OF INDIRECT ADDRESSING  ;SUGGESTED BY KENNETH SKIER IN THE JAN  ;1980 OF BYTE, P. 118.:  ;  ;A JSR INSTRUCTION FOLLOWED BY "ADDRS"  ;ARE LOADED INTO CONSECTIVE LOCATIONS,  ;BEGINNING AT LOCATION "JUMP" ;PUSH ON STACK ) )PUSH PASCAL )RTS ;BACK TO PASCAL )  ;======================================= ).PROC CALL,1; 1 PARAMETER WORD  ;  ;PROCEDURE CALL(ADDRS);  ;  ; EFFECT:  ; CALLS THE ROUTINE LOCATED AT ADDRS SSOCIATED WITH )PLA ;FUNCTIONS ) )POP ADDRS ;SAVE ADDRESS TO 7;PEEK )LDA #00 ;INITIALIZE )TAY ;Y-REG )PHA ;PUSH MSB OF 7;RETURNED VALUE: 7;ZERO 7 )LDA @ADDRS,Y ;LOAD A WITH LSB 7;OF RETURN VALUE )PHA EFFECT:  ;  ; THE CONTENTS OF ADDRS ARE  ; RETURNED BY PEEK  ;  ;---------------------------------------  ADDRS .EQU 02  ADDRSHI .EQU 03 )POP PASCAL ) )PLA ;DISCARD 4 BYTES )PLA ;OF STACK BIAS )PLA ;A)STA @ADDRS,Y ;STORE VALUE AT 7;ADDRS )PLA ;DISCARD MSB VALUE ) )PUSH PASCAL )RTS ;BACK TO PASCAL )  ;======================================= ).FUNC PEEK,1 ;1 PARAMETER WORD  ;  ;FUNCTION PEEK(ADDRS:INTEGER):INTEGER  ;  ; VALUE IS STORED AT ADDRS  ;  ;---------------------------------------  ADDRS .EQU 02  ADDRSHI .EQU 03 )POP PASCAL ) )LDY #00 ;INITIALIZE Y-REG ) )POP ADDRS ;SAVE ADDRESS 7;ARGUMENT ) )PLA ;LSB OF VALUE  PASCALHI .EQU 01  BIOSIN .EQU 0C083  BIOSOUT .EQU 0C08B  CONCHECK .EQU 0D681  VIDOUT .EQU 0D7E7   ;=======================================  ; ).PROC POKE,2 ;2 PARAMETER WORDS  ;  ;PROCEDURE(VALUE,ADDRS:INTEGER)  ;  ; EFFECT:  ;  ; DEMVALUE(WORD:INTEGER);  ; SNDCHAR;  ; GTCHAR;  ;  ;---------------------------------------  ).MACRO POP )PLA )STA %1 )PLA )STA %1+1 ).ENDM ) ).MACRO PUSH )LDA %1+1 )PHA )LDA %1 )PHA ).ENDM ) );GLOBAL EQUATES  PASCAL .EQU 00ONE NUMBER )LDY #00 )LDA @LOCATION,Y )STA LENGTH ) );INITIALIZE TO GET THE FIRST );DIGIT )LDY #01 )  NXTDIGIT TYA )PHA ;SAVE DIGIT NUMBER ON STACK )LDA BIOSIN ;SWITCH TO BIOS )LDA @LOCATION,Y ;DISPLAY DIGIT )JSR VIDOUT ;ON CONSOLE  LDA BIOSOUT ;BACK TO PASCAL )PLA ;RECOVER DIGIT NUMBER )TAY )LDA @LOCATION,Y ;GET DIGIT AGAIN ) );CONVERT DIGIT FROM CHAR FORM )SEC )SBC #30 )BNE START )LDA #0A ;IN CASE DIGIT IS 0 ) );INITITALIZE X TO COUNT PULSES  START TAX  N^2T )LDA #00 )PHA )LDA DATAIN )PHA ) );OUTPUT TO CONSOLE )JSR VIDOUT ) )LDA BIOSOUT )PUSH PASCAL )RTS ) ).END  HE LIBRARY  ; UNIT MICROMODEM.  ;  ;---------------------------------------  DATAIN .EQU 0C0A7 ) )POP PASCAL ) )PLA ;DISCARD 4 BYTES OF )PLA ;FUNCTION BIAS )PLA )PLA ) )LDA BIOSIN )JSR CONCHECK ) );GET CHARACTER AND );PUSH FUNCTION RESULTAIN. THE ROUTINE ASSUMES THE  ; RECEIVER REGISTER IS FULL.  ;  ; AFTER FETCHING THE CHARACTER, THE  ; ROUTINE OUTPUTS IT TO THE CONSOLE  ; SCREEN AND RETURNS THE VALUE TO THE  ; CALLING PROGRAM AS A FUNCTION RESULT.  ;  ; THIS ROUTINE IS PART OF T)BEQ HOME )JSR BUMP )STX RPTR )LDA CONBUF,X )STA DATAOUT )JSR OUTA  HOME LDA BIOSOUT )RTS )  ;=======================================  ; ).FUNC GTCHAR  ;  ; A ROUTINE TO GET ONE CHARACTER FROM  ; THE MICROMODEM DATA INPUT LOCATION  ; DAIBRARY  ; UNIT MICROMODEM.  ;  ;---------------------------------------  RPTR .EQU 0BF18  WPTR .EQU 0BF19  CONBUF .EQU 03B1  BUMP .EQU 0D72C  DATAOUT .EQU 0778  OUTA .EQU 0C202 )LDA BIOSIN )JSR CONCHECK )LDX RPTR )CPX WPTR ;NEWBITS 3 );BACK TO PASCAL )PUSH PASCAL )RTS )  ;=======================================  ; ).PROC SNDCHAR  ;  ; A PROCEDURE TO OUTPUT ONE CHARACTER  ; THROUGH THE MICROMODEM LOCATED IN  ; SLOT 2.  ;  ; ROUTINE IS CALLED FROM THE L  ;---------------------------------------  MODEMCOPY.EQU 067A  MODEM .EQU 0C0A5  )POP PASCAL ) );PULL THE VALUE OF THE NEW );BITS TO BE SET AND UPDATE );MODEM )PLA )ORA MODEMCOPY )STA MODEMCOPY )STA MODEM ) )PLA ;DISCARD MSB OF ) ; WORD. THIS IS A ROUTINE WRITTEN  ; ESPECIALLY FOR USE BY THE LIBRARY UNIT  ; MICROMODEM.  ;  ; THE ROUTINE LOGICAL OR'S ITS ARGUMENT  ; WITH THE CONTENTS OF MODEMCOPY, $067A,  ; SAVES THE RESULT IN MODEMCOPY AND  ; WRITES IT TO MODEM, $C0A5.  ;1 )BNE WAIT2 )RTS )  ;=======================================  ; ).PROC NEWMODEMVALUE,1  ;  ; A PROCEDURE TO CHANGE THE CONTENTS  ; OF LOCATION $C0A5 WHICH IS THE (SLOT  ; 2) LOCATION OF THE MICROMODEM CONTROL WHILE THEN GET );THE NEXT DIGIT )JSR LONGWAIT )INY )BPL NXTDIGIT )  DONE PUSH PASCAL )RTS )  LONGWAIT LDX #05  AGAIN LDA #0FF )JSR WAIT )DEX )BNE AGAIN )RTS )  WAIT SEC  WAIT2 PHA  WAIT3 SBC #01 )BNE WAIT3 )PLA )SBC #0);DIAL THE DIGIT  PULSE LDA HANGUP )STA MODEM )LDA #WAIT61 )JSR WAIT )LDA PICKUP )STA MODEM )LDA #WAIT39 )JSR WAIT )DEX )BNE PULSE ) );WHEN DONE WITHE A DIGIT CHECK );TO SEE IF DONE WITH NUMBER ) )CPY LENGTH )BEQ DONE );IF NOT, WAIT A  (*$S+*)(* SWAPPING REQUIRED FOR UNITS *)   UNIT MICROMODEM;INTRINSIC CODE 23 DATA 24;  "INTERFACE " $CONST DATAIN= -16217; (* $C0A7 *) *ACIA= -16218; (* $C0A6 *) *MODEM= -16219; (* $COA5 *) *KEYBDE= -16384; (* $C000 *) *OUTA= -15870; (*RD *) "BEGIN #MEMORY.ADDRS:=MODEMCOPY; #MEMORY.VALUE^[0]:=0; #NEWMODEMVALUE(WORD); "END; "  PROCEDURE HANGUP; "(* HANG UP THE PHONE, TURN OFF THE MODEM *) "BEGIN #SETMODEM(0); "END; "  PROCEDURE SNDCHAR;  EXTERNAL; "(* GET A CHARACTER FROM TDIALING *) "VAR DATA,WAIT:INTEGER; "BEGIN #WAIT:=0; #WHILE NOT CARRIER AND (WAIT<10000) DO $BEGIN %WAIT:=WAIT+1; %MEMORY.ADDRS:=DATAIN; %DATA:=MEMORY.VALUE^[0]; $END; "END; "  PROCEDURE SETMODEM; "(* WRITE A NEW VALUE TO THE MODEM &CONTROL WO"(* DIAL THE INDICATED NUMBER, DISPLAY THE DIGITS &AS THEY ARE DIALED *) &  PROCEDURE DIAL; "(* DIAL THE INDICATED NUMBER *) "BEGIN #WRITE('DIALING...'); #DIALIT(NUMBER); #WRITELN; "END; "  PROCEDURE WAITFORCARRIER; "(* WAIT FOR CARRIER AFTER UP; "(* PICK UP THE PHONE, WAIT FOR DIAL TONE *) "VAR DUMMY,WAIT:INTEGER; "BEGIN #NEWMODEMVALUE(128); #(* WAIT FOR DIAL TONE *) #FOR WAIT:=0 TO 3000 DO DUMMY:=0; "END; "  PROCEDURE DIALIT(NUMBER:STRING);  EXTERNAL; RITE IT TO MODEM. *) &  PROCEDURE ENABLETRANSMIT; "(* TURN ON THE MODEM TRANSMITTER *) "BEGIN #NEWMODEMVALUE(2); "END; "  PROCEDURE SETMODE;  (* SET THE MODE AND BAUD RATE *) "BEGIN #NEWMODEMVALUE(4*ORD(MD)+ORD(BR)); "END; "  PROCEDURE PICKUE^[0]:=WORD; #REPEAT DUMMY:=0 UNTIL NOT CARRIER; "END; "  PROCEDURE NEWMODEMVALUE(NEWBITS:INTEGER);  EXTERNAL; "(* LOGICAL OR THE VALUE LAST WRITTEN TO &LOCATION MODEM (STORED IN MODEMCOPY) &WITH THE ARGUMENT, STORE THE RESULT &IN MODEMCOPY AND W"(* DETERMINE LAST VALUE WRITTEN TO MODEM *) "BEGIN #MEMORY.ADDRS:=MODEMCOPY; #MODEMSTATUS:=MEMORY.VALUE^[0]; "END; "  PROCEDURE INITACIA; "(* INITIALIZE ACIA *) "VAR DUMMY:INTEGER; "BEGIN #MEMORY.ADDRS:=ACIA; #MEMORY.VALUE^[0]:=3; #MEMORY.VAL CHECK FOR ACIA ERROR *) "BEGIN #MEMORY.ADDRS:=ACIA; #ACIAERROR:=MEMORY.VALUE^[0]>3; "END; "  FUNCTION ACIASTATUS; "(* DETERMINE ACIA STATUS *) "BEGIN #MEMORY.ADDRS:=ACIA; #ACIASTATUS:=MEMORY.VALUE^[0]; "END; "  FUNCTION MODEMSTATUS; EGIN #MEMORY.ADDRS:=ACIA; #RCVRFULL:=ODD(MEMORY.VALUE^[0]); "END; "  FUNCTION TRANSEMPTY; "(* CHECK IF ACIA TRANSMITTER REGISTER IS EMPTY *) "BEGIN #MEMORY.ADDRS:=ACIA; #TRANSEMPTY:=ODD(MEMORY.VALUE^[0] DIV 2); "END; "  FUNCTION ACIAERROR; "(*MODEM; #RINGING:=MEMORY.VALUE^[0]<128; "END; "  FUNCTION CARRIER; "(* TEST FOR PRESENCE OF CARRIER *) "BEGIN #MEMORY.ADDRS:=ACIA; #CARRIER:=MEMORY.VALUE^[0] MOD 8<4; "END; "  FUNCTION RCVRFULL; "(* CHECK IF ACIA RECEIVER REGISTER IS FULL *) "B$TYPE WORD=PACKED ARRAY[0..1] OF 0..255; $ )FREEUNION=RECORD CASE BOOLEAN OF +TRUE:(ADDRS:INTEGER); +FALSE:(VALUE:^WORD); +END; + $VAR MEMORY:FREEUNION; $  FUNCTION RINGING; "(* DETERMINE WHETHER THE PHONE IS RINGING *) "BEGIN #MEMORY.ADDRS:=E(MD:MODE;BR:BAUDRATE); $PROCEDURE PICKUP; $PROCEDURE DIAL(NUMBER:STRING); $PROCEDURE WAITFORCARRIER; $PROCEDURE HANGUP; $PROCEDURE SETMODEM(WORD:INTEGER); $PROCEDURE SENDCHAR; $PROCEDURE GETCHAR(VAR CH:CHAR); $ "IMPLEMENTATION " CARRIER:BOOLEAN; $FUNCTION RCVRFULL:BOOLEAN; $FUNCTION TRANSEMPTY:BOOLEAN; $FUNCTION ACIAERROR:BOOLEAN; $FUNCTION ACIASTATUS:INTEGER; $FUNCTION MODEMSTATUS:INTEGER; $ $PROCEDURE INITACIA(WORD:INTEGER); $PROCEDURE ENABLETRANSMIT; $PROCEDURE SETMOD $C202 *) *DATAOUT= 1912; (* $0778 *) *MODEMCOPY=1658; (* $067A *) * *RESETFLAG= 8; *SELFTEST= 16; * $TYPE BAUDRATE=(LOW,HIGH); $ MODE= (ANSWER,ORIGINATE); * $VAR MD:MODE; $ BR:BAUDRATE; * $FUNCTION RINGING:BOOLEAN; $FUNCTIONHE KEYBOARD, &TRANSFER IT TO THE MODEM OUTPUT &LOCATION DATAOUT, AND TRANSMIT THE &CHARACTER VIA THE MODEM ROUTINE &LOCATED AT OUTA *) &  PROCEDURE SENDCHAR; "BEGIN #SNDCHAR; "END; "  FUNCTION GTCHAR:CHAR;  EXTERNAL; "(* FETCH THE CHARACTER STORED IN THE &MODEM INPUT LOCATION DATAIN AND &SEND IT TO THE SCREEN. PASS THE &CHARACTER AS A FUNCTION RESULT. *) &  PROCEDURE GETCHAR; "BEGIN #CH:=GTCHAR; "END; "  BEGIN !SETMODEM(RESETFLAG);  END.  W LONG TO DRAW THE LINE *)  BEGIN #(* DRAW THE FACE FIRST *) #XBASE:=X0+ATCOL*WIDTH+5; #YBASE:=Y0-(ATROW*HEIGHT)+22; #DRAWCOLOR:=COLOURS[FACE,PERSON.SHOWSUP[FACE]]; #FOR INX:=0 TO 5 DO BEGIN &SKIPTO(XBASE,YBASE-INX); &MOVE(13) #END; #DRAWLEN:=13;OR)  END;   PROCEDURE DRAWFACE(PERSON:ZYGOTE;ATROW,ATCOL:INTEGER);  VAR #GENE:INTEGER; TRAIT:CHARACTERISTIC; #XBASE,YBASE:INTEGER; (* WHERE X,Y LEFT CORNER IS NOW *) #INX, (* WHICH FILLER LINE TO DRAW *) #DRAWLEN:INTEGER; (* HO#NMALE, (* HOW MANY MALES *) #NFEMALE, (* HOW MANY FEMALES *) #ROWSIZE, (* # TO DISPLAY PER ROW *) #COLOFFSET: (* IN ORDER TO CENTER FACES *) &INTEGER; &  PROCEDURE SKIPTO(X,Y:INTEGER);  BEGIN #PENCOLOR(NONE); MOVETO(X,Y); PENCOLOR(DRAWCOL -NHOMDOM, (* NUMBER HOMOZYGOUS DOMINANT *) -NHETDOM, (* NUMBER HETEROZYGOUS DOMINANT *) -NHOMREC: (* NUMBER HETEROZYGOUS RECESSIVE *) 0INTEGER; *END; #RESTART, #NOPADDLES:BOOLEAN; #NKIDS, (* SIZE OF THEKIDS ARRAY *) PE; )SHOWSUP:ARRAY[FACE..HAIR] OF GENETYPE; &END; &  VAR  DRAWCOLOR:SCREENCOLOR; #COLOURS: &ARRAY[FACE..HAIR,DOMINANT..RECESSIVE] OF SCREENCOLOR; #KEY:CHAR; #MOM,DAD:ZYGOTE; #THEKIDS:ARRAY[0..23] OF ZYGOTE; #STATS: ARRAY[FACE..HAIR] OF RECORD *) #ESC=27; (* CODE FOR ESC KEY *) #  TYPE #SEXTYPE=(MALE,FEMALE); #GENETYPE=(DOMINANT,RECESSIVE); #CHARACTERISTIC=(FACE,HAIR); #ZYGOTE= &RECORD )SEX:SEXTYPE; )(* EACH TRAIT HAS TWO GENES *) )TRAITS:ARRAY[FACE..HAIR,0..1] OF GENETY(*$S+*)  PROGRAM GENEPOOL;  (*$C Copyright 1980 JDEisenberg *)  USES TURTLEGR,APPLESTU;   CONST #GENE0=0; GENE1=1; #WIDTH=35; HEIGHT=32; (* AREA OF A FACE *) #X0=0; Y0=148; (* BASE X,Y FOR FACES *) #BEL=7; (* ASCII BELL CODEHERE 1N^Rr #FOR INX:=6 TO 9 DO BEGIN &SKIPTO(XBASE+(13-DRAWLEN),YBASE-INX); &MOVETO(XBASE+DRAWLEN,YBASE-INX); &IF PERSON.SEX=FEMALE THEN DRAWLEN:=DRAWLEN-1 #END; #(* SHOULDERS *) #DRAWCOLOR:=VIOLET; #IF PERSON.SEX=MALE THEN DRAWLEN:=24 ELSE DRAWLEN:=22; #XBASE:=X0+ATCOL*WIDTH; #SKIPTO(XBASE+10,YBASE-10); MOVE(5); #FOR INX:=11 TO 12 DO BEGIN &SKIPTO(XBASE+(24-DRAWLEN),YBASE-INX); &MOVETO(XBASE+DRAWLEN,YBASE-INX); &IF PERSON.SEX=FEMALE THEN DRAWLEN:=DRAWLEN+2 #END; #(* NOW DRAW THE HAIR *) #DRAWCOLSE BEGIN )WRITE('HETEROZYGOUS DOMINANT'); &END #END; #  BEGIN #(* WRITE INVISIBLY ON TEXT PAGE *) #PAGE(OUTPUT); #GOTOXY(1,1); WRITE('MOTHER'); #GOTOXY(10,2); SHOWZYGOTE(MOM,HAIR); #GOTOXY(10,3); SHOWZYGOTE(MOM,FACE); #GOTOXY(1,5); WRITE('FATHER #BEGIN &IF WHAT=HAIR THEN )WRITE('HAIR: ') &ELSE )WRITE('FACE: '); &IF WHO.TRAITS[WHAT,GENE0]=WHO.TRAITS[WHAT,GENE1] THEN BEGIN )WRITE('HOMOZYGOUS'); )IF WHO.TRAITS[WHAT,GENE0]=DOMINANT THEN ,WRITE('DOMINANT') )ELSE ,WRITE('RECESSIVE') &END EL&END #END; (* FOR *) #(* AND DISPLAY THEM *) #FOR INX:=0 TO NKIDS DO &DRAWME(THEKIDS[INX],1+(INX DIV ROWSIZE), )(INX MOD ROWSIZE)+COLOFFSET);  END;   PROCEDURE STATISTICS;  VAR KEY:CHAR;  #PROCEDURE SHOWZYGOTE(WHO:ZYGOTE;WHAT:CHARACTERISTIC);IT,GENE0]; /IF SHOWSUP[TRAIT]=RECESSIVE THEN 2STATS[TRAIT].NHOMREC:=STATS[TRAIT].NHOMREC+1 /ELSE 2STATS[TRAIT].NHOMDOM:=STATS[TRAIT].NHOMDOM+1 ,END ELSE BEGIN /SHOWSUP[TRAIT]:=DOMINANT; /STATS[TRAIT].NHETDOM:=STATS[TRAIT].NHETDOM+1 ,END )END NFEMALE:=NFEMALE+1 )END; )FOR TRAIT:=FACE TO HAIR DO BEGIN ,TRAITS[TRAIT,GENE0]:=MOM.TRAITS[TRAIT,RANDOM MOD 2]; ,TRAITS[TRAIT,GENE1]:=DAD.TRAITS[TRAIT,RANDOM MOD 2]; ,IF TRAITS[TRAIT,GENE0]=TRAITS[TRAIT,GENE1] THEN BEGIN /SHOWSUP[TRAIT]:=TRAITS[TRA  END; #ROWSIZE:=8; #COLOFFSET:=0; #FOR INX:=0 TO 23 DO BEGIN &WITH THEKIDS[INX] DO BEGIN )IF INX=1 THEN SEX:=MALE )ELSE IF INX=2 THEN SEX:=FEMALE )ELSE IF (RANDOM MOD 2)=0 THEN BEGIN ,SEX:=MALE; NMALE:=NMALE + 1 )END ELSE BEGIN ,SEX:=FEMALE;#DRAWME(MOM,0,3); DRAWME(DAD,0,4); #(* GENERATE THE KIDS *)  INX:=0; #NKIDS:=23; #NMALE:=1; NFEMALE:=1; (* GUARANTEES ONE OF EACH *) #FOR TRAIT:=FACE TO HAIR DO BEGIN &STATS[TRAIT].NHOMDOM:=0; &STATS[TRAIT].NHOMREC:=0; &STATS[TRAIT].NHETDOM:=0;;  REPEAT &READ(KEYBOARD,KEY) #UNTIL (KEY=' ') OR (KEY=CHR(ESC)); #ERSLINE(23)  END;   PROCEDURE GENERATION;  VAR #INX:INTEGER; #ASEX:SEXTYPE; #TRAIT:CHARACTERISTIC;  BEGIN #(* DRAW THE PARENTS *) #FILLSCREEN(BLACK); #PENCOLOR(NONE); #MOVETO(COL*7,184-ROW*8)  END;   PROCEDURE ERSLINE(ROW:INTEGER);  BEGIN #AT(0,ROW); #WSTRING(' ');  END;   PROCEDURE PSPACEBAR;  BEGIN #AT(3,23); #WSTRING('Press spacebar to continue'))END; )XBASE:=XBASE+14 &END (* FOR GENE *) #END (* FOR TRAIT *)  END;   PROCEDURE DRAWME(PERSON:ZYGOTE;ATROW,ATCOL:INTEGER);  BEGIN #DRAWFACE(PERSON,ATROW,ATCOL); #DRAWGENES(PERSON,ATROW,ATCOL)  END; #  PROCEDURE AT(COL,ROW:INTEGER);  BEGIN #FOR TRAIT:=FACE TO HAIR DO BEGIN &YBASE:=Y0-(ATROW*HEIGHT)+ORD(TRAIT)*5; &XBASE:=X0+ATCOL*WIDTH; &FOR GENE:=GENE0 TO GENE1 DO BEGIN )DRAWCOLOR:=COLOURS[TRAIT,PERSON.TRAITS[TRAIT,GENE]]; )FOR INX:=0 TO 3 DO BEGIN ,SKIPTO(XBASE,YBASE+INX); ,MOVE(9) N:ZYGOTE;ATROW,ATCOL:INTEGER);  VAR #GENE:INTEGER; #TRAIT:CHARACTERISTIC; #XBASE,YBASE:INTEGER; (* WHERE X,Y LEFT CORNER IS NOW *) #INX:INTEGER; (* WHICH FILLER LINE TO DRAW *)  BEGIN #(*COLOUR IN THE GENE SQUARES *) 4 #END; #(* NOW DRAW EYES/NOSE/MOUTH *) #DRAWCOLOR:=BLACK2; #SKIPTO(XBASE+3,YBASE-3); MOVETO(XBASE+3,YBASE-3); #SKIPTO(XBASE+8,YBASE-3); MOVETO(XBASE+8,YBASE-3); #SKIPTO(XBASE+6,YBASE-7); MOVETO(XBASE+6,YBASE-9);  END;   PROCEDURE DRAWGENES(PERSOOR:=COLOURS[HAIR,PERSON.SHOWSUP[HAIR]]; #XBASE:=X0+ATCOL*WIDTH+6; YBASE:=Y0-(ATROW*HEIGHT)+23; #INX:=0; #WHILE INX < 13 DO BEGIN &SKIPTO(XBASE+INX,YBASE); &IF PERSON.SEX=FEMALE THEN MOVETO(XBASE+6,YBASE+3) &ELSE MOVETO(XBASE+INX,YBASE+3); &INX:=INX+'); #GOTOXY(10,6); SHOWZYGOTE(DAD,HAIR); #GOTOXY(10,7); SHOWZYGOTE(DAD,FACE); #GOTOXY(1,9); WRITE('OUT OF THESE 24 CHILDREN,'); #GOTOXY(6,10); WRITE(NMALE:2,' ARE MALE'); #GOTOXY(6,11); WRITE(NFEMALE:2,' ARE FEMALE'); #GOTOXY(1,13); WRITE('OFFSPRING''S HAIR'); #GOTOXY(10,14); #WRITE('HOMOZYGOUS DOMINANT: ',STATS[HAIR].NHOMDOM:3); #GOTOXY(10,15); #WRITE('HETEROZYGOUS DOMINANT:',STATS[HAIR].NHETDOM:3); #GOTOXY(10,16); #WRITE('HOMOZYGOUS RECESSIVE: ',STATS[HAIR].NHIT,GENE]:=DOMINANT; &END; &ONEKID.SHOWSUP[TRAIT]:=DOMINANT #END; #FILLSCREEN(BLACK); #DRAWME(ONEKID,0,3); #AT(1,6); WSTRING('If both genes for hair (or face) are'); #AT(1,8); WSTRING('dominant, then the child is called'); #AT(1,10); WSTRING('HOMOZYWSTRING('from each parent.'); #PSPACEBAR;  END;   PROCEDURE EXPLAIN3;  VAR #ONEKID:ZYGOTE; #TRAIT:CHARACTERISTIC; #GENE:INTEGER;  BEGIN #ONEKID.SEX:=MALE; #FOR TRAIT:=FACE TO HAIR DO BEGIN &FOR GENE:=GENE0 TO GENE1 DO BEGIN )ONEKID.TRAITS[TRA#AT(12,5); WSTRING('->'); #AT(1,13); WSTRING('The bottom row shows their face genes'); #PSPACEBAR; #AT(12,5); WSTRING(' '); #AT(1,15); WSTRING('Each Zorkon child wears two hair'); #AT(1,16); WSTRING('(and face) colour genes, one from'); #AT(1,17); ('->'); #AT(1,9); WSTRING('The boxes beneath them tell you what'); #AT(1,10); WSTRING('genes they carry.'); #PSPACEBAR; #AT(12,5); WSTRING(' '); #AT(1,12); WSTRING('The top row shows their hair genes.'); #PSPACEBAR; #AT(12,4); WSTRING(' '); up hair.'); #DRAWFACE(EXPKIDS[3],4,7); #PSPACEBAR  END;   PROCEDURE EXPLAIN2;  BEGIN #LEGEND; #AT(1,6); WSTRING('This is a typical Zorkon couple,'); #AT(1,7); WSTRING('Martha and Sam.'); #PSPACEBAR; #AT(12,4); WSTRING('->'); #AT(12,5); WSTRING genes.'); #PSPACEBAR; #AT(1,18); WSTRING('Male Zorkons have square'); #AT(1,19); WSTRING('faces and straight hair.'); #DRAWFACE(EXPKIDS[2],4,6); #PSPACEBAR; #AT(1,20); WSTRING('Female Zorkons have round'); #AT(1,21); WSTRING('faces and flat, piled-#SETCOLOURS(NONE,NONE,GREEN,WHITE1); #DRAWFACE(EXPKIDS[0],2,6); DRAWFACE(EXPKIDS[3],2,7); #(* RESTORE COLOURS TO NORMAL *) #SETCOLOURS(ORANGE,BLUE,GREEN,WHITE1); #AT(1,15); WSTRING('Green hair genes are dominant'); #AT(1,16); WSTRING('over white hair blue or orange faces.'); #AT(1,11); WSTRING('Orange face genes are'); #AT(1,12); WSTRING('dominant over blue face'); #AT(1,13); WSTRING('genes.'); #DRAWFACE(EXPKIDS[0],2,6); DRAWFACE(EXPKIDS[3],2,7); #PSPACEBAR; #(* MAKE ONLY HAIR SHOW UP *) KIDS[INX],0,INX+2); #END; #(* MAKE ONLY FACES SHOW UP *) #SETCOLOURS(ORANGE,BLUE,NONE,NONE); #EXPKIDS[0].SEX:=FEMALE; #AT(1,6); WSTRING('Above you see four Zorkons.'); #AT(1,8); WSTRING('Zorkons may have green or white hair'); #AT(1,9); WSTRING('and (INX MOD 2)=0 THEN SEX:=MALE ELSE SEX:=FEMALE; )CASE INX DIV 2 OF ,0: SHOWSUP[FACE]:=DOMINANT; ,1: SHOWSUP[FACE]:=RECESSIVE; )END; )CASE INX DIV 2 OF ,0: SHOWSUP[HAIR]:=DOMINANT; ,1: SHOWSUP[HAIR]:=RECESSIVE; )END; &END; (* WITH *) &DRAWFACE(EXP&COLOURS[FACE,RECESSIVE]:=RECFACE; &COLOURS[HAIR,DOMINANT]:=DOMHAIR; &COLOURS[HAIR,RECESSIVE]:=RECHAIR; #END;  BEGIN #FILLSCREEN(BLACK); #(* SET UP ALL COMBINATIONS OF HAIR/FACE COLOURS *) #FOR INX:=0 TO 3 DO BEGIN &WITH EXPKIDS[INX] DO BEGIN )IFom ->'); #AT(25,3); WSTRING('<- Dad');  END;   PROCEDURE EXPLAIN;  VAR #INX:INTEGER; #EXPKIDS:ARRAY[0..3] OF ZYGOTE; # #PROCEDURE SETCOLOURS(DOMFACE,RECFACE,DOMHAIR,RECHAIR:SCREENCOLOR); #BEGIN &COLOURS[FACE,DOMINANT]:=DOMFACE; TS[FACE].NHOMREC:3); #GOTOXY(2,23); WRITE('PRESS SPACEBAR TO CONTINUE'); #TEXTMODE; (* POOF-APPEARS LIKE MAGIC *) #REPEAT &READ(KEYBOARD,KEY) #UNTIL KEY = ' '; #GRAFMODE  END;   PROCEDURE LEGEND;  BEGIN #FILLSCREEN(BLACK); #AT(8,3); WSTRING('MOMREC:3); #GOTOXY(1,18); WRITE('OFFSPRING''S FACES'); #GOTOXY(10,19); #WRITE('HOMOZYGOUS DOMINANT: ',STATS[FACE].NHOMDOM:3); #GOTOXY(10,20); #WRITE('HETEROZYGOUS DOMINANT:',STATS[FACE].NHETDOM:3); #GOTOXY(10,21); #WRITE('HOMOZYGOUS RECESSIVE: ',STAGOUS DOMINANT for that trait.'); #PSPACEBAR; #FOR TRAIT:=FACE TO HAIR DO BEGIN &FOR GENE:=GENE0 TO GENE1 DO BEGIN )ONEKID.TRAITS[TRAIT,GENE]:=RECESSIVE; &END; &ONEKID.SHOWSUP[TRAIT]:=RECESSIVE #END; #DRAWME(ONEKID,0,4); #AT(1,12); WSTRING('If both genes are recessive, then the'); #AT(1,14); WSTRING('child is called HOMOZYGOUS RECESSIVE.'); #PSPACEBAR; #FOR TRAIT:=FACE TO HAIR DO BEGIN &ONEKID.TRAITS[TRAIT,GENE0]:=DOMINANT; &ONEKID.SHOWSUP[TRAIT]:=DOMINANT; #END; # HADERROR THEN BEGIN /CHARTYPE(5); (* REVERSE VIDEO *) /AT(3,23); WSTRING('Males have square faces'); /CHARTYPE(10); (* NORMAL VIDEO *) /HADERROR:=TRUE ,END; )END &UNTIL THEKIDS[POSITION].SEX=MALE; &DAD:=THEKIDS[POSITION]; &DRAWCURSOR; &IF HADERRG('<-,-> to move; spacebar to choose') )ELSE ,WSTRING('Press button to choose'); )DRAWCOLOR:=REVERSE; )REPEAT ,GETPOSITION; ,DRAWCURSOR; ,DRAWCURSOR )UNTIL GOTCHA; )IF THEKIDS[POSITION].SEX<>MALE THEN BEGIN ,WRITE(CHR(BEL)); (* K'DING *) ,IF NOT&WSTRING('Press S for statistics'); &AT(3,21); &WSTRING('Press RETURN to start again'); &AT(3,22); WSTRING('Press ESC to exit'); &REPEAT )GOTCHA:=FALSE; )AT(3,18); WSTRING('Choose the new male genetic type'); )AT(3,19); )IF NOPADDLES THEN ,WSTRINITION-LASTPOS)>3 THEN LASTPOS:=POSITION; ,POSITION:=LASTPOS DIV (240 DIV NKIDS); ,IF POSITION > NKIDS THEN POSITION:=NKIDS; ,GOTCHA:=BUTTON(0) )END &END; & #BEGIN &LASTPOS:=0; POSITION:=0; &HADERROR:=FALSE; &AT(3,20); N POSITION:=POSITION+1; /IF POSITION < 0 THEN POSITION:=NKIDS; /IF POSITION > NKIDS THEN POSITION:=0; ,END )END; )IF NOT NOPADDLES THEN BEGIN (* UNGRAMMATICAL BUT CORRECT *) ,POSITION:=PADDLE(0); ,(* MAKE SURE PADDLE REALLY IS MOVING *) ,IF ABS(POSHEN EXIT(CHOOSETYPES); ,IF EOLN(KEYBOARD) THEN BEGIN /RESTART:=TRUE; /EXIT(CHOOSETYPES) ,END; ,IF KEY='S' THEN BEGIN /STATISTICS ,END; ,IF NOPADDLES THEN BEGIN /GOTCHA:=(KEY=' '); /IF ORD(KEY)=8 THEN POSITION:=POSITION-1 /ELSE IF ORD(KEY)=21 THE)XBASE:=X0+COL*WIDTH+11; )YBASE:=Y0-(ROW*HEIGHT)+4; )SKIPTO(XBASE-3,YBASE);MOVETO(XBASE+3,YBASE); )SKIPTO(XBASE,YBASE-3);MOVETO(XBASE,YBASE+3) &END;  &PROCEDURE GETPOSITION; &BEGIN )IF KEYPRESS THEN BEGIN ,READ(KEYBOARD,KEY); ,IF KEY=CHR(ESC) T:=MALE  END;   PROCEDURE CHOOSETYPES;  VAR #LASTPOS,POSITION:INTEGER; #GOTCHA,HADERROR:BOOLEAN;  &PROCEDURE DRAWCURSOR; &VAR ROW,COL,XBASE,YBASE:INTEGER; &BEGIN )ROW:=(POSITION DIV ROWSIZE)+1; )COL:=(POSITION MOD ROWSIZE)+COLOFFSET; &TRAITS[HAIR,GENE0]:=DOMINANT; &TRAITS[HAIR,GENE1]:=RECESSIVE; &TRAITS[FACE,GENE0]:=DOMINANT; &TRAITS[FACE,GENE1]:=RECESSIVE; &SHOWSUP[HAIR]:=DOMINANT; &SHOWSUP[FACE]:=DOMINANT; #END; #(* SET UP FATHER SAME AS MOM, BUT MALE *) #DAD:=MOM; #DAD.SEXBEGIN &EXPLAIN; EXPLAIN2; EXPLAIN3; &EXPLAIN4; GENERATION #END ELSE BEGIN &ERSLINE(1); ERSLINE(20); &ERSLINE(22); ERSLINE(23) #END  END;   PROCEDURE INITPARENTS;  BEGIN #(* SET UP MOTHER WITH ALL THE GENES *) #WITH MOM DO BEGIN &SEX:=FEMALE; #AT(2,20); WSTRING('A simulation of a genetics experiment'); #AT(5,22); WSTRING('Copyright 1980 by JDEisenberg'); #AT(1,23); WSTRING('Press spacebar to start, ? for help'); #REPEAT &READ(KEYBOARD,KEY) #UNTIL (KEY=' ') OR (KEY='?'); #IF KEY='?' THEN ) #ELSE &WSTRING('Use paddle zero to select'); #AT(1,11); WSTRING('the genetic types.'); #PSPACEBAR  END;   PROCEDURE SPLASHPAGE;  VAR INX:INTEGER;  BEGIN #GENERATION; #AT(7,1); WSTRING('Welcome to the GenePool'); #LEGEND; #AT(1,6); WSTRING('You may select male and female genetic'); #AT(1,7); WSTRING('types, and a random sampling of their'); #AT(1,8); WSTRING('offspring will be produced.'); #AT(1,10); #IF NOPADDLES THEN &WSTRING('Use the arrow keys to select'DRAWME(ONEKID,0,5); #AT(1,16); WSTRING('Finally, if the child gets one dominant'); #AT(1,18); WSTRING('and one recessive gene for a trait,'); #AT(1,20); WSTRING('the child is HETEROZYGOUS DOMINANT.'); #PSPACEBAR  END;   PROCEDURE EXPLAIN4;  BEGIN OR THEN ERSLINE(23); &HADERROR:=FALSE; &REPEAT )GOTCHA:=FALSE; )AT(3,18); WSTRING('Choose the new female genetic type.'); )REPEAT ,GETPOSITION; ,DRAWCURSOR; ,DRAWCURSOR )UNTIL GOTCHA; )IF THEKIDS[POSITION].SEX <> FEMALE THEN BEGIN ,WRITE(CHR(BEL)); (* K'DING *) ,IF NOT HADERROR THEN BEGIN /CHARTYPE(5); (* REVERSE VIDEO *) /AT(3,23); WSTRING('Females have rounded faces'); /CHARTYPE(10); (* NORMAL VIDEO *) /HADERROR:=TRUE; ,END; )END &UNTIL THEKIDS[POSITION].SEX=FEMALE; &MOMen : ARRAY [1..7] OF 0..255; $locked : ARRAY [1..7] OF BOOLEAN; $ftype : ARRAY [1..7] OF 0..127; $fname : ARRAY [1..7] OF STRING [30]; # $bitmap : ARRAY [0..34] OF ARRAY [0..15] OF BOOLEAN; #  FUNCTION cblk(t:INTEGER;s,N, $CATUNIT : INTEGER; (* COUNTERS *) $ANS,QUES : STRING[80]; $CHARARRAY : PACKED ARRAY [0..512] OF CHAR; $bytearray : PACKED ARRAY [0..512] OF 0..255; $endcat : BOOLEAN; $types : STRING[8]; $ $t,s,vol : 0..255; $tst,tss,fl  PROGRAM readcat; # #(*$C COPYRIGHT (C) 1980 BY LEE MEADOR *) #(* ONLY COMMERCIAL RIGHTS RESERVED *) # #(* PROGRAM TO SHOW CATALOG OF DOS 3.3 DISK ON THE SCREEN *) #(* By Lee Meador - 21 Dec 1980 *) #  VAR I,J,K,L,MN^Ǡâ)IF (NOT RESTART) AND (KEY <> CHR(ESC)) THEN ,GENERATION &UNTIL RESTART OR (KEY=CHR(ESC)); #UNTIL KEY=CHR(ESC); #PAGE(OUTPUT); #TEXTMODE  END. ; &COLOURS[HAIR,RECESSIVE]:=WHITE1; &COLOURS[FACE,DOMINANT]:=ORANGE; &COLOURS[FACE,RECESSIVE]:=BLUE; &RESTART:=FALSE; &INITPARENTS #END;   BEGIN #RANDOMIZE; #REPEAT &INITIALISE; &SPLASHPAGE; &REPEAT )CHOOSETYPES; N'T HAVE PADDLES ATTACHED *) &POS0:=PADDLE(0); &FOR DELAY:=1 TO 50 DO BEGIN END; &POS1:=PADDLE(1); &NOPADDLES:=((POS0=255) AND (POS1=255)) AND 1((BUTTON(0)) AND (BUTTON(1))); &(* SET UP COLOURS FOR FACE/HAIR DISPLAY *) &COLOURS[HAIR,DOMINANT]:=GREEN:=THEKIDS[POSITION]; &DRAWCURSOR #END; # #PROCEDURE INITIALISE; #VAR POS0,POS1,DELAY:INTEGER; (* FOR READING PADDLES *) #BEGIN &INITTURTLE; &(* IF BOTH PADDLES READ 255, AND BOTH BUTTONS *) &(* ARE PRESSED, THEN IT'S A SAFE BET THAT YOU *) &(* DO:INTEGER):INTEGER; # #BEGIN { calculate block from track, sector } %IF s=0 THEN s := 15 ELSE IF s=15 THEN s := 0; %cblk := ((t*8+(15-s) DIV 2)*2 + ((15-s) MOD 2)); #END; &  PROCEDURE getcat(i:INTEGER);  #VAR off,j,k: INTEGER; # #BEGIN { move the byte array into the catalog information } %off := 256*i; %t := bytearray [off+1]; %s := bytearray [off+2]; %FOR j := 1 TO 7 DO 'BEGIN )tst[j] := bytearray[off + 11 + (j-1)*35 + 0]; )tss[j] := bytearray[off + 11 + (j-1)); "  SHOW_BITMAP; " "WRITELN('Push button to continue'); "READLN(ans); "  END. Print out the number of free sectors } " "k := 0; "FOR i := 0 TO 34 DO FOR j := 0 TO 15 DO IF bitmap [I] [J] THEN &k := k + 1; & "WRITELN; "WRITELN(' ',k:4,' Free Sectors'); "WRITELN; " "WRITELN('Push button to continue'); "READLN(ans=l := succ(l); =j := j DIV 2; =END; 7WRITELN(types[l],FLEN[K]:4, ?' ',fname[k],TST[K]:4,TSS[K]:4) 7END { then } 2ELSE endcat := true 2 -ELSE WRITELN('.............'); $ $END; { for k := 1 to 7 } "END; { while not endcat }  "{ Calculate and } " ${ Read in the next sector of the DOS 3.3 catalog } $ $FOR k := 1 TO 7 DO BEGIN -IF tst[k] < 127 -THEN 2IF tst[k] <> 0 2THEN BEGIN 7IF locked[k] THEN WRITE('*') DELSE WRITE(' '); 7l := 1; 7j := ftype[k]; 7while j <> 0 do =BEGIN "WRITELN; $ "{ Print out the contents of the catalog } " "endcat := false; $ "WHILE NOT endcat DO BEGIN $ $i := cblk(t,s); { Track, Sector } $UNITREAD(catunit,bytearray,512,i DIV 2); $getcat(i MOD 2); { get catalog data from bytearray t := bytearray[(i MOD 2)*256+1]; { track of 1st catalog sector } "s := bytearray[(i MOD 2)*256+2]; { sector of 1st catalog sector } " "{ Print out the volume number, etc } " "WRITELN('CATALOG'); "WRITELN; "WRITELN('Disk Volume ',vol); " "{ Read in the VTOC of the DOS 3.3 catalog } " "t := 17; "s := 00; "i := cblk(t,s); { Track, Sector } "UNITREAD(catunit,bytearray,512,i DIV 2); "getbmap(i MOD 2); "vol := bytearray[(i MOD 2)*256+6]; { Volume num from VTOC } "BRS??';  END; "  BEGIN " "initypes; "WRITELN('DOS 3.3 CATALOG'); "WRITELN; "REPEAT %WRITELN('What unit # for diskette? '); %READLN(catunit); "UNTIL CATUNIT IN [4,5,11..14]; " "WRITELN; "WRITELN('Put disk in #' ,catunit ); "READLN(ans); ELSE WRITE(i DIV 10:2); "WRITELN; " "WRITE(' ':5); "FOR i := 0 TO 34 DO WRITE(i MOD 10:2); "WRITELN;  END; (* SHOW_BITMAP *)   PROCEDURE initypes;  "BEGIN { set up the various types a DOS file can be } $types := 'TIA); &FOR j := 0 TO 34 DO IF bitmap [J] [I] THEN WRITE(' ':2) MELSE WRITE('*':2); &WRITELN; &END; & "WRITE(' ':5); "FOR i := 0 TO 34 DO WRITE('--'); "WRITELN; " "WRITE(' ':5); "FOR i := 0 TO 34 DO IF i DIV 10 = 0 THEN WRITE(' ':2) " ,jint := bytearray[off + 56 + l*4 + 1]; ,FOR k := 0 TO 7 DO 0bitmap[l] [k+8] := jbool [7-k]; ,END; { for l := 0 to 34 do with j } , "END; " PROCEDURE SHOW_BITMAP;   VAR I,J: INTEGER;   BEGIN #FOR i := 15 DOWNTO 0 DO &BEGIN &WRITE(I:2,' ! 'l:PACKED ARRAY [0..7] OF BOOLEAN); 'END; {j record} ' 'l,k,off: INTEGER;  "BEGIN " off := i*256; (FOR l := 0 TO 34 DO WITH j DO BEGIN ,jint := bytearray[off + 56 + l*4 + 0]; ,FOR k := 0 to 7 DO 0bitmap[l] [k] := jbool [7-k]; '; )for k := 0 TO 29 DO fname [j] [k+1] := -CHR(bytearray[off + 11 +(j-1)*35 + 3 + k]); - 'END; { for j := 1 to 7 } #END; { getcat } '  PROCEDURE getbmap(i:integer);   VAR j: RECORD .CASE b: BOOLEAN OF 3true: (jint: 0..255); 3false: (jboo*35 + 1];  locked [j] := ((bytearray[off + 11 + (j-1)*35 + 2] DIV 128) = 1);  ftype [j] := bytearray[off + 11 + (j-1)*35 + 2] MOD 128; )flen [j] := bytearray[off + 11 + (j-1)*35 + 33]; )fname [j] := '012345678901234567890123456789N^WWor('Illegal command') #ELSE CASE ws[1] OF # $ #'R':writeln(o,'{',copy(ws,3,length(ws)-2),'}'); #'T':T(ws); #'M': BEGIN IF ws[3]='@'THEN *writeln(o,'match(',copy(ws,4,length(ws)-4),');') *ELSE writeln(o,'match(''',copy(ws,3,length(ws)-2),''');'); gth(ws)-1) $END; $ !IF length(ws)>2 THEN IF ws[3]=' ' THEN delete(ws,3,1); !IF length(ws)<2 THEN $ERROR('Line too short') !ELSE #IF ws[2]<>':' THEN &ERROR('COLON EXPECTED') !ELSE #IF not (ws[1] IN ['T','R','A','M','J','E','C','U','X']) THEN &err#IF i^ IN digits THEN #BEGIN read (i,c); write(o,c,':'); #skip; IF i^IN digits THEN error('Label must be single digit') #END; #readln(i,ws); !If ws[1] IN['Y','N'] THEN ! BEGIN &IF ws[1]='Y' THEN (write(o,'IF not flag THEN '); (ws:=copy(ws,2,len''',',ws,i) $ELSE insert(',''',ws,i); $i:=i+1; b:=not(b) $END; !I:=I+1 !END; ! #writeln(o,'(''',copy(ws,3,length(ws)-2),''');'); #IF not b THEN error('Unmatched @') !END; ! !PROCEDURE line; !VAR #j: INTEGER; !BEGIN #skip; ws:=copy(ws,1,length(ws)-1) "ELSE write(o,'ln'); "i:=1; b:=true; "WHILE i<=length(ws) DO $BEGIN $IF(ws[i]=apostrophe) and b THEN &BEGIN (insert(apostrophe,ws,i); i:=i+1 &END "  ELSE "IF ws[i]='@' THEN $BEGIN delete (ws,i,1); $IF b THEN INSERT(='a' TO 'z' DO %BEGIN 'write(o,c,':=0;',c,'s:='''';'); 'IF ord(c)mod 4=0 THEN writeln(o); %END; #writeln(o,'END;');  END;   PROCEDURE T(ws:STRING);   VAR #i:INTEGER; #b:BOOLEAN; #  BEGIN  "write(o,'write'); "IF ws[length(ws)]=';'THEN $#writeln(o,'PROCEDURE match(S:STRING);VAR x,y:STRING;'); #writeln(o,'BEGIN x:=concat('','',ans,'',''); y:=concat('','',s,'','');'); #writeln(o,'flag:=pos(x,y)>0'); #writeln(o,'END;'); #writeln(o,'PROCEDURE initialize;'); #writeln(o,'BEGIN'); #FOR c:,'VAR a,b,c,d,e,f,g,h,i,j,k,'); #writeln(o,'l,m,n,o,p,q,r,s,t,u,v,w,x,y,z:INTEGER;'); #writeln(o,'as,bs,cs,ds,es,fs,gs,hs,is,js,ks,ls,'); #writeln(o,'ms,ns,os,ps,qs,rs,ss,ts,us,vs,ws,xs,ys,zs:STRING;'); #writeln(o,'ans:STRING;flag:BOOLEAN;'); BEGIN "WHILE i^=' ' DO get(i)  END;   PROCEDURE translate;   PROCEDURE heading;  BEGIN  #writeln(o,'PROGRAM',name,';'); #writeln(o,'(*$G+*)'); #writeln(o,'LABEL 0,1,2,3,4,5,6,7,8,9,10;'); #writeln(o,'TYPE charset=SET OF CHAR;'); #writeln(oariables,digits,letters:SET OF CHAR; "c:CHAR; "j:INTEGER; "  PROCEDURE error(message:STRING);  BEGIN #writeln(ws); #writeln('ERROR: ',message); #writeln('Type anything to continue'); #readln(zzz); #badsyntax:=true  END;    PROCEDURE skip; PROGRAM PILOT;    CONST "apostrophe='''';  el=10;{ label for end of procedure or program }  VAR "badsyntax:BOOLEAN; "zzz, { snooze string to interrupt translation } "ws, { the work string } "name:STRING; "I,O:Text; "V' END; #'J':BEGIN 'IF not (ws[3] IN digits) THEN error('Digit expected'); 'writeln(o,'GOTO ',ws[3],';') 'END; #'E':writeln(o,'GOTO ',el,';'); #'C':writeln(o,copy(ws,3,length(ws)-2),';'); #'U':writeln(o,copy(ws,3,length(ws)-2)); #'X':writeln(o,'flag:=',copy(ws,3,length(ws)-2),';'); #'A':IF length(ws)>4 THEN error('Ask statment too long') 'ELSE CASE length(ws) OF &2: writeln(o,'readln(ans);'); &3: IF ws[3] IN variables THEN writeln(o,'readln(',ws[3],');') )ELSE error('VariablP simply by adding a  WRITE statment to the transltor.  %Once a PILOT/P program has been  edited and saved, the perprocessor is  invoked by executing the file  PILOT.CODE . the preprocessor then  prompts for the file containing the  PILOT prer-aided  instruction (CAI) programs.  %This PREPROCESSOR accepts PILOT/P  source code and translates it into  Pascal source code. The translated  program may be run like any outher  Pascal program. Any Pascal feature may  be added to PILOT/PILOT/P FROM JULY 1980 BYTE page 154   PILOT/P: Implementing a Highlevel  Language in a Hurry -by- DAVID MUNDIE   %PILOT is a simple but  entertaining language which is useful  for introducing beginners to computing  and for writing computO^WW"readln(name); "reset(i,concat(name,'.TEXT')); "rewrite(o,concat('/',name,'.TEXT')); "translate; "IF badsyntax THEN $close(o,purge) "ELSE %close(o,lock)  END.  & n('*:',name); $writeln(o,'BEGIN initialize; '); $WHILE not eof(i) DO &line; $writeln(o,el,':END.')  END;    BEGIN {PILOT} "variables:=['a'..'z'];digits:=['0'..'9']; letters:=['A'..'Z']; "badsyntax:=false; "write('Translate what file?'); BEGIN readln(i,ws);writeln(ws); (writeln(o,'PROCEDURE ',copy(ws,3,length(ws)-2),';'); (writeln(o,'LABEL 0,1,2,3,4,5,6,7,8,9,10;'); (writeln(o,'BEGIN'); & While (i^<>'*') and (not(eof(i))) DO *line; (writeln(o,el,':END;'); (readln(i) &END; $writele expected'); &4: IF (ws[3] IN variables)and(ws[4]='s') THEN +writeln(o,'readln(',copy(ws,3,2),');') )ELSE error('String variable expected') )END &END;skip !END; ! !BEGIN{translate} # writeln('Translating...'); $heading;skip; $WHILE i^='*' DO &ogram to be processed. The  preprocessor then writes its  translation onto a text file whose  name is the input file name preceded  by a slash-for example, /DEMO.TEXT.  &If a syntax error is discovered,  the line containing the error is  displayed along with an error message,  and processing is interrupted untill  the user signals the program to  continue. If errors are discovered,  the output file is purged; otherwise,  the output file may be compiled and  executed in the no:=i+1 C:getchoice   U: Not needed. the compute command  fufills the function of the standard U  command.    XXXXXXX TABLE 1 STANDARD PILOT  COMMANDS USED IN PILOT/P SHOWN  ABOVEXXX  =:=:=:=:=:=:=:=:=:=:=:=:=:=:=:=:=:=:=:=:    S(c<11)   X: Examine the following bolean  expression and set the flag  accordingly. Operators are +,-  ,*,/,=,<,<=,>=,<>,AND,OR,and NOT.   C: Compute or call. Perform the  follong assignment,or invoke the  following subroutine !Example: C:i T: type reminder of the terminal.  Variables may be displayed if their  names are surrounded by at signs (@).   M: match ANS to the following string.  A string variable may be used if its  name is included between at-signs "Example X:(c>0)and assigned to that ariable. If not,  input is asigned to the special string  variable ANS.   J: Jump to the following labels must  be single digits   E: Exit from the main program(or the  current subroutine)   R: Remark  second occurrence marks rhe end of the  subroutine.   Y Executes the following command if  the flag is true.   N Execute the following comand if flag  is true   A: Accept input from the terminal. If  followed by a variable name, input is ocedure TRANSLATE,you  could allow the PILOT programmer to  declare local  variables,types,proceedures, and so  on.    SYMBOL USE   *: Identifies and delimits  subroutines, the first occurrence is  followed by subroutine nam,while the   the output file depending on wheather  or not syntax errors were encountered.   %The preprocessor is currently  restricted to the ten digits 0 thru 9  for Pascal/p's labels. They can be  modified for only needed labels. By  mdifying the prT delimiter "@" and inserting  apostrophes as needed. Procedure LINE  is the heart of the program; it  converts one line of PILOT code into  one line of Pascal code. the main  program opens appropriate actions on "write" or  "writeln" statment. The last character  in the work string WS is examined to  determine wheather or not to suppress  the carage return at the end of the  line. The preprocessor then goes  through the work string removing the  PILOriables by simply  adding:   writeln(o,'r1:real;f1:text;a1:array  1..10 of string');   after the other declarations in  HEADING.   T is a sprcial procedure to handle the  messy transformation of a PILOT "type"  (T) command into a Pascal  constants,variables,types, procedures  and functions. It is here that  PILOT/P's features may be expanded  indefinitely. As a trivial example the  real variable "f1", the file "f1", and  the array fo strings "a1" may be added  to PILOT/P's vars, as  described above.Procedure SKIP skips  leading blanks,so that PILOT/P  programs may be intended for maximum  legiblilty. Procedure HEADING writes  the heading for the target program,  including declarations for all global it stands now, has  twenty-six integer variables "A" to  "Z" and twenty-six string variables  "AS" to "ZS". Of course outher  variables may be added as needed by  making trivial modifications to the  preprocessor.   Procedure ERROR handles errormal manner.  Changes from standard PILOT  COMMANDS ARE AS FOLLOWS.  !(1) Tne assignment operator is  Pascal's ":=" rather than BASIC'S  "=".  (2) the tokens "Y" and "N" must  precede, not follow their related  commands.  (3) PILOT/P as YNBOL USE   *: Parameters may be included  Pascal-fashion after the procedure  name.  Example: *:TEST(s:string)   T: Any Pascal writ-parameter list  may be included between the at-signs  (@). This facility gives the PILOT/P  programer full control over the  display,and elimites the need for such  commands as 1802 PILOT's K command.  Example: T:@char(12)@ clears the  screen on many video terminals.    M: Any Pascal string AST,INDEX :INTEGER; !EXISTS,DONE :BOOLEAN;  TODAY :DATE; !THISPAYMENT :REAL; !STORE :STORECARD; !STORES :ARRAY[1..30] OF STORECARD; !STORAL :FILE OF ; !DATE= "RECORD #YY:INTEGER; #MM:INTEGER; #DD:INTEGER; "END;  STORECARD= "RECORD #NAME:STRING; #LASTPAID:DATE; #BALANCE:REAL; #LASTPAYMENT:REAL; #MINPAYMENT:REAL; #CARRYCHARGE:REAL; #MONTHLYCOST:REAL; #TOTALCARRY:REAL; "END; !  VAR !LPROGRAM DEBTS;  {KEEPS TRACK OF ALL REVOLVING DEBTS ON DISK FILE}  {DISK FILE NAME IS STORE.DATA}   CONST !CLERSCRN=26; !CLEREOL=28; !CLEREOS=25; !FIRSTLINE=3; !FIRSTYR=70; !LASTYR=99; !  TYPE !MNTH=1..12; !DAY=1..31; !CHOICESET=SET OF CHAR1 2 G M E R C L 8H(?^#T: What is your choice(1 to 10)?; #A: c #X: c in [1..10] "NT: @c@ is out of range #U: UNTIL flag #*:     **** THESE PILOT COMMANDS HAVE  EXTENSIONS IN Pilot/p ******    semicolon.) The following example  shows how Pascal's REPEAT statment may  be used in PILOT/P:   *: Getchoice( var c:integer)  R: Accepts a number and checks  its value  #R: #U: REPEAT tment or series of  statmentsmay be used.( The  perprocessor automaticlly adds a  trailing semicolon as a statment  separator.)    U: Any Pascal statment or  statment fragment may be used.(The  preprocessor does not add a trailling expression may  be used if it is surrounded by at-  signs !Example: M@concat(vs,'ing')@    X: Any Pascal boolean expression may  be used, wheather arithmetic or not  Example: X:copy(ns,1,1)='T'  X:length(ans)>10    C: Any Pascal staSTORECARD; !DATEISCURRENT :BOOLEAN; !CHOICE :CHOICESET; !REPLY :CHAR; !DATERROR :BOOLEAN; !   PROCEDURE CLRSCRN; !BEGIN "WRITE(CHR(CLERSCRN)); !END; !  PROCEDURE CLRFROM(LINE:INTEGER); !BEGIN "GOTOXY(0,LINE); "WRITE(CHR(CLEREOS)); !END;   PROCEDURE CLREOL(LINE:INTEGER); !BEGIN "GOTOXY(0,LINE); "WRITE(CHR(CLEREOL)); !END; !  PROCEDURE CLRTO(LINE:INTEGER); !VAR I:INTEGER; !BEGIN "FOR I:=0 TO LINE-1 DO #BEGIN $GOTOXY(0,I);IT; !VAR C,C2:CHAR; !BEGIN "CLRSCRN; "INFORM; "DATEISCURRENT:=FALSE; "DONE:=FALSE; "CHOICE:=['D','G','P','C','A','L','E','F','R','T','Q']; "WRITELN; "WRITELN('WARNING - IF A DATA FILE DOES NOT EXIST'); "WRITELN(' (it wont on the very first run)'WRITE(STORAL,'STORE.DATA'); {OPEN A NEW ONE} "FOR INDEX:=1 TO LAST DO #BEGIN $STORAL^:=STORES[INDEX]; $PUT(STORAL); #END; {OF INDEXING} "CLOSE(STORAL,LOCK); {MAKE IT PERMANENT ON DIR.} "DONE:=TRUE; !END; {CLOSEFILE} !  PROCEDURE IN!WHILE NOT EOF(STORAL) DO "BEGIN #INDEX:=INDEX+1; #GET(STORAL); #STORES[INDEX]:=STORAL^; "END; {WHILE} ! INDEX:=INDEX-1; "LAST:=INDEX; !END; {REOPEN} !  PROCEDURE CLOSEFILE; !BEGIN "CLOSE(STORAL,LOCK); {CLOSE EXISTING FILE} "RE BEGIN !REWRITE(STORAL,'STORE.DATA'); !WRITELN; !WRITELN('** NEW FILE - STORE.DATA - WAS CREATED'); !INDEX:=0; !LAST:=0;  END; !  PROCEDURE REOPEN; !BEGIN "RESET(STORAL,'STORE.DATA'); "INDEX:=1; "STORES[INDEX]:=STORAL^;  WRITELN(' THIS PROGRAM KEEPS PERMANENT RECORDS OF YOUR');  WRITELN('DEBTS TO STORES, ETC, THAT REQUIRE MONTHLY PAYMENTS');  WRITELN('THE DATA IS KEPT ON A FILE NAMED - STORE.DATA ');  WRITELN; !END; {INFORM} !  PROCEDURE OPENFILE; !VAR C:CHAR;  PAYMENT? '); #READLN(LASTPAYMENT); #WRITE(' WHAT IS THE CARRYING CHARGE IN PERCENT? '); #READLN(CARRYCHARGE); #MONTHLYCOST:=BALANCE*CARRYCHARGE/100.0; #TOTALCARRY:=0; ! END; {WITH} " CLRTO(FIRSTLINE); "END; {ADD} !  PROCEDURE INFORM; !BEGIN#WHILE DATERROR DO GETDATE(LASTPAID); #WRITE(' WHAT IS THE CURRENT BALANCE? '); #READLN(BALANCE); #WRITE(' IF YOU KNOW MIN. PAYMENT, ENTER IT, ELSE ENTER 0 '); #READLN(X); #IF X=0 THEN X:=BALANCE/10.0; #MINPAYMENT:=X; #WRITE(' HOW MUCH WAS THE LAST#INDEX:=LAST; # WITH STORES[INDEX] DO %BEGIN #WRITELN; #WRITELN(' ':10,'ADDING A NEW RECORD - -'); #WRITELN; #WRITE(' ENTER STORE/CREDITOR NAME-> '); #READLN(NAME); #WRITELN(' ENTER DATE OF LAST PAYMENT'); #DATERROR:=TRUE; N(' ':20,MM:2,'/',DD:2,'/',YY); %END; #END {NOT ERROR} "ELSE #BEGIN " WRITELN(' ??? DATE DD/MM/YY = ',D,M,Y); $WRITELN(' PLEASE TRY AGAIN'); #END; "END; {GETDATE} " !PROCEDURE ADD; "VAR C :CHAR; &X :REAL; "BEGIN #CLRSCRN; #LAST:=LAST+1; s MM DD YY -> '); "READLN(M,D,Y); "IF (M<1) OR (M>12) THEN DATERROR:=TRUE; "IF (D<1) OR (D>31) THEN DATERROR:=TRUE; "IF (Y<20) OR (Y>99) THEN DATERROR:=TRUE; "IF NOT DATERROR THEN #BEGIN $WITH ADAY DO %BEGIN &MM:=M; &DD:=D; &YY:=Y; &WRITEL PROCEDURE CHOOSE; !BEGIN "WRITE(' ':5,'Choose an item from the Menu->');  REPEAT $READ(REPLY); #UNTIL REPLY IN CHOICE !END; {CHOOSE}   PROCEDURE GETDATE(VAR ADAY:DATE); !VAR M,D,Y:INTEGER; !BEGIN "DATERROR:=FALSE; "WRITE(' Enter date aminimum payment');  WRITELN('R)':6,' Remove a creditor');  WRITELN('T)':6,' Total all debts');  WRITELN('Q)':6,' Quit');  IF DATEISCURRENT THEN SHOWDATE "ELSE  WRITELN(' ':8,'**NOTE: FIRST COMMAND SHOULD BE -D- FOR DATE');  END; {SHOWMENU}  ,' Global list of creditors');  WRITELN('P)':6,' Pay a creditor');  WRITELN('C)':6,' Correct a record');  WRITELN('A)':6,' Add a creditor');  WRITELN('L)':6,' list Late payments');  WRITELN('E)':6,' Expanded creditor info');  WRITELN('F)':6,' Figure $CLREOL(I); #END; {DO} !END; !  PROCEDURE SHOWDATE; !BEGIN "WRITE(' ':14); "WRITELN('TODAY IS: ',TODAY.MM,'/',TODAY.DD,'/',TODAY.YY); !END; !  PROCEDURE SHOWMENU; !BEGIN  CLRFROM(FIRSTLINE);  WRITELN('D)':6,' todays Date');  WRITELN('G)':6); "WRITELN('YOU MUST CREATE ONE BY USING THE'); "WRITELN(' A (ADD) COMMAND');  WRITE('DOES A DATA FILE EXIST (Y/N)? '); "READ(C); "IF C<>'Y' THEN #BEGIN $WRITELN; $WRITELN(' ANY EXISTING FILE WILL BE CLOBBERED!!'); " WRITE(' DO YOU WANT TO START A NEW ONE ? '); $READ(C2); $IF C2<>'Y' THEN C:='Y'; #END; "EXISTS:=FALSE; "IF C='Y' THEN EXISTS:=TRUE; "IF EXISTS THEN REOPEN #ELSE OPENFILE;  CLRSCRN;  END; {INIT}   PROCEDURE QUIT; !VAR C1,C2:CHAR; !BEGIN :INTEGER; "TOTALMONTH,TOTALBALANCE :REAL; "C :CHAR; !BEGIN "CLRSCRN; "TOTALMONTH:=0; "TOTALBALANCE:=0; "FOR I:=1 TO LAST DO #WITH STORES[I] DO $BEGIN %TOTALBALANCE:=TOTALBALANCE+BALANCE; %TOTALMONTH:=TOTAL I:=1 TO LAST DO &BEGIN 'SHOWALL(I); 'WRITE(' - - Hit a key to cont. '); 'READ(C); $ CLRSCRN; &END; {FOR} $END {'Y'} "ELSE #EXPOSE  END; {EXPAND}   PROCEDURE FIGUREMIN; !BEGIN END; !  PROCEDURE TOTALALL; !VAR "I #WRITE('THAT CHOICE IS NOT IN THE LIST'); "END; {ELSE}  END; {EXPOSE} !  PROCEDURE EXPAND; !VAR C:CHAR; " I:INTEGER; "BEGIN #CLRTO(FIRSTLINE); #GOTOXY(5,0); #WRITE('Do you want to step through all ? '); #READ(C); #IF C='Y' THEN $BEGIN %FORALS; "GOTOXY(5,0); "WRITE('Expand which one (number) ? '); "READLN(I); "IF (I>0) AND (I<=LAST) THEN #BEGIN $SHOWALL(I); $WRITE(' - - Hit a key to cont. '); $READ(C); ! CLRTO(FIRSTLINE); #END !ELSE "BEGIN #GOTOXY(6,1); } "ELSE #BEGIN $GOTOXY(6,0); $WRITE('THAT NUMBER IS NOT IN THE LIST !'); #END; {IF} "END; {PAY}   {START A GROUP OF DUMMY PROCS HERE} !  PROCEDURE LATE; !BEGIN END; !  PROCEDURE EXPOSE; !VAR I:INTEGER; ! C:CHAR; !BEGIN "CLRSCRN; "GLOBLASTPAYMENT:=THISPAYMENT; &LASTPAID:=TODAY; %END; {WITH} $SHOWALL(I); $WRITELN; $WRITE(' ':10,'ALL O.K. ? '); $READ(ANSWER); # CLRTO(FIRSTLINE); $IF ANSWER='N' THEN %BEGIN &GOTOXY(10,0); &WRITE(' USE ''C'' TO CORRECT IT'); $ END; {IF} $END {IF"CLRSCRN; "GLOBALS; "GOTOXY(5,0); "WRITE('Pay who ? '); "READLN(I); "IF (I<=LAST) AND (I>0) THEN #BEGIN $SHOWALL(I); $WRITELN; $WRITE(' ':10,'Pay how much ? '); $READLN(THISPAYMENT); $WITH STORES[I] DO %BEGIN &BALANCE:=BALANCE-THISPAYMENT; &. ',MONTHLYCOST:8:2);  WRITELN('Total charges to date = $...... ',TOTALCARRY:8:2);  WRITELN('Minimum payment = $............. ',MINPAYMENT:8:2);  WRITELN; #END; {WITH} !END; {SHOWALL}   PROCEDURE PAY; !VAR I:INTEGER; %ANSWER:CHAR; !BEGIN D:2,'/',YY:2);  WRITELN;  WRITELN('Total balance due = $........... ',BALANCE:8:2);  WRITELN('Amount of last payment = $...... ',LASTPAYMENT:8:2);  WRITELN('Monthly carrying charge: %...... ',CARRYCHARGE:8:2);  WRITELN('Monthly finance charge = $.....T:=TRUE;  END;  #  PROCEDURE SHOWALL(I:INTEGER); !VAR C:CHAR; #BEGIN $WITH STORES[I] DO %BEGIN &CLRSCRN; &GOTOXY(10,0);  WRITELN(I:2,') ',NAME);  WRITELN;  WRITE('Date of last payment :............. ');  WITH LASTPAID DO WRITELN(MM:2,'/',D#GOTOXY(9,0); #WRITE(' Hit a key to continue'); #READ(C);  CLRTO(FIRSTLINE); "END; {REPLY='G'}  END; {GLOBALS}   PROCEDURE GETTODAY; !BEGIN "CLRTO(FIRSTLINE); "GOTOXY(0,0); "DATERROR:=TRUE; "WHILE DATERROR DO GETDATE(TODAY); "DATEISCURRENLIN); #WRITE(BALANCE:8:2); #WITH LASTPAID DO WRITE(MM:6,'/',DD:2,'/',YY:2); #WRITE(LASTPAYMENT:8:2); #WRITELN; $END; {WITH} "END; {DO} !WRITELN('-----------------------------------------------'); !IF REPLY='G' THEN ! BEGIN #CLREOL(0); !END; {QUIT} !  PROCEDURE GLOBALS; !VAR C:CHAR;  LIN:INTEGER; !BEGIN "CLRSCRN; "GOTOXY(0,FIRSTLINE); "FOR INDEX:=1 TO LAST DO #BEGIN # WITH STORES[INDEX] DO %BEGIN #LIN:=FIRSTLINE+INDEX-1; #WRITE(INDEX:3,'. '); #WRITE(NAME); #GOTOXY(18, "CLRTO(FIRSTLINE); "GOTOXY(5,0); "WRITE(' DO YOU WANT TO QUIT (Y/N)? '); "READ(C1); "IF C1='Y' THEN #BEGIN $DONE:=TRUE; $WRITELN; $WRITE(' DO YOU WANT THIS TO BE THE NEW FILE (Y/N)? '); $READ(C2); $IF C2='Y' THEN CLOSEFILE; #END; {IF C1='Y'} Y[Z@\?Y[[@^ZOUYEB-2SXR-6mPYD;A_B^k4AD_BSZX-4AD_BSZX-4AD_BSZX>16Oycd6Bybwz6twzwzwq4}g4v{7xudsrtzs6261::BYBWZTWZWXUS,.,$?-4AD_BSZX-4AD_BSZX>16Wxr6b~s6bybwz6uwffm}zs4w|vfsq4dqf4y{z`|q4}g40438$@[@UXY[Z@\.#.&=/6CF]@QXZ/"WRITELN(' When you''ve seen enough'); $WRITE(' press a key.... '); "READ(C); ! CLRTO(FIRSTLINE); !END; {TOTALALL} "  PROCEDURE REMOVE1; !VAR I:INTEGER; %C:CHAR; !BEGIN "CLRSCRN; "GLOBALS; "CLRTO(FIRSTLINE); "GOTOXY(5,0); "WRITE('ReA^ââN {MAIN PROG} !INIT; "REPEAT #SHOWMENU; #CHOOSE; #SERVE; "UNTIL DONE  END.  "END; {CORRECT} )  PROCEDURE SERVE;  BEGIN #CASE REPLY OF !'D':GETTODAY; !'G':GLOBALS; !'P':PAY; !'C':CORRECT; !'A':ADD; !'L':LATE; !'E':EXPAND; !'F':FIGUREMIN; !'R':REMOVE1; !'T':TOTALALL; !'Q':QUIT; #END; {CASE} !END; {SERVE}   BEGIBEGIN )WRITE('Total carry charge to date ? '); )READLN(TOTALCARRY); )END; $'Q':; ) END; {CASE} &UNTIL WHAT='Q'; % CLRTO(FIRSTLINE); %END {IF} #ELSE $BEGIN %GOTOXY(6,1); %WRITE('THAT NUMBER IS NOT IN THE RECORDS'); $END; {ELSE} ASTPAYMENT); )END; $'M':BEGIN )WRITE('Minumum payment ? '); )READLN(MINPAYMENT); )END; $'P':BEGIN )WRITE('Percent monthly carry charge ? '); )READLN(CARRYCHARGE); )END; $'C':BEGIN )WRITE('Cost per month ? '); )READLN(MONTHLYCOST); )END; $'T':GIN )WRITE('New Name? ');  READLN(NAME); )END; $'B':BEGIN )WRITE('New Balance= '); )READLN(BALANCE); )END; $'D':BEGIN )DATERROR:=TRUE; )WHILE DATERROR DO GETDATE(LASTPAID); )END; $'L':BEGIN )WRITE('amount of Last payment'); )READLN(L%WRITELN('CORRECT one of the following:'); %WRITELN('N)ame,B)alance,D)ate,L)astpmnt,M)inpmnt'); %WRITELN('P)ercent,C)ost/mnth,T)otal charge,Q)uit'); %REPEAT &READ(KEYBOARD,WHAT) %UNTIL WHAT IN WHATSIT;  WITH STORES[I] DO &CASE WHAT OF $'N':BEINTEGER; !BEGIN "WHATSIT:=['N','B','D','L','M','P','C','T','Q']; "CLRSCRN; "GLOBALS; "GOTOXY(5,0); "WRITE('Correct which record (number) ? ');  READLN(I);  IF (I>0) AND (I<=LAST) THEN " BEGIN $REPEAT %SHOWALL(I); ='Y'} ! END {IN LIST} #ELSE {NOT IN LIST} $BEGIN %CLREOL(1); ! WRITE(' THAT NUMBER IS NOT IN THE LIST!!'); $END; {ELSE) "END; {IF} !END; {REMOVE1} !  {END OF DUMMY PROCS}   PROCEDURE CORRECT; !VAR WHAT:CHAR; %WHATSIT:SET OF CHAR; %I:move which one (number) ? '); "READLN(I); "IF (I>0) AND (I<=LAST) THEN #BEGIN #WITH STORES[I] DO WRITE(' Remove ',NAME,' ? '); #READ(C); #IF C='Y' THEN ! BEGIN %LAST:=LAST-1; %FOR INDEX:=I TO LAST DO &STORES[INDEX]:=STORES[INDEX+1]; %END; {C4MARCH 1981 Disk of the Month C *Dallas Apple Corps -- Fort Worth Apple User Group 8compiled by Lee Meador   GETIME, STRFORT, CLOCKUNIT, CLKUNT1.1, CLOCK.DOC, STARTUP - A $unit for using the California Computer Systems clock card $under Pascal.  PILOT, PILOT.DOC - From a recent issue of BYTE magazine, this $program will convert your Pilot program into a Pascal $program that will do the same thing. This is not a full $Pilot implementation. The documentation describes the $limitations of thoes $a catalog. The number of free sectors appears after the $list of files on the disk. Then a map of the free and used $sectors is printed. You can use the functions provided to $write your own DOS/PASCAL converter. $by Lee Meador - FWAUG, DAC $$are probable given two parents. The program draws the $decendents on the hi-res screen IN COLOR. $typed in by Jim Herman - FWAUG $  DOSCAT - Do CATALOGs of your DOS 3.3 disks in Pascal. The $program asks you what unit the 3.3 disk is in and then d(the old version). It will NOT work with $the new version. $typed in by Gary Boudreaux - DAC  GENEPOOL - This program is from Creative Computing for January $1981. It does a simulation of the gene combinations that agazine. It is written by Tom Woteki from Washington, DC. $If you have a DC Hayes Micromodem this provides a MICROMODEM $unit that allows you to use it directly from Pascal $programs. This program is written to work with VERSION 1.0 $of Apple Pascal (the true size). $originally by Glen Dower $from Gary Boudreaux - DAC $modified extensively by Lee Meador - FWAUG, DAC  FULLDUPLEX, SYSGEN, STUP, NATIVECODE, MCRMODEM - This is the $program described (and listed) in the January issue of BYTE $m$as NEW.CHARSET for you to substitute when you are ready. $You can change dots between black and white. Choose the $shape to edit. Choose the file with the character set to be $edited. Look at the shape on the text screen or on the $graphics screenCHAR and WSTRING functions. The shape of $these characters is stored in the file SYSTEM.CHARSET on $your APPLE1: disk. This program lets you change these $shapes in a screen oriented manner. The results are saved bes the change you will get $back. (ie. 1 ten dollar bill, 2 quarters and 3 pennies) $by Gary Boudreaux - DAC  CHAREDIT - An editor program for character sets. Your Apple $Pascal has the ability to draw characters on the Hi-Res $screen using the Wof 2 humps). $by Mike Laumer - DAC  CASHREG - A cute little program that adds up your purchases $(except for the tax). After it tells you what the total $cost is you type in the amount of money that you use to pay $for the stuff. Then it descri$cuts out the hidden lines. Uses Hi-Res screen. This $program is not too fast but does a lot. One of the pictures $it draws looks like the surface of a pond just after a rock $fell in and the other looks like a potato chip surface (with $4 instead unctions. Mike provides you with two options $you can choose for interesting pictures complete with scale $factors, veiwing angle, x & y cutoff points, etc. When you $get bold enter your own factors when asked. This program RFORT is a demonstration in $FORTRAN. Startup will set the system date from the clock $card. Part of this is in Assembly and part in Pascal. $by David Walling - DAC   PLOTTER - This is a fascinating program. It draws a 3-D view of $mathematical fThe unit is called CLOCKSTUFF and allows you $to get the hour, minute, second, year, month, day and day of $the week in several formats. Finally the function UPDATE $sets the system date in memory. There are also several $programs using the unit. STis program. $from TJ Pundiak - Apple Net $  DEBTS - Use this program to keep track of your debts (providing $you have disk space). It will let you delete them as you $pay them etc. Use it as is, or modify it for your own $personal finance system. $from TJ Pundiak - Apple Net  README - You are now reading the contents of README. $  NOTE: Most code files are for version 1.1 of Pascal. I don't $know what version the CCS Clock Routines are compiled in. EN:=TRUE $END; "WRITELN(PRT,CHR(15)); (* SET PRINTER TO CONDENSED PRINT*)  ENDBUF:=29; "FOR I:=0 TO 17 DO (* 18 LINES, 30 VALUES/LINE *)  BEGIN &K:=I * 30; &WRITELN(PRT); &WRITE(PRT,K:3,': '); -------------------------------------------------------------------------*)  PROCEDURE DUMPTOPRINTER;  BEGIN (*------ DUMP TO PRINTER ------*)  IF PRTOPEN = FALSE THEN " BEGIN &REWRITE(PRT,'PRINTER:'); &PRTOP&IF PASS = 0 THEN WRITE(BUF[K+J]:3) (* DEC DUMP PASS *) &ELSE WRITE(CHR(BUF[K+J]):1) (* ASCII DUMP PASS *) "END; "WRITELN  END; (*------ DUMP TO SCREEN ------*)   (*- SCREEN ------*) "ENDBUF:=24; "FOR I:=0 TO 20 DO (* 21 LINES, 25 VALUES/LINE *) "BEGIN $WRITELN; $K:= I * 25; $IF I = 20 THEN ENDBUF:=11; (* ONLY 12 VALUES ON LAST LINE *) $FOR J:=0 TO ENDBUF DO $PRTOPEN :BOOLEAN; $INCHAR :CHAR; $OKCHARSET :PACKED SET OF 0..255; $  (*--------------------------------------------------------------------------*)  PROCEDURE DUMPTOSCREEN;  BEGIN (*------ DUMP TO  (*==========================================================================*)  VAR BUF :PACKED ARRAY[0..511] Of 0..255;  INFILE :FILE; $PRT :TEXT; $INNAME,BLKSTR:STRING; $I,J,K,ENDBUF :INTEGER; $PASS,BLKNO,I1:INTEGER; PROGRAM DUMP;  (*==========================================================================*)  (* 05/17/81 DUMP A DISK FILE BLOCK *)  (* BLOCKS ARE DUMPED IN BOTH DEC AND ASCII TO THE SCREEN & PTR (IF RQSTD) *)N^% (* PUT LINE ADDRESS TO PRINTER *) &IF I = 17 THEN ENDBUF:=1; (* ONLY 2 VALUES ON LAST LINE *) &FOR J:=0 TO ENDBUF DO (IF PASS = 0 THEN WRITE(PRT,BUF[K+J]:4) (* DEC DUMP *) (ELSE *BEGIN ,I1:=(BUF[K+J]); (* ASCII DUMP *) ,IF I1 IN OKCHARSET THEN WRITE(PRT,CHR(I1):1) ,ELSE WRITE(PRT,CHR(63):1) *END $END; $WRITELN(PRT); (* PUT CR IN LAST LINE *) $WRITELN(PRT,CHR(18))N^%(WRITELN('Any more blocks to be dumped (Y or N)? '); (READLN(INCHAR) &UNTIL INCHAR = 'N'; &CLOSE(INFILE) $END  END. (*DUMP*) " ------'); *WRITE('DUMP TO MONITOR (Y or N)? '); READLN(INCHAR); *IF INCHAR = 'Y' THEN DUMPTOSCREEN; *WRITE('DUMP TO PRINTER (Y or N)? '); READLN(INCHAR); *IF INCHAR = 'Y' THEN DUMPTOPRINTER (END; " WRITELN; red.'); (WRITELN('Turn printer on if printout is desired.'); (FOR PASS := 0 TO 1 DO (* 0 = DEC DUMP, 1 = ASCII DUMP *) (BEGIN *IF PASS = 0 THEN WRITELN('------------- DEC DUMP -------------') *ELSE WRITELN('------------ ASCII DUMP ------('files have 2 header blocks before them (put out by Pascal).'); &REPEAT (WRITE('Enter block number to dump: '); (READLN(BLKNO); (I := BLOCKREAD(INFILE,BUF,1,BLKNO); (*READ IN BLOCK*) (WRITELN('Dump will go to monitor and to the printer also if desi"(*$I-*) (*TURN ERROR CK OFF*) "RESET(INFILE,INNAME); (*OPEN FILE*) "IF IORESULT <> 0 THEN WRITELN('FILE NOT FOUND') "ELSE $BEGIN &(*$I+*) (*TURN ERROR CK BACK ON *) &WRITELN('One block is 512 characters. The first blk is #0. Text'); &WRITELN=[32..126]; (* LEGAL SET OF ASCII PRINTABLE CHARS *) "WRITELN('DUMP PROGRAM:Produces a DEC or ASCII dump of a requested file blk'); "WRITELN('Enter the name of the file to dump (e.g.BOB1:WOOD.TEXT): '); "READLN(INNAME); ----------------------------------*)   (*============================*)  (* MAIN PROGRAM *)  (*============================*)  BEGIN (*------ DUMP ------*) "PRTOPEN:=FALSE; "OKCHARSET:; (* RETURN TO NORMAL PRINT *) $WRITELN(PRT);WRITELN(PRT) (* SKIP LINES *) "END; (*------ DUMP TO PRINTER ------*)  (*----------------------------------------PROGRAM DIRECTORY;   VAR VALUE,BYTE,PERCENT,VOLUMN,DA,MO,YR,BLOCK:INTEGER; $BUFFER:PACKED ARRAY[0..511] OF 0..255; $  BEGIN "WRITE('VOLUME 4 or 5? '); "READLN(VOLUMN); "BLOCK:=2; "UNITREAD(VOLUMN,BUFFER,512,BLOCK,0);  DA:=(BUFFER[20] DIV 16)+(agazine. It is written by Tom Woteki from Washington, DC. $If you have a DC Hayes Micromodem this provides a MICROMODEM $unit that allows you to use it directly from Pascal $programs. This program is written to work with VERSION 1.0 $of Apple Pascal (the true size). $originally by Glen Dower $from Gary Boudreaux - DAC $modified extensively by Lee Meador - FWAUG, DAC  FULLDUPLEX, SYSGEN, STUP, NATIVECODE, MCRMODEM - This is the $program described (and listed) in the January issue of BYTE $m$as NEW.CHARSET for you to substitute when you are ready. $You can change dots between black and white. Choose the $shape to edit. Choose the file with the character set to be $edited. Look at the shape on the text screen or on the $graphics screenNOW HOW I GOT IT IN THERE... "I HAVE A PROBLEM WITH THE YEAR...IT "SEEMS THAT ITS YEAR ONE... GOOD LUCK.  NOTE: "FOR THE CAL COMP CLOCK STUFF YOU HAVE "TO REALLY TAKE THE CLOCKUNIT.TEXT AND "COMPILE IT THEN PUT IT INTO THE LIBRA- "RY ... READ THE PASCAL MANUAL CALL THE "AUTHOR OR ME TERRY PUNDIAK, N3BDC . "I HAVE IT MY SYSTEM LIBRARY NOW, BUT "DON'T N^:=BUFFER[BYTE] + 256*BUFFER[BYTE+1]; "WRITELN('NEXT OPEN BLOCK: ',VALUE); "PERCENT:=ROUND(((VALUE-6)*100)/274); "WRITELN('DISK IS ',PERCENT:2,'% FULL.');  END.  BUFFER[21] MOD 2)*16; "MO:=(BUFFER[20] MOD 16); "YR:=BUFFER[21] DIV 2; "WRITELN(MO,'/',DA,'/',YR); "BYTE:=BUFFER[16]*26+2; "IF BYTE > 510 THEN $BEGIN &BLOCK:=BYTE DIV 512 +2; &BYTE:=BYTE MOD 512; &UNITREAD(VOLUMN,BUFFER,512,BLOCK,0) $END; "VALUE(the old version). It will NOT work with $the new version. $typed in by Gary Boudreaux - DAC  GENEPOOL - This program is from Creative Computing for January $1981. It does a simulation of the gene combinations that