`L i=L\Ʃx ? N'i  ͭЅ?0ȱ Ѕ?iȱi lԠԠ͠ԠϠŠͮŠ SYSTEM.APPLE   L$JN^ʟ!.TEXT   PLOTTER.CODE #GENEPOOL.TEXT XT  CHAREDIT.CODE  GRAFEDIT.TEXT  GRAFEDIT.CODE  SHOWFOTO.TEXT  SHOWFOTO.CODE SNOWFLAKE.TEXTSNOWFLAKE.CODE TURTLE.TEXT  TURTLE.CODE   PLOTTER_e SKETCH2.TEXT ei GRAPH1.TEXT im GRAPH2.TEXT mq SQUARES.TEXT qu HEXAGONS.TEXT uy GRAFPROC.TEXT y} HEXAGON2.TEXT } STARS.TEXT  DEMOPIC.TEXT  CHAREDIT.TEPGRAPH1 DSPCHRSET.TEXT!  DEFCHARS.TEXT ɡ*CRECHARSET.TEXT*2CRECHARDOC.TEXT28 SERENDIP.TEXT v8B CUBE.TEXT2 EBJ DOODLER.TEXT JS BLIZZARD.CODE S_ PILOT.TEXT &꽌ɪɖ'*&%&,E'зЮ꽌ɪФ`+*xH&x'8*7Ixix&&  ') + &п x) ++`FG8`0($ p,&") (jJJ>L+ "?I>  N `  ` x V Nx .x- z `V0^*^*>` aI꽌ɪVɭ&Y&&Y& 꽌ɪ\8`&PROGRAM READCHARS;   (* $THIS PROGRAM READS THE DATA IN $SYSTEM.CHARSET (USED IN SCREEN $GRAPHIC CHARACTERS) AND DISPLAYS $THEM ON THE SCREEN. $CHARACTERS ARE EXPRESSED BY A $DOT MATRIX SEVEN ACROSS BY EIGHT $DOWN. EACH CHARACTER IS REPRESENTED "BEGIN $IF NOT (CH IN ['W','E','R','S','F','X','C','V','B','D','M']) 'THEN EXIT(MOVE); $DX:=0; DY:=0; $IF CH IN ['D','B','M'] &THEN MODE:=CH & &ELSE (BEGIN *CASE CH OF , ,'W': BEGIN DY:=-1; DX:=-1 END; ,'E': DY:=-1; ,'R': BEGIN DX:=1; DY:=-OP:ARRAY[0..7] OF INTEGER; $ $ $  PROCEDURE PUTCHAR; "BEGIN $BLK:=(CHARID DIV 64); $I1:=BLOCKREAD(G,BUF,1,BLK); $I:=(CHARID MOD 64) * 8; $FOR J:=0 TO 7 DO &BUF[J+I]:=CHR(CHARINT[J]); $I1:=BLOCKWRITE(G,BUF,1,BLK) "END; " "  PROCEDURE MOVE;  PROGRAM DEFCHARS;   CONST X0=10; Y0=10; XM=16; YM=17;   VAR CHARINT:ARRAY[0..7] OF INTEGER; $BLK,I,I1,J,CHARID:INTEGER; $F,G:FILE; $X,Y,DX,DY:INTEGER; $CHARBOOL:ARRAY[0..7,0..6] OF BOOLEAN; $BUF:PACKED ARRAY[0..511] OF CHAR; $CH,MODE:CHAR; $TWVAR N^ɡIN ,READLN(I1); ,I1:=(I1-1)*8 *END; (IF CH='%' THEN EXIT(PROGRAM) (END $END  END. .FOR I2:=8 DOWNTO 1 DO 0BEGIN 2REM:=NUM DIV TWOP[I2]; 2IF REM > 0 THEN CH:='*' 4ELSE CH:='.'; 2NUM:=NUM - (REM*TWOP[I2]); 2S[VERTMAX+1-K,I2]:=CH 0END; .I1:=I1+1; ,END; (FOR K:=1 TO VERTMAX DO *WRITELN(S[K]); (READLN(CH); (IF CH='#' THEN *BEGDO $TWOP[I]:=TWOP[I-1]*2; "RESET(F,'*SYSTEM.CHARSET'); "FOR LOOP:=1 TO 2 DO $BEGIN &I:=BLOCKREAD(F,BUF,1); &PAGE(OUTPUT); &I1:=0; &WHILE I1 <= 511 DO (BEGIN *GOTOXY(0,10); *FOR K:=1 TO VERTMAX DO ,BEGIN .NUM:=ORD(BUF[I1]); "VERTCHAR = 1..VERTMAX;   VAR "BUF:PACKED ARRAY[0..511] OF CHAR; "LOOP,I,I1,I2,K,NUM,REM:INTEGER; "CH,CH1:CHAR; "F:FILE; "S,S1:ARRAY[VERTCHAR] OF PACKED ARRAY[1..8] OF CHAR; "TWOP:ARRAY[1..8] OF INTEGER; "  BEGIN "TWOP[1]:=1; "FOR I:=2 TO 8 $BY EIGHT BYTES, EACH OF WHICH CON- $TAINS A ROW (I.E. SEVEN BITS) OF $DATA. OF EACH GROUP OF EIGHT BYTES $THE LEFT-HAND BYTE REPRESENTS THE $BOTTOM ROW AND THE RIGHTMOST BIT $REPRESENTS THE LEFTMOST DOT. $  *)   CONST "VERTMAX = 8;   TYPE 1 END; ,'S': DX:=-1; ,'F': DX:=1; ,'X': BEGIN DX:=-1; DY:=1 END; ,'C': DY:=1; ,'V': BEGIN DX:=1; DY:=1 END; , ,END; (* CASE *) * *CASE MODE OF * ,'D': BEGIN 3CHARBOOL[Y-Y0,X-X0]:=TRUE; 3WRITE('+') 3END; 3 ,'B': BEGIN 3CHARBOOL[Y-Y0,X-X0]:=FALSE; 3WRITE('.') 3END; 3 ) END; (* CASE MODE *) - +X:=X+DX; Y:=Y+DY; +IF XXM THEN X:=XM; +IF YYM THEN Y:=YM; + +GOTOXY(X,Y) (END "END; " " "BEGIN (* MAIN *)  *)  (* 8TH COLUMN OF CHARACTER *)  (* CAN NOT BE SET. *)  (* BYTE SET TO 127 WILL TURN ON *)  (* ALL BITS IN A ROW. *)  (* BITS ARE REVERSED BECAUSE THE *)  (* CHARACTER SET IS CONSIDERED)  (* CHARACTERS ARE 8 BYTES EACH. *)  (* 1ST BYTE IS ON BOTTOM ROW. *)  (* 8TH BYTE IS ON TOP ROW. *)  (* BITS ARE REVERSED. *)  (* 1 SETS 7TH COLUMN. *)  (* 64 SETS 1ST COLUMN.  (**************************************)  (* PROGRAM TO CREATE A NEW FILE *)  (* TO REPLACE SYSTEM.CHARSET. *)  (**************************************)  (* AUTHOR: DAVID NEUMANN *)  (**************************************BEG 1 2YN^6(END; &PUTCHAR $UNTIL CH='%'; $CLOSE(G,LOCK) "END. AT (GOTOXY(X0,YM+3); (WRITE('CHAR NUMBER (DEC, 0-127) = '); (READLN(CHARID) &UNTIL (CHARID >=-1) AND (CHARID <= 127); & &FOR I:=0 TO 7 DO (BEGIN *CHARINT[I]:=0; *FOR J:=0 TO 6 DO ,IF CHARBOOL[7-I,J]=TRUE .THEN CHARINT[I]:=CHARINT[I]+TWOP[J] (OUTPUT); &FOR I:=Y0 TO YM DO (BEGIN *GOTOXY(X0,I); *WRITE('.......') (END; &MODE:='M'; &X:=X0; Y:=Y0; GOTOXY(X,Y); &FOR I:=0 TO 7 DO *FOR J:=0 TO 6 DO ,CHARBOOL[I,J]:=FALSE; &REPEAT (READ(KEYBOARD,CH); (MOVE &UNTIL CH IN ['*','%']; & &REPE$PAGE(OUTPUT); $RESET(F,'#4:SYSTEM.CHARSET'); $REWRITE(G,'#5:NEW.CHARSET'); $FOR I:=1 TO 2 DO &BEGIN (I1:=BLOCKREAD(F,BUF,1); (I1:=BLOCKWRITE(G,BUF,1) &END; $CLOSE(F,LOCK); $TWOP[0]:=1; $FOR I:=1 TO 7 DO &TWOP[I]:=TWOP[I-1]*2; & $REPEAT &PAGE *)  (* A BOOLEAN ARRAY. BOOLEAN ARRAY*)  (* ELEMENTS ARE NUMBERED FROM THE*)  (* LEFT OF A WORD. *)  (* EACH CHARACTER IS AN 8 X 8 *)  (* BOOLEAN ARRAY. *)  (**************************************)  (* THE WHOLE CHARACTER SET CAN *)  (* NOT BE READ INTO A 128 X 8 X 8*)  (* BOOLEAN ARRAY BECAUSE ARRAY *)  (* ELEMENTS ARE NOT PACKED ACROSS*)  (* WORD BOUNDARIES. THE 3RD DIM. *MIN:INTEGER;  XPAT,YPAT,CX,CY:INTEGER; $I:INTEGER; $DIR:CHAR;  BEGIN  REPEAT "IF MIXEDSET[CHINDX].CHANGED $THEN &BEGIN ((* START ON NEW PATTERN *) (XPAT := NEWPATX; (YPAT := NEWPATY; &END $ELSE &BEGIN ((* START ON OLD PATTERN *) (XPAT :OCEDURE CLEAR(LNG:INTEGER);  VAR $SAVEX,SAVEY:INTEGER; $I:INTEGER;  BEGIN  SAVEX := TURTLEX;  SAVEY := TURTLEY;  FOR I:=1 TO LNG DO "WCHAR(' ');  MOVETO(SAVEX,SAVEY);  END;   PROCEDURE UPDATE(CHINDX:INTEGER);  VAR $XLOC,YLOC,XMAX,YMAX,XMIN,Y$POWEROFTWO := 1; $FOR COL:=0 TO 6 DO &BEGIN ((* CHANGE FROM BOOLEAN TO INTEGER *) (IF MIXEDSET[CHINDX].NEWCHAR[ROW,COL] *THEN ,TEMP := TEMP + POWEROFTWO; (POWEROFTWO := POWEROFTWO * 2; &END;  NEWSET[CHINDX,ROW] := TEMP; "END;  END;   PRN *) &DRAWBLOCK(NEWSET[CHINDX],1,0,0,8,8,NEWX,NEWY,10); &DRAWPAT(CH.NEWCHAR,NEWPATX,NEWPATY);  END;  END;  PROCEDURE FORMCHAR(CHINDX:INTEGER);  VAR $ROW,COL,TEMP,POWEROFTWO:INTEGER;  BEGIN  FOR ROW:=0 TO 7 DO "BEGIN $TEMP := 0; (THEN WCHAR('1') (ELSE WCHAR('0'); "END;  END;   BEGIN  (* DRAW OLD CHARACTER AND PATTERN *)  DRAWBLOCK(OLDSET[CHINDX],1,0,0,8,8,OLDX,OLDY,10);  DRAWPAT(CH.OLDCHAR,OLDPATX,OLDPATY);  IF CH.CHANGED "THEN $BEGIN &(* DRAW NEW CHARACTER AND PATTERAR(CHINDX:INTEGER; CH:MIXEDTYPE);   PROCEDURE DRAWPAT(CH:TYPECHAR;PATX,PATY:INTEGER);  VAR $J,K:INTEGER;  BEGIN  (* DRAW 7X6 PATTERN OF 1'S AND 0'S *)  FOR J:= 0 TO 7 DO "BEGIN $MOVETO(PATX,PATY+DOTSVERT*J); $FOR K:= 0 TO 6 DO " IF CH[J,K] ,MIXEDSET[I].NEWCHAR[J,K] := ODD(TEMP); ,TEMP := TEMP DIV 2; *END;  END; "END;  INITTURTLE;  END;   PROCEDURE READANDECHO(VAR ANS:CHAR);  BEGIN  READ(KEYBOARD,ANS);  IF ORD(ANS) <> ESC "THEN $WCHAR(ANS);  END;   PROCEDURE DISPLAYCHS NOT BEEN CHANGED *) $MIXEDSET[I].CHANGED := FALSE; $FOR J:=0 TO 7 DO &BEGIN (TEMP := OLDSET[I,J]; (FOR K:=0 TO 6 DO *BEGIN ,(* OLDCHAR AND NEWCHAR SAME AS OLDSET *) ,MIXEDSET[I].OLDCHAR[J,K] := ODD(TEMP);  (* READ SYSTEM.CHARSET INTO OLDSET *)  I := BLOCKREAD(INFILE,OLDSET,2);  NEWSET := OLDSET;  PAGE(OUTPUT);  WRITE('INITIALIZING CHARACTER ');  (* INITIALIZE MIXEDSET *)  FOR I:=BEGCH TO ENDCH DO "BEGIN $GOTOXY(23,0); $WRITE(I); $(* CHARACTER HABYTE;  NEWSET:PACKED ARRAY[0..127,0..7] OF BYTE; $MIXEDSET:PACKED ARRAY[0..127] OF MIXEDTYPE; $INFILE,OUTFILE:FILE;   PROCEDURE INITIALIZE;  VAR $I,J,K,TEMP:INTEGER;  BEGIN  RESET(INFILE,'*:SYSTEM.CHARSET');  REWRITE(OUTFILE,'*:NEWCHARSET');%TYPECHAR = PACKED ARRAY[0..7,0..6] OF BOOLEAN;  MIXEDTYPE = RECORD 3CHANGED: BOOLEAN; 3OLDCHAR: TYPECHAR; 3NEWCHAR: TYPECHAR; 1END;  VAR  CHARPOS:INTEGER; $ANS:CHAR;  LI:INTEGER[3]; $S:STRING; $OLDSET:PACKED ARRAY[0..127,0..7] OF 90;  NEWPATX = 140; (NEWPATY = 90;  TYPE BYTE = 0..255;   (* TYPECHAR WAS CHANGED FROM BYTE TO $BOOLEAN BECAUSE THERE APPARENTLY $IS NOT ENOUGH DATA SPACE WHEN $MIXEDSET IS BYTE. *) S*)  (**************************************)  PROGRAM CRECHARSET;  USES TURTLEGRAPHICS;  CONST (ESC = 27; (DOTSHORZ = 7; (DOTSVERT = 10; (BEGCH = 0; (ENDCH = 127; (OLDX = 20; (OLDY = 125; (NEWX = 208; (NEWY = 125; (OLDPATX = 60; (OLDPATY = )  (* OF THIS PACKED BOOLEAN ARRAY *)  (* IS PUT ON A WORD BOUNDARY, AND*)  (* THIS MAKES EACH ROW TWO BYTES *)  (* WIDE. A BYTE OF DATA AND A *)  (* BYTE OF HOLE. THE FILE WITH *)  (* THE CHARACTER SET HAS NO HOLE= OLDPATX; (YPAT := OLDPATY; &END; "(* CHARACTERS ARE 7 BITS WIDE *) "(* PATTERNS ARE 7 CHARACTERS WIDE *) "XMAX := XPAT + 6 * DOTSHORZ; "(* VERTICAL DISTANCE BETWEEN CHARACTERS IS 10 BITS *) "YMAX := YPAT + DOTSVERT * DOTSHORZ; "XMIN := XPAT; "YMIN := YPAT; "MOVETO(20,30); "CLEAR(38); "WSTRING('O(NES Z(EROES S(INGLE R(ESTORE '); "READANDECHO(ANS); "(* GET TYPE OF CHANGE *) "CASE ANS OF $'O' : BEGIN ,MIXEDSET[CHINDX].CHANGED := TRUE; ,FOR CY:=0 TO 7 DO .FOR CX:=0 TO 6 DO 0MIXEDUST CONVERT DIGITS INSTEAD OF READING AN INTEGER *) ,CHARPOS := 0; ,READANDECHO(ANS); ,WHILE (NOT EOLN(KEYBOARD)) AND (ANS IN ['0'..'9']) DO .BEGIN 0CHARPOS := 10 * CHARPOS + (ORD(ANS) - ORD('0')); 0READANDECHO(ANS); ,END; ,IF CHARPOS < BEGCH .THEPOS < BEGCH .THEN CHARPOS := BEGCH; *END; $'F' : BEGIN ,CHARPOS := CHARPOS + 1; ,IF CHARPOS > ENDCH .THEN CHARPOS := ENDCH; *END; $'P' : BEGIN ,MOVETO(20,10); ,CLEAR(40); ,WSTRING('POSITION WHERE? '); ,(* WANT TO ECHO NUMBERS TYPED *) ,(* SO M UPDATE(CHARPOS); "MOVETO(20,10);  CLEAR(40); "WSTRING('F(RWRD B(CKWRD P(OSITION J(UMP '); "READANDECHO(ANS); "(* GET MOVEMENT INDICATOR WITHIN CHARACTER SET *) "CASE ANS OF $'B' : BEGIN  CHARPOS := CHARPOS - 1; ,IF CHAR TO LONG INTEGER, THEN STRING *) "(* IN ORDER TO DISPLAY INTEGER IN GRAPHICS MODE *) "LI := CHARPOS; "STR(LI,S); "WSTRING(S); "MOVETO(20,10); "CLEAR(40); "WSTRING('DO YOU WANT TO CHANGE (Y/N)?'); "READANDECHO(ANS); "IF ANS = 'Y' $THEN OF OUTER CASE *)  UNTIL (ORD(ANS) = ESC);  MOVETO(20,30);  CLEAR(38);  END;  BEGIN  INITIALIZE;  CHARPOS := BEGCH;  REPEAT "FILLSCREEN(BLACK); "DISPLAYCHAR(CHARPOS,MIXEDSET[CHARPOS]); "MOVETO(20,40); "CLEAR(9); "WSTRING('INDEX='); "(* CONVERTCHAR := MIXEDSET[CHINDX].OLDCHAR; ,(* CLEAR PORTION OF SCREEN THAT CONTAINED NEW CHARACTER *) ,VIEWPORT(NEWPATX,279,NEWPATY,191); ,FILLSCREEN(BLACK); ,VIEWPORT(0,279,0,191); ,FORMCHAR(CHINDX); ,DISPLAYCHAR(CHINDX,MIXEDSET[CHINDX]); *END; "END; (* ,MIXEDSET[CHINDX].CHANGED := TRUE; ,FORMCHAR(CHINDX); ,CHARTYPE(10); * DISPLAYCHAR(CHINDX,MIXEDSET[CHINDX]); ,MOVETO(20,40); ,CLEAR(32); *END; " 'R' : BEGIN ,(* RESTORE OLD CHARACTER *) ,MIXEDSET[CHINDX].CHANGED := FALSE; ,MIXEDSET[CHINDX].NEW,MOVETO(XLOC,YLOC); ,WCHAR(' '); ,MOVETO(XLOC,YLOC); ,UNTIL (ORD(DIR) = ESC); ,XPAT := NEWPATX; ,YPAT := NEWPATY; ,XMAX := XPAT + 6 * DOTSHORZ; ,YMAX := YPAT + DOTSVERT * DOTSHORZ; ,XMIN := XPAT; ,YMIN := YPAT; COMPLEMENT CHARACTER TO ERASE CURSOR *) :CHARTYPE(5); :WCHAR(DIR); :CHARTYPE(3); :MOVETO(XLOC,YLOC); 8END; ,END; (* OF INNER CASE *) ,(* DRAW NEW CHARACTER *) ,DRAWBLOCK(NEWSET[CHINDX],1,0,0,8,8,NEWX,NEWY,10); ,WCHAR(' '); ,(* DISPLAY CURSOR *) X 8THEN XLOC := XMAX; 4END; .(* 0 AND 1 CHANGE PATTERN *) .'0','1' : BEGIN :MIXEDSET[CHINDX].CHANGED := TRUE; :CY := (YLOC-YPAT) DIV DOTSVERT; :CX := (XLOC-XPAT) DIV DOTSHORZ; :MIXEDSET[CHINDX].NEWCHAR[CY,CX] := DIR = '1'; :FORMCHAR(CHINDX); :(* 8THEN YLOC := YMAX; 4END; .'M' : BEGIN 6YLOC := YLOC - DOTSVERT; 6IF YLOC < YMIN 8THEN YLOC := YMIN; 4END; .'J' : BEGIN 6XLOC := XLOC - DOTSHORZ; 6IF XLOC < XMIN 8THEN XLOC := XMIN; 4END; .'K' : BEGIN 6XLOC := XLOC + DOTSHORZ; 6IF XLOC > XMARTYPE(3); ,WCHAR(' '); ,MOVETO(XPAT,YPAT); ,XLOC := XPAT; ,YLOC := YPAT; ,REPEAT ,READ(KEYBOARD,DIR); ,(* CHECK DIRECTION OF MOVE *) ,(* CHECK FOR LIMITS OF PATTERN *) ,CASE DIR OF .'I' : BEGIN 6YLOC := YLOC + DOTSVERT; 6IF YLOC > YMAX ); * DISPLAYCHAR(CHINDX,MIXEDSET[CHINDX]); *END; $'S' : BEGIN ,MOVETO(20,40); ,WSTRING('I=UP J=LEFT K=RIGHT M=DOWN '); ,(* MOVE TO LOWER LEFT CORNER OF PATTERN *) ,(* DRAW INVERSE CHARACTER TO SHOW CURSOR POSITION *) ,MOVETO(XPAT,YPAT); ,CHASET[CHINDX].NEWCHAR[CY,CX] := TRUE; ,FORMCHAR(CHINDX); * DISPLAYCHAR(CHINDX,MIXEDSET[CHINDX]); *END; $'Z' : BEGIN ,MIXEDSET[CHINDX].CHANGED := TRUE; ,FOR CY:=0 TO 7 DO .FOR CX:=0 TO 6 DO 0MIXEDSET[CHINDX].NEWCHAR[CY,CX] := FALSE; ,FORMCHAR(CHINDXN CHARPOS := BEGCH; ,IF CHARPOS > ENDCH .THEN CHARPOS := ENDCH;  END; $'J' : BEGIN $ MOVETO(20,10); ,CLEAR(40); ,WSTRING('JUMP WHERE (B/E) ?'); ,READANDECHO(ANS); ,IF ANS = 'B' .THEN CHARPOS := BEGCH .ELSE 0IF ANS = 'E' 2THEN CHARPOS := ENDCH; *END; "END; (* OF CASE *)  UNTIL ORD(ANS) = ESC;  TEXTMODE;  (* WRITE NEW CHARACTER SET FILE *)  CHARPOS := BLOCKWRITE(OUTFILE,NEWSET,2);  CLOSE(OUTFILE,LOCK);  GOTOXY(0,10);  WRITELN('FILE NEWCHARSET HAS BEEN CREATED.'); of  single bit changes. The character and  pattern for both the old and new  character are displayed. %If you respond N for no to the  change the character prompt, you are  asked which character to look at next  by the following prompt: !F(RWRD the cursor on the pattern. When  the cursor is on the bit you want to  change, hit a 1 or 0 to turn the bit on  or off. Changes made to the pattern  will be reflected in the new character  which is also displayed.  % - this ends the the cycle%S - this means that you want to  change single bits of the new  character. The cursor is then moved  onto the pattern of the character and a  new prompt line is displayed:  I=UP J=LEFT K=RIGHT M=DOWN %Type in the appropriate letter to  movese options mean:  %O - the new character will be all  1's or a solid white block  %Z - the new character will be all  0's or a solid black block %R - the new character is restored  to the value of the old character  ed pattern  of 1's and 0's that represents this  character. You are then asked:  !DO YOU WANT TO CHANGE (Y/N)?  %If you respond Y for yes, you are  then asked what type of change you want  to make:  !O(NES Z(EROES S(INGLE R(ESTORE %Theed  with WCHAR and WSTRING.  %It takes some time to initialize  the characters, so the index of the  character being initialized is  displayed to let you know the program  is running. %The program then displays the  first character and an expandNOTES ON USING CRECHARSET  %The program CRECHARSET allows you  to modify the characters which are  displayed by the graphics procedures  WCHAR and WSTRING. The program creates  the file *NEWCHARSET which must be  renamed to *SYSTEM.CHARSET to be us(^  WRITELN('RENAME TO SYSTEM.CHARSET TO USE');  WRITELN('WITH WCHAR AND WSTRING PROCEDURES.');  END.  B(CKWRD P(OSITION J(UMP  %This allows you to:  %F - move forward one character  %B - move backward one charcter  %J - jump to the beginning or end  of the character set  %P - position yourself at any  character in the character set. This  number is in the range 0 to 127. A  return, space or non-digit will end the  number.  % - this ends the program. A  file named *NEWCHARSET has been  created. To use it with WCHAR and  WSTRING, change *SZE ORIGIN *) (X:= RANDOM MOD 50; (Y:= RANDOM MOD 50 " END "UNTIL ORD(CH)=27; "TEXTMODE; "WRITELN('BACK TO PASCAL')  END.  & MID; &MAKEDOT(A,B); &MAKEDOT(XMAX-A,B); &MAKEDOT(XMAX-A,YMAX-B); &MAKEDOT(A,YMAX-B) $UNTIL KEYPRESS; $READ(KEYBOARD,CH); $IF CH IN ['1'..'9'] THEN &BEGIN (* NEW PICTURE *) (FILLSCREEN(BLACK); (K:=ORD(CH)-ORD('0') &END $ELSE $ BEGIN (* RANDOMI"INITTURTLE; "FRAME(WHITE); "X:=21; Y:=13; "REPEAT $REPEAT &X:=X-Y/V[K]; &IF X<1 THEN X:=X+XMAX ELSE IF X>XMAX THEN X:=X-XMAX; &Y:=Y+X/W[K]; &IF Y>YMAX THEN Y:=Y-YMAX ELSE IF Y<1 THEN Y:=Y+YMAX; &A:=TRUNC(X) DIV 2 + XMID; &B:=TRUNC(Y) DIV 2 + YSTOP'); "FOR A:=1 TO 2000 DO; "V[1]:=3; W[1]:=1.5; "V[2]:=2; W[2]:=2.1; "V[3]:=0.5; W[3]:=1.1; "V[4]:=2; W[4]:=4; "V[5]:=1; W[5]:=2; "V[6]:=0.9; W[6]:=3; "V[7]:=7; W[7]:=8; "V[8]:=-2; W[8]:=-2; "V[9]:=8; W[9]:=-8; "K:=1;  BEGIN "PENCOLOR(NONE); "MOVETO(X,Y); "PENCOLOR(WHITE); "MOVE(1);  END;   BEGIN (*MAIN*) "RANDOMIZE; "WRITELN('HIT SPACE TO RANDOMIZE'); "FOR A:=1 TO 1000 DO; "WRITELN('HIT DIGIT FOR NEW PATTERN'); "FOR A:=1 TO 1000 DO; "WRITELN('HIT ESC TO TEGER; (CH:CHAR;   PROCEDURE FRAME(COLOR:SCREENCOLOR);  BEGIN "PENCOLOR(NONE);MOVETO(0,0); "PENCOLOR(COLOR); "MOVETO(0,YMAX);MOVETO(XMAX,YMAX); "MOVETO(XMAX,0);MOVETO(0,0); "VIEWPORT(2,XMAX-2,2,YMAX-2)  END;   PROCEDURE MAKEDOT(X,Y:INTEGER); PROGRAM SERENDIP;  USES TURTLEGRAPHICS,APPLESTUFF;   CONST XMAX=279; (YMAX=191; (XMID=140; (YMID=96;  (* TO BE SAFE, MAKE THIS A COMMENT WHICH QUICKLY BECOMES INVISIBLE*)   VAR X,Y:REAL; (V,W:ARRAY [1..9] OF REAL; (A,B:INTEGER; (K:INN^VvYSTEM.CHARSET to some  other name and change *NEWCHARSET to  *SYSTEM.CHARSET N^5EE LINES(VAR PIC: PICTURE);  VAR L: POINT; E: EDGE;  BEGIN L:=1; "WITH PIC DO $BEGIN M:=0; &FOR E:=1 TO 12 DO IF E IN VIS THEN (WITH ED[E] DO *BEGIN ,IF (L<>HERE) OR (M=0) THEN .BEGIN 0M:=M+1; 0MV[M].DRAW:=FALSE; 0MV[M].PX:=SP[HERE].SX; 0MV[M].S:=VIS+[1,2,3,4] "ELSE IF -M11>=VLIM THEN VIS:=VIS+[5,6,7,8]; "IF M21>=VLIM THEN VIS:=VIS+[3,7,11,12] "ELSE IF -M21>=VLIM THEN VIS:=VIS+[1,5,9,10]; "IF M31>=VLIM THEN VIS:=VIS+[2,6,10,11] "ELSE IF -M31>=VLIM THEN VIS:=VIS+[4,8,9,12]  END;  PROCEDUR END;   PROCEDURE PROJECT;  VAR I: POINT;  BEGIN "FOR I:=1 TO 8 DO WITH P[I] DO $BEGIN &SP[I].SX:=TRUNC(Y*XSF/(DIST-X))+XMID; &SP[I].SY:=TRUNC(Z*YSF/(DIST-X))+YMID; $END  END;   PROCEDURE VISIBILITY;  BEGIN "VIS:=[]; "IF M11>=VLIM THEN VI:=-P[2].Z; "P[3].X:=M11+M21+M31; P[5].X:=-P[3].X; "P[3].Y:=M12+M22+M32; P[5].Y:=-P[3].Y; "P[3].Z:=M13+M23+M33; P[5].Z:=-P[3].Z; "P[4].X:=M11+M21-M31; P[6].X:=-P[4].X; "P[4].Y:=M12+M22-M32; P[6].Y:=-P[4].Y; "P[4].Z:=M13+M23-M33; P[6].Z:=-P[4].Z; PROCEDURE POINTS;  BEGIN "P[1].X:=M11-M21-M31; P[7].X:=-P[1].X; "P[1].Y:=M12-M22-M32; P[7].Y:=-P[1].Y; "P[1].Z:=M13-M23-M33; P[7].Z:=-P[1].Z; "P[2].X:=M11-M21+M31; P[8].X:=-P[2].X; "P[2].Y:=M12-M22+M32; P[8].Y:=-P[2].Y; "P[2].Z:=M13-M23+M33; P[8].ZIN "SA:=SIN(A); SB:=SIN(B); SC:= SIN(C); "CA:=COS(A); CB:=COS(B); CC:= COS(C); "T1:=SB*CC; T2:=SB*SC; "M11:=CB*CC; M21:=CB*SC; M31:=-SB; "M12:=SA*T1-CA*SC; "M22:=CA*CC+SA*T2; M32:=SA*CB; "M13:=SA*SC+CA*T1; "M23:=CA*T2-SA*CC; M33:=CA*CB;  END;  "ED[8].HERE:=8; ED[8].THERE:=5; "ED[9].HERE:=1; ED[9].THERE:=5; "ED[10].HERE:=2; ED[10].THERE:=6; "ED[11].HERE:=3; ED[11].THERE:=7; "ED[12].HERE:=4; ED[12].THERE:=8;  END;   PROCEDURE MATRIX(A,B,C: REAL);  VAR T1,T2,SA,CA,SB,CB,SC,CC: REAL;  BEGBEGIN "ED[1].HERE:=1; ED[1].THERE:=2; "ED[2].HERE:=2; ED[2].THERE:=3; "ED[3].HERE:=3; ED[3].THERE:=4; "ED[4].HERE:=4; ED[4].THERE:=1; "ED[5].HERE:=5; ED[5].THERE:=6; "ED[6].HERE:=6; ED[6].THERE:=7; "ED[7].HERE:=7; ED[7].THERE:=8; ICTURE; (P: ARRAY [POINT] OF COORD; (ED: ARRAY [EDGE] OF ENDS; (SP: ARRAY [POINT] OF SCOORD; (VIS: SET OF EDGE; (AD,BD,CD: INTEGER; (VLIM,DTOR,XSF,YSF: REAL;  M11,M12,M13,M21,M22,M23,M31,M32,M33: REAL; (CH: CHAR; (  PROCEDURE INITCUBE;  OORD = RECORD X,Y,Z: REAL END; (ENDS = RECORD HERE,THERE: POINT END; (SCOORD = RECORD SX,SY: INTEGER END; (PENMOVE = RECORD PX,PY: INTEGER; DRAW: BOOLEAN END; (PICTURE = RECORD M: INTEGER; MV: ARRAY [1..18] OF PENMOVE END;   VAR NEWPIC,OLDPIC: P(*$S+*) (* ENABLE SWAPPING *)   PROGRAM CUBE;   USES TURTLEGRAPHICS, TRANSCEND, APPLESTUFF;   CONST XMAX = 279; (YMAX = 191; (XMID = 140; (YMID = 96; (PI = 3.145926; (DIST = 6.0; (SF = 0.6; (  TYPE POINT = 1..8; (EDGE = 1..12; (CPY:=SP[HERE].SY; .END; ,M:=M+1; ,MV[M].DRAW:=TRUE; ,MV[M].PX:=SP[THERE].SX; ,MV[M].PY:=SP[THERE].SY; ,L:=THERE *END $END  END;   PROCEDURE DRAWCUBE(VAR PIC:PICTURE; C:SCREENCOLOR);  VAR I: INTEGER;  BEGIN "WITH PIC DO $BEGIN &FOR I:=1 TO M DO (WITH MV[I] DO *BEGIN ,IF DRAW THEN .PENCOLOR(C) ,ELSE .PENCOLOR(NONE); ,MOVETO(PX,PY) *END $END  END;   PROCEDURE COPYPIC(VAR NP,OP: PICTURE);  VAR I: INTEGER;  BEGIN "FOR I:=1 TO NP.M DO $BEGIN &OP.MV[I].PX:=NP.MV[I] &B:= (B+C) MOD 256; &Z:= SINTAB[ A*B MOD 256 ] + 127; &IF I=2 THEN PENCOLOR(RANDCOLOR); &MOVETO(Z*SINTAB[ (B+64) MOD 256 ] DIV XADJ + XMID, -Z*SINTAB[B] DIV YADJ + YMID) $END; "FOR I:=1 TO DELAY DO $FOR C:=1 TO DELAY DO;  END;   BEGIN (* DOODLBLACK); "A:=RANDOM MOD 127 + 1; "C:=RANDOM MOD 255 + 1; "PENCOLOR(NONE);MOVETO(4,4);PENCOLOR(WHITE);WINT(C); "PENCOLOR(NONE);MOVETO(4,12);PENCOLOR(WHITE);WINT(A); "PENCOLOR(NONE); "IF ODD(A) THEN B:=0 ELSE B:=64; "FOR I:=1 TO LOOPEND(C) DO " BEGIN FUNCTION LOOPEND(INC:INTEGER):INTEGER;  VAR LOOP:INTEGER;  BEGIN "LOOP:=256; "WHILE NOT ODD(INC) DO "BEGIN $INC:=INC DIV 2; $LOOP:=LOOP DIV 2 "END; "LOOPEND:=LOOP+1  END;   PROCEDURE RANDFIGURE;  VAR A,C,I,Z:INTEGER;  BEGIN "FILLSCREEN(   FUNCTION RANDCOLOR:SCREENCOLOR;  BEGIN "IF COLORFUL THEN $RANDCOLOR:=COLORS[RANDOM MOD 6]  ELSE RANDCOLOR:=WHITE  END;   PROCEDURE WINT(N:INTEGER);  VAR D:INTEGER[8]; %S:STRING;  BEGIN "D:=N;STR(D,S);WSTRING(S)  END;  ND;   PROCEDURE INITSINTAB;  VAR F:REAL; %I:INTEGER;  BEGIN "F:=PI/128; "FOR I:=0 TO 255 DO SINTAB[I]:=TRUNC(SIN(F*I)*128)  END;   PROCEDURE THATSALL;  VAR CH:CHAR;  BEGIN "TEXTMODE; "READ(KEYBOARD,CH); "WRITELN;WRITELN('BYE...')  END;] OF INTEGER; (COLORFUL:BOOLEAN; (CH:CHAR; (B:INTEGER;   PROCEDURE FRAME(COLOR:SCREENCOLOR);  BEGIN "PENCOLOR(NONE);MOVETO(0,0); "PENCOLOR(COLOR); "MOVETO(0,YMAX);MOVETO(XMAX,YMAX); "MOVETO(XMAX,0);MOVETO(0,0); "VIEWPORT(1,XMAX-1,1,YMAX-1);  E(*$s+*)  PROGRAM DOODLER;   USES TURTLEGRAPHICS,TRANSCEND,APPLESTUFF;   CONST XMAX=279; (YMAX=191; (XMID=140; (YMID=96; (XADJ=260; (YADJ=350; (PI=3.1415936; (DELAY=40;   VAR COLORS:ARRAY[0..5] OF SCREENCOLOR; (SINTAB:ARRAY[0..255N^U BD:=0; CD:=0; "INITTURTLE; "REPEAT $ROTATE(AD*DTOR,BD*DTOR,CD*DTOR); " AD:=(AD+2) MOD 360; $BD:=(BD+5) MOD 360; $CD:=(CD+10) MOD 360 "UNTIL KEYPRESS; "READ(KEYBOARD,CH); "TEXTMODE;WRITELN('BYE...')  END. "DRAWCUBE(NEWPIC,WHITE1);  END;   BEGIN (* CUBE *) "VLIM:=1/DIST; "YSF:=SF*YMID*(DIST-1); "XSF:=YSF*0.75*XMID/YMID; "DTOR:=PI/180; "INITCUBE; "WITH NEWPIC DO $BEGIN M:=1; &MV[M].PX:=XMID; &MV[M].PY:=YMID; &MV[M].DRAW:=FALSE $END; "AD:=0;.PX; &OP.MV[I].PY:=NP.MV[I].PY; &OP.MV[I].DRAW:=NP.MV[I].DRAW $END; "OP.M:=NP.M  END;   PROCEDURE ROTATE(A,B,C: REAL);  BEGIN "COPYPIC(NEWPIC,OLDPIC); "MATRIX(A,B,C); "POINTS; "PROJECT; "VISIBILITY; "LINES(NEWPIC); "DRAWCUBE(OLDPIC,BLACK1);ER *) "WRITE('WOULD YOU LIKE RANDOM COLORS ? '); "READ(CH);COLORFUL:=(CH = 'Y');WRITELN; "WRITELN('PRESS ANY KEY TO QUIT.'); "WRITELN('PLEASE WAIT FOR FIRST FIGURE.'); "INITSINTAB; "INITTURTLE; "FRAME(WHITE); "RANDOMIZE; "COLORS[0]:=WHITE; "COLORS[1]:=GREEN; "COLORS[2]:=VIOLET; "COLORS[3]:=ORANGE; "COLORS[4]:=BLUE; "COLORS[5]:=REVERSE; "REPEAT RANDFIGURE UNTIL KEYPRESS; "THATSALL  END.  o G F ũiM   ! iˍiA*  A0i      B%o  Ɖ  á^?,,HH,,,,# % %ȡI " !!"#š "!  V0N _š á š# % %ȡI " !!"#š "!  š ȡ $ $$0 ˡ$ "     N68:<>@BDFHJLNPRTVXZ\^`bdfhjlnprtvxz|~ &0  ءء68:<>@BDFHJLNPRTVXZ\^`bdfhjlnprtvxz|~   "$&(*,.0240?.ؿ 000   "$&(*,.024"p* PATTERNS  H ]?г   ȡR% , A ÚH  H    ,  % Ao šok,  ÍA  Í؍@H oٓ؍UH H H oAT |mki`h>ȡ!B"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:='A' TO 'Z' DO $BEGIN &WRITE(O,C,':=0;',C,'S:='''';'); S,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;'); "WRITELN(O,'PROCEDURE MATCH(S:STRING); VAR X,Y:STRING;'); 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(O,'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); "WRITELN('ERROR: ',MESSAGE); "WRITELN('TYPE ANYTHING TO CONTINUE'); "READLN(ZZZ); "BADSYNTAX:=TRUE  END;   PROCEDURE SKIP;  BEGIN "WHILE I^=' ' DO GET(I)  END;   PROCEDURE TRANSLATE;   PROCEDURE HEADING;  BEGIN "WRITELN(O,'PROGRAM ',(* L+*)  PROGRAM PILOT;  CONST "APOSTROPHE=''''; "EL=10;  VAR "BADSYNTAX:BOOLEAN; "ZZZ, "WS, "NAME:STRING; "I,O:TEXT; "VARIABLES,DIGITS,LETTERS:SET OF CHAR; "C:CHAR; "J:INTEGER; "  PROCEDURE ERROR(MESSAGE:STRING);  BEGIN "WRITELN(WN^hb Doran pqij0`m`; -Qá`Pá 0 c& * d  &<Tl* Granny Smith presents:צ' R E C U R S I V E B L I Z Z A R D' R E C U R S I V E B L I Z Z A R Dצ by צ Bo (after 6th flake)צ צPress any key to continue  ~ For your visual delectation, GrannyKdKuKdK@ (This program produces snowflakes using a$recursive algorithm with variations chosen at random.צPress Q at any time to Quit i?hj  ȡ   hɄ  ȡ]hńš ގ ȡš  h*0 NhKudK&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 $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(''',',WS,I) *ELSE INSERT(',''',WS,I); *I:=I+1; B:=NOT(B) *END; &I:=N^ ""WRITE('TRANSLATE WHAT FILE?'); "READLN(NAME); "RESET(I,CONCAT(NAME,'.TEXT')); "REWRITE(O,CONCAT(NAME,'.P.TEXT')); "WRITE('START TRANSLATE'); "TRANSLATE; "IF BADSYNTAX THEN $CLOSE(O,PURGE) "ELSE $CLOSE(O,LOCK)  END. ' ELN('*:',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; %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; #WRITABLE 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%'X': WRITELN(O,'FLAG:=',COPY(WS,3,LENGTH(WS)-2),';'); %'A': IF LENGTH(WS)>4 THEN ERROR('ASK STATEMENT 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('VARIF 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)); E 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),''');'); *END; %'J': BEGIN % IH(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 (ERROR('ILLEGAL COMMAND') &ELSE CAS$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 FLAG THEN ') &ELSE WRITE(O,'IF NOT FLAG THEN '); &WS:=COPY(WS,2,LENGTH(WS)-1) $END; "IF LENGTI+1 $END; "WRITELN(O,'(''',COPY(WS,3,LENGTH(WS)-2),''');'); "IF NOT B THEN ERROR('UNMATCHED @')  END;  PROCEDURE LINE;  VAR "J:INTEGER;  BEGIN "SKIP; "IF I^ IN DIGITS THEN $BEGIN READ(I,C); WRITE(O,C,':'); (* PSUP-BOWLES PAGE 25/26 *)   PROGRAM GRAPH1;  USES TURTLEGRAPHICS;  BEGIN "INITTURTLE; "PENCOLOR (WHITE); "MOVE(100); "TURN(120); "MOVE(100); "TURN(120); "MOVE(100); "READLN; "TEXTMODE; "  END. N^SIN (*MAIN PROGRAM*);  "COPYWRITE; "INSTRUCTIONS; "INITTURTLE; "PENCOLOR(NONE); "SKETCH; "PAGE(OUTPUT); "TEXTMODE; "  END.  ONE; $'W': PCOLOR:=WHITE; $'B': PCOLOR:=BLACK; $'G': PCOLOR:=GREEN; $'V': PCOLOR:=VIOLET; $'O': PCOLOR:=ORANGE; $'T': PCOLOR:=BLUE; $'F': FILLSCREEN(REVERSE); $'C': FILLSCREEN(BLACK); $'Q': EXIT(SKETCH); $ "END; "  GOTO 1;   END;   BEGL 1;   VAR  "CH: CHAR;  "  BEGIN   1:  "WHILE NOT KEYPRESS DO BEGIN $ $X:= PADDLE(0); $FOR DELAY:=1 TO 100 DO;  Y:= PADDLE(1); $PENCOLOR(PCOLOR); $MOVETO(X,Y); $CURSOR; $ "END; " "READ(CH); " "CASE CH OF " $'N': PCOLOR:=N  PROCEDURE CURSOR;   VAR "J,I: INTEGER; "  BEGIN  "FOR J:=0 TO 1 DO BEGIN " FOR I:=0 TO 3 DO BEGIN $ PENCOLOR(REVERSE); &TURN(90); $ MOVE(10); $ PENCOLOR(NONE); &MOVETO(X,Y); " END; "END;   END;   PROCEDURE SKETCH;   LABE' T: TURQUOISE'); "WRITELN; WRITELN(' F: FILLS THE SCREEN WITH REVERSE'); "WRITELN; WRITELN(' C: CLEARS THE SCREEN TO BLACK'); "WRITELN; WRITELN(' Q: QUIT, ENDS THE ETCH-A-SKETCH'); "WRITELN; WRITELN('HIT RETURN TO BEGIN'); "READLN; "  END;  SIMULATE AN ETCH-A-'); "WRITELN('SKETCH.'); WRITELN; "WRITELN('TO CHANGE THE PCOLOR TYPE:'); "WRITELN(' N: NONE'); "WRITELN(' W: WHITE'); "WRITELN(' B: BLACK'); "WRITELN(' G: GREEN'); "WRITELN(' V: VIOLET'); "WRITELN(' O: ORANGE'); "WRITELN(SKETCH'); "GOTOXY(13,10); "WRITELN('BY ROGER SOLES');  FOR DELAY:=1 TO 5000 DO;   END;   PROCEDURE INSTRUCTIONS;   BEGIN  "PAGE(OUTPUT); "WRITELN('PASCAL ETCH-A-SKETCH -- BY ROGER SOLES'); WRITELN; WRITELN; "WRITELN('THIS PROGRAM WILL PROGRAM ETCH;   USES TURTLEGRAPHICS, APPLESTUFF;   (*$G+,C PASCAL ETCH-A-SKETCH BY ROGER SOLES*)   VAR "X,Y,DELAY: INTEGER;  PCOLOR: SCREENCOLOR; "  PROCEDURE COPYWRITE;   BEGIN  "PAGE(OUTPUT); "GOTOXY(10,7); "WRITELN('PASCAL ETCH-A-(* PSUP-BOWLES CHAPTER 2, PAGE 51. *)   PROGRAM SQUARES;  USES TURTLEGRAPHICS; "  PROCEDURE ONESQUARE; "BEGIN $PENCOLOR(WHITE); $MOVE(50); $TURN(90); $MOVE(50); $TURN(90); $MOVE(50); $TURN(90); $MOVE(50); $TURN(90); $PENCOLOR(NONE); "ENN^50); "TURN(144); "MOVE(150); "TURN(144); "MOVE(150); "TURN(144); "MOVE(150); "TURN(144); "MOVE(75); "READLN; "TEXTMODE; "  END. URN(90); "MOVE(50); "READLN; "INITTURTLE; "PENCOLOR(WHITE); "MOVE(100); "TURN(180); "MOVE(200); "TURN(180); "MOVE(100); "TURN(90); "MOVE(100); "TURN(180); "MOVE(200); "READLN; "INITTURTLE; "PENCOLOR(WHITE); "MOVE(75); "TURN(144); "MOVE(1(* PSUP-BOWLES EXERCISE 1.2 PAGE 29 *)   PROGRAM GRAPH2;  USES TURTLEGRAPHICS;  BEGIN "INITTURTLE; "PENCOLOR(NONE); "MOVE(50); "TURN(90); "PENCOLOR(WHITE); "MOVE(50); "TURN(90); "MOVE(100); "TURN(90); "MOVE(100); "TURN(90); "MOVE(100); "TN^SD; $ !BEGIN #INITTURTLE; #MOVETO(200,95); #ONESQUARE; #MOVETO(95,110); #TURN(45); #ONESQUARE; #MOVETO(50,35); #TURN(20); #ONESQUARE; #MOVETO(175,10); #TURN(-45); #ONESQUARE; #READLN; #TEXTMODE;   END. (* PSUP-BOWLES PAGE 59 *)   PROGRAM GRAFPROCS; "USES TURTLEGRAPHICS;   PROCEDURE TRIANGLE(SIZE:INTEGER);  BEGIN $PENCOLOR (WHITE); $MOVE(SIZE); $TURN(120); $MOVE(SIZE); $TURN(120); $MOVE(SIZE); $TURN(120); $PENCOLOR(NONE); "END;   PRON^"TEXTMODE;  END. IANGLE; $TURN(60); $TRIANGLE; $TURN(60); $TRIANGLE; $TURN(60); $TRIANGLE; $TURN(60); $TRIANGLE; $TURN(60); $TRIANGLE; "END;  BEGIN "INITTURTTLE; "MOVETO(160,40); "HEXAGON; "MOVETO(230,130); "HEXAGON; "MOVETO(50,95); "HEXAGON; "READLN; (* PSUP-BOWLES EXERCISE 2.1 PAGE 57 *)   PROGRAM HEXAGONS; "USES TURTLEGRAPHICS;  PROCEDURE TRIANGLE; "BEGIN $PENCOLOR (WHITE); $MOVE(30); $TURN(120); $MOVE(30); $TURN(120); $MOVE(30); $PENCOLOR (NONE); "END;  PROCEDURE HEXAGON; "BEGIN $TRN^SCEDURE SQUARE(SIZE:INTEGER); "BEGIN $PENCOLOR(WHITE); $MOVE(SIZE); $TURN(90); $MOVE(SIZE); $TURN(90); $MOVE(SIZE); $TURN(90); $MOVE(SIZE); $TURN(90); $PENCOLOR(NONE); "END; "  BEGIN "INITTURTLE; "MOVETO(225,125); "TRIANGLE(50); "TURN(120); "TRIANGLE(75); "TURN(120); "TRIANGLE(25); "MOVETO(0,0); "TURNTO(0); "SQUARE(100); "MOVETO(190,20); "TURN(30); "SQUARE(50); "READLN; "TEXTMODE; "  END. (* PSUP-BOWLES PAGE 65 *)   PROGRAM STARS; "USES TURTLEGRAPHICS; "VAR SCALE:INTEGER; "  PROCEDURE STAR(SIZE:INTEGER); "BEGIN $TURN(-18); $PENCOLOR(WHITE); $MOVE(SIZE); $TURN(144); $MOVE(SIZE); $TURN(144); $MOVE(SIZE); $TURN(144); $MOVE(SIZN^(230,130); "HEXAGON(50,95); "READLN; "TEXTMODE;  END. AGON(X,Y:INTEGER); "BEGIN $MOVETO(X,Y); $TRIANGLE(20); $TURN(60); $TRIANGLE(25); $TURN(60); $TRIANGLE(30); $TURN(60); $TRIANGLE(35); $TURN(60); $TRIANGLE(40); $TURN(60); $TRIANGLE(45); "END;  BEGIN "INITTURTTLE; "HEXAGON(160,40); "HEXAGON(* PSUP-BOWLES EXERCISE 2.2 PAGE 63 *)   PROGRAM GRAPH5; "USES TURTLEGRAPHICS;  PROCEDURE TRIANGLE(SIZE:INTEGER); "BEGIN $PENCOLOR (WHITE); $MOVE(SIZE); $TURN(120); $MOVE(SIZE); $TURN(120); $MOVE(SIZE); $PENCOLOR (NONE); "END;  PROCEDURE HEXN^SE); $TURN(144); $MOVE(SIZE); $TURN(144); $PENCOLOR(NONE); $TURN(18); "END; "  BEGIN "SCALE:=10; "INITTURTLE; "PENCOLOR(WHITE); "TURN(45); "MOVE(SCALE*8); "STAR(SCALE*4); "MOVETO(139,95); "TURNTO(165); "PENCOLOR(WHITE); "MOVE(SCALE*4); "STAR(SCALE*8); "MOVETO(139,95); "TURN(150); "PENCOLOR(WHITE); "MOVE(SCALE*6); "STAR(SCALE*6); "READLN; "TEXTMODE; "  END.  BEGINDECENDDEC ENDMAIN BEGINMAIBEGINGETENDGET BEGINDISENDDIS GETSTARTGETEND /"/!0 0O^1E(F,CHEAT.PTRPART^,16);  CLOSE(F,LOCK);  END; $  BEGIN (* MAIN PROGRAM *)  INITTURTLE;  DRAWPICS;  BSAVE(':DEMO.PIC');  FILLSCREEN(BLACK);  BLOAD(':DEMO.PIC');  REPEAT UNTIL KEYPRESS;  TEXTMODE;  END.  T.INTPART := HIRESP1;  RESET(F,FILENAME);  IO := BLOCKREAD(F,CHEAT.PTRPART^,16);  CLOSE(F,LOCK);  END;   PROCEDURE BSAVE(FILENAME : STRING);  VAR IO : INTEGER; $F : FILE;  BEGIN  CHEAT.INTPART := HIRESP1;  REWRITE(F,FILENAME);  IO := BLOCKWRITETO(0,0); PENCOLOR(NONE);  MOVETO(75,95); WSTRING(' THIS IS A TEST ');  MOVETO(28,5); WSTRING('');  END;   PROCEDURE BLOAD(FILENAME : STRING);  VAR IO : INTEGER; $F : FILE;  BEGIN  CHEA$CH : CHAR; ,  PROCEDURE DRAWPICS; (* THIS CAN BE REPLACED WITH ANY GRAPHICS ROUTINE *)  BEGIN  MOVETO(0,0); PENCOLOR(WHITE);  MOVETO(279,0); TURN(90);  MOVETO(279,191); TURN(90);  MOVETO(0,191); TURN(90);  MOVINSON *)  (* *)  USES TURTLEGRAPHICS, APPLESTUFF;  CONST HIRESP1 = 8192;  VAR CHEAT : RECORD CASE BOOLEAN OF ,TRUE : (INTPART : INTEGER); ,FALSE : (PTRPART : ^INTEGER);  END; o the volume  directory. *)   (* *)  (* PROGRAM LOADS AND SAVES HIRES SCREEN TO DISK *)  (* APPLE COMPUTER 12/79 BY JO & CHARLIE KELLNER *)  (* BASED ON "SLIDE SHOW" BY BILL ATKdis-  played.   The "USES TURTLEGRAPHICS" statement  allocates space for the hi-res screen,  and should be referenced even if Turtle-  graphics are not actually used. Note  that the "CLOSE (F,LOCK)" closes the file  and places it permanently int PROGRAM DEMOPIC; (* PASCAL HI-RES LOAD/SAVE TO DISK *)   (* This program was copied from The  International Apple Cores APNOTE G12 *)   (* This demo program Creates a hi-res  picture in PASCAL, then saves it to  disk. It is then relocated and N^x# index: 0..numchars; &xscreen: 0..xmax; {position for next blockwrite} &yscreen: 0..ymax; {ditto} &col: 0..maxcols; &row: 0..maxrows; &tempstr: string; {used for wstring function} &ch: char; {for printode = 10; {write over screen contents} &maxcols = 10;maxrows = 13; {display format for 80-col screen} &spacex = 20;spacey = 12; {spacing for blockwrite on screen} &xstart = 35; {space past indexes} #var #end; {put_charset} {to get it fixed w/o losing everything.} # #Procedure Display; #const &xmax = 279;ymax = 167; &rowsize = 1; {for blockwrite} &xskip = 0;yskip = 0; {ditto} &width = 7;height = 8; {ditto} &mn begin )writeln(chr(7),'I/O error # ',temp); )exit(putcharset) &end;  {$i-} close(workfile,lock); {$i+}  temp:=ioresult; &if temp=0 then exit(program); {we're through - quit} &write(chr(7),'I/O error # ',temp) {don't crap out on error - try} )outname := 'apple2:system.charset'; &if outname = '$' then outname := inname; & &workfile^ := character;  {$i-} {don't croak on error} &rewrite(workfile,outname); &put(workfile);  {$i+} temp := ioresult; {save ioresult to print} &if temp <> 0 theset} # # # #Procedure Put_charset; #var temp:integer; #begin &writeln; &write('Enter filename ( escapes, ''*'', ''$'') :'); &readln(outname); &if length(outname)=0 then exit(putcharset); &if outname = '*' then w figure out what happened} & &if ioresult <> 0 then begin )getcharset := false; )writeln('File not found.'); &end &else begin )getcharset := true; )character := workfile^; {move all 128 chars from buffer} &end; &close(workfile); #end; {get_char); &if length(inname) = 0 then exit(program); {abort on null} &if inname = '*' then inname := 'apple2:system.charset'; {default}   {$i-} {turn off error check so prog can do it} &reset(workfile,inname); {recall 'reset' also does a 'get'}  {$i+} {no#c: char; #foundfile: boolean; #clearline, #escape: char; # #(* has_silent: boolean; {if you've got one} *) # # # #Function Get_charset: boolean; #begin &write('File to edit ( quits, ''*'' defaults) :'); &readln(innamerray [0..numchars] of charimage; #charfile = file of charset;  Var #character: charset; {this is the 128 characters to be munched} #workfile: charfile; {SYSTEM.CHARSET or similar} #outname: string; {file names} #inname: string; write to your input file. }   Uses turtlegraphics,smarterm (* ,silentype *);  Const #numchars = 127; #clr_line = 29; #esc = 27; { }  Type #charimage = packed array[0..7] of 0..255; {treat as byte array, unpack later} #charset = packed aft anyway. See READ.ME.TEXT for notes on the smarterm unit. }  {When started it will ask for the file to edit. '*' defaults to }  {Apple2:System.Charset -- change as necessary. On exit, '*' writes }  {to that same default file, while '$' will Program Charedit;   {This program edits the SYSTEM.CHARSET, or similar file from any disk.}  {It does not do the 'half-dot shift' that the Pascal Animation editor }  {can do, but the standard turtlegraphics drawing routines do not show }  {this shi question} &i: integer; # #begin {long routine so it can nicely display characters} &initturtle; &seehires; &for col := 0 to maxcols - 1 do begin {write columns across screen} )moveto(xstart+spacex*col,ymax+16); )str(col,tempstr); )wstring(tempstr) &end; &for row := 0 to maxrows - 1 do begin {neatly write row # on screen} )str(row*10,tempstr); )moveto(21-7*length(tempstr),ymax-spacey*row); )tempstr:=concat(tempstr,':'); )wstring(tempstr) &end; &for index := 0 to numchars do begin )row := i7end; 7row := 7;col := 0 {reset cursor} 4end; / /27 {escape}: showchar(index); {redraw figure before exit} / /3 {etx}: begin {recode bytes} 4for row := 7 downto 0 do begin 7word := 0; 7ctr := 1; 7for col := 0 to 6 do begin :if newchar[row,col]/ /75,107 {k}:if col < 6 then col := col + 1; / /77,109 {m}:if row > 0 then row := row - 1; / /90,122 {zero}:begin 4for row := 7 downto 0 do 7for col := 0 to 6 do begin :newchar[row,col] := false; :gotoxy(startx+2*col,starty-row); :write('.') ; ,case ord(ch) of /32 {space}:begin 4newchar[row,col] := false; 4write('.') 1end; 1 /83,115 {set}:begin 4newchar[row,col] := true; 4write('*') 1end; 1 /73,105 {i}:if row < 7 then row := row + 1; / /74,106 {j}:if col > 0 then col := col - 1; or in the upper left} )gotoxy(0,0); )write('Change: clears, S(et, [i,j,k,m move],'); )write(' Z(ero, accepts, aborts.',clearline); )cursoron; {make sure cursor is visible} )repeat ,gotoxy(startx+2*col,starty-row); ,read(keyboard,ch))write('Edit which ASCII code: ',clearline); )index := getnum(index); )showchar(index) &end; {newcode} % % % &Procedure Change(var index: integer); &var )ch: char; )col,row: integer; )ctr: integer; &begin )row := 7; )col := 0; {position cursf changed and (new_value <= maxsize) ,then getnum := new_value ,else getnum := old_value {don't change if or illegal value} &end; {getnum} ! & & &Procedure Newcode(var index: integer); &begin )gotoxy(0,2); egin )new_value := 0; )changed := false; )read(ch); )while ch in ['0'..'9'] do begin {exit on non-digit} ,new_value := new_value*10 + ord(ch) - ord('0'); ,changed := true; {remember we've read in at least one good digit} ,read(ch) )end; {while} )i )end; {row} )cursoron &end; {showchar} & & & &Function Getnum(old_value: integer): integer; &{get digits from keyboard - return previous value if only} &const )maxsize=numchars; &var )new_value:integer; )changed:boolean; )ch:char; &b,for col := 0 to 6 do begin /bit := word mod 2; {decode left-most 7 bits} /word := word div 2; /if (bit = 1) then begin 2write('* '); 2newchar[row,col] := true /end /else begin 2write('. '); 2newchar[row,col] := false /end {test bit} ,end {col} &begin )cursoroff; {don't have irritating display} )gotoxy(22,2); {write over previous ASCII code} )write(clearline,index); )for row := 7 downto 0 do begin ,gotoxy(startx,starty-row); ,word := character[index,row]; {get each byte of char} eger; &word: 0..255; &c: char; &newchar: charmask; &index: 0..numchars; ! &Procedure Showchar(var index: integer); {draw an expanded view of} &var {a new character. } )word: 0..255; )bit,row,col: integer;to menu [edit or main]} #end; {display} # # # #Procedure Edit; #const &starty = 12; {bottom of enlarged char map} &startx = 33; {left boundary of char map} #type &charmask = array[0..7,0..7] of boolean; {enlarged char map} #var &i,bit,line: int&if has_silent then begin )moveto(0,0); )wstring('Would you like to print this file? :'); read(ch); )if ch='y' then begin ,setnegative; ,printpic )end {begin print} &end; {has_printer routine}  *) & &read(ch); &seetext; &exit(display) {return ndex div maxcols; )col := index - row * maxcols; )xscreen := spacex*col+xstart; {char pos. on screen} )yscreen := ymax - spacey*row; )drawblock(character[index],rowsize,xskip,yskip, ,width,height,xscreen,yscreen,mode) &end; {for}   (* then word := word + ctr; :ctr := ctr*2 7end; 7character[index,row]:=word 4end; 4ch:=escape {force exit} 1end , ,end {case} )until ch = escape &end; {change} * # # #begin {edit} &index := 0; {char # 0 first} &page(output); {clear field} &newcode(index); &repeat {until hit} )cursoroff; {don't have an irritating display} )gotoxy(0,0); {home, don't clear screen} )write('Edit: C(hange, A(dvance, P(revious, N(ew, '); )write('D(isplay, exits:',clearline); )cursoron; )read(c)ȡ+ ܂𩅃zy  "$&(*,.0468:t>@BDFHJLNPRTVXZ\^`bdfhjlnprtvxz|~xp!ۏ ڕٹ.*ɡšɡšġ?ȡ-!ۏ ڕ.خġ_ ݂0Ȅ: RצEdit which ASCII code: خHצ*Change: clears, S(et, [i,j,k,m move],צ$ Z(ero, accepts, aborts./`  ġ! ەȡ[á!צ* . p  ݳ 6   11ȡ%#ۏǧP    11ȡG P ǧ ܏22P2צ:Q2P11ȡF  ۏ#ǧ ܏ǧ , '*', '$') :/P/á/*/צapple2:system.charsetP/$/XP/"ˡ8 I/O error #  "á I/O error # Ͷ*File to edit ( quits, '*' defaults) :XPXáX*Xצapple2:system.charsetPX"ˡ(File not found. *Enter filename ( escapesB1@*P CHAREDIT ge(output); &write('Charedit: E(dit, D(isplay all, Q(uit:',clearline); &read(c); &case c of )'e','E': edit; )'d','D': display; )'q','Q': quit; &end {case}; #until false {infinite repeat}  end. {main} quit}; B    begin {main} #clearline := chr(clr_line); escape := chr(esc); #while not get_charset do ; {get_charset doesn't loop - for some reason!} # #(* has_silent := hasprinter; {check if silentype present} *) # #repeat {infinite repeat} &pae the character set,'); )writeln(' E(xit without saving,'); )writeln(' R(eturn to Charedit.'); )read(keyboard,ch); )case ch of ,'e','E': exit(program); ,'r','R': exit(quit); ,'s','S': put_charset; )end {case} &end {infinite repeat} #end {/end; {previous} , ,'n','N':newcode(index); , ,'d','D':display; ) )end {case}; &until c=escape; #end; {edit}  #Procedure Quit; #var ch: char; #begin &page(output); &while true do begin )gotoxy(0,0); )writeln('Quit:'); )writeln(' S(av; )case c of ,'c','C':change(index); , ,'a','A':begin 2if index < numchars then index := index + 1; 2gotoxy(22,2); 2showchar(index) /end; {advance} , ,'p','P':begin 2if index > 0 then index := index - 1; 2gotoxy(22,2); 2showchar(index) ~٩áL s^  F F*Edit: C(hange, A(dvance, P(revious, N(ew, D(isplay, exits:ܹDF Fɡ FFFFš FFFqFkgAp`EO +I"$&(*,.02468:<>@DQJLNPRTVXZk^ܩá2 P Quit:צ S(waits for you to type a letter for the color: }  {k - black (sorry) }  {w - white }  {g - green one of the buttons. The }  {program beeps to confirm, and then waits for you to do the same at }  {a second point. }  { }  {Fill  {Several of the options (box, circle, viewport) require two points }  {on the figure (for circle, the center and a point on the edge; for }  {box and viewport, two diagonal corners). This is done by moving }  {the cursor to that point and pushing copy of hi-res screen 1) that may be very rapidly }  {displayed with 'Showfoto'. }  { } r) which provide a }  {very compact way to store pictures, as well as allowing the }  {drawing to be edited by deleting the most recent instruction. }  {If desired (for speed) the picture may also be saved as a foto- }  {file (a 16-blocks they produce are incompatible. }  { }  {Hit '?' for instructions at any time. Drawings are always saved }  {as graffiles (instructions for the graphic edito Program Graphic_Editor;   {A program to help you design figures with straight lines and }  {circles using the game paddles or joystick. The format is similar }  {to the Pilot Graphics Editor, but is not identical, and the }  {graffileSTART PSTART PEND 78O^ 1"(V~": v   R(eturn to Charedit.عp jfEs^ ,( "$&(*,.02468:<>@XDFHJLNPRTVXZlh6 H / צ%Charedit: E(dit, D(isplay all, Q(uit: lh dDq\ & "$&(*,.02468:<>@PVFHJLNPRTVXZfave the character set, E(xit without saving, R(eturn to Charedit.عp jfEs^ ,( "$&(*,.02468:<>@XDFHJLNPRTVXZl }  {v - violet }  {o - orange }  {b - blue }  {r - reverse. }  {It then moves straight down from the cursor's position as far as }  {possible and starts drawing horizontal lines of your chosen color }  {until it hits a line directly above tfor i := 1 to len do /s := concat(s,copy(alphabet,command[cmd_ctr+i],1)); ,cmd_ctr := cmd_ctr + len )end; &pencolor(none); &moveto(anchor.x,anchor.y); &wstring(s); &cmd := 't' #end; {writestring} # # #Procedure Disk; {handle in and out here} #cth(s); 2put_cmd(len); 2for i := 1 to len do 5command[cmd_ctr+i] := 5pos(copy(s,i,1),alphabet); 2cmd_ctr := cmd_ctr + len; 2command[0] := cmd_ctr /end; ,seehires )end )else begin {playback mode} ,adv_cmd; ,len := command[cmd_ctr]; ,s := ''; ,,seetext; ,writeln; ,writeln('String to be shown : '); ,readln(s); ,if (cmd_ctr + length(s) + 1) > max_cmd /then begin 2Writeln('Command buffer overflow. String cannot be saved.'); 2rem_cmd; rem_cmd; rem_cmd /end , else begin / len := leng&read(cmd); &cmd := 't'; &seehires #end;    Procedure Writestring; #var &s: string; &len,i: integer; #begin &if playback then adv_cmd; &readpaddles(anchor); &if not playback )then begin ,put_cmd(write_cmd); ,put_point(anchor); pressing button #1 draws a white'); &write('line, button #0 draws a black line.'); &writeln(' Hit ''q'' to resume track mode.'); &writeln; writeln('Hit to quit program.'); &writeln; writeln('Hit a key to continue...'); &repeat until keypress; teln('T(rack paddles (default).'); &writeln('V(iewport - give two opposite corners.'); &writeln('W(rite string at cursor point.'); &writeln('X - erase the last command.'); &writeln; &write('Pressing the buttons starts Rubberband mode - '); &writeln('&writeln('C(ircle - give center and point on rim.'); &writeln('D(isk get or put.'); &writeln('E(rase in viewport.'); &writeln('F(ill with color.'); &writeln('G(rid in viewport.'); #(* writeln('P(rint screen.'); *) &writeln('R(eset viewport.'); &wri# #Procedure Menu; #begin &page(output); &seetext; &writeln('Pascal Graphic Editor 1.2'); &writeln;writeln; &writeln('Available Commands:'); &writeln; &writeln('B(ox - give two opposite corners.'); forward; #Procedure Adv_cmd; forward; #Procedure Read_paddles(var here: point); forward; #Procedure Re_run; forward; #Procedure Get_point(var here: point); forward;  Procedure Big_cursor(here: point); forward; #Procedure Call_Procs; forward; # al; #i: integer; #anchor,point_1,point_2,ul,lr: point; #cmd: char; #command: command_type; #cmd_ctr: 0..max_cmd; #play_back: boolean; # # #Procedure Put_point(here: point); forward; #Procedure Put_cmd(word: integer); forward; #Procedure Rem_cmd;#write_cmd = -8; rubber_cmd = -9; # #pi = 3.1415926; #num_sides = 60;  Type #point = record x,y: integer end; #command_type = array[0..max_cmd] of integer;   var #alphabet: string[120]; #x_min,x_max,y_min,y_max: integer; #x_scale,y_scale: red - it is for work lines } #{only. Command[0] stores the # of commands entered. } #max_cmd = 1000; #box_cmd = -1; circle_cmd = -2; fill_cmd = -3; #empty_cmd = -5; reset_cmd = -6; view_cmd = -7; Const #x_val = 250; y_val = 240; #scrn_x_max = 279; scrn_y_max = 191; # #{These are the values stored in command to repesent the various } #{options. Most have several numbers stored following. Note that } #{'grid' is not here as it is NOT storehe initial point. }  { }  { by Norris Preyer, McCallie School, Chattanooga, Tn. 37404 }   Uses applestuff,smarterm,turtlegraphics,transcend (* ,silentype *);  onst &hires_start = 8192; &hires_length = 8192; #type # byte = 0..255; &screen = packed array [1..hires_length] of byte; &hook = record ,case boolean of ,true : (ptr : ^screen); ,false: (addr: integer) ,end; #var &graffile : file of command_type; &filename : string; &ch : char; &input : boolean; &result : integer; &foo : hook; &num : integer; &do_foto : boolean; &fotofile : file; &i:integer; & &Procedure Bad_io; &begin )seetext; )close(graffile); )w(anchor); /put_point(point_2); /pencolor(none); /moveto(anchor.x,anchor.y); /if button0 then pencolor(black) else pencolor(white); /if button0 then put_cmd(0) else put_cmd(1); /moveto(point_2.x,point_2.y); /pencolor(none); /anchor := point_2 ,end do begin /pencolor(none); /moveto(anchor.x,anchor.y); /pencolor(reverse); /moveto(point_2.x,point_2.y); /big_cursor(point_2) ,end; ,pencolor(none); ,if (button(0)) or (button(1)) then begin /button0 := button(0); /put_cmd(rubber_cmd); /put_point)moveto(right,height); )pencolor(none); )height := height + 1 &until (height > ymax) #end {fill}; # # #Procedure Rubber_band; #var &i:integer; &button0:boolean; #begin &if not playback )then repeat ,read_paddles(point_2); ,for i := 1 to 2 or.x - 1; )repeat {find right-most point} ,right := right + 1 )until screenbit(right,height) or (right > xmax); )if right > xmax then exit(fill); )if left = right then exit(fill); {at top} ) )moveto(left,height); )pencolor(color); (fill); &height := height + 1; &pencolor(none); & &repeat )left := anchor.x + 1; )repeat {find left-most point at this level} ,left := left - 1 )until screenbit(left,height) or (left < x_min); )if left < x_min then exit(fill); ) )right := anchfor i := 1 to command[cmd_ctr] do color := succ(color); ,adv_cmd; ,get_point(anchor) )end; & &height := anchor.y + 1; &repeat {find bottom} )height := height - 1 &until screenbit(anchor.x,height) or (height < y_min); &if height < y_min then exit/'v','V' : color := violet; /'o','O' : color := orange; /'b','B' : color := blue; /'r','R' : color := reverse ,end; ,put_cmd(ord(color)); ,read_paddles(anchor); ,put_point(anchor) )end )else begin {in playback mode} ,adv_cmd; ,color := none; ,)then begin ,put_cmd(fill_cmd); ,cmd := 't'; ,repeat /read(ch) ,until ch in ['k','K','w','W','g','G','v','V', 9'o','O','b','B','r','R']; ,case ch of /'k','K' : color := black; /'w','W' : color := white; /'g','G' : color := green; then bad_io; )close(foto_file,lock); )result := ioresult; )if result <> 0 then bad_io &end; {foto} #seehires; #{$i+} #end; {disk} # # #Procedure Fill; #var &left,right,height:integer; &ch:char; &color:screencolor; #begin &if not playback 1,length(filename)-5); )filename := concat(filename,'.foto'); )rewrite(foto_file,filename); )result := ioresult; )if result <> 0 then bad_io; )foo.addr := hires_start; )num := blockwrite(foto_file,foo.ptr^,16); )result := ioresult; )if result <> 0 ,seehires; ,get(graffile); ,command := graffile^; ,re_run )end )else begin ,graffile^ := command; ,put(graffile); ,close(graffile,lock) )end; &result := ioresult; &if result <> 0 then bad_io; &if do_foto then begin )filename := copy(filename,riteln;write('File name : ');readln(filename); &filename := concat(filename,'.graf'); &{$i-} &if input )then reset(graffile,filename) )else rewrite(graffile,filename); &result := ioresult; &if result <> 0 then bad_io; &if input )then begin &read(ch); &writeln; &if not (ch in ['g','G','s','S']) then begin )seehires; )exit(disk) &end; &input := (ch = 'g') or (ch = 'G'); &if not input then begin )write('F(oto file?'); )read(ch); )writeln; )do_foto := (ch='y') or (ch='Y') &end; &writeln('I/O error #',result); )writeln;writeln('Press a key to continue...'); )read(cmd); )seehires; )cmd := 't'; )exit(disk) &end; & #begin {disk} # seetext; &cmd := 't'; &writeln;writeln; &write('Do you want to G(et or S(ave a picture ? ');)until keypress {not playback} )else begin {in playback mode} ,adv_cmd; ,get_point(anchor); ,adv_cmd; ,get_point(point_2); ,pencolor(none); ,moveto(anchor.x,anchor.y); ,adv_cmd; ,if command[cmd_ctr] = 0 /then pencolor(black) /else pencolor(white); ,moveto(point_2.x,point_2.y); ,pencolor(none); ,anchor := point_2 )end; &if keypress then read(cmd); {throw away char} &cmd := 't' {resume track mode} #end; {rubber_band} # # #Procedure Put_cmd{word: integer}; #begin &ifint_2.y)); &pencolor(none); &moveto(point_1.x+round(r),point_1.y); &for i := 1 to num_sides do begin )angle := 2 * pi * i / num_sides; )circle_point.x := round(point_1.x + r * cos(angle)); )circle_point.y := round(point_1.y + r * sin(angle)); )pencoe:real; &circle_point:point; &i:integer; #begin &if not playback then put_cmd(circle_cmd) else adv_cmd; &read_twice; &if not playback then begin )put_point(point_1); )put_point(point_2) &end; &r := sqrt(sqr(point_1.x-point_2.x) + sqr(point_1.y-po&moveto(ul.x,lr.y); &pencolor(white); &moveto(ul.x,ul.y); &moveto(lr.x,ul.y); &moveto(lr.x,lr.y); &moveto(ul.x,lr.y); &pencolor(none); &cmd := 't'; &for i := 1 to 100 do ; {delay for paddle} #end; {box} ) # # #Procedure Circle; #var &r,anglpoint_1.y; ,ul.y := point_2.y )end; #end; {get_rect} # # # #Procedure Box; #var i: integer; #begin &if not playback then put_cmd(box_cmd) else adv_cmd; &if not get_rect then begin )rem_cmd; )exit(box) &end; &pencolor(none); hich corner do we have?} )then begin ,ul.x := point_1.x; ,lr.x := point_2.x )end )else begin ,lr.x := point_1.x; ,ul.x := point_2.x )end; &if point_1.y > point_2.y )then begin ,ul.y := point_1.y; ,lr.y := point_2.y )end )else begin ,lr.y := ctangle?} &or (point_1.y = point_2.y) )then begin ,note(30,30); ,cmd := 't'; ,get_rect := false; ,exit(get_rect) )end; &get_rect := true; &if not playback then begin )put_point(point_1); )put_point(point_2) &end; &if point_1.x < point_2.x {w,read_paddles(point_1); ,note(20,20); ,repeat track until button(0) or button(1); ,read_paddles(point_2); ,note(20,20) )end #end; {read_twice} # # # #Function Get_rect:boolean; #begin &read_twice; &if (point_1.x = point_2.x) {do we have a rehor); &big_cursor(anchor) #end; {track} # # #  Procedure Read_twice; #begin &if playback )then begin ,get_point(point_1); ,adv_cmd; ,get_point(point_2) )end )else begin ,repeat track until button(0) or button(1); n ,pencolor(none); ,moveto(x_min,y); ,pencolor(reverse); ,moveto(x_max,y); ,pencolor(none); ,moveto(x,y_min); ,pencolor(reverse); ,moveto(x,y_max) )end; &pencolor(none) #end; {big_cursor} #  # #Procedure Track; #begin &read_paddles(anc x_max; ,for i := 1 to 10 do; ,here.y := y_min + round(paddle(0)*y_scale); ,if here.y > y_max then here.y := y_max )end #end; {read_paddle} # # # #Procedure Big_cursor{here: point}; #var i:integer; #begin &for i := 1 to 2 do )with here do begi&here.y := command[cmd_ctr]; #end; {get_point} # # # #Procedure Read_paddles{var here: point}; #var i:integer; #begin &if playback )then get_point(here) )else begin ,here.x := x_min + round(paddle(1)*x_scale); ,if here.x > x_max then here.x :=# #Procedure Adv_cmd; #var i:integer; #begin &if cmd_ctr < command[0] )then cmd_ctr := cmd_ctr + 1 )else exit(call_procs) #end; {adv_cmd} # # # #Procedure Get_point{var here: point}; #begin % here.x := command[cmd_ctr]; &adv_cmd; & & & #Procedure Put_point{here: point}; #begin &put_cmd(here.x); &put_cmd(here.y) #end; {put_point} # # # #Procedure Rem_cmd; #begin &if cmd_ctr > 0 then begin )cmd_ctr := cmd_ctr - 1; )command[0] := cmd_ctr &end #end; {rem_cmd} # #  cmd_ctr < max_cmd - 1 )then begin ,cmd_ctr := cmd_ctr + 1; ,command[cmd_ctr] := word; ,command[0] := cmd_ctr )end )else begin ,note(20,20); {overflow} ,note(20,20); ,exit(call_procs) {punch out of whatever command we're in} )end #end; {put_cmd}lor(white); )moveto(circle_point.x,circle_point.y); )pencolor(none) &end; &pencolor(none); &cmd := 't' #end; {circle} # # # #Procedure Empty; #begin &if not playback then put_cmd(empty_cmd); &fillscreen(black); &cmd := 't' #end; {empty} # # # #Procedure Grid; #var &i,j:integer; &dot:boolean; #begin &dot := true; &for i := 0 to 35 do )for j := 0 to 24 do ,if (8*i >= x_min) and (8*i <= x_max) ,and(8*j >= y_min) and (8*j <= y_max) ,then drawblock(dot,1,0,0,1,1,8*i,8*j,10); &cmd )read(cmd); )if (cmd = 'y') or (cmd ='Y') ,then cmd := chr(27) ,else cmd := 't' &end #until (ord(cmd) = 27)  end. " teln('Cmd_ctr = ',cmd_ctr); ,writeln;write('Press a key to continue'); ,rem_cmd; ,read(cmd); ,cmd := 't'; ,seehires )end; &if keypress then read(cmd); # if ord(cmd) = 27 then begin )seetext; )writeln; )write('Do you really want to quit ? '); IJKLMNOPQRSTUVWXYZ'; #alphabet := concat(alphabet,'[\]^_`abcdefghijklmnopqrstuvwxyz{|}~'); #reset_viewport; #initturtle; #seehires; #repeat &call_procs; &if cmd_ctr >= max_cmd - 1 )then begin ,seetext; ,writeln('Command buffer overflow!!'); ,wrie_last; )'?' : menu; &end; &if button(0) or button(1) then rubber_band; #end; {call_procs} & &   begin {main} #cmd_ctr := 0; #command[0] := cmd_ctr; #playback := false; #cmd := 't'; #alphabet := ' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGH&case cmd of )'b','B' : box; )'c','C' : circle; )'d','D' : disk; )'f','F' : fill; )'g','G' : grid; )'e','E' : empty; &(* 'p','P' : print; *) )'r','R' : reset_viewport; )'t','T' : track; )'v','V' : view; )'w','W' : writestring; )'x','X' : removremove_last); &while (cmd_ctr > 0) and (command[cmd_ctr] >= 0) do )cmd_ctr := cmd_ctr - 1; &cmd_ctr := cmd_ctr - 1; {remove last command word} &command[0] := cmd_ctr; &re_run #end; {remove_last} & & & #Procedure Call_Procs; #begin et_viewport; ,view_cmd : view; ,write_cmd : writestring; ,rubber_cmd : rubberband )end {case} &end; {while} &playback := false; &cmd := 't' #end; {re_run} # # #  Procedure Remove_last; " var i:integer; #begin &if command[0] = 0 then exit(true; &cmd_ctr := 0; &viewport(0,279,0,191); &fillscreen(black); &while cmd_ctr < command[0] do begin )cmd_ctr := cmd_ctr + 1; )case command[cmd_ctr] of ,box_cmd : box; ,circle_cmd : circle; ,fill_cmd : fill; ,empty_cmd : empty; ,reset_cmd : res&x_min := ul.x; x_max := lr.x; &y_min := lr.y; y_max := ul.y; &viewport(x_min,x_max,y_min,y_max); &x_scale := (x_max - x_min) / x_val; &y_scale := (y_max - y_min) / y_val; &cmd := 't' #end; {view} # # # # Procedure Re_run; #begin &playback := n,y_max); &x_scale := x_max/x_val; &y_scale := y_max/y_val; &cmd := 't' #end; {reset_viewport} & & & #Procedure View; #begin &if not playback then put_cmd(view_cmd) else adv_cmd; &if not get_rect then begin )rem_cmd; )exit(view) &end; print )end )else printpic; &cmd := 't'; &seehires #end; {print} #*) # # #Procedure Reset_Viewport; #begin &if not playback then put_cmd(reset_cmd); &x_min := 0; x_max := scrn_x_max; &y_min := 0; y_max := scrn_y_max; &viewport(x_min,x_max,y_mi:= 't' #end; {grid} # # # #(* #Procedure Print; #begin &seetext; &writeln; &write('Single or double-size (s/d) ? '); &read(cmd); &setnegative; &setdark(7); &if (cmd = 'd') or (cmd = 'D') )then begin ,setunidirect; ,setleftmargin(12); ,dbl*GRAPHICE إT=*>RآCFBšآB ȡةAD@šة@,fبȡ/CBکAک@; N QQ > OQM StS\ =ɡ+==T=ؚT= Lب=š==T=*=Tɡ== ,آT=ة@šnGl >Mȡ!RQNMM J QMRQ١١NMQMEQMRQT=áNM68:<>@RDFHJkNPR}VXZq^`mdfhQQ0HT=Hȡ HHQQRةAɍةAɡRکCɍکCɡR٩Bō٩Bšá"̅AʅAˡ ̅BƅEʅB̅C"̅AʅAˡƅE"̅AʅAˡƅE0 P >tS۳۹# ~ ytBwl +=1 -$&(DP.024 File name : ƅPƅ̅nƅnƅPƅnצ.grafUƅnPʅ@ ƅ ƅ"̅AʅAˡʅ@TبإT"̅AʅAˡʅDƅƅƅnƅƅnPƅ̅nƅnƅPƅnצ.fotoUƅnPƅEƅtS ƅEƆqƁ-tS)Do you want to G(et or S(ave a picture ? ƅ?ʅ? ʅ?gʅ?GÍ̅@ʅ@8 F(oto file?ƅ?ʅ?yʅ?YÍ̅D+צP*+,*,ȡ=--P-ƀT=*ƀ-P**=+=RQtSh   I/O error #A Press a key to continue...Sing to be shown : P=šM1Command buffer overflow. String cannot be saved._++*+,*,ȡ+T=*-*-**=+=T=qT=lack line. Hit 'q' to resume track mode.צHit to quit program.צHit a key to continue...StS >Q>QStrצW(rite string at cursor point.צX - erase the last command.-Pressing the buttons starts Rubberband mode -צ pressing button #1 draws a whiteצ#line, button #0 draws a bE(rase in viewport.צF(ill with color.G(rid in viewport.R(eset viewport.T(rack paddles (default).צ&V(iewport - give two opposite corners. צPascal Graphic Editor 1.2Available Commands:צ!B(ox - give two opposite corners.'C(ircle - give center and point on rim.צD(isk get or put.Bq M4OM9 RPNéOMÍtS>OMPNɡ PLNJPJNLOMš OKMIOIMKj>LILKJKJILItSdȡ l>>OMPNOMPO<ȡTI@ފ<POtSc > tSname : string; #ch : char; #foo : hook; #hires : screen; #num : integer; #hires_file : file; # #Procedure Bad_io; #var result : integer; #begin &result := ioresult; &if result <> 0 then begin )seetext; )writeln('I/O error #',result); )exit(prm,turtlegraphics;  Const #hires_start = 8192; #hires_length = 8192;  Type #byte = 0..255; #screen = packed array [1..hires_length] of byte; #hook = record /case boolean of 2true : (ptr : ^screen); 2false: (addr: integer) /end;  Var #fileProgram Showfoto;   {Shows fotofiles (from Grafedit or similar sources) on the hi-res}  {screen. This program appends '.foto' to whatever filename you }  {enter. Press a key to return to the command-level menu. }   Uses applestuff,smarterO^F= צPress a key to continueStS SSáQDo you really want to quit ? SSyéSYÍStSSá: 0<J B$6^(Z4'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZx??x?צ$[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ǜ?x =ġCommand buffer overflow!!צ Cmd_ctr = = צPress a key to continueStS SSáQDo you really want to quit ? SSyéSYÍStSSá: 0<=T=>tSצ; !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZx??x?צ$[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ǜ?x =ġCommand buffer overflow!!צ Cmd_ctr = =T=E`S0   |?xt ><:0:8 "$&F*F.FDB68:<>@BDF~|zpzxTVXZ\^`bdfjn D@AtSb>=ǿ  =TɡW==T= 51-)%!  # +17>tSr Tá=ťT=Ą===#ȡGȡ5ُCُBȄ؏AĄ؏@Ȅُ؏ tSQH d>CBAǿ@CBA@ FBD@tSJ>LCJBIAK@CBA@ FBCogram) &end #end; #  begin #write('File name ? '); readln(filename); #filename := concat(filename,'.foto'); #foo.addr := hires_start; #initturtle; #seehires; #{$i-} #reset(hires_file,filename); #bad_io; #num := blockread(hires_file,foo.ptr^,16); #{$i+} #bad_io; #close(hires_file); #read(ch); #seetext  end. p := false #end; {initilize} & & & #Procedure Newvalue(var value:integer); #var ch : char; #begin &write(value,' :'); {returns original value if hit} &read(ch); &if eoln then exit(newvalue); &value := 0; &while not eoln do begin )value h, n= # of sides} #out,flipflop : boolean; {determine how turtle turns at each level} #maxsize : integer; # # # #Procedure Initilize; #begin &level := 1; {set up for triangle to start (why not?)} &n := 3; &maxsize := 100; &out := true; &flipflo Program Snowflake; {Recursive fractal-type curve drawing program}   Uses turtlegraphics,smarterm,applestuff;   Const pi = 180.0; {degrees for turtlegraphics}   Var #side,theta : real; #ch : char; #level,n,i : integer; {level=recursion deptHERE  O^a -9 ƀ:SYSTEM.SWAPDISK&:(7,*SYSTEM.WRK.CODE[*]תצTo what codefile? ( צO,á<צ$88š8(8X͞"ˡ0 I/O error # B/[ File name ? PWWPW.fotoUWP -//-./,/Bq(SHOWFOTO := value * 10 + ord(ch) - ord('0'); {else decode char by char} )read(ch); &end #end; {newvalue} & # # #Procedure Newtruth(var switch:boolean); {return original value if hit} #var s : string; #begin &if switch then write('yes') else write('no'); &write(' :'); &readln(s); &if length(s) = 0 then exit(newtruth); &writeln; &switch := s[1] in ['Y','y'] #end; {newtruth} # # # #Procedure Wend(level:integer; side:real; out,flipflop:boolean); &{draO^ڣ(y/n) : 4C(`á ȡKI*0 G  צ Snowflake curve drawing program.צ6Enter new values: leaves value, depth := 0 quitsצRecursion depth : áצNumber of sides :  Size (50+) : Outward growing? (y/n) : Flip-flop? 2 ܏ ءٓá#١  f4Cȡ4Cٓ G  צ Snowflake curve drawing program.  d   צ :   ق0#`yesצnoצ :PáR|BqSNOWFLAK ; &theta := 2 * pi / n; &initturtle; &seehires; &moveto(40,96); &pencolor(white); &if n = 3 then turn(30) else turn(round(theta/2)); &for i := 1 to n do wend(level,side,out,flipflop); &read(ch); &seetext; #until false  end. {Snowflake}  value(level); &if level = 0 then exit(program); &write('Number of sides :'); newvalue(n); &write('Size (50+) :'); newvalue(maxsize); &write('Outward growing? (y/n) :'); newtruth(out); &write('Flip-flop? (y/n) :'); newtruth(flipflop); &side := maxsize#end; {wend} #    Begin {main} #page(output); #writeln('Snowflake curve drawing program.');  initilize; #write('Enter new values: leaves value, depth := 0 quits'); #repeat {forever} &writeln; writeln; &write('Recursion depth :'); new,wend (level-1,side/3,out,flipflop); ,turn (round(pi)); ,for i := 1 to n-1 do wend (level-1,side/3,out,flipflop); ,turn (round(pi)); {face forward again} ,wend (level-1,side/3,out,flipflop); ,if not out then turn (round(-2*theta)) )end {else} 1 then level := 1; {terminate if too small} & &if level = 1 )then begin {bottom recursion level --> straight sides} ,move (round(side)); ,if out /then turn (round(-theta)) /else turn (round(theta)) ,end {then} )else begin {put flakes on side} w one side if level=1; else push 'til its easy} #var i:integer; #begin & &{neat sounds!} ¬e(50-10*level,10); & &if keypress then exit(wend); {crap out if desired} & &{take care of various options} &if flipflop then out := not out; &if side <=)'m','M': move_proc; )'t','T': turn_proc; )'p','P': color_proc; )'i','I': init_proc; )'q','Q': quit_proc &end #until ch = chr(27); { also punches out} #quit_proc  end. wport(0,278,170,191); &fillscreen(black); &pencolor(none); &moveto(0,180); &wstring('M(ove, T(urn, P(encolor, I(nit, Q(uit:'); &read(keyboard,ch); &wchar(ch); &viewport(1,278,1,168); &moveto(x,y); &turnto(angle); &pencolor(color); &case ch of (temp_s = 'REVERSE') then color := reverse; &pencolor(color) #end; {color_proc} # # # #Procedure Quit_proc; #begin &seetext; &exit(program) #end; {quit_proc} # # #  begin {Main} #init_proc; #repeat {until 'Q' or } &draw_turtle; &viehen color := violet; &if (temp_s = 'orange') or (temp_s = 'ORANGE') then color := orange; &if (temp_s = 'blue') or (temp_s = 'BLUE') then color := blue; &if (temp_s = 'none') or (temp_s = 'NONE') then color := none; &if (temp_s = 'reverse') or &if (temp_s = 'white') or (temp_s = 'WHITE') then color := white; &if (temp_s = 'black') or (temp_s = 'BLACK') then color := black; &if (temp_s = 'green') or (temp_s = 'GREEN') then color := green; &if (temp_s = 'violet') or (temp_s = 'VIOLET') t&moveto(0,180); &wstring('Color: White, Black, Green, Violet'); &moveto(0,170); &wstring('Orange, Blue, None, Reverse: '); &readln(keyboard,temp_s); &wstring(temp_s); &viewport(1,278,1,168); &moveto(x,y); &turnto(angle); 278,1,168); &moveto(x,y); &turnto(angle); &turn(temp_ang); &angle := turtleang #end; {turn_proc} # # # #Procedure Color_proc; #var &temp_s: string; &temp_c: screencolor; #begin &viewport(0,279,170,191); &fillscreen(black); &pencolor(none); # #Procedure Turn_proc; #var &temp_ang: integer; &temp_s: string; #begin &pencolor(none); &viewport(0,279,170,191); &moveto(0,170); &wstring('Turn how much? '); &readln(keyboard,temp_ang); &str(temp_ang,temp_s); &wstring(temp_s); &viewport(1,&moveto(0,170); &wstring('Move how far? '); &readln(keyboard,dist); &str(dist,temp_s); &wstring(temp_s); &viewport(1,278,1,168); &moveto(x,y); &turnto(angle); &pencolor(color); &move(dist); &x := turtlex; &y := turtley #end; {move_proc} # # closes at (x,y) } &turnto(angle); {face turtle correctly} &pencolor(color) {reset color} #end; {draw_turtle} # # # #Procedure Move_proc; #var &temp_s: string; &dist: integer; #begin # pencolor(none); &viewport(0,279,170,191); ) #end; {init_proc} # # # #Procedure Draw_turtle; #const &width = 2; &length = 7; &ang = 17; #begin &pencolor(white); &turn(-90); &move(width); &turn(90+ang); &move(length); &turn(180-2*ang); &move(length); &moveto(x,y); {make sure it moveto(279,169); &moveto(0,169); &moveto(0,0); & &viewport(1,278,1,168); & &{Effect of Initturtlegraphics on simulated turtle} &angle := 0; &x := 140; &y := 85; &color := none; &fillscreen(black); &pencolor(none); &moveto(x,y); &turnto(angle Program Turtle_Simulator;  uses turtlegraphics,smarterm;  var #ch: char; #angle,x,y: integer; #color: screencolor; # # # #Procedure Init_proc; #begin &initturtle; &seehires; & &moveto(0,0); {draw box} &pencolor(white); &moveto(279,0); & (*$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, R MAIN MODIFY ROTATE HIDDEN DIVIDE SEND INITIALIMENU Oa fO^ğNONEׯצreverseצREVERSETǪǿ  Ǵצ&M(ove, T(urn, P(encolor, I(nit, Q(uit:Ǩ okgc_ItX# !- "$&(*,.02468:<>@ODFHcLNa[TVmá )"(>\&REENצvioletVIOLETׯצorangeORANGEׯ צblueBLUEׯ צnoneNONEׯצreverseצREVERSETǪǿ  Ǵצ&M(ove, T(urn, P(encolor, I(nit, Q(uit:Ǩ okgc_ItX# !one, Reverse: PǨ צwhiteצWHITEצblackצBLACKצgreenצGREENצvioletVIOLETׯצorangeORANGEׯ צblueBLUEׯ צnone*  TǪǿ ǪצTurn how much?  P Ǩ TxǪǿ  Ǵצ"Color: White, Black, Green, VioletǪOrange, Blue, NǩǩǨ njU ^ZZǴ:Ǫǿ ǪצMove how far? * *P Ǩ B1@*TURTLESI C3,XROT,YROT,ZROT, &DISTANCE,DELTA,BREADTH,DIVISIONS, &STEP,X,Y,CONX,CONY,CON1, &G,T,R,T1,T2:REAL; $SELECTION:INTEGER; $CH:CHAR; $STOP:BOOLEAN; $COL:SCREENCOLOR;   (* THE FOLLOWING VARIABLES ARE USED IN #THE LOWER LEVEL ROUTINES ALMOST #EXCLUSIVELY. *)  $FIRSTRIGHT,FIRSTLEFT:BOOLEAN; $U3,U4,U8:INTEGER;  U9,L9,LEFTSIDE,RIGHTSIDE,S7,S8,S9, &X1,Y1,X3,Y3,X4,Y4,X5,Y5,Y7, &X8,Y8,OLDX,OLDY:REAL;  B1,B2:ARRAY[0..279] OF REAL;   PROCEDURE INTERSECT; (*FIND AN INTERSECTION*)   VAR I 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(HIDDE+DELTAY*DELTAY); "IF L8>L9 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; &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 Y7