`L i=L\Ʃx ? N'i  ͭЅ?0ȱ Ѕ?iȱi lԠԠ͠ԠϠŠͮŠ SYSTEM.APPLE   L$JN^$$LEX.CODEb SYSGEN.CODEvgR STARTUP.CODEvgRSTARTUP.CODEvgRSTARTUP.CODEvgREXTg HOWTO.TEXT=vg$NATIVECODE.TEXTB MICRO.TEXT=vgB SYSGEN.TEXTvgB STARTGEN.TEXTvgB FULL.TEXTr=vgRNATIVECODE.CODER MICRO.CODE=vgR MICRO.LINK=vgRFULLDUPc\n DOCUMENT.TEXTvgnx FORMAT.TEXTvgx| MONEY.TEXT=vg| UNSTRING.TEXTvg FILEBURP.TEXTvgLDOSPASCAL.TEXTgAFORMATUNIT.TEXT CLEAN.TEXT=vg CLEAN2.TEXTvgFILEMAKER.TPSCAL22INDEXTODOM.TEXT$PROVERBS4.TEXTgC AXIOMS.TEXTvgC"ARAYSEARCH.TEXT$"*STANDEVIAT.TEXT*0NEWCARBUY.TEXToR0:FILEDEMO7.TEXTo:>DRAFTSMAN.TEXTo>\CROSSWORD.TEXTg&꽌ɪɖ'*&%&,E'зЮ꽌ɪФ`+*xH&x'8*7Ixix&&  ') + &п x) ++`FG8`0($ p,&") (jJJ>L+ "?I>  N `  ` x V Nx .x- z `V0^*^*>` aI꽌ɪVɭ&Y&&Y& 꽌ɪ\8`&>San Francisco Apple Core J 4Pascal April Disk of the "Every Other Month" % % CBy Max Nareff  PROVERBS4.TEXT.............A fun item takes 60 words in the text file  AXIOMS.TEXT AXIOMS.TEXT and through selective random %generatN^#C  FULLDUPLEX.CODE  SYSGEN.CODE  STARTUP.CODE   T will only work with Pascal 1.0. Of course,  NATIVECODE.CODE once BIOS 1.1 is figured out and the assembly  MICRO.CODE language stuff is modified, the Pascal stuff  MICRO.LINK should work ok. NATIVECODE.TEXT............Library unit for using the Hayes Micromodem II.  MICRO.TEXT See Byte Magazine, February, 1981.  SYSGEN.TEXT  STARTGEN.TEXT NOTE: Because of BIOS 1.0 dependencies, this  FULL.TEX  FILEMAKER.TEXT.............Utility for use with above.   HOWTO.TEXT.................Some documentation.   ,By Tom Woteki, Typed in by George Golden from Byte Magazine  files and transfers to Pascal.   /By Shin'Ichirou Sugou, S.F. Apple Core member in Japan  CLEAN.TEXT.................Utility for use with a commercially available ;"cleaning disk". 3 drive version.   CLEAN2.TEXT................2 drive version. er compiled, this UNIT goes into ;SYSTEM.LIBRARY.  6Typed in by Roger Curtis from Call Apple   FILEBURP.TEXT Looks at disk files in hex and ASCII.  7By Tom Cole, modified by Gene Jackson   DOSPASCAL.TEXT.............Reads DOS 3.3 FORMAT.TEXT display on the 40 character Apple screen. Does  MONEY.TEXT things like centering, putting text inside of a  UNSTRING.TEXT box of stars, and floating dollar signs.  FORMATUNIT.TEXT............Aft........Creates crossword puzzles and cryptograms.  1Contributed from the Suncoast Tampa Apple Groupies J ABy Ronald Kennedy %  DOCUMENT.TEXT..............A really neat system for formating text for .....Thinking of trading your old gas guzzler? %  FILEDEMO7.TEXT.............A demo of writing to and reading from a text disk %file. *  DRAFTSMAN.TEXT.............How to install lines into a program. * % BBy Lance Frohman CROSSWORD.TEXT.....ion using set operations, provides a series of aphorisms. %  ARAYSEARCH.TEXT............A demo of "searching an array".   STANDEVIAT.TEXT............For the statisticians-computes mean, average, and %standard deviation.  NEWCARBUY.TEXT........ PROGRAM PROVERBS4;  (*ASSORTED APHORISMS ASSEMBLED AT RANDOM  FROM AN ARRAY OF 60 WORDS STORED IN THE  TEXT FILE 'AXIOMS'. "BASED ON 'APHORISMS',A BASIC PROGRAM  IN THE SF APPLE CORE LIBRARY. "MANY NEW WORDS HAVE BEEN ADDED AND  ONLY ONE ARRAY COR SERMON?->>Y/N?':31); &READ (KEYBOARD, CH); &WRITELN #UNTIL (CH = 'N'); #WRITELN ('THE END':23)  END.  S".'); #WRITELN;WRITE # ('ENTER NO OF DRIVE.EX-->"#5" ':35); #READLN (DRIVE); #FILENAME := ,CONCAT(DRIVE,':AXIOMS.TEXT');  END; (*INTRO*)   BEGIN (*MAIN*) #PAGE (OUTPUT); #INTRODUCTION; #RETRIEVE; #REPEAT &COMPOSE; &WRITELN;WRITE *('ANOTHEOMPOSE*)   PROCEDURE INTRODUCTION;  BEGIN #WRITELN;WRITELN  ('SHORT-ORDER PROVERBS':30); #WRITELN;WRITELN  (' A MOTLEY MEDLEY OF PROVERBS CREATED AT'); #WRITELN  ('RANDOM FROM AN ARRAY OF 60 WORDS STORED'); #WRITELN  ('IN THE FILE NAMED "AXIOM.WRITE (WORD[K],' OF '); &UNTIL (K IN ROWK); .ROWK := ROWK - [K]; & &REPEAT )L := (RANDOM MOD 20 + 1) + 40;(*41-60*) )IF (L IN ROWL) THEN .WRITELN (WORD[L]); &UNTIL (L IN ROWL); .ROWL := ROWL - [L] . #UNTIL (ROWL = [ ]) (*SET EMPTY*)  END; (*C ARRAY*) &REPEAT )J := RANDOM MOD 20 + 1;(*NOS.1-20*) )IF (J IN ROWJ) THEN .WRITE (WORD[J]:11,' IS THE '); &UNTIL (J IN ROWJ); .ROWJ := ROWJ - [J]; & &REPEAT )K := (RANDOM MOD 20 + 1) + 20;(*21-40*) )IF (K IN ROWK) THEN )  BEGIN #RANDOMIZE; # "(*INITIALIZE SET VARS FOR EACH GROUP*) #ROWJ := [1..20]; (*FOR FIRST GROUP WORDS*) #ROWK := [21..40];(*2ND.GROUP WORDS*) #ROWL := [41..60];(*3RD.GROUP WORDS*) # #REPEAT '(*SELECTS FROM EACH OF 3 WORD .GROUPS IN THE STOREDER-  ENCE',AFTER FIRST BEING USED TO SELECT A  NEW ARRAY ELEMENT(WORD).THUS A NON-REPET-  ETIVE RANDOM SELECTION OF WORDS IN THE  APHORISMS. *)   PROCEDURE COMPOSE;  TYPE $RANGE = SET OF 1..NUMBER;  VAR $ROWJ, ROWK, ROWL : RANGE;(*SET VAR*,END; (*J*) )READLN (F) (*POINTER TO NEXT LINE*) &END; (*I*) #CLOSE (F)  END; (*RETRIEVE*)  &(*IN THE PROCEDURE COMPOSE*)  (*DIGITS ARE TESTED FOR 'SET' MEMBERSHIP.  IF PRESENT AS A RESULT OF RANDOM NO.GEN-  ERATION,THEY ARE REMOVED BY 'SET DIFFRIEVE;  BEGIN $(*$I-*) #RESET (F,FILENAME); $(*$I+*) #IF (IORESULT <> 0) THEN %BEGIN (WRITELN ('I/O ERROR-RESTART'); (EXIT (PROGRAM) %END; % #FOR I := 1 TO NUMBER DO &BEGIN )FOR J := 1 TO SIZE DO ,BEGIN /READ (F,CH); /WORD[I,J] := CH = 60; (*NO.OF WORDS*)   TYPE TEXT = FILE OF CHAR; 'LIST = PACKED ARRAY -[1..NUMBER,1..SIZE] OF CHAR; '  VAR F : TEXT; 'WORD : LIST; 'FILENAME : STRING[23]; 'I, J, 'K, L : INTEGER; 'CH : CHAR; 'DRIVE : STRING;   PROCEDURE RETNTAINING THE 60 WORDS  IS USED. "TO AVOID REPETITION OF THE RANDOMLY  GENERATED WORDS,"SET MEMBERSHIP" & "SET  DIFFERENCE" IS EMPLOYED. )PREPARED BY MAX J.NAREFF,3/81*) !  USES APPLESTUFF;   CONST SIZE = 7; (*MAX.SIZE OF WORD*)  NUMBERLOVE HOPE HEALTH AVARICE OBESITY DECENCY CHARITY NAIVETE ENERGY SANITY LUST SLEEP POETRY GOLD PRAYER SCANDAL REVENGE SHAME NEED PRIDE SOUL MOTHER GENESIS RESULT EXCESS FRIEND ENEMY REWARD BLIGHT SECRET THIEF FATHER ED LETTER*) *BEGIN -FOR I := 1 TO SIZE DO 0IF (CH IN [A[I]]) THEN 2BEGIN 5WRITELN 1(A[I]:15,' LOCATION',I:3); 5COUNT := COUNT + 1; (*INCREMENTS WITH EACH*) 2END;(*FOR*) (*LETTER FOUND*) 2 '(*NO INCREMENT-LETTER NOT FOUND*) -IF (COUNTEND; (*INTRO*) # #PROCEDURE SEARCH; #BEGIN &CLEARFROM (LINE); &WRITE #('WHICH LETTER TO SEARCH FOR? ':34); &READ (CH);; &WRITELN; &COUNT := 3; (*SPECIAL COUNTER*) & &IF (CH IN ['A'..'Z']) THEN (*INPUT ERROR CHECK*) & #(*SEARCH ARRAY FOR SELECT ('ITS LOCATION.26 LETTERS ARE GENERATED AT'); &WRITELN;WRITELN  ('RANDOM AND STORED IN THE ARRAY TO BE'); &WRITELN;WRITELN  ('SEARCHED."SET" MEMBERSHIP IS THE SEEKER.'); &WRITELN;WRITE /(' TO CONTINUE':29); &READ (KEYBOARD, CH); &WRITELN; ##END; (*GENERATE*) # #PROCEDURE INTRODUCTION; #BEGIN &PAGE (OUTPUT); &GOTOXY (0,5); &WRITELN ('SIMPLE ARRAY SEARCH':29); &WRITELN;WRITELN  ('WILL SEARCH FOR DESIRED LETTER AND WRITE'); &WRITELN;WRITELN R); #BEGIN &GOTOXY (0,LINE); &WRITELN (CHR(11)); #END; (*CLEARFROM*) #  (*GENERATE 26 NUMBERS,CONVERT TO CHARS*) #PROCEDURE GENERATE; #BEGIN #RANDOMIZE; #FOR I := 1 TO SIZE DO &BEGIN )CH := CHR(RANDOM MOD 26 + 65); )A[I] := CH; &END (*FOR*) S APPLESTUFF;   CONST SIZE = 26;   TYPE ALFA = PACKED ARRAY[1..SIZE] OF CHAR;   VAR A : ALFA; 'CH : CHAR; 'I, LINE, 'COUNT :INTEGER; ' '  (*SCREEN FORMATTER-CLEAR TO END OF SCREEN*) #PROCEDURE CLEARFROM (LINE:INTEGEPROGRAM ARAYSEARCH;  (*A SIMPLE ARRAY SEARCH USING "SET" MEM-  BERSHIP AS THE SEARCHER.26 RANDOM LETTERS  ARE GENERATED AND STORED IN AN ARRAY.THE  DESIRED LETTER IS THEN SOUGHT AND BOTH  IT AND ITS LOCATION IS WRITTEN. 2BY MAX J.NAREFF,1/81*)  USEN^$PROMISE CREDO SAVIOUR ELIXIR SOURCE SYMBOL BADGE BIRTH DEATH SUCCESS MONEY GREED BEAUTY SCIENCE SEX FAILURE WEALTH DREAMS GRIEF ROMANCE PEACE WHISKEY HEROISM GUILT TROUBLE CHANGE CRIME TIME =3) THEN 0WRITELN $(CH:7,' IS NOT STORED IN THIS ARRAY'); *END (*IF(CH IN ['A'..'Z'])*) ( &ELSE (*IF CHAR NOT LETTER*) )WRITELN  ('CHARACTER NOT IN ALPHABET-REPEAT REQUEST');   LINE := LINE + COUNT; (*SPECIAL SCREEN FORMATTER*) &IF (LINE>20) THEN LINE := 0; #END; (*SEARCH*) &  BEGIN (*MAIN*) #INTRODUCTION; #LINE := 0; #GENERATE; #REPEAT %SEARCH; %WRITELN; %WRITE  ('ANOTHER SEARCH(SAME ARRAY)-->(Y/N)?':37); &READ (KEYBOARD,CH); &WRITELN; #UNTIL (CH = 'N'); #WRITELNREAL;  BEGIN #ADDER := 0; #FOR I := 1 TO NUMENTRYS DO &BEGIN )ADDER := ADDER + SQR( A[I] ); &END; (*FOR*) #SUMOFSQUARES := ADDER;  END; (*SUM*)   (*COMPUTES AVERAGE OF THE NUMBERS*)  FUNCTION AVERAGE:REAL;  VAR ADDER : REAL;  BEGIN #ADDER :EDIAN := A[MIDVAL] #ELSE %(*IF NUMBER IS EVEN,AVERAGE THE TWO 9MIDDLE VALUES*) %MIDVAL := (MIDVAL-1 + MIDVAL) DIV 2; %MEDIAN := A[MIDVAL]  END; (*MEDIAN*) &  (*COMPUTES SUM OF SQUARES OF THE NUMBERS*)  FUNCTION SUMOFSQUARES : REAL;  VAR ADDER : )A[L] := TEMP; &END; (*FOR*)  END; (*SORT*) # #(*DETERMINES MEDIAN OF ENTRIES*)  FUNCTION MEDIAN:REAL;  VAR MIDVAL : INTEGER;  BEGIN #SORT; #(*FIND LOCATION MIDDLE VALUE IN SORT*) #MIDVAL :=( NUMENTRYS DIV 2 ) + 1; #IF ODD (NUMENTRYS) THEN %M A[I]*) #FOR I := 1 TO NUMENTRYS - 1 DO &BEGIN )(*FIND ELEMENT WITH SMALLEST 0VALUE IN REST OF ARRAY*) )L := I; )FOR J := (I + 1) TO NUMENTRYS DO ,IF A[J] < A[L] THEN L := J; #(*EXCHANGE SMALLEST VALUE WITH A[I]*) )TEMP := A[I]; )A[I] := A[L]; INTEGER; '  PROCEDURE INTAKE;  BEGIN #FOR I := 1 TO NUMENTRYS DO &BEGIN )READ (NUMBER); )A[I] := NUMBER; &END; (*FOR*)  END; (*INTAKE*)   PROCEDURE SORT;  VAR TEMP : REAL; %J, L : INTEGER; %  BEGIN (*SORT*) #(*STORE NEXT SMALLEST VALUE INE SQUARE OF THE AVERAGE). 2BY MAX J.NAREFF,1/81*)   USES TRANSCEND;   CONST SIZE =15; (*NO.OF VALUES TO BE ENTERED*)   TYPE STOREHOUSE = ARRAY[1..SIZE] OF REAL;   VAR NUMBER : REAL; 'A : STOREHOUSE; 'I, NUMENTRYS : PROGRAM STANDEVIAT;  (*CALCULATES STANDARD DEVIATION AND THE MEDIAN OF A NUMBER OF VALUES.  OPERATIONS INCLUDE THE SUM OF THE SQUARES OF EACH NUMBER,SORTING,  THE AVERAGE AND MEDIAN VALUES,AND THE SQUARE ROOT OF THE (SUM OF THE  SQUARES/NUMBER MINUS THN^q; #WRITE ('THIS ARRAY= '); #WRITELN (A); #WRITELN ('THE END.':23)  END. = 0; #FOR I := 1 TO NUMENTRYS DO  BEGIN )ADDER := ADDER + A[I]; &END; (*FOR*) #AVERAGE := ADDER / NUMENTRYS;  END; (*AVERAGE*)   (*COMPUTES SQRT OF (SUM OF SQUARES/NUMBER-SQUARE OF AVERAGE)*)  PROCEDURE FINISH;  VAR STADEVIATION : REAL;  BEGIN #STADEVIATION :=  SQRT (SUMOFSQUARES / NUMENTRYS 9-SQR (AVERAGE)); #WRITELN;WRITELN  ('AVERAGE VALUE OF THE ',NUMENTRYS,' NUMBERS = ',AVERAGE:4:2); #WRITELN; #WRITELN "('THE MEDIAN VALUE =':25,MEDIAN:4:2); #WRI ('TRADE YOUR CAR IN NOW! ITS WORTH IT.') )END (*ELSE*) #END; (*PRINTANSWER*) )  BEGIN #PAGE (OUTPUT); #GETDATA; #WEIGHDATA; #PRINTANSWER  END.   END; (*WEIGHDATA*)  #PROCEDURE PRINTANSWER; #BEGIN &IF (DECIDER > TIMECARKEPT) THEN )BEGIN ,WRITELN;WRITELN  ('STICK WITH OLD CAR FOR NUMBER OF YEARS'); ,WRITELN (('YOU HAD PLANNED TO KEEP IT.'); )END (*IF*) ) &ELSE )BEGIN ,WRITELN;WRITELN  (' OLD CAR - TIME NORMALLY KEPT '); &READLN (TIMECARKEPT); $END; (*GETDATA*) # #PROCEDURE WEIGHDATA; #BEGIN &RATIO := NEWCARMPG / (NEWCARMPG - OLDCARMPG); &DECIDER := TRUNC(  (RATIO * OLDCARMPG * COSTNEWCAR) / ,(AVEDISTDRIVEN *CURPRICEGAS)); #EADLN (OLDCARMPG); &WRITE  (' NEW CAR - TOTAL COST $'); &READLN (COSTNEWCAR); &WRITE  (' OLD CAR - AVE.DIST. DRIVEN P/YR '); &READLN (AVEDISTDRIVEN); &WRITE  (' CURRENT COST OF GASOLINE P/G $'); &READLN (CURPRICEGAS); &WRITE S'); &WRITELN  ('GUZZLER CAR FOR A SMALLER ONE?.'); &WRITELN;WRITELN  ('JUST ANSWER THE QUESTIONS WHICH FOLLOW.'); &WRITELN;WRITE  (' NEW CAR - MILES PER GALLON (BEST) '); &READLN (NEWCARMPG); &WRITE  (' OLD CAR - MILES PER GALLON (BEST) '); &RX J.NAREFF,2/81*)   VAR #NEWCARMPG, OLDCARMPG, RATIO, #COSTNEWCAR, CURPRICEGAS, #AVEDISTDRIVEN : REAL; # #TIMECARKEPT, DECIDER : INTEGER; # #PROCEDURE GETDATA; #BEGIN &WRITELN  (' SHOULD YOU CONSIDER TRADING YOUR BIG GAPROGRAM NEWCARBUY;  (*AN AID TO BUYING A NEW CAR BASED ON CAR EFFICIENCY AND COST*)  (*EQUATION OBTAINED FROM THE "AFTERBURNER",JAN-FEB 81,A USAF NEWSLETTER  FOR RETIRED PERSONNEL.THE ORIGINATOR IS A SPACE ENGINEER,ROBERT G.CHAMBERLAIN.  PREPARED BY MAN^RRF VALUES DESIRED.');  WRITELN;WRITE  ('HOW MANY NUMBERS TO BE INCLUDED?.'); #READLN (NUMENTRYS); #WRITELN ('ENTER THE NUMBERS>>>':30); #INTAKE; #FINISH; #WRITELN ('THE END':23)  END.  TELN; #WRITELN  ('STANDARD DEVIATION =':25,STADEVIATION:4:2);  END;   BEGIN (*MAIN*) #PAGE (OUTPUT); #WRITELN  ('STANDARD DEVIATION':29); #WRITELN;WRITELN  ('COMPUTES SD OF UP TO 15 NUMBERS.ADJUST '); #WRITELN;WRITELN  ('ARRAY TO SUIT NUMBER ON^RAM); %END; % #WHILE NOT EOF (F) DO  (*COULD HAVE USED'FOR LOOP'HERE INSTEAD*) &BEGIN )WHILE NOT EOLN(F) DO  (*COULD HAVE USED'FOR LOOP'HERE ALSO*) ,BEGIN /READ (F, CH); /WRITE (CH); ,END; (*EOLN*) )READLN (F); (*ON TO NEXT LINE*) )WRITELN &EWRITEFILE*)   PROCEDURE READFILE;  BEGIN #WRITELN;WRITELN .('NOW READING FILE':28); '(*REOPEN FILE FOR READING*) '  (*$I-*) #RESET (F, FILENAME);  (*$I+*)  #IF (IORESULT<>0) THEN %BEGIN (WRITELN (('I/O ERROR-RESTART PROGRAM'); (EXIT (PROG AS INDIVIDUAL CHARS WHICH WOULD REQUIRE  ANOTHER LOOP.READING CHAR ARRAYS CAN  ONLY BE DONE ONE CHAR AT A TIME*) # #FOR I := 1 TO X DO &WRITELN (F,WORD[I]); & #CLOSE (F, LOCK); (*SAVES NEW FILE ON DISK*) #FOR I := 1 TO 250 DO (*DELAY*)  END; (*IO CHECKING ON*)  #IF (IORESULT<>0) THEN &BEGIN )WRITELN +('I/O ERROR-RESTART PROGRAM'); )EXIT (PROGRAM) &END; & #WRITELN ('WRITING TO FILE':27); #  (*NOTE-PACKED ARRAY OF CHAR CAN BE WRITEN  TO SCREEN AS SINGLE STRINGS RATHER THAN D[I,J] := CH; -END; (*J LOOP*) +READLN (END (*I LOOP*)  END; (*MAKEARRAY*)   PROCEDURE WRITEFILE;  BEGIN #(*OPENS NEW FILE.REMOVES 2OLD FILE,IF SAME NAME*) 2  (*$I-*) (*TURNS OFF IO CHECKING*) #REWRITE (F, FILENAME);  (*$I+*) (*ONCAT (FILENAME,'.TEXT'); #END; (*INTRO*) & &(*FILL ARRAY WITH NAMES*)  PROCEDURE MAKEARRAY ;  BEGIN #WRITELN )('ENTER FIVE 5-CHAR WORDS':32);  FOR I := 1 TO X DO (*FIVE WORDS*) (BEGIN +FOR J := 1 TO X DO (*5-CHARS*) -BEGIN 0READ (CH); 0WOR&WRITELN  ('THE NEW LIST OF STRINGS AND THEN A FINAL'); &WRITELN  ('DEMONSTRATIVE READ.'); &WRITELN;WRITELN  (' ENTER-VOL:FILENAME-OF THE FILE TO BE'); &WRITELN ('CREATED.'); &READLN (FILENAME); &IF POS ('.TEXT',FILENAME) = 0 THEN (FILENAME := CCTION; #BEGIN &WRITELN  ('A DISK I/O DEMO INVOLVING STRINGS':37); &WRITELN;WRITELN  (' THIS PROGRAM SENDS STRINGS TO A DISK'); &WRITELN  ('FILE CREATED BY THE USER.IT THEN READS'); &WRITELN  ('THE FILE,FOLLOWED BY A SORT,REFILING OF'); IZE*)   TYPE ALFA = (PACKED ARRAY[1..X,1..X] OF CHAR;  TEXT = FILE OF CHAR;   VAR WORD, TEMP : ALFA;  CH : CHAR; &I, J : INTEGER; (*LOOP INDICES*) &F : TEXT; (*FILE DESIGNATOR*) &FILENAME : STRING[15]; &  PROCEDURE INTRODU'BEGINNER'S GUIDE...-1980-MCGRAW-HILL*)  (*CHIRILIAN,P-'PASCAL'-1980-MATRIX PUB.INC.*)  (*GROGONO,P-'PROGRAMMING IN PASCAL'-1980*)  (* ADDISON-WESLEY*)  (*ZAKS,R-'INTRO.TO PASCAL'-1981-SYBEX *)   CONST X = 5; (*LOOP AND ARRAY SPROGRAM FILEDEMO7;  (*A DEMO OF DISK I/O OPERATIONS INVOLVING  A PACKED TWO-DIMENSIONAL ARRAY OF CHAR  (STRING).PREPARED IN CONJUNCTION WITH  PRECEDING FILEDEMO PROGRAMS. 2BY MAX J.NAREFF,3/81*)  (*REFERENCES- *)  (*BOWLES,K-ND; (*EOF*) #CLOSE (F)  END; (*READFILE*) #  PROCEDURE SORTER ;  VAR #L : INTEGER; (*SWAP VAR*)  BEGIN #WRITELN ('NOW SORTING STRINGS':30); #FOR I := 1 TO 250 DO BEGIN END;(*PAUSE*) # #FOR I := 1 TO (X - 1) DO &BEGIN )L := I; )FOR J := (I + 1) TO X DO ,IF (WORD[J] < WORD[L]) THEN /L := J; )TEMP[I] := WORD[I]; )WORD[I] := WORD[L]; )WORD[L] := TEMP[I]; &END (*FOR I*)  END; (*SORTER*)   BEGIN (*MAIN*) #PAGE (OUTPUT); #INTRODUCTION; #MAKEARRAY; #WRITEFILE; #READFILESUB CRY Z X C p(N^2c (2); #DRAWLINE (35,C); #LINESPACE (2); #DRAWLINE (40,D); #DRAWLINE (30,E); #LINESPACE (4); #DRAWLINE (20,F); #LINESPACE (2); #DRAWLINE (39,G)  END.  :INTEGER);  BEGIN #FOR I := 1 TO X DO &WRITELN  END; (*LINESPACE*)   BEGIN (*MAIN*) #PAGE (OUTPUT); #LINESPACE (3); #WRITELN  ('DRAWS DIFFERENT TYPE LINES-A DEMO':36); #WRITELN; #DRAWLINE (40,A); #LINESPACE (2); #DRAWLINE (30,B); #LINESPACEB := 35; (*" " " #*) 'C := 42; (*" " " **) 'D := 45; (*" " " -*) 'E := 46; (*" " " .*) 'F := 47; (*" " " /*) 'G := 62; (*" " " >*) #FOR I := 1 TO X DO &WRITE (CHR(Y)); #WRITELN  END; (*DRAWLINE*)   PROCEDURE LINESPACE (XPROGRAM DRAFTSMAN;  (*DRAWS LINES OF DIFFERENT TYPES. 2BY MAX J.NAREFF,3/81*)   VAR I : INTEGER; (*LOOP INDEX*) $A, B, C, D, E, F, G : INTEGER; (*ASCII VALUES*) $  PROCEDURE DRAWLINE (X:INTEGER;VAR Y:INTEGER);  BEGIN 'A := 94; (*ASCII FOR ^*) 'N^; #SORTER ; #WRITEFILE; #WRITELN; #READFILE  END.  PROGRAM CROSSWORDS;  USES APPLESTUFF;   (*THIS PROGRAM LETS YOU CREATE VARIOUS*)  (*PUZZLES FOUND IN CROSSWORD PUZZLE *)  (*BOOKS. *)  (* FOR CRYPTOGRAMS, TYPE IN A SAY-*)  (*ING OR QUOTATION AND THE COMPUTER *)ETTER: CHAR); )CONST ,CONVERT_TO_1_TO_26=7.9348E-4; (*26/32767*) )VAR ,RAND_1_TO_26: 1..26; )BEGIN (*RANDOM_LETTER_A_TO_Z*) ,RAND_1_TO_26:=TRUNC(RANDOM*CONVERT_TO_1_TO_26)+1; ,LETTER:=CHR(RAND_1_TO_26+ADJUST); )END; (*RANDOM_LETTER_A_TO_Z*) & &BEJECT)); )PROMPT('TYPE IN EXAMPLE',EXAMPLE); )WRITELN(PAPER,SKIP_A_LINE,'EXAMPLE: ',EXAMPLE); &END; (*GET_SUBJECT*) & &PROCEDURE MAKE_CODE; # VAR )CODE_LETTER,LOOP:'A'..'Z'; )LETTERS_LEFT: SET OF 'A'..'Z'; ) )PROCEDURE RANDOM_LETTER_A_TO_Z(VAR L&QUIT,QUOTE_DONE: BOOLEAN; & &PROCEDURE GET_SUBJECT; &VAR )SUBJECT,EXAMPLE: STRING; &BEGIN (*GET_SUBJECT*) )PROMPT('TYPE IN SUBJECT',SUBJECT); )IF SUBJECT='' THEN EXIT(CRYPTOS); )WRITELN(PAPER); )UNDERLINE(CONCAT('SUBJECT: ',SUBJECT),9+LENGTH(SUB_STRING*) &ORDINAL:=ORD(CHARACTER)-ADJUST; &STRING_ONE:=COPY('ABCDEFGHIJKLMNOPQRSTUVWXYZ',ORDINAL,1); #END; (*CHAR_TO_STRING*) # #PROCEDURE CRYPTOS; #VAR &CODE:ARRAY['A'..'Z'] OF STRING_SINGLE; &ALPHABET: SET OF 'A'..'Z'; (RESPONSE); #END; (*PROMPT*) # #FUNCTION VALUE(CHARACTER:CHAR): INTEGER; #BEGIN (*VALUE*) &VALUE:=ORD(CHARACTER)-48; #END; (*VALUE*) & #PROCEDURE CHAR_TO_STRING(CHARACTER:CHAR;VAR STRING_ONE:STRING_SINGLE); #VAR &ORDINAL: 1..26; #BEGIN (*CHAR_TOTE(PAPER,' ':PRINTER_COLUMNS-POSITION); &WRITELN(PAPER,COPY(LINE_STRING,1,LENGTH(PHRASE)):POSITION); #END; (*UNDERLINE*) # #PROCEDURE PROMPT(QUESTION:STRING; VAR RESPONSE:STRING); #BEGIN (*PROMPT*) &WRITELN(SKIP_A_LINE,QUESTION,SKIP_A_LINE); &READLN#PROCEDURE UNDERLINE(PHRASE:STRING;POSITION:INTEGER); #CONST &LINE_STRING='________________________________________________________________________________'; #BEGIN (*UNDERLINE*) &WRITE(PAPER,PHRASE:POSITION); &IF POSITION FOR THE MAIN MENU. *)   (*WRITTEN FEB 28,1981 BY LANCE FROHMAN*)  (*IDEA FROM FEBDOM CRYPTOGRAM PROGRAM *)  CONST #ASTERISK='********************************************************************************'; #PRINTER_COLUMNS)  (*INSTEAD OF THE CODE TO RETURN TO THE*)  (*MENU. *)  (* FOR QUOTATION PUZZLES JUST TYPE*)  (*IN A SAYING OR QUOTATION AND THE *)  (*COMPUTER WILL CREATE THE PUZZLE.TYPE*)  (* / FOR A NEW PUZZLE AND JUS (*TYPE IN TWO WORDS THAT CONTAIN ONLY *)  (*THE LETTERS IN THE TEN LETTER CODE. *)  (*THE COMPUTER WILL PRINT OUT A LONG *)  (*DIVISION PROBLEM USING THE LAST TWO *)  (*WORDS YOU TYPED IN AS THE DIVIDEND *)  (*AND DIVISOR. JUST TYPE * *)  (* FOR WORD ARITHMETIC PUZZLES, *)  (*TYPE IN A WORD OR PHRASE THAT CONT- *)  (*AINS 10 DIFFERENT LETTERS (DON'T *)  (*TYPE IN THE SPACES). THIS WILL BE *)  (*THE CODE FOR THE DIGITS 0-9. NEXT *) *)  (* FOR CRYPTOQUIZZES FIRST TYPE IN*)  (*THE SUBJECT AND AN EXAMPLE, THEN *)  (*TYPE IN SEVERAL OTHER EXAMPLES WHICH*)  (*WILL BE ENCODED. TYPE / TO *)  (*START A NEW PUZZLE AND JUST TYPE *)  (* FOR THE MAIN MENU.  (*WILL ENCODE AND PRINT IT. TO START A*)  (*NEW CRYPTOGRAM WITH A NEW CODE,PRESS*)  (* / AT THE BEGINNING OF THE *)  (*LINE. TO RETURN TO THE MAIN MENU *)  (*JUST TYPE AT THE BEGINNING *)  (*OF THE LINE. GIN (*MAKE_CODE*) )LETTERS_LEFT:=ALPHABET; )FOR LOOP:='A' TO 'Z' DO ,BEGIN (*FOR*) /REPEAT 2RANDOM_LETTER_A_TO_Z(CODE_LETTER); /UNTIL 2((CODE_LETTER IN LETTERS_LEFT) AND (CODE_LETTER <> LOOP)); /CHAR_TO_STRING(CODE_LETTER,CODE[LOOP]); , LETTERS_LEFT:=LETTERS_LEFT-[CODE_LETTER]; ,END; (*FOR*) &END; (*MAKE_CODE*) & &PROCEDURE ENCODE; &VAR )LOOP: 1..256; )MESSAGE,CODED_MESSAGE: STRING; &BEGIN (*ENCODE*) )CODED_MESSAGE:=''; )PROMPT('ENTER LINE TO BE CODED, / FOR NEW CODE, 0)); &END; (*GET_CODE*) & &PROCEDURE DIVISION; &VAR )QUOTIENT,PRODUCT,SHORT_PRODUCT,DIFFERENCE,SHN CODE FOR DIGITS 0-9',DIGIT_CODE); ,IF DIGIT_CODE='' /THEN /BEGIN (*IF THEN*) 2QUIT:=TRUE; 2EXIT(GET_CODE); /END; (*IF THEN*) /CHECK_CODE; )UNTIL ,NOT(CODE_ERROR); )REPEAT ,PROMPT('TYPE IN CODED DIVIDEND',DIVID_STRING); ,DECODE(DIVID_STRING,D/CHAR_TO_STRING(CODED_NUMBER[LOOP],CODED_DIGIT); /DIGIT:=POS(CODED_DIGIT,DIGIT_CODE)-1; /NUMBER:=NUMBER*10+DIGIT; ,END; (*FOR*) )END; (*DECODE*) & &BEGIN (*GET_CODE*) )PAGE(OUTPUT); )REPEAT ,DIGIT_CODE:=''; ,LETTERS_IN_CODE:=[]; ,PROMPT('TYPE IEN ERROR('ERROR, TERM CANNOT BE BLANK',' ',' '); ,FOR LOOP:=1 TO LENGTH(CODED_NUMBER) DO ,BEGIN (*FOR*) /IF NOT(CODED_NUMBER[LOOP] IN LETTERS_IN_CODE) 2THEN ERROR('ERROR, "',CODED_NUMBER[LOOP],'" IS UNDEFINED'); SAGE:STRING;BAD_CHAR:CHAR;END_MESSAGE:STRING); ,BEGIN (*ERROR*) /WRITELN(SKIP_A_LINE,BEGIN_MESSAGE,BAD_CHAR,END_MESSAGE); /GOOD_TERM:=FALSE; /EXIT(DECODE); ,END; (*ERROR*) , )BEGIN (*DECODE*) ,NUMBER:=0; ,GOOD_TERM:=TRUE; ,IF CODED_NUMBER='' /TH'S'); /LETTERS_IN_CODE:=LETTERS_IN_CODE+[DIGIT_CODE[LOOP]]; ,END; (*FOR*) )END; (*CHECK_CODE*) & )PROCEDURE DECODE(CODED_NUMBER:STRING;VAR NUMBER:BIG_NUMBER); )VAR ,LOOP,DIGIT: INTEGER; ) CODED_DIGIT: STRING_SINGLE; ) ,PROCEDURE ERROR(BEGIN_MES,FOR LOOP:=1 TO 10 DO ,BEGIN (*FOR*) /IF ((DIGIT_CODE[LOOP]<'A') OR (DIGIT_CODE[LOOP]>'Z')) 2THEN ERROR('ERROR IN CODE, "',DIGIT_CODE[LOOP],'" IS ILLEGAL'); /IF (DIGIT_CODE[LOOP] IN LETTERS_IN_CODE) 2THEN ERROR('ERROR IN CODE, 2 ',DIGIT_CODE[LOOP],'' /WRITELN(SKIP_A_LINE,BEGIN_MESSAGE,BAD_CHAR,END_MESSAGE); /CODE_ERROR:=TRUE; /EXIT(CHECK_CODE); ,END; (*ERROR*) ) )BEGIN (*CHECK_CODE*) ,CODE_ERROR:=FALSE; ,IF LENGTH(DIGIT_CODE)<>10 /THEN ERROR('ERROR, CODE MUST CONTAIN 10 LETTERS',' ',' '); &PROCEDURE GET_CODE; &VAR )LOOP: INTEGER; )LETTERS_IN_CODE: SET OF CHAR; )CODE_ERROR,GOOD_TERM: BOOLEAN; ) )PROCEDURE CHECK_CODE; )VAR ,LOOP: INTEGER; ) ,PROCEDURE ERROR(BEGIN_MESSAGE: STRING;BAD_CHAR:CHAR;END_MESSAGE:STRING); ,BEGIN (*ERROR*)&BEGIN (*POWERS_OF_TEN*) )POWER_OF_TEN[0]:=1; )POWER_OF_TEN[1]:=10; )POWER_OF_TEN[2]:=100; )POWER_OF_TEN[3]:=1000; )POWER_OF_TEN[4]:=10000; )POWER_OF_TEN[5]:=100000; )POWER_OF_TEN[6]:=1000000; )POWER_OF_TEN[7]:=10000000; &END; (*POWERS_OF_TEN*) )#PROCEDURE WORD_ARITHMETIC; #TYPE &BIG_NUMBER=INTEGER[8]; #VAR &DIVIDEND,DIVISOR: BIG_NUMBER; &POWER_OF_TEN: ARRAY[0..7] OF BIG_NUMBER; &DIGIT_CODE,DIVID_STRING,DIVIS_STRING: STRING; &LOOP: INTEGER; &QUIT: BOOLEAN; & &PROCEDURE POWERS_OF_TEN; FALSE; &REPEAT )PAGE(OUTPUT); )QUOTE_DONE:=FALSE; )IF CHOICE=2 ,THEN GET_SUBJECT; )MAKE_CODE; )REPEAT ,ENCODE )UNTIL ,(QUIT OR QUOTE_DONE); )WRITELN(PAPER,SKIP_A_LINE,ASTERISK); &UNTIL )(QUIT); #END; (*CRYPTOS*) (CODED_MESSAGE,CODE[MESSAGE[LOOP]]) AELSE CODED_MESSAGE:= DCONCAT(CODED_MESSAGE,COPY(MESSAGE,LOOP,1)); ;END; (*FOR*) 8WRITELN(PAPER,SKIP_A_LINE,CODED_MESSAGE); 5END; (*IF ELSE*) &END; (*ENCODE*) # #BEGIN (*CRYPTOS*) &ALPHABET:=['A'..'Z']; &QUIT:=RN> IF DONE', ,MESSAGE); )IF (MESSAGE='') ,THEN /QUIT:=TRUE ,ELSE /IF MESSAGE='/' 2THEN 5QUOTE_DONE:=TRUE 2ELSE 5BEGIN (*IF ELSE*) 8FOR LOOP:=1 TO LENGTH(MESSAGE) DO ;BEGIN (*FOR*) >IF MESSAGE[LOOP] IN ALPHABET ATHEN CODED_MESSAGE:= DCONCATORT_DIFFERENCE: BIG_NUMBER; )QUOT_DIGITS,QUOT_STRING,SHORT_PD_STRING,SHORT_DF_STRING:STRING; )QUOT_LENGTH,SPACES,LOOP: INTEGER; , )PROCEDURE ENCODE(NUMBER:BIG_NUMBER;VAR CODED_NUMBER:STRING); )VAR ,NUMBER_STRING: STRING; ,LOOP: INTEGER; )BEGIN (*ENCODE*) ,CODED_NUMBER:=''; ,STR(NUMBER,NUMBER_STRING); ,FOR LOOP:=1 TO LENGTH(NUMBER_STRING) DO /CODED_NUMBER:=CONCAT(CODED_NUMBER, 2COPY(DIGIT_CODE,VALUE(NUMBER_STRING[LOOP])+1,1)); )END; (*ENCODE*) & &BEGIN (*DIVISION*) )WRITELN(PAPEREGER; &BEGIN (*PRINT_LETTERS*) )FOR LOOP1:=1 TO 4 DO )BEGIN (*FOR*) ,WRITE(PAPER,VERTICAL_LINE); ,FOR LOOP2:=1 TO LINE_LENGTH DO /WRITE(PAPER,PARAGRAPH[LOOP1,LOOP2],VERTICAL_LINE); ,WRITELN(PAPER); )END; (*FOR*) &END; (*PRINT_LETTERS*) 5 #BEGIN NGTH DO ,FOR LOOP2:=1 TO 3 DO /FOR LOOP3:=(LOOP2+1) TO 4 DO 2IF PARAGRAPH[LOOP2,LOOP1] IF DONE', /LINE); ,IF (LINE='/') OR (LINE='') /THEN /BEGIN (*IF THEN*) _PUZZLE; #CONST &VERTICAL_LINE='|'; #VAR &MESSAGE: STRING[255]; &DOUBLE_LENGTH,LINE_LENGTH: INTEGER; &PARAGRAPH: ARRAY[1..4,1..65] OF CHAR; &QUIT: BOOLEAN; & &PROCEDURE GET_QUOTATION; &VAR )LINE: STRING; )NUMBER_OF_BLANKS: INTEGER; )QUOTE_DONEF_STRING:40); )WRITELN(PAPER,SKIP_A_LINE,ASTERISK); &END; (*DIVISION*) # #BEGIN (*WORD_ARITHMETIC*) &QUIT:=FALSE; &POWERS_OF_TEN; &REPEAT )GET_CODE; )IF NOT(QUIT) ,THEN DIVISION; &UNTIL )QUIT; #END; (*WORD_ARITHMETIC*) # #PROCEDURE QUOTATION2PRODUCT:=SHORT_PRODUCT*POWER_OF_TEN[SPACES]; 2ENCODE(SHORT_PRODUCT,SHORT_PD_STRING); 2UNDERLINE(SHORT_PD_STRING,40-SPACES); 2DIFFERENCE:=DIFFERENCE-PRODUCT; /END (*IF THEN*) )END; (*FOR*) )ENCODE(DIFFERENCE,SHORT_DF_STRING); )WRITELN(PAPER,SHORT_D 2SPACES:=QUOT_LENGTH-LOOP; 2IF LOOP>1 5THEN 5BEGIN (*IF THEN*) 8SHORT_DIFFERENCE:=DIFFERENCE DIV POWER_OF_TEN[SPACES]; 8ENCODE(SHORT_DIFFERENCE,SHORT_DF_STRING); 8WRITELN(PAPER,SHORT_DF_STRING:(40-SPACES)); 5END; (*IF THEN*) ),40); )WRITELN(PAPER,DIVIS_STRING:(39-(LENGTH(DIVID_STRING))) ,,')',DIVID_STRING); )DIFFERENCE:=DIVIDEND; )FOR LOOP:=1 TO QUOT_LENGTH DO )BEGIN (*FOR*) ,SHORT_PRODUCT:=VALUE(QUOT_DIGITS[LOOP])*DIVISOR; ,IF SHORT_PRODUCT>0 /THEN /BEGIN (*IF THEN*)); )UNDERLINE('0 1 2 3 4 5 6 7 8 9',70); )QUOTIENT:=DIVIDEND DIV DIVISOR; )STR(QUOTIENT,QUOT_DIGITS); )ENCODE(QUOTIENT,QUOT_STRING); )QUOT_LENGTH:=LENGTH(QUOT_STRING); )UNDERLINE(CONCAT(COPY(BLANKS,1,LENGTH(DIVID_STRING)-QUOT_LENGTH+1), ,QUOT_STRING(*QUOTATION_PUZZLE*) &QUIT:=FALSE; &REPEAT )GET_QUOTATION; )IF MESSAGE<>'' ,THEN ,BEGIN (*IF THEN*) /SET_AND_PRINT_LINEUP; /REORDER_LETTERS; /PRINT_LETTERS; /WRITELN(PAPER,SKIP_A_LINE,ASTERISK); ,END; (*IF THEN*) &UNTIL )QUIT; #END; (*QUOTATION_PUZZLE*)  PROCEDURE DISPLAY_CHOICES; #BEGIN (*DISPLAY_CHOICES*) &PAGE(OUTPUT); &WRITELN('MENU':22); &WRITELN(SKIP_A_LINE,'CRYPTOGRAMS............................1'); &WRITELN(SKIP_A_LINE,'CRYPTOQUIZZES..........................2')ELN'S.  %THE UNIT IS FOR USE WITH THE 40  COLUMN VIDEO SCREEN ONLY. IT CAN BE  CHANGED FOR USE WITH 80 COLUMN BOARDS  WITHOUT MUCH DIFFICULTY.  % (SCREEN CONTROL COMMANDS   PROCEDURE HOME; "EXACTLY LIKE A PAGE (OUTPUT) "COMMAND, JUST EAS  DESIRE TO MODIFY THEM.  %THE PROCEDURES INCLUDED ALLOW FOR  CURSOR CONTROL, FORMATTING OF STRING  VARIABLES OR CONSTANTS, FORMATTING OF  LONG INTEGERS, AND EASY USE OF LONG  SECTIONS OF PROSE WITHIN A PROGRAM  WITHOUT USING INNUMERABLE WRIT.FORMATSTUFF  %THIS SYSTEM.LIBRARY UNIT CAN BE  INVOKED WITH THE 'USES FORMATSTUFF;'  STATEMENT IN THE DECLARATION PORTION  OF YOUR PROGRAMS. THE ROUTINES ARE IN  P-CODE AND THE SOURCE CODE IS INCLUDED  ON THIS DISK AS 'FORMAT.UNIT', IF YOU O^SE; #REPEAT  DISPLAY_CHOICES; &SELECT; #UNTIL &FINISHED;  END. (*MAIN*) # 5:BEGIN (*CHOICE=5*) .FINISHED:=TRUE; .PAGE(OUTPUT); .PAGE(PAPER); .CLOSE(PAPER); +END (*CHOICE=5*) &END; (*CHOICE*) #END; (*SELECT*) #  BEGIN (*MAIN*) #RANDOMIZE; #REWRITE(PAPER,'PRINTER:'); #SKIP_A_LINE:=CHR(13); (**) #FINISHED:=FAL.UNDERLINE('WORD ARITHMETIC',48); .WRITELN(PAPER,SKIP_A_LINE,ASTERISK); .WORD_ARITHMETIC; .END; (*CHOICE=3*) )4:BEGIN (*CHOICE=4*) .UNDERLINE('QUOTATION PUZZLE',48); .WRITELN(PAPER,SKIP_A_LINE,ASTERISK); .QUOTATION_PUZZLE; .END; (*CHOICE=4*) & .UNDERLINE('CRYPTOGRAMS',46); .WRITELN(PAPER,SKIP_A_LINE,ASTERISK); .CRYPTOS; .END; (*CHOICE=1*) )2:BEGIN (*CHOICE=2*) .UNDERLINE('CRYPTOQUIZZES',47); .WRITELN(PAPER,SKIP_A_LINE,ASTERISK); .CRYPTOS; .END; (*CHOICE=2*) )3:BEGIN (*CHOICE=3*) E); #END; (*DISPLAY_CHOICES*) # #PROCEDURE SELECT; #BEGIN (*SELECT*) &REPEAT )GET(KEYBOARD); &UNTIL )(KEYBOARD^>'0') AND (KEYBOARD^<'6'); &CHOICE:=VALUE(KEYBOARD^); &WRITELN(PAPER,SKIP_A_LINE,SKIP_A_LINE); &CASE CHOICE OF )1:BEGIN (*CHOICE=1*) ; &WRITELN(SKIP_A_LINE,'WORD ARITHMETIC........................3'); &WRITELN(SKIP_A_LINE,'QUOTATION PUZZLE.......................4'); &WRITELN(SKIP_A_LINE,'EXIT PROGRAM...........................5'); &GOTOXY(0,20); &WRITELN('TYPE IN CHOICE',SKIP_A_LINIER TO TYPE.  HOMES CURSOR, AND CLEARS SCREEN.   PROCEDURE CLEAREOS; "CLEARS FROM CURRENT CURSOR POSITION  TO END OF SCREEN.   PROCEDURE CLEAREOL; "CLEARS FROM CURRENT CURSOR POSITION  TO END OF LINE.   !EX., GOTOXY (10,10); &CLEAREOS; &WRITE (NAME);    (CURSOR CONTROL COMMANDS  FUNCTION HPOS: INTEGER; ! RETURNS THE CURRENT HORIZONTAL "CURSOR POSITION (0-79). #EX., CH := HPOS; GOTOXY ((HPOS+5),0); )  FUNCTION VPOS: INTEGER; "RETURNS THE CURRENT VS COMMAS AT EVERY THIRD 'NUMERIC POSITION. PLACES A 'DOLLAR SIGN AT THE GIVEN LEFT 'MARGIN AND RIGHT JUSTIFIES THE 'NUMBER. THE LAST TWO DIGITS, 'PRESUMABLY CENTS, ARE NOT 'PRINTED. NEGATIVE SIGNS ARE 'PLACED AT THE END. "'$.' AS ABOVE, ONL * %******************************    #LONG INTEGER FORMATTING COMMANDS  "FIRST, THE LONG INTEGER SHOULD BE "CONVERTED TO A STRING VARIABLE USING "THE BUILT-IN STR PROCEDURE. THE "FOLLOWING 'FORMAT' CODES ARE USED: " "'$' INSERT EX., TITLE := '@CHECKBOOK@MAIN MENU@'; %FORMAT ('EN',5,34,TITLE); % !OUTPUT LOOKS AS FOLLOWS: ! %****************************** %* * %* CHECKBOOK * %* MAIN MENU * %* FORMATTING COMMANDS $  IF THE STRING VARIABLE OR CONSTANT  PASSED TO THE PROCEDURE CONTAINS THE  CHARACTER '@', THEN A FORCED END OF  LINE OCCURS, THE STRING FOLLOWING THE  @ CHARACTER IS THEN FORMATTED AS PER  THE PASSED PARAMETERS.  PLE GROUPIES';  FORMAT('LJ',5,20,NAME);  %SUNCOAST TAMPA %APPLE GROUPIES % %  FORMAT('EN',0,39,NAME);   ****************************************  * SUNCOAST TAMPA APPLE GROUPIES *  ****************************************   &STRING STRING WILL BE %CENTERED. USEFUL FOR TITLE %PAGES, PAGE NUMBERS, ETC. ( ( (STRING FORMATTING COMMANDS (  'EN' JUST LIKE 'CN' COMMAND EXCEPT THE %ENTIRE STRING IS ENCLOSED IN A %BORDER OF ASTERISKS. ( # #EXAMPLES: #  NAME:='SUNCOAST TAMPA AP"FOLLOWS : "  'LJ' LEFT JUSTIFIED. LIKE A WRITELN %ONLY THE LINE WILL BE PLACED %WITHIN THE MARGINS BROKEN AT %NATURAL SPACES (FILLING).  'RJ' AS ABOVE ONLY RIGHT JUSTIFIED %WITHIN THE MARGINS.  'CN' AS ABOVE ONLY EACH SEGMENT OF %THE BROKEN UPAB(0); ' 'STRING FORMATTING COMMANDS %  PROCEDURE FORMAT (CODE:STRING; LM,RM #:INTEGER; S:STRING); # "THE PROCEDURE TAKES A STRING "VARIABLE OR CONSTANT AND FORMATS IT "BETWEEN THE GIVEN LEFT AND RIGHT "MARGINS ACCORDING TO THE CODE AS ;VTAB(7); IS THE SAME # AS GOTOXY (5,7); #EX., VTAB(16);WRITE(' HELLO'); (VTAB(18);WRITE('TO YOU'); (TABUP(4);HTAB(2);WRITE('A'); $OUTPUT LOOKS LIKE: "A  HELLO % % TO YOU % !NOTE THAT A WRITELN IS EFFECTIVELY )TABDOWN(1); HT COMMANDS "  PROCEDURE VTAB (Y:INTEGER);  PLACES THE CURSOR AT THE ABSOLUTE "POSITION INDICATED BY THE VALUE Y "WHICH CAN RANGE FROM 0-23. THE "CURRENT HORIZONTAL POSITION IS "UNCHANGED (UNLIKE THE APPLESOFT VTAB "COMMAND). " EX., HTAB(5)"POSITION. IF ANYONE KNOWS HOW TO "MAKE THE CURSOR INVISIBLE DURING "SCREEN OUTPUT PLEASE TELL ME. #EX., HTAB(10);WRITE('CONTROL'); (HTAB(5);WRITE('CURSOR'); # #OUTPUT WOULD LOOK LIKE: %CURSORONTROL ( (CURSOR CONTROL BECAUSE "TO USE THE GOTOXY COMMAND BOTH EXACT "X AND Y COORDINATES MUST BE KNOWN. "THE RANGE OF X MUST BE 0-79. THIS "ROUTINE DOES NOT USE A POKE COMMAND. "THIS IS BECAUSE A WHITE SQUARE "WILL REMAIN AT THE PRIOR CURSOR ATIVE TO CURRENT POSITION. #EX., TABLEFT(10); # # # (CURSOR CONTROL COMMANDS %  PROCEDURE HTAB (X:INTEGER); "PLACES CURSOR AT THE ABSOLUTE "POSITION INDICATED BY THE VALUE X. "THE CURRENT VERTICAL POSITION REMAINS "UNCHANGED. THIS IS USEFULERTICAL CURSOR "POSITION (0-23). "  PROCEDURE TABUP(X:INTEGER);  PROCEDURE TABDOWN(X:INTEGER);  PROCEDURE TABRIGHT(X:INTEGER);  PROCEDURE TABLEFT (X:INTEGER); "SELF-EXPLANATORY. THERE IS NO RANGE "CHECKING BUILT-IN. TABS X NUMBER OF "SPACES RELY THE DECIMAL 'POINT AND TWO LAST DIGITS ARE 'PRINTED. "'#' AS ABOVE, ONLY NO DOLLAR SIGN. "'#.' AS ABOVE, ONLY NO DOLLAR SIGN, 'DECIMAL POINT AND LAST 2 DIGITS 'ARE DISPLAYED. " %LONG INTEGER FORMATTING COMMANDS % !EX., &PROGRAM MONEY; &USES FORMATSTUFF; &VAR D : INTEGER[20]; +M : STRING; &BEGIN 'D := -123456789; 'STR (D,M); 'FORMAT('$.',10,25,M); 'FORMAT('$',10,25,M); 'FORMAT('#',10,25,M); &END. ' !OUTPUT LOOKS LIKE: ! % $ 1,234,567.89- % $ 1,234,567- 01,23O^졡BE MADE TO RECOG-  NIZE IMBEDDED COMMANDS LIKE ('^PAGE').  FOR SOME REASON THE DISK ACCESS SEEMS  VERY SLOW TO ME. THIS ROUTINE USES ! READLN (FID,S); WRITELN (S);  IF SOMEONE CAN SPEED THIS ROUTINE UP,  IT WOULD BE NICE. 4RON KENNEDY 1/81 TO SEE A ROUTINE TO MAKE  THE CURSOR INVISIBLE WHEN WRITING TO THE  SCREEN (PROCEDURE CURSOR(COLOR);). THE  FORMAT PROCEDURE COULD INCLUDE A FILL  JUSTIFY ROUTINE BUT ON A 40 CHARACTER  SCREEN THIS COULD LOOK SILLY. THE FORM-  PROSE PROCEDURE COULD "AND DISPLAYS APPROPRIATE MESSAGES "ACCORDING TO IORESULT. ! ! ! ! ! ! ! (SUGGESTED MODIFICATIONS (  I OFFER THIS PROGRAM IN ITS ROUGH STATE  TO ENCOURAGE OTHERS TO EXAMINE THE CODE  AND TO LEARN FROM IT OR TO MODIFY IT.   I WOULD LIKE ISPLAYED. !  OTHER ADVANTAGES INCLUDE NOT HAVING TO "COMPILE LENGTHY INSTRUCTIONS ALONG "WITH YOUR NON-TEXT CODE. OBJECT "CODE COULD BE DISTRIBUTED WITH THE "INSTRUCTIONS REMAINING IN TEXTFILES. "  FORMPROSE INCLUDES AN IO ERROR TRAP HAS CERTAIN  ADVANTAGES IN THAT YOUR TEXT IS EASY  TO EDIT IN FUTURE REVISIONS OF YOUR  PROGRAM. 'PROSE FORMATTING COMMANDS %  IF YOU ARE CONFUSED, THEN LOOK AT THE "FILE 'DOCUMENT.TEXT' ON THIS DISK. "IT IS THAT FILE WHICH IS CURRENTLY "BEING D EDITOR IS  USED FOR THE >EDIT: PROMPT, ONLY 23  LINES OF TEXT ARE SEEN AT ONE TIME.  THIS MAKES IT EASY TO USE THE

KEY  TO FLIP THROUGH THE TEXT AND SEE  EXACTLY WHAT WILL BE PRINTED OUT BY  FORMPROSE (INSTRUCT.TEXT);   USING THE EDITOR  A SET OF INSTRUCTIONS FOR A PROGRAM  THEN CREATE A FILE CALLED &INSTRUCT.TEXT (OR WHATEVER)  USING THE PASCAL EDITOR. I SUGGEST  SETTING THE ENVIRONMENT TO FORMAT THE  TEXT (FILLING=TRUE, LEFT=0, RIGHT=39,  ETC.).   SINCE THE TOP LINE IN THEES "AT A TIME. THE 24TH LINE IS USED TO "ASK TO CONTINUE OR ABORT. "THE TEXT IS DISPLAYED TO THE SCREEN "JUST AS YOU TYPED IT IN USING THE "EDITOR. %PROSE FORMATTING COMMANDS %  FOR INSTANCE, IF YOU WANT TO CREATE (FILENAME); " "THIS PROCEDURE OPENS A TEXTFILE ON "THE DISK CALLED 'FILENAME', WHERE "FILENAME IS OF THE FORM : )#4:EXAMPLE.TEXT %MYDISK:INSTRUCTIONS +*PAGEONE.TEXT ETC. "THE TEXT WITHIN THIS FILE IS READ "AND PRINTED TO THE SCREEN 23 LIN4,567- % % % %PROSE FORMATTING COMMANDS %  SINCE STRING VARIABLES ARE LIMITED TO  80 CHARACTERS WHEN TYPING FROM THE  KEYBOARD, THE DEVELOPMENT OF  PARAGRAPHS SUCH AS THESE ARE TEDIOUS  AND INVOLVE NUMEROUS WRITELN'S.   PROCEDURE FORMPROSE PROGRAM FORMATDEMO ;   USES FORMATSTUFF;   VAR SAMPLE :STRING; (CODE :STRING; (LEFT,RIGHT :INTEGER; (S1 :STRING; (QUIT :BOOLEAN;   PROCEDURE WAIT; !VAR CH :CHAR; !BEGIN "GOTOXY(0,23); "WRITE('PRESS TO CONTINUE ':34); "UNITCLEAR(1); "READ(CH); "UNITCLEAR(1); "WRITELN !END (* WAIT *); !  FUNCTION NUMCHECK (NUMBER,LOW,HIGH:INTEGER):BOOLEAN; !BEGIN "IF ((NUMBER >= LOW) AND (NUMBER <= HIGH)) #THEN NUMCHECK := TRUE #ELSE BEGIN )WRITE(C'^LSE; "SLEN := LENGTH(S); "REPEAT #CH := S[SLEN]; #IF CH IN NUMERALS $THEN BEGIN *TEMP := ORD(CH); *TEMP := TEMP - 48; *N := N + (TEMP * COLUMN); *COLUMN := COLUMN * 10 )END $ELSE IF CH IN SYMBOLS *THEN BEGIN 0CASE CH OF 1'-' :NEGATE := TRUR; (SLEN :INTEGER; (TEMP :INTEGER; (COLUMN :LONG; (NEGATE :BOOLEAN; (PERCENT :BOOLEAN; ! !BEGIN "NUMERALS := ['0'..'9']; "SYMBOLS := ['$',',','.','%','+','-',' ']; "N := 0; "TEMP := 0; "COLUMN := 100; "NEGATE := FALSE; "PERCENT := FAPROGRAM MONEYDEMO;   USES FORMATSTUFF;   TYPE LONG = INTEGER[36];   VAR L :LONG; (S :STRING; (QUIT :BOOLEAN; (  PROCEDURE UNSTR (S:STRING; VAR N:LONG); $ !VAR NUMERALS:SET OF CHAR; (SYMBOLS :SET OF CHAR; (CH :CHAN^q COMMAS, TRAILING  NEGATIVE SIGN, AND WITH OR WITHOUT  DECIMAL POINT AND LEADING '$' SIGN.  % %EXAMINE THE SOURCE CODE FOR MORE  EXPLICIT INSTRUCTION AND POSSIBLE  MODIFICATION TO FIT YOUR NEEDS. $ 6RON KENNEDY TO A LONG INTEGER FOR  MATHEMATICAL MANIPULATION, THEN  CONVERT IT BACK TO A STRING FOR FOR-  MATTED OUTPUT.  % %THE SYSTEM.LIBRARY UNIT FORMAT-  STUFF ON THIS DISK INCLUDES ROUTINES  TO FORMAT STRINGS OF NUMERALS AS  MONETARY FIGURES WITHHE FORMAT OF THE UNSTR PROCEDURE  IS AS FOLLOWS: .UNSTR (S,LONG);  WHERE LONG IS THE TARGET LONG INTEGER. % % % % %WITH THESE TWO PROCEDURES, ONE  CAN INPUT A MONETARY VALUE IN ITS  NATURAL FORM, E.G. $ 45,000.50, AND  CONVERT IT+PROCEDURE UNSTR  # %THIS PROCEDURE WAS WRITTEN TO  COMPLEMENT THE BUILT-IN STR PRO-  CEDURE WHICH CONVERTS A LONG INTEGER  INTO A STRING. THE FORMAT OF THAT  PROCEDURE IS: .STR (LONG,S);  WHERE S IS THE TARGET STRING VARIABLE.  %TE; 1'.' :BEGIN :N := N DIV 100; :COLUMN := 100 9END; 1'%' :PERCENT := TRUE; 0END (*CASE*); /END *ELSE BEGIN 0WRITE(CHR(7)); 0WRITELN('ILLEGAL SYMBOL IN STRING'); 0N := 0; 0EXIT(UNSTR) /END; #SLEN := SLEN - 1; "UNTIL (SLEN = 0); "IF NEGATE THEN N := N * (-1); "IF PERCENT THEN N := N DIV 100 !END; (  BEGIN !HOME; !FORMPROSE('#4:MONEY.TEXT'); !REPEAT "HOME; "WRITELN('TYPE IN A NUMBER.'); "WRITELN('THE SYMBOLS + - $ , . % ARE OK TO USE.'); "WRITELN; "READLN(S); "UNSTR(SE WRITELN(P,'HEXADECIMAL INTERPRETED'); &WRITELN(P,'LO NIBBLE':40); &WRITE(P,' ':7); &FOR I:=0 TO 15 DO (* X-AXIS *) (WRITE(P,HEX[I],' ':3); &WRITELN(P); &FOR I:=1TO 70 DO WRITE(P,'-'); &WRITELN(P); &J:=1;I:=1;(* RESET COLUMN & LINE # *) &FOR K:=0HARACTERS '); &NOTE(50,10); &WRITE('BLOCK (DECIMAL: )'); &READLN(BLOCK); &I:=BLOCKREAD(F,BUF,1,BLOCK); &WRITELN(P,' ':32,'FILEBURP'); &WRITELN(P,'FILE - ',FNAME); &WRITELN(P,'BLOCK - ',BLOCK); &IF ASCII THEN WRITELN(P,'ASCII/HEX INTERPRETED') (ELS"' HI NIBBLE '; "VLN:=CHR(124); "REPEAT (*FOR EACH FILE*) $NOTE(50,10); $WRITE('FILE NAME: '); $READLN(FNAME); $RESET(F,FNAME); $REWRITE(P,'PRINTER:'); $REPEAT (* FOR EACH BLOCK PRINTED *) &ASCII:=YES('INTERPRET AS CE &BEGIN (DOIT(I MOD 16); (HEXI[L]:=HEX[I DIV 16]; &END; "END; (* DOIT *)  BEGIN "L:=1; "HEXI:='00'; "DOIT(I);  END; (* DECTAHEX *)   BEGIN (* MAIN PROGRAM *) "HEX:='0123456789ABCDEF'; "VERT:=(*NOTE THE SPACES*) ); $WRITELN; $UNITCLEAR(1); "UNTIL CH IN ['Y','N',' ']; "YES:=CH IN ['Y',' '];  END; (* YES *)   PROCEDURE DECTAHEX(I:INTEGER);  VAR L:INTEGER;  PROCEDURE DOIT(I:INTEGER); "BEGIN $IF I<16 THEN &BEGIN (HEXI[L]:=HEX[I]; (L:=L-1; &END $ELS$I,J,K:INTEGER; &HEX:PACKED ARRAY[0..15] OF CHAR; %HEXI:PACKED ARRAY[0..1] OF CHAR; %VERT:PACKED ARRAY[0..40] OF CHAR; (P:INTERACTIVE; (  FUNCTION YES(M:STRING):BOOLEAN;  VAR CH:CHAR;  BEGIN "REPEAT $NOTE(50,10); $WRITE (M,' (Y/N)? '); $READ(CH(*$L PRINTER: *)  PROGRAM FILEBURP; !(* BY ROGER CURTIS, MAY 18,1980 $CALL-APPLE, SEPTEMBER 1980 *) $  USES APPLESTUFF;   VAR ASCII:BOOLEAN; &BUF:PACKED ARRAY[0..511] OF 0..255; $FNAME:STRING; (F:FILE; # VLN:CHAR; (*VERTICLE LINE*) #BLOCK, N^LL); "STR (L,S); "FORMAT('#.',10,30,S); "SKIP(3); "WRITE('CONTINUE ? (Y/N) '); "READLN(S); "IF S='N' THEN QUIT:=TRUE !UNTIL (QUIT=TRUE); !HOME  END.  ,L); "WRITELN; "WRITE('YOUR STRING VARIABLE = '); "WRITELN(S); "SKIP(3); "WRITELN('THE UNSTR COMMAND CONVERTED IT TO'); "WRITE('A LONG INTEGER = '); "WRITELN(L); "SKIP(3); "FORMAT('LJ',0,39,'THE LONG INTEGER CAN BE REFORMATTED TO A NUMBER STRING.' TO 511 DO (BEGIN *IF J=1 THEN (* DO Y- AXIS *) ,BEGIN .IF K MOD 64=0 THEN 0BEGIN (* SKIP 4TH LINE *) 2WRITELN(P,VERT[I],VLN:4); 2I:=I+1 0END; .DECTAHEX(K DIV 16); .WRITE(P,VERT[I],' ',HEXI,VLN); .I:=I+1; ,END; *IF J<=16 THEN (* PRINT A BYTE*) ,BEGIN (*AS CHARACTER*) .IF (ASCII) AND (BUF[K] > 32) AND 0(BUF[K] < 127) THEN 0WRITE(P,' "',CHR(BUF[K]),'"') .ELSE 0BEGIN (* OR AS HEX*) 2DECTAHEX(BUF[K]); 2WRITE(P,HEXI:4); 0END; .J:=J+1 ,END; *IF J>16 THEN 2) < 32 (THEN C2 := ' '; 'IF ORD(C2) > 127 (THEN C2 := CHR( ORD(C2) MOD 128); 'IF ORD(C2) > 95 (THEN C2 := CHR( ORD(C2) - 48); 'C:= ' '; 'C[1] := C2; 'S := CONCAT(S,C) &END; "REPEAT #DELETE (S,LENGTH(S),1) "UNTIL ( COPY(S,LENGTH(S),1) <> ' ' );O VOLUME #5'); "UNUMB := 5; !END; !  FUNCTION MATCH (ITEM:INTEGER):BOOLEAN;  !VAR #A,B :INTEGER; #C :STRING; #C1,C2:CHAR; #S :STRING; # !BEGIN "S := ''; "B := ITEM*35 - 22; "FOR A := 1 TO 28 #DO BEGIN 'C2 := SECTOR[B+A]; 'IF ORD(C'IF CH <> 'Y' (THEN SCTR[LOOP] := BUFF[LOOP+PTR] (ELSE SCTR[LOOP] := CHR( ORD( BUFF[LOOP+PTR]) MOD 128) &END !END; !  PROCEDURE INITVOL;  !BEGIN "WRITE(CHR(12),'DOS 3.3 --> PASCAL TEXTFILE TRANSFER'); "WRITELN; "WRITELN('PLACE DOS 3.3 DISK INT:INTEGER; # !BEGIN "IF SECTOR = 15 #THEN #ELSE IF SECTOR = 0 )THEN )ELSE SECTOR := 15 - SECTOR; "BLK := (TRACK*16 + SECTOR) DIV 2; "UNITREAD (UNUM,BUFF,512,BLK); "PTR := 256*((TRACK*16 + SECTOR) MOD 2); "FOR LOOP := 0 TO 255 #DO BEGIN GER; "SLINK :INTEGER; "I,J,K :INTEGER; "UNUMB :INTEGER; "NAME :STRING; "CH :CHAR; "  PROCEDURE READSECTOR (VAR SCTR:SECTORBUFFER; :UNUM,TRACK,SECTOR:INTEGER); !VAR #BLK :INTEGER; #BUFF :BLOCKBUFFER; #PTR :INTEGER; #LOOP :INTEGER; #REL FFER = PACKED ARRAY[0..511] OF CHAR; "  VAR "DISK :FILE; "TEMP :INTERACTIVE; "BLOCK :BLOCKBUFFER; "SECTOR:SECTORBUFFER; "TSLIST:SECTORBUFFER; "TSPTR :INTEGER; "DVOL :INTEGER; "BNUM :INTEGER; "TNUM :INTEGER; "SNUM :INTEGER; "TLINK :INTE  (* DOS 3.3 --> PASCAL TRANSFER PROGRAM #ORIGINAL PROGRAM BY TOM COLE FOR %USE WITH CORVUS DRIVE DRIVE. #MODIFIED FOR DISK ][ DRIVES BY %GENE JACKSON.  *)   PROGRAM TRANSFER;   TYPE "SECTORBUFFER = PACKED ARRAY[0..255] OF CHAR; "BLOCKBUN^AA(* LINE IS DONE *)  BEGIN .WRITELN(P); .J:=1; (*RESET*) ,END; (END; &WRITELN(P); $UNTIL NOT YES('ANOTHER BLOCK'); $CLOSE(F);CLOSE(P); "UNTIL NOT YES('ANOTHER FILE');  END.  "GOTOXY (0,20); "WRITELN(' '); "GOTOXY (0,20); "WRITELN(S); "IF S = NAME #THEN MATCH := TRUE #ELSE MATCH := FALSE; !END; !  PROCEDURE INIT;  !BEGIN "CH := ' '; "INITVOL; "REPEAT #TNUM := 17; #SNUM := 15; #GOTOXY (0,5); #WRITE ('FILE TO TRANSFER ? '); #READLN(NAME); #IF LENGTH(NAME) = 0 $THEN EXIT(TRANSFER); #REPEAT $READSECTOR(SECTOR,UNUMB,TNUM,SNUM); $FOR I := 1 TO 7 %DO IF MATCH(I) )THEN EXIT(INIT); $SNUM := SNUM - 1 #UNTIL (SNUS:STRING); "PROCEDURE FORMPROSE (FILENAME:STRING); "  IMPLEMENTATION "  (* PEEK FUNCTION WRITTEN BY DAN SOKOL *)  (* SEE I.A.C. APNOTES FOR POKE PROC. *)  FUNCTION PEEK(ADDR:INTEGER):INTEGER; !TYPE PA = PACKED ARRAY[0..1] OF 0..255; &MAGIC = RECO TABUP (X:INTEGER); "PROCEDURE TABDOWN (X:INTEGER); "PROCEDURE TABLEFT (X:INTEGER); "PROCEDURE TABRIGHT (X:INTEGER); "PROCEDURE HTAB (X:INTEGER); "PROCEDURE VTAB (Y:INTEGER); "PROCEDURE SKIP (N:INTEGER); "PROCEDURE FORMAT (CODE:STRING;LM,RM:INTEGER;(*$C WRITTEN BY RONALD KENNEDY *)  (*$S+*)   UNIT FORMATSTUFF; INTRINSIC CODE 26 DATA 27;   INTERFACE "VAR PROSEID : TEXT; "FUNCTION HPOS:INTEGER; "FUNCTION VPOS:INTEGER; "PROCEDURE HOME; "PROCEDURE CLEAREOS; "PROCEDURE CLEAREOL; "PROCEDUREO^졡1,BNUM); *GOTOXY (0,15); *WRITE('BLOCK: ',BNUM:3); *BNUM := BNUM + 1 )END "UNTIL TSPTR > 255; "READSECTOR (TSLIST,UNUMB,TLINK,SLINK) !UNTIL FALSE; !WRITELN  END. ! SECTOR: ',SNUM:3,' '); #READSECTOR (SECTOR,UNUMB,TNUM,SNUM); #IF (TSPTR DIV 2) MOD 2 = 0 $THEN J := 0 $ELSE J := 256; #TSPTR := TSPTR + 2; #FOR I := 0 TO 255 $DO BLOCK[I+J] := SECTOR[I]; #IF J = 256 $THEN BEGIN *K := BLOCKWRITE (DISK,BLOCK,N BEGIN *IF J=0 +THEN BEGIN 1FOR I := 256 TO 511 2DO BLOCK[I] := CHR(0); 1J := BLOCKWRITE(DISK,BLOCK,1,BNUM); 1GOTOXY (0,15); 1WRITE ('BLOCK: ',BNUM:3) 0END; *CLOSE (DISK,LOCK); *EXIT (TRANSFER) )END; #GOTOXY (0,13); #WRITE('TRACK: ',TNUM:3,' !SNUM := ORD(SECTOR[I*35 - 23]); !READSECTOR (TSLIST,UNUMB,TNUM,SNUM); !REPEAT "TLINK := ORD(TSLIST[1]); "SLINK := ORD(TSLIST[2]); "TSPTR := 12; "REPEAT #TNUM := ORD(TSLIST[TSPTR]); #SNUM := ORD(TSLIST[TSPTR + 1]); #IF (TNUM=0) AND (SNUM=0) $THE0,11); !IF CH = 'Y' "THEN WRITE('7 BIT DATA ') "ELSE WRITE('8 BIT DATA '); !CLOSE (TEMP,LOCK); !RESET (DISK,NAME); !IF POS('.TEXT',NAME) <> 0 ! THEN BNUM := 2 "ELSE BNUM := 0; !TNUM := ORD(SECTOR[I*35 - 24]); "IF LENGTH(NAME)=0 #THEN EXIT(TRANSFER); "(*$I-*) "RESET (TEMP,NAME); "IF IORESULT = 0 #THEN CLOSE (TEMP,PURGE); "REWRITE(TEMP,NAME); "(*$I+*) !UNTIL IORESULT = 0; !GOTOXY (0,11); !WRITE ('STRIP PARITY ? (Y/N) '); !READ (KEYBOARD,CH); !GOTOXY(M=0); #WRITELN; #WRITELN('FILE NOT FOUND.',CHR(7)) "UNTIL FALSE; !END;   BEGIN (*MAIN*) !INIT; !REPEAT "GOTOXY (0,9); "WRITE ('PASCAL FILE NAME ..................'); "GOTOXY (0,9); "WRITE ('PASCAL FILE NAME '); "READLN(NAME); RD CASE BOOLEAN OF /TRUE: (INT: INTEGER); /FALSE: (PTR:^PA); .END;  VAR CHEAT : MAGIC; !BEGIN "CHEAT.INT := ADDR; "PEEK := CHEAT.PTR^[0]; !END; !  FUNCTION HPOS; !BEGIN HPOS := PEEK(244) END; !  FUNCTION VPOS; !BEGIN VPOS := PEEK(245) END; !  PROCEDURE HOME; !BEGIN PAGE(OUTPUT) END; !  PROCEDURE CLEAREOS; !BEGIN WRITE(CHR(11)) END; !  PROCEDURE CLEAREOL; !BEGIN WRITE(CHR(29)) END; !  PROCEDURE TABUP ; !VAR I :INTEGER; %CH :CHAR; !BEGIN "CH := C); #IF CH = CHR(27) %THEN BEGIN +CLOSE(PROSEID); +EXIT(FORMPROSE) *END %ELSE PAGE(OUTPUT); "END; % !BEGIN (* FORMPROSE *) "(*$I-*) "RESET(PROSEID,FILENAME); "I := IORESULT; "IF I <> 0 #THEN BEGIN # S:= 'ERROR IN PROSE FILENAME OR DISK; )WRITELN(BORDER) (END;  END (* FORMAT *);   PROCEDURE FORMPROSE ; !VAR S :STRING; )CH :CHAR; )I :INTEGER; !PROCEDURE PAUSE; "BEGIN #GOTOXY (0,23); #WRITE(' TO CONTINUE, TO ABORT '); #READ(KEYBOARD,CH3HTAB ((WIDTH-LENGTH(T)) DIV 2 + LM); 3WRITELN(T) 2END; ('E' : BEGIN 3HTAB(LM); 3WRITE('*'); 3HTAB ((WIDTH-LENGTH(T)) DIV 2 + LM +2); 3WRITE(T); 3HTAB(RM); 3WRITELN('*') 2END; $END(*CASE*); #END; "IF CODE[1] = 'E' #THEN BEGIN )HTAB(LM)IDTH); 8J := LENGTH(T) 7END; *END %ELSE BEGIN +T := S; +CHECKFORBREAK; *END; $DELETE (S,1,J); $CASE CODE[1] OF % 'L' : BEGIN 3HTAB(LM); 3WRITELN(T) 2END; ('R' : WRITELN(T:(1+RM)); ('C' : BEGIN DTH) %THEN BEGIN +T := COPY(S,1,WIDTH+1); +FINDLASTSPACE; +CHECKFORBREAK; +IF (LENGTH(T) > WIDTH) ,THEN IF (WIDTH > 4) 2THEN BEGIN 8INSERT('-',T,(LENGTH(T)-1)); 8DELETE(T,(LENGTH(T)-1),2); 8J := LENGTH(T) - 1 7END 2ELSE BEGIN 8T := COPY(T,1,WHEN BEGIN )BORDER := '*'; )FOR I := 2 TO WIDTH DO *BORDER := CONCAT(BORDER,'*'); )HTAB(LM); )WRITELN(BORDER); )WIDTH := WIDTH - 4; )IF WIDTH <1 THEN EXIT (FORMAT); (END; "S := CONCAT (S,'@'); "WHILE (LENGTH(S) > 0) DO #BEGIN $IF (LENGTH(S) > WI$THEN DELETE (T,POS('.',T),3); #WRITELN (T:RM+1) "END; " !BEGIN (* FORMAT *) "WIDTH := RM - LM +1; "IF WIDTH < 1 THEN EXIT(FORMAT); "IF (CODE[1] = '$') OR (CODE[1] = '#') #THEN BEGIN )FORMATNUMBER(S); )EXIT (FORMAT) (END; "IF CODE[1] = 'E' #T',T); +2 : T := CONCAT ('.',T); *END(*CASE*); #IF NEGATE $THEN T := CONCAT (T,'-') $ELSE T := CONCAT (T,' '); #IF CODE[1] = '$' $THEN BEGIN *HTAB(LM); *WRITE ('$'); *RM := RM - LM - 1 )END; #IF CODE[LENGTH(CODE)] <> '.' $ELSE NEGATE := FALSE; #TLEN := LENGTH(T); #IF TLEN > 2 $THEN BEGIN *INSERT ('.',T,TLEN-1); *I := 4; *WHILE ((TLEN-I)>1) DO +BEGIN ,INSERT (',',T,TLEN-I); ,I := I + 3 +END; )END $ELSE CASE TLEN OF +0 : T := '.00'; +1 : T := CONCAT ('.0WHILE (T[LENGTH(T)] <> ' ') DO ,DELETE (T,LENGTH(T),1); *T[LENGTH(T)] := '@'; )END; "END; !PROCEDURE FORMATNUMBER (T:STRING); "VAR TLEN,I :INTEGER; )NEGATE :BOOLEAN; "BEGIN #IF T[1] = '-' $THEN BEGIN *NEGATE := TRUE; *DELETE (T,1,1) )END(BORDER :STRING; !PROCEDURE CHECKFORBREAK; "BEGIN #I := POS('@',T); #IF I <> 0 $THEN BEGIN *DELETE(T,I,LENGTH(T)-I+1); *J := LENGTH(T) + 1; )END $ELSE J := LENGTH(T); "END; !PROCEDURE FINDLASTSPACE; "BEGIN #IF POS(' ',T) <> 0 $THEN BEGIN *; !  PROCEDURE VTAB ; !BEGIN "GOTOXY (HPOS,Y) !END; !  PROCEDURE SKIP ; !VAR M:INTEGER; !BEGIN FOR M := 1 TO N DO WRITELN END; ! (*$R-*)  PROCEDURE FORMAT ;  VAR T :STRING; (WIDTH :INTEGER; (I,J :INTEGER; "CH := CHR(08); "FOR I := 1 TO X DO UNITWRITE(1,CH,1,0,12) !END; !  PROCEDURE TABRIGHT ; !VAR I :INTEGER; %CH :CHAR; !BEGIN "CH := CHR(28); "FOR I := 1 TO X DO UNITWRITE(1,CH,1,0,12) !END;   PROCEDURE HTAB ; !BEGIN "GOTOXY (X,VPOS) !ENDHR(31); "FOR I := 1 TO X DO UNITWRITE(1,CH,1,0,12) !END; !  PROCEDURE TABDOWN ; !VAR I :INTEGER; %CH :CHAR; !BEGIN "CH := CHR(10); "FOR I := 1 TO X DO UNITWRITE(1,CH,1,0,12) !END; !  PROCEDURE TABLEFT ; !VAR I :INTEGER; %CH :CHAR; !BEGIN DRIVE.'; )CASE I OF *10 : S:='SPECIFIED PROSE NOT ON DISK'; *7 : S:='ILLEGAL FILE NAME'; *5,9,2 : S:='SPECIFIED DISK DRIVE NOT ON-LINE'; )END (*CASE*); )WRITELN(CHR(7)); )WRITELN('I/O ERROR CODE #',(I)); )WRITELN(S); )WRITELN('DESIGNATED FILE IS ''',FILENAME,''''); )WRITELN; )PAUSE; )EXIT(FORMPROSE) (END; "(*$I+*) "PAGE(OUTPUT); "REPEAT #READLN(PROSEID,S); #WRITELN(S); #IF PEEK(245) = 23 THEN PAUSE "UNTIL EOF(PROSEID); "CLOSE (PROSEID); "PAUSE !END (* FOND(* CLEANDISK *);   PROCEDURE WRITEFILE;  BEGIN "WRITELN('PUT ''APPLE1:'''); "WAIT; " "RESET(F,'APPLE1:CLEAN-BLOCK'); "SEEK(F,0); "F^:=BLOCKNUM; "PUT(F); "CLOSE(F,LOCK)  END(* WRITEFILE *);    BEGIN(* MAIN *) "READFILE; "CHECK; "CLEANIMES LIFE.'); =234 THEN IF BLOCKNUM>=276 THEN BEGIN PRESET(F,'APPLE1:CLEAN-BLOCK'); PSEEK(F,0); EGIN "WRITE(CHR(7))  END;   PROCEDURE ALARM;  BEGIN "WRITE(CHR(7)); "WRITE(CHR(7))  END;   PROCEDURE WAIT;  VAR CH:CHAR;  BEGIN "WRITE('PRESS '' SPACE BAR'' TO CONTINUE '); BELL; "REPEAT $READ(KEYBOARD,CH) "UNTIL CH=' '; "WRITELN; "WRITE FILE'. *) "  VAR F:FILE OF INTEGER; (* APPLE1: CLEAN-BLOCK*) $BUFFER:PACKED ARRAY [0..255] OF CHAR; (* USE FOR 'UNITREAD' *) $BLOCKNUM:INTEGER; (* // *) $  PROCEDURE BELL;  BPROGRAM CLEAN;  (*---------------------------------------------------------------------- "BY SHIN'ICHIROU SUGOU " " "THIS PROGRAM IS FOR USING 'CLEANING DISKETT'. " "IT CONSISTS OF 'BELL', 'ALARM', 'WAIT', 'READ FILE', 'CHECK', "'CLEANDISK', 'WRIT1 2 N^RMPROSE *); "(*$R+*)   BEGIN  END. DISK(11); "CLEANDISK(5); "CLEANDISK(4); "WRITEFILE  END. 1 2 ??N^N^ BEGIN(* MAIN *) "READFILE; "CHECK; "CLEANDISK(5); "CLEANDISK(4); "WRITEFILE  END. BLOCKNUM); $BLOCKNUM:=BLOCKNUM+1  END  END(* CLEANDISK *);   PROCEDURE WRITEFILE;  BEGIN "WRITELN('PUT ''APPLE1:'''); "WAIT; " "RESET(F,'APPLE1:CLEAN-BLOCK'); "SEEK(F,0); "F^:=BLOCKNUM; "PUT(F); "CLOSE(F,LOCK)  END(* WRITEFILE *);   =234 THEN IF BLOCKNUM>=280 THEN BEGIN PRESET(F *) $  PROCEDURE BELL;  BEGIN "WRITE(CHR(7))  END;   PROCEDURE ALARM;  BEGIN "WRITE(CHR(7)); "WRITE(CHR(7))  END;   PROCEDURE WAIT;  VAR CH:CHAR;  BEGIN "WRITE('PRESS '' SPACE BAR'' TO CONTINUE '); BELL; "REPEAT $READ(KEYBOARPROGRAM CLEAN2;   (* FOR TWO DRIVE SYSTEM *)  "  VAR F:FILE OF INTEGER; (* APPLE1: CLEAN-BLOCK*) $BUFFER:PACKED ARRAY [0..255] OF CHAR; (* USE FOR 'UNITREAD' *) $BLOCKNUM:INTEGER; (* //PROGRAM FILEMAKER;   VAR F:FILE OF INTEGER;   BEGIN "REWRITE(F,'APPLE1:CLEAN-BLOCK'); "F^:=0; "PUT(F); "CLOSE(F,LOCK)  END. .  "P.S. 'CLEAN2' IS A MODIFIED PROGRAM  FOR TWO DISKS SYSTEM. KS IS USED PER A "DISK. "   PROC. WRITEFILE " "LASTLY, REWRITES NEW 'BLOCK NUMBER' "TO 'APPLE1:CLEAN-BLOCK'. "  --------------------------------------- "TO USE THIS PROGRAM, RUN 'FILEMAKER'  FIRST TO CREATE A FILE 'CLEAN-BLOCK' ON  'APPLE1:'"'BLOCK NUMBER' IS LARGER THAN 279, "THEN COMPUTER REJECTS THIS CLEANING "DISKETTE AND REWRITES STARTING 'BLOCK "NUMBER' TO 0 FOR BEING USE A NEW "CLEANING DISKETTE. "   PROC. CLEANDISK " "THIS PROCEDURE DO THE TASK USING "'UNITREAD'. TWO BLOCOU "KNOW, IN PASCAL, THERE IS 280 BLOCK "ON ONE DISKETTE. (FROM 0 TO 279) "   PROC. CHECK " "THEN, CHCKS 'BLOCK NUMBER'. IF 'BLOCK "NUMBER' IS LARGER THAN 234 THEN "COMPUTER DISPLAYS THE MESSAGE 'HOW "LONG THIS DISKETTE CAN BE USED'. IF O FIT ANY SYSTEM, THAT IS, ONE  DISK SYSTEM, TWO DISK DISKS SYSTEM, AND  SO ON.  "EXPLANATION OF THIS PROGRAM  "  ---------------------------------------  PROC. READFILE " "FIRST, THIS PROGRAM READS STARTING "'BLOCK NUMBER' FROM 'APPLE1:'. Y OF THIS CLEANING DISK  BECOMES DIRTY, MOVE THE DISK HEAD TO  CLEAR PORTION, AND USE. "IT IS VERY DIFFICULT TO DO WHAT 3) IS  SAYING. SO, I MADE THIS PROGRAM.  "THIS PROGRAM IS WRITTEN FOR THREE  DISKS SYSTEM. BUT IT WILL BE EASY TO  CHANGE T  SHIN'ICHIROU SUGOU "THE INSTRUCTIONS FOR A COMMERCIALLY  AVAILABLE "CLEANING DISK" STATE:  1) 5-10 SECONDS CLEANING IS ENOUGH.  2) IT IS MORE EFFECTIVE TO USE IT  BEFORE SARTING DISK OR AFTER HAVING  FINISHED TO USE DISK.  3) IF THE SURFACE(^$N^2B 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 8;DESTINATION ROUTINE (JSR JUMP ( (PUSH PASCAL (RTS (  ;======================NG 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 CALL, THEN TO PASCAL.   ;---------------------------------------  ;SUGGESTED BY KENNETH SKIER IN THE JAN  ;1980 OF BYTE, PAGE 118  ;  ;A JSR INSTRUCTION FOLLOWED BY "ADDRS"  ;ARE LOADED INTO CONSECUTIVE LOCATIONS  ;  ;BEGINNING AT LOCATION "JUMP". CALL THEN  ;EXECUTES A JSR TO THAT LOCATION THEREBY  ;TRANSFERRI TO PASCAL ( ;====================================== (.PROC CALL,1 ;1 PARAMETER WORD  ;  ;PROCEDURE CALL(ADDRS);  ;  ; EFFECT:  ; CALLS THE ROUTINE LOCATED AT ADDRS  ; AND RETURNS TO PASCAL  ;  ;USES A FORM OF INDIRECT ADDRESSING S TO 8;PEEK (LDA #00 ;INITIALIZE (TAY ;Y-REG (PHA ;PUSH MSB OF 8;RETURNED VALUE: 8;ZERO  (LDA @ADDRS,Y ;LOAD A WITH LSB 8;OF RETURN VALUE (PHA ;PUSH ON STACK ( (PUSH PASCAL (RTS ;BACK---------------------------------------  ADDRS .EQU 02  ADDRSHI .EQU 03 (POP PASCAL ( (PLA ;DISCARD 4 BYTES (PLA ;OF STACK BIAS (PLA ;ASSOCIATED WITH (PLA ;FUNCTIONS ( (POP ADDRS ;SAVE ADDRE(PUSH PASCAL (RTS ;BACK TO PASCAL  ;========================================== (.FUNC PEEK,1 ;1 PARAMETER WORD  ;  ;FUNCTION PEEK(ADDRS:INTEGER):INTEGER  ;  ; EFFECT:  ;  ; THE CONTENTS OF ADDRS ARE RETURNED BY PEEK  ;  ;----ADDRS .EQU 02  ADDRSHI .EQU 03 (POP PASCAL ( (LDY #00 ;INITIALIZE Y-REG ( (POP ADDRS ;SAVE ADDRESS 8;ARGUMENT ( (PLA ;LSB OF VALUE (STA @ADDRS,Y ;STORE VALUE AT 8;ADDRS (PLA ;DISCARD MSB VALUE ( 00  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:  ;  ; VALUE IS STORED AT ADDRS  ;  GTCHAR;  ;  ; THOMAS H. WOTEKI  ; LAST UPDATE MAY 1980  ; FROM BYTE, FEB 1981 PG. 106  ; %.MACRO POP %PLA %STA %1 %PLA %STA %1+1 %.ENDM % %.MACRO PUSH %LDA %1+1 %PHA %LDA %1 %PHA %.ENDM % %;GLOBAL EQUATES  PASCAL .EQU;  ; These routines are stored in the  ; system library:  ;  ; POKE(VALUE,ADDRS:INTEGER;  ; PEEK(ADDRS:INTEGER):INTEGER;  ; CALL(ADDRS:INTEGER);  ; DIALIT(NUMBER:STRING);  ; NEWMODEMVALUE(WORD:INTEGER);  ; SNDCHAR;  ; =====================  ; (.PROC DIALIT,1  ;  ;A PROCEDURE TO DIAL THE PHONE USING  ;THE D.C. HAYES MICROMODEM II.  ;  ;THIS ROUTINE IS CALLED BY THE PROCEDURE  ;  ; 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 THE LOBRARY UNIT.  ;  ;===========================================   MODEM .EQU 0C0A5 ASCAL (PLA ;DISCARD 4 BYTES OF (PLA ;FUNCTION BIAS (PLA (PLA (LDA BIOSIN (JSR CONCHECK ( (LDA #00 ;GET CHAR AND PUSH (PHA ;FUNCTION RESULT (LDA DATAIN (PHA ( (JSR VIDOUT ;OUTPUT TO CONSOLE ( (LDA BIOSOUT (PUSH PASCAL (RTS ( ROUTINE  ;OUTPUTS IT TO THE CONSOLE SCREEN AND  ;RETURNS THE VALUE TO THE CALLING PROGRAM  ;AS A FUNCTION RESULT.  ;  ;THIS ROUTINE IS PART OF THE LIBRARY  ;UNIT MICROMODEM  ;  ;--------------------------------------  DATAIN .EQU 0C0A7  (POP P(RTS (  ;=====================================  ; (.FUNC GTCHAR  ;  ;A ROUTINE TO GET ONE CHARACTER FROM  ;THE MICROMODEM DATA INPUT LOCATION  ;DATAIN. THE ROUTINE ASSUMES THE  ;RECEIVER REGISTER IS FULL.  ;  ;AFTER FETCHING THE CHARACTER THE F18  WPTR .EQU 0BF19  CONBUF .EQU 03B1  BUMP .EQU 0D72C  DATAOUT .EQU 0778  OUTA .EQU 0C202 (LDA BIOSIN (JSR CONCHECK (LDX RPTR (CPX WPTR (BEQ HOME (JSR BUMP (STX RPTR (LDA CONBUF,X (STA DATAOUT (JSR OUTA  HOME LDA BIOSOUT (RTS  ;===================================  ; (.PROC SNDCHAR  ;  ;A PROCEDURE TO OUTPUT ONE CHARACTER  ;THROUGH THE MICROMODEM IN SLOT 2.  ;  ;ROUTINE IS CALLED FROM THE UNIT MICROMODEM  ;  ;------------------------------------  RPTR .EQU 0BODEMCOPY .EQU 067A  MODEM .EQU 0C0A5  (POP PASCAL 7;PULL THE VALUE OF THE NEW 7;BITS TO BE SET AND UPDATE 7;MODEM (PLA (ORA MODEMCOPY (STA MODEMCOPY (STA MODEM ( (PLA ;DISCARD MSB OF 8;NEWBITS (PUSH PASCAL ;BACK TO PASCAL  ;ESPECIALLY FOR USE BY THE LIBRARY  ;UNIT - MICROMODEM.  ;  ;THE ROUTINE LOGICALLY ORS ITS ARGUMENT  ;WITH THE CONTENTS OF MODEMCOPY, $067A,  ;SAVES THE RESULT IN MODEMCOPY AND WRITES  ;IT TO MODEM, $C0A5.  ;-----------------------------------  M#01 (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  ;WORD. THIS IS A ROUTINE WRITTEN AIT A 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 SES   PULSE LDA HANGUP ;DIAL THE DIGIT (STA MODEM (LDA #WAIT61 (JSR WAIT (LDA PICKUP (STA MODEM (LDA #WAIT39 (JSR WAIT (DEX (BNE PULSE ( (;WHEN DONE WITH DIGIT (;CHECK TO SEE IF DONE WITH NUMBER ( (CPY LENGTH (BEQ DONE (;IF NOT, W(PLA ;RECOVER DIGIT NUMBER (TAY (LDA @LOCATION,Y ;GET DIGIT AGAIN ( (SEC ;CONVERT DIGIT (SBC #30 ;FROM CHAR FORM (BNE START (LDA #0A ;IN CASE DIGIT IS 0 (  START TAX ;INITIALIZE X TO COUNT PUL #01 ;INITIALIZE TO GET THE FIRST 8;DIGIT 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 DA MODEMCOPY ;INITIALIZE LOCATIONS (AND #7F ;HANGUP AND PICKUP FOR (STA HANGUP ;PROPER DIALING (LDA MODEMCOPY (ORA #80 (STA PICKUP (LDY #00 ;REMEMBER HOW MANY DIGITS (LDA @LOCATION,Y ;IN THE TELEPHONE NUM (STA LENGTH ( (LDY MODEMCOPY .EQU 067A  WAIT61 .EQU 99  WAIT39 .EQU 7A  LOCATION .EQU 02  LENGTH .EQU 04  HANGUP .EQU 06  PICKUP .EQU 07  (POP PASCAL ;SAVE THE PASCAL RETURN 8;ADDRESS (POP LOCATION ;POP THE MEMORY ADDRESS 8;OF THE TELEPHONE NUM (L(.END N^2Bit 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 pickup; #{ Pick]:=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 write #{ Determine last value written to modem } #BEGIN $memory.addrs:=acia; ! modemstatus:=memory.value^[0] ; #END; ! !PROCEDURE initacia; #{ Initialize ACIA } #VAR dummy:INTEGER; #BEGIN $memory.addrs:=acia; $memory.value^[0]:=3; $memory.value^[0BEGIN $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; GIN $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 } #BE$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.addrstmode(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 se; { $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; $FUNCTION{$ PRINTER:}  {$S+} { Swapping required for UNITS }  UNIT MICROMODEM; INTRINSIC CODE 23 DATA 24;  "INTERFACE " $CONST datain = -16217; { $C0A7 } *acia = -16218; { $C0A6 } *modem = -16219; { $C0A5 } *keybde = -16384; { $C000 } *outa = -15870 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; #{ 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 dialiOM 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 ( (LDY #00  XRREAD LDA PRG6,Y (STA RREAD0C202  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 (CPY #03 (BCC XRINIT ( (LDY #00  XIC;===============================  ;  (.PROC SYSGEN  ;  ;-------------------------------  BIOSIN .EQU 0C083  BIOSOUT .EQU 0C08B  CONCHECK .EQU 0D681  ACIA .EQU 0C0A6  DATAOUT .EQU 0778  DATAIN .EQU 0C0A7  MODEM .EQU 0C0A5  OUTA .EQU N^BB#{Fetch the char stored in the modem input location #datain and send it to the screen. Pass the char as #a function result } # !PROCEDURE getchar; #BEGIN $ch:=gtchar; #END; # !BEGIN "setmodem(resetflag); !END. r 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; GIN $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 char from the keyboard, transfeng } #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 word } #BE,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 ;JSR CONCHECK (.BYTE 0AD,0A6,0C0 ;LDA ACIA (.BYTE 29,02 N^RRln ('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 Dr. Wo''s Apple Pascal!'); !writeln ; !writeln ('The system has just been modified to'); !writeln ('enable communications through the'); !writeN^BBDA 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 ;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 ;JSR CONCHECK (.BYTE 0AD,0A6,0C0 ;L(*$LPRINTER:*)  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); hhhhhhHH`"hhhhhhhhHHHH`&hh `hh HH`&hhhhz)z H ׭h80  nz n cƥHH` n`8Hh`91)'II.0 [d.4] POKE "IF carrier #THEN terminal; !UNTIL NOT tryagain; !hangup;  END. :CHAR;  BEGIN !REPEAT "page(output); "gotoxy(0,5); "write('No carrier. Try again? (Y/N)->'); "read(answr); "writeln; "tryagain:=answr IN['Y','y']; !UNTIL answr IN ['Y','N','y','n'];  END;   BEGIN { fullduplex } !REPEAT "dialup; OT carrier )THEN BEGIN /hangup; /unitclear(1); /exit(terminal); .END )ELSE BEGIN /write('#'); /error:=peek(datain); .END #ELSE IF rcvrfull )THEN getchar(ch) )ELSE sendchar; !UNTIL NOT carrier;  END;   FUNCTION tryagain:BOOLEAN;  VAR answrln('Waiting 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 N!writeln; !write(' --> '); !readln(number); !getaciacntl(word); !page(output); !gotoxy(0,5); !write('Preparing to dial, please wait...'); !initacia(word); !pickup; !setmode(originate,high); !writeln('OK');  dial(number); !writeln; !write ODD 1 29'); #writeln; #write('ACIA control word--> '); #readln(word); "UNTIL word IN [1,5,9,13,17,21,25,29]; !END;   BEGIN { dialup } !setmodem(resetflag); !page(output); !gotoxy(0,5); !writeln('Enter the phone number.'); n(' 7 ODD 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 #GOTOXY(0,3); #writeln('Select the ACIA control word:'); #writeln;writeln; #writeln('CHAR PARITY STOP CONTROL'); #writeln('LENGTH BIT BITS WORD '); #writeln('----------------------------'); #writeln(' 7 EVEN 2 1'); #writelhhh zzhHH` ֮ ,׎x ­`*hhhhhh ֩HH ׭HH`,4dFrPOKE POKE PEEK PEEK CALL CALL DIALIT DIALIT NEWMODEM NEWMODEMSNDCHAR SNDCHAR GTCHAR GTCHAR  t MICROMODMICROMOD   8  ُ؂ ǀǸ ȡ & تPצ Dialing...R0 'ɄY?'2z BR DIALIT GTCHAR MD MEMORY NEWMODEM SNDCHAR  Z?Z?Z?Z?  8  ُ؂ ǀǸ ȡ & تPצ Dialing...R0 'ɄY?'2z    .N@v&8v>,?Z?Z?Z?Z?  8  ُ؂ ǀǸ ȡ & تPצ Dialing...R0 'ɄY?'2z [?ǀ6Z?6Z?Z?Z?Z?Z?Z?ROCEDURE hangup; $PROCEDURE setmodem(word:INTEGER); $PROCEDURE sendchar; $PROCEDURE getchar(VAR ch:CHAR);  !IMPLEMENTATION E TION carrier:BOOLEAN; $FUNCTION rcvrfull:BOOLEAN; $FUNCTION transempty:BOOLEAN; $FUNCTION aciaerror:BOOLEAN; $FUNCTION aciastatus:INTEGER;  FUNCTION modemstatus:INTEGER; $ $PROCEDURE initacia(word:INTEGER); $PROCEDURE enabletransmit; $PROCEDURE setmode(md:mode; br:baudrate); $PROCEDURE pickup; $PROCEDURE dial(number:STRING); $PROCEDURE waitforcarrier; $P$TYPE baudrate = (low,high); *mode = (answer,originate); * $VAR md : mode; *br : baudrate; * $FUNCTION ringing:BOOLEAN; $FUNCTION carrier:BOOLEAN; $FUNCTION rcvrfull:BOOLEAN; $FUNCTION transempty:BOOLEAN; $FUNCTION aciaerror:BOOLEAN; $FUN " $CONST datain = -16217; { $C0A7 } *acia = -16218; { $C0A6 } *modem = -16219; { $C0A5 } *keybde = -16384; { $C000 } *outa = -15870; { $C202 } *dataout= 1912; { $0778 } *modemcopy= 1658; { $067A } * *resetflag = 8; *selftest = 16; * """d MICROMODMICROMOD '" " $CONST datain = -16217; { $C0A7 } *acia = -16218; { $C0A6 } *modem = -16219; { $C0A5 } *keybde = -16384; { $C000 } *outa = -15870; { $C202 } *dataout= 1912; { $0778 } *modemcopy= 1658; { $067A } * *resetflag = 8; *selftest = 16; *  * &#Y?L צNo carrier. Try again? (Y/N)->ڳڳ@@~P* צ!Preparing to dial, please wait...*   צOK Waiting for carrier...T צ"Carrier OK. Begin communications. EVEN 1 25 8 ODD 1 29ACIA control word-->  """" צEnter the phone number. -->  7 ODD 2 5 7 EVEN 1 9 7 ODD 1 13 8 NONE 2 17 8 NONE 1 21 8  צSelect the ACIA control word:CHAR PARITY STOP CONTROLLENGTH BIT BITS WORD ---------------------------- 7 EVEN 2 1'X FULLDUPL x ­`*hhhhhh ֩HH ׭HH`,4f*>^P 6H *N<ialing...R0 'ɄY?'2z    hhhhz)z H ׭h80  nz n cƥHH` n`8Hh`91)hhh zzhHH`  ֮ ,׎  8  ُ؂ ǀǸ ȡ & تPצ Dialing...R0 'ɄY?'2z [?ǀ6Z?6Z?Z?Z?Z?Z?Z?ROCEDURE hangup; $PROCEDURE setmodem(word:INTEGER); $PROCEDURE sendchar; $PROCEDURE getchar(VAR ch:CHAR);  !IMPLEMENTATION E TION carrier:BOOLEAN; $FUNCTION rcvrfull:BOOLEAN; $FUNCTION transempty:BOOLEAN; $FUNCTION aciaerror:BOOLEAN; $FUNCTION aciastatus:INTEGER;  FUNCTION modemstatus:INTEGER; $ $PROCEDURE initacia(word:INTEGER); $PROCEDURE enabletransmit; $PROCEDURE setmode(md:mode; br:baudrate); $PROCEDURE pickup; $PROCEDURE dial(number:STRING); $PROCEDURE waitforcarrier; $P$TYPE baudrate = (low,high); *mode = (answer,originate); * $VAR md : mode; *br : baudrate; * $FUNCTION ringing:BOOLEAN; $FUNCTION carrier:BOOLEAN; $FUNCTION rcvrfull:BOOLEAN; $FUNCTION transempty:BOOLEAN; $FUNCTION aciaerror:BOOLEAN; $FUN *,6hhhhhhhhHHHH`&f 6  צOK Waiting for carrier...T צ"Carrier OK. Begin communications. SYSGEN "IF carrier #THEN terminal; !UNTIL NOT tryagain; !hangup;  END. :CHAR;  BEGIN !REPEAT "page(output); "gotoxy(0,5); "write('No carrier. Try again? (Y/N)->'); "read(answr); "writeln; "tryagain:=answr IN['Y','y']; !UNTIL answr IN ['Y','N','y','n'];  END;   BEGIN { fullduplex } !REPEAT "dialup; OT carrier )THEN BEGIN /hangup; /unitclear(1); /exit(terminal); .END )ELSE BEGIN /write('#'); /error:=peek(datain); .END #ELSE IF rcvrfull )THEN getchar(ch) )ELSE sendchar; !UNTIL NOT carrier;  END;   FUNCTION tryagain:BOOLEAN;  VAR answrln('Waiting 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 N!writeln; !write(' --> '); !readln(number); !getaciacntl(word); !page(output); !gotoxy(0,5); !write('Preparing to dial, please wait...'); !initacia(word); !pickup; !setmode(originate,high); !writeln('OK');  dial(number); !writeln; !write using the Filer.G(X[ e k|N]`LשL ֭)x `L] ֭J`|qf[PTEXT#CODE#饀!צ!Welcome to Dr. Wo's Apple Pascal!$The system has just been modified to!enable communications through theצMicromodem II in slot 2.צ$Please set the DATE' STARTUP SYSGEN SYSGEN  X[ e k|N]`LשL ֭)x `L] ֭J`|qf[P'