home *** CD-ROM | disk | FTP | other *** search
- ( System messages ) empty stack dictionary full has incorrect address mode isn't unique disc range ? full stack Error reading block !! Error writing block !! ( System messages ) compilation only, use within definitions execution only conditionals not paired definition not finished in protected dictionary use only when loading off current editing screen declare vocabulary ( 1 and 2 dimensional array definitions ) FORTH DEFINITIONS : ARRAY ( compile: n -- ; exec: n -- addr ) <BUILDS DUP , DUP + ALLOT DOES> (ARRAY) ; : STRING ( compile: n -- ; exec: n -- addr ) <BUILDS DUP , ALLOT DOES> (CARR) ; : 2ARRAY ( compile: rows cols -- ; exec: row col -- addr ) <BUILDS 2DUP , , * DUP + ALLOT DOES> (2ARR) ; : STRINGS ( compile: n maxlen -- ; exec: n char -- addr ) <BUILDS SWAP 2DUP , , * ALLOT DOES> (2CARR) ; ( CRT control functions : Infoton I-100 ) FORTH DEFINITIONS DECIMAL : ESC 27 EMIT ; : CUR> ( row column -- ) ESC 102 EMIT 32 + EMIT ( col) 32 + EMIT ( row) ; : GOTOXY ( column row -- ) SWAP CUR> ; : PAGE ( -- clear, home cursor ) 12 EMIT ; : CLREOS ( -- clear to end of screen ) ESC 74 EMIT ; : CLREOL ( -- " line ) ESC 75 EMIT ; : HOME 0 0 GOTOXY ; ;S ( Dr. Eaker's CASE construct: FD 3:187 1982 ) FORTH DEFINITIONS ( begin CASE construct: n CASE ... OF ... ENDOF ...ENDCASE ) : CASE ?COMP CSP @ !CSP 4 ; IMMEDIATE : OF 4 ?PAIRS COMPILE (XOF) HERE 0 , 5 ; IMMEDIATE : ENDOF 5 ?PAIRS COMPILE BRANCH HERE 0 , SWAP 2 [COMPILE] THEN 4 ; IMMEDIATE : ENDCASE 4 ?PAIRS COMPILE DROP BEGIN SP@ CSP @ = 0= WHILE 2 [COMPILE] THEN REPEAT CSP ! ; IMMEDIATE ;S ( "Starting Forth" line editor - load screen ) ( FD 3:80 ) CR ." Editor loading, please wait..." 1 WARNING ! FORTH DEFINITIONS HEX : TEXT HERE C/L 1+ BLANKS WORD HERE PAD C/L 1+ CMOVE ; : LINE DUP 0FFF0 AND IF 17 MESSAGE DROP QUIT ENDIF SCR @ (LINE) DROP ; VOCABULARY EDITOR IMMEDIATE HEX : WHERE DUP B/SCR / DUP SCR ! ." Scr " DECIMAL . SWAP C/L /MOD C/L * ROT BLOCK + CR C/L TYPE CR HERE C@ - SPACES 5E EMIT [COMPILE] EDITOR QUIT ; --> ( S.F. editor definitions ) EDITOR DEFINITIONS : #LOCATE R# @ C/L /MOD ; : #LEAD #LOCATE LINE SWAP ; : #LAG #LEAD DUP >R + C/L R> - ; : -MOVE LINE C/L CMOVE UPDATE ; : BUF-MOVE PAD 1+ C@ IF PAD SWAP C/L 1+ CMOVE ELSE DROP ENDIF ; : >LINE# #LOCATE SWAP DROP ; : FIND-BUF PAD 50 + ; : INSERT-BUF FIND-BUF 50 + ; : (HOLD) LINE INSERT-BUF 1+ C/L DUP INSERT-BUF C! CMOVE ; : (KILL) LINE C/L BLANKS UPDATE ; : (SPREAD) >LINE# DUP 1 - 0E DO I LINE I 1+ -MOVE -1 +LOOP (KILL) ; --> ( S.F. editor definitions, cont. ) : DISPLAY-CURSOR CR SPACE #LEAD TYPE 05E EMIT #LAG TYPE #LOCATE . DROP ; : (TOP) 0 R# ! ; : SEEK-ERROR (TOP) FIND-BUF HERE C/L 1+ CMOVE HERE ." couldn't find " COUNT TYPE QUIT ; : X >LINE# DUP (HOLD) 0F DUP ROT DO I 1+ LINE I -MOVE LOOP (KILL) ; : T C/L * R# ! 0 DISPLAY-CURSOR ; : L SCR @ LIST ; : N 1 SCR +! ; : B -1 SCR +! ; : (R) >LINE# INSERT-BUF 1+ SWAP -MOVE ; : P 5E TEXT INSERT-BUF BUF-MOVE (R) ; --> ( S.F. editor definitions, cont. ) : WIPE 10 0 DO I (KILL) LOOP ; : COPY B/SCR * OFFSET @ + SWAP B/SCR * B/SCR OVER + SWAP DO DUP FORTH I BLOCK 2 - ! 1+ UPDATE LOOP DROP FLUSH ; : 1LINE #LAG FIND-BUF COUNT MATCH R# +! ; : (SEEK) BEGIN 3FF R# @ < IF SEEK-ERROR ENDIF 1LINE UNTIL ; : (DELETE) >R #LAG + R - #LAG R MINUS R# +! #LEAD + SWAP CMOVE R> BLANKS UPDATE ; : (F) 5E TEXT FIND-BUF BUF-MOVE (SEEK) ; : F (F) DISPLAY-CURSOR ; : (E) FIND-BUF C@ (DELETE) ; : E (E) DISPLAY-CURSOR ; : D (F) E ; --> ( S.F. editor definitions, cont. ) 0 VARIABLE COUNTER : TILL #LEAD + 5E TEXT FIND-BUF BUF-MOVE 1LINE 0= IF SEEK-ERROR ENDIF #LEAD + SWAP - (DELETE) DISPLAY-CURSOR ; : BUMP 1 COUNTER +! COUNTER @ 38 > IF 0 COUNTER ! CR CR 0F MESSAGE 0C EMIT ENDIF ; : S 0C EMIT 5E TEXT 0 COUNTER ! FIND-BUF BUF-MOVE SCR @ DUP >R DO I SCR ! (TOP) BEGIN 1LINE IF DISPLAY-CURSOR SCR ? BUMP ENDIF 3FF R# @ < UNTIL LOOP R> SCR ! ; --> ( S.F. editor definitions, cont. ) : I 5E TEXT INSERT-BUF BUF-MOVE INSERT-BUF COUNT #LAG ROT OVER MIN >R R R# +! R - >R DUP HERE R CMOVE HERE #LEAD + R> CMOVE R> CMOVE UPDATE DISPLAY-CURSOR ; : U C/L R# +! (SPREAD) P ; : R (E) I ; : M SCR @ >R R# @ >R >LINE# (HOLD) SWAP SCR ! 1+ C/L * R# ! (SPREAD) (R) R> C/L + R# ! R> SCR ! ; : t T ; : l L ; : n N ; : b B ; : p P ; : f F ; : s S ; : i I ; : u U ; : r R ; FORTH DEFINITIONS DECIMAL CR CR ." Current screen is " SCR ? EDITOR ;S ( Screen move utilities ) EDITOR DEFINITIONS DECIMAL ( n -- copy screen n to the current screen ) : GET SCR @ COPY ; ( n m -- GET m screens, beginning at n ) : GET# OVER + SWAP DO FORTH I EDITOR GET 1 SCR +! LOOP ; 234 CONSTANT SCR/DRIVE ( single density, 8" ) ( n m -- copy screen n on drive 0 to screen m on drive 1 ) : DCOPY DR0 SCR/DRIVE + COPY ; ( n -- copy screen n to the same screen on drive 1 ) : >DR1 DUP DCOPY ; : #>DR1 OVER + 1+ SWAP DO ( n m -- copy n-m) FORTH I EDITOR >DR1 LOOP ; FORTH DEFINITIONS ;S ( fig-FORTH PORTABLE EDITOR WFR 01 MAY 79 ) FORTH DEFINITIONS HEX : TEXT HERE C/L 1+ BLANKS WORD HERE PAD C/L 1+ CMOVE ; : LINE DUP FFF0 AND 17 ?ERROR SCR @ (LINE) DROP ; VOCABULARY EDITOR IMMEDIATE HEX : WHERE ( PRINT SCREEN # AND IMAGE OF ERROR ) DUP B/SCR / DUP SCR ! ." Screen # " DECIMAL . SWAP C/L /MOD C/L * ROT BLOCK + CR C/L TYPE CR HERE C@ - SPACES 5E EMIT [COMPILE] EDITOR QUIT ; EDITOR DEFINITIONS : #LOCATE R# @ C/L /MOD ; : #LEAD #LOCATE LINE SWAP ; : #LAG #LEAD DUP >R + C/L R> - ; : -MOVE LINE C/L CMOVE UPDATE ; --> ( fig-FORTH PORTABLE EDITOR, continued ) : H LINE PAD 1+ C/L DUP PAD C! CMOVE ; : E LINE C/L BLANKS UPDATE ; : S DUP 1 - 0E DO I LINE I 1+ -MOVE -1 +LOOP E ; : D DUP H 0F DUP ROT DO I 1+ LINE I -MOVE LOOP E ; : M R# +! CR SPACE #LEAD TYPE 5F EMIT #LAG TYPE #LOCATE . DROP ; : T DUP C/L * R# ! DUP H 0 M ; : L SCR @ LIST 0 M ; --> ( fig-FORTH PORTABLE EDITOR, continued ) : R PAD 1+ SWAP -MOVE ; : P 1 TEXT R ; : I DUP S R ; : TOP 0 R# ! ; : CLEAR SCR ! 10 0 DO FORTH I EDITOR E LOOP ; : COPY B/SCR * SWAP B/SCR * B/SCR OVER + SWAP DO DUP FORTH I BLOCK 2 - ! 1+ UPDATE LOOP DROP FLUSH ; --> ( fig-FORTH PORTABLE EDITOR, continued ) : 1LINE ( scan line with cursor for match to PAD text ) ( update cursor, return boolean ) #LAG PAD COUNT MATCH R# +! ; : FIND ( string at PAD over full screen, else error ) BEGIN 3FF R# @ < IF TOP PAD HERE C/L 1+ CMOVE 0 ERROR ENDIF 1LINE UNTIL ; : DELETE ( backwards at cursor by count-1 ) >R #LAG + FORTH R - ( save blank fill location ) #LAG R MINUS R# +! ( backup cursor ) #LEAD + SWAP CMOVE R> BLANKS UPDATE ; ( fill from end ) : N ( find next occurence of previous text ) FIND 0 M ; : F ( find occurence of text ) 1 TEXT N ; --> ( fig-FORTH PORTABLE EDITOR, continued ) : B ( BACKUP CURSOR BY TEXT IN PAD ) PAD C@ MINUS M ; : X ( delete following text ) 1 TEXT FIND PAD C@ DELETE 0 M ; : TILL ( delete from cursor to text end on this line ) #LEAD + 1 TEXT 1LINE 0= 0 ?ERROR #LEAD + SWAP - DELETE 0 M ; : C ( spread at cursor and copy in following text ) 1 TEXT PAD COUNT #LAG ROT OVER MIN >R FORTH R R# +! R - >R DUP HERE R CMOVE HERE #LEAD + R> CMOVE R> CMOVE UPDATE 0 M ; FORTH DEFINITIONS DECIMAL LATEST 12 +ORIGIN ! ( TOP NFA ) HERE 28 +ORIGIN ! ( FENCE ) HERE 30 +ORIGIN ! ( DP ) ' EDITOR 6 + 32 +ORIGIN ! ( VOC-LINK ) HERE FENCE ! ;S ( utilities: memory dump: ?PR, etc. ) FORTH DEFINITIONS DECIMAL MYSEG VARIABLE SEGMENT ( base segment for FETCH ) : NTIMES BASE @ 4 MAX ; ( -- n # locations to be displayed ) : FETCH SEGMENT @ SWAP :C@ ; ( addr -- n ) : ?NL 1+ NTIMES MOD 0= ; ( -- f start new line ? ) ( -- n field width for printing depends on base ) : FWIDTH BASE @ CASE 16 OF 3 ENDOF 10 OF 4 ENDOF 8 OF 4 ENDOF 2 OF 9 ENDOF 16 BASE ! 3 SWAP ENDCASE ; ( n -- f tf if n is printable ) : ?PR 127 AND DUP 127 < OVER 31 > AND ; : (D#) DUP NTIMES + SWAP DO ( addr -- dump numbers ) I ?NL IF LEAVE ENDIF I FETCH FWIDTH .R LOOP ; --> ( utilities: memory dump: DUMP ) : (DC) DUP NTIMES + SWAP DO ( addr -- dump chars ) I ?NL IF LEAVE ENDIF I FETCH ?PR IF EMIT ELSE DROP 46 EMIT ENDIF LOOP ; ( -- print SEGMENT if not FORTH ) : SEG. SEGMENT @ MYSEG = 0= IF SEGMENT @ 0 5 D.R THEN 58 EMIT ; : DUMP ( n -- n2 : display contents from n to n2-1 ) 8 0 DO CR DUP DUP DUP SEG. 0 5 D.R SPACE ( address ) (D#) SPACE SPACE ( numbers ) (DC) ( chars ) DUP NTIMES MOD NTIMES SWAP - + LOOP ; ;S ( Utilities: DEPTH S? VOC? BASE? ) FORTH DEFINITIONS DECIMAL ( -- n depth of stack ) : DEPTH SP@ S0 @ SWAP - 2 / 0 MAX ; ( -- non-destructive stack display ) : S? DEPTH IF SP@ S0 @ 2- DO I ? -2 +LOOP ELSE ." empty " ENDIF ; : VOC. 4 - NFA ID. ; ( addr -- print vocabulary id. ) ( -- print CURRENT and CONTEXT ID ) : VOC? CURRENT @ CONTEXT @ 2DUP = IF ." CURRENT and CONTEXT are " VOC. DROP ELSE ." CONTEXT is " VOC. ." , CURRENT is " VOC. THEN 3 SPACES ; ( -- show current base in decimal ) : BASE? BASE @ DUP DECIMAL . BASE ! ; ;S ( Utilities: SIZE? NEW ) FORTH DEFINITIONS DECIMAL ( -- show current length of FORTH dictionary and remaining free space ) : SIZE? HERE 0 6 D.R ." bytes used, " S0 @ HERE - 0 6 D.R ." bytes free " ; ( -- update start-up parameters to reflect FORTH's current state ) : NEW CR ." current version is " 10 +ORIGIN C@ 65 + EMIT CR ." new version (A-Z)? " KEY DUP EMIT 65 - 10 +ORIGIN C! ( user version ) [ ' FORTH 4 + ] LITERAL @ 12 +ORIGIN ! ( top of FORTH) R0 @ 6 + 18 +ORIGIN 16 CMOVE ; ( user variables ) ;S ( utilities: BUFS? ) FORTH DEFINITIONS HEX : .HEAD SPACE DUP 0< IF 2A EMIT ( * ) 7FFF AND ELSE BL EMIT ENDIF 5 .R ; : .TOP CR CR ." addr block contents" ; ( -- show state of block buffers ) : BUFS? .TOP FIRST #BUFF 0 DO CR DUP 0 5 HEX D.R DECIMAL ( buffer address ) DUP @ .HEAD ( block #, updated? ) DUP USE @ = IF ." <-USE " ELSE DUP PREV @ = IF ." <-PREV" ELSE 6 SPACES THEN THEN DUP 2+ 5 SPACES 28 TYPE ( print buffer's contents ) B/BUF 4 + + LOOP CR ." * = updated buffer " ; DECIMAL ;S ( utilities: VLIST, DLIST ) FORTH DEFINITIONS HEX : DLIST CR CR CR VLIST ; ( fig VLIST ) : MORE? DUP IF @ 0A081 = 0= ENDIF ; DECIMAL 10 VARIABLE TABSTOP : TAB BEGIN OUT @ TABSTOP @ MOD WHILE SPACE REPEAT ; : WORDS ( show context vocabulary, in columns ) CR CR CR VOC? 80 OUT ! CONTEXT @ @ BEGIN OUT @ C/L > IF CR 0 OUT ! THEN DUP MORE? WHILE DUP ID. TAB PFA LFA @ REPEAT DROP ; ;S ( utilities: DATE?, T>, >T, .T, TIME? ) FORTH DEFINITIONS DECIMAL : ## 0 <# # # #> TYPE ; ( print tos as 2-digit # ) : DATE? DATE@ ## 47 EMIT ## 47 EMIT ## SPACE ; ( -- show date) 0 VARIABLE [T] 2 ALLOT 0 VARIABLE [ET] 2 ALLOT ( unpack, pack 'times': sec/csec hr/min ) : T> [T] 2! [T] 2+ C@ ( csec ) [T] 3 + C@ ( sec ) [T] C@ ( min ) [T] 1+ C@ ( hr ) ; : >T [T] 1+ C! ( hr ) [T] C! ( min ) [T] 3 + C! ( sec ) [T] 2+ C! ( csec ) [T] 2@ ; : -MOD60 - DUP 0< IF 60 + -1 ( borrow ) ELSE 0 THEN ; : -MOD100 - DUP 0< IF 100 + -1 ( borrow ) ELSE 0 THEN ; : -MOD24 - DUP 0< IF 24 + -1 ( borrow ) ELSE 0 THEN ; : .T ## 58 EMIT ## 58 EMIT ## 46 EMIT ## SPACE ; : TIME? TIME@ T> .T ; ( -- show current time ) --> ( utilities: ET0, ET? ) 0 VARIABLE [T0] 2 ALLOT 0 VARIABLE [T1] 2 ALLOT ( d1 d2 -- csec sec min hr subtract two times; result is unpacked ) : T- [T0] 2! [T1] 2! [T1] 2+ C@ [T0] 2+ C@ -MOD100 ( delta csec ) [T1] 3 + C@ + [T0] 3 + C@ -MOD60 ( delta sec ) [T1] C@ + [T0] C@ -MOD60 ( delta min ) [T1] 1+ C@ + [T0] 1+ C@ -MOD24 ( delta hr ) ; : ET0 TIME@ [ET] 2! ; ( reset elapsed time ) : ET TIME@ [ET] 2@ T- ( measure elapsed time ) ; : ET? ET DROP ( ignore carry ) .T ; ( -- show elapsed time) ( csec sec min hr -- n n=time in csec ) : >CS 60 * + 60 * + 100 * + ; : ET(S) ET DROP >CS ( show elapsed time in seconds ) 0 <# # # 46 HOLD #S #> TYPE SPACE ; ( utilities: DISCOPY ) FORTH DEFINITIONS DECIMAL 1872 CONSTANT MAXREC : PAUSE ." hit any key to continue..." KEY DROP ; : FILL #BUFF OVER + SWAP DO I MAXREC > 0= IF I MAXREC + BLOCK 2- ! UPDATE ELSE LEAVE THEN LOOP ; : BLOCK0 FIRST LIMIT OVER - BLANKS ; : NL CR 0 OUT ! ." Block" ; : NL? OUT @ 70 > IF NL THEN ; : DISPLAY NL? 7 .R ; ( absolute sector disk copy: takes about 10 minutes if you ) ( only use 8 buffers !! ) : DISKCOPY CR ." Place the source disk in drive A, " ." and the destination disk in drive B. " CR PAUSE ." please wait" CR FLUSH DR0 0 DRIVE ! BLOCK0 NL MAXREC 0 DO I DISPLAY I FILL FLUSH #BUFF +LOOP CR CR ." Disk copy finished. " ; ( System benchmarks, see FD 3,#'s 1 & 6 ) FORTH DEFINITIONS : MARK ; : LOOPTEST 32767 0 DO LOOP ; : (TEST) 32767 0 DO I DUP DROP DROP LOOP ; : -TEST 32767 0 DO I DUP - DROP LOOP ; : *TEST 32767 0 DO I DUP * DROP LOOP ; : /TEST 32767 0 DO 32767 I / DROP LOOP ; : PAUSE KEY DUP 78 = SWAP 110 = OR IF ." halted" QUIT ENDIF ; : (EXC) CR ." LOOPTEST..." ET0 LOOPTEST ET(S) PAUSE CR ." (TEST) ..." ET0 (TEST) ET(S) PAUSE CR ." -TEST ..." ET0 -TEST ET(S) PAUSE CR ." *TEST ..." ET0 *TEST ET(S) PAUSE CR ." /TEST ..." ET0 /TEST ET(S) ; : BENCH BEGIN CR CR CR (EXC) PAUSE AGAIN ; ;S ( RANDOM NUMBER GENERATOR, J. E. Rickenbacker ) ( FORTH DIMENSIONS II/2 PAGE 34 ) FORTH DEFINITIONS DECIMAL 0 VARIABLE SEED : (RAND) SEED @ 259 * 3 + 32767 AND DUP SEED ! ; ( n -- n1 returns pseudo-random number n1, 0<=n1<n ) : RANDOM (RAND) 32767 */ ; ( TRIG LOOKUP ROUTINES WITH SINE * 10000 TABLE ) : TABLE ( ... N -> , CREATE 'TABLE' DATA TYPE ) <BUILDS 0 DO , LOOP ( COMPILE N ELEMENTS ) DOES> SWAP 2 * + @ ( EXECUTE TABLE LOOKUP ) ; 10000 9998 9994 9986 9976 9962 9945 9925 9903 9877 9848 9816 9781 9744 9703 9659 9613 9563 9511 9455 9397 9336 9272 9205 9135 9063 8988 8910 8829 8746 8660 8572 8480 8387 8290 8192 8090 7986 7880 7771 7660 7547 7431 7314 7193 7071 6947 6820 6691 6561 6428 6293 6157 6018 5878 5736 5592 5446 5299 5150 5000 4848 4695 4540 4384 4226 4067 3907 3746 3584 3420 3256 3090 2924 2756 2588 2419 2250 2079 1908 1736 1564 1391 1219 1045 0872 0698 0523 0349 0175 0000 ( 91 ELEMENTS OF TABLE PLACED ON STACK ) 91 TABLE SINTABLE --> ( TRIG TABLE LOOKUP ROUTINES, CONTINUED ) : S180 ( N -> N RETURNS SINE 0-180 DEGREES ) DUP 90 > ( IF GREATER THAN 90 DEGREES ) IF 180 SWAP - ENDIF ( SUBTRACT FROM 180 ) SINTABLE ( THEN TAKE SINE ) ; : SIN ( N -> SINE RETURN SINE OF ANY NO. OF DEGREES ) 360 MOD ( BRING WITHIN + OR - 360 ) DUP 0< IF 360 + ENDIF ( IF NEGATIVE, ADD 360 ) DUP 180 > ( TEST IF GREATER THAN 180 ) IF 180 - S180 MINUS ( IF SO, SUBTRACT 180, NEGATE SINE ) ELSE S180 ENDIF ( OTHERWISE, STRAIGHTFORWARD ) ; : COS ( N -> COSINE ) 360 MOD ( PREVENT OVERFLOW NEAR 32767 ) 90 + SIN ; ( COS IS SIN WITH 90 DEG PHASE SHIFT ) ( THE GAME OF LIFE, ADAPTED FROM DAVE BOULTON ) ( FORTH DIMENSIONS III/5 PAGE 24 ) FORTH DEFINITIONS DECIMAL : TASK ; 8 LOAD DECIMAL 39 CONSTANT XLEN 22 CONSTANT YLEN XLEN YLEN 2ARRAY UNIVERSE 0 VARIABLE #GENERATION : J RP@ 6 + @ ; : CHECK DUP 3 = IF DROP 2+ ELSE 2 = 0= IF 4 + ENDIF ENDIF ; : CLEAR YLEN 0 DO XLEN 0 DO I J UNIVERSE 0 SWAP C! LOOP LOOP ; : DISPLAY PAGE ." Generation " #GENERATION @ . YLEN 0 DO XLEN 0 DO I J UNIVERSE C@ IF I 2 * J GOTOXY 42 EMIT ENDIF LOOP LOOP HOME ; --> ( THE GAME OF LIFE, CONTINUED ) : X- 1 - DUP 0 < IF DROP XLEN 1 - ENDIF ; : X+ 1 + DUP XLEN = IF DROP 0 ENDIF ; : Y- 1 - DUP 0 < IF DROP YLEN 1 - ENDIF ; : Y+ 1 + DUP YLEN = IF DROP 0 ENDIF ; : CELL C@ 1 AND + ; : GENERATE YLEN 0 DO XLEN 0 DO 0 I X- J UNIVERSE CELL I X+ J UNIVERSE CELL I X- J Y+ UNIVERSE CELL I J Y+ UNIVERSE CELL I X+ J Y+ UNIVERSE CELL I X- J Y- UNIVERSE CELL I J Y- UNIVERSE CELL I X+ J Y- UNIVERSE CELL I J UNIVERSE C@ 1 AND SWAP CHECK I J UNIVERSE C! LOOP LOOP ; --> ( THE GAME OF LIFE, CONTINUED ) 0 VARIABLE CUR 0 VARIABLE SETUPFLAG : .CUR CUR @ XLEN /MOD SWAP DUP + SWAP GOTOXY ; : !CUR 0 MAX YLEN XLEN * 1 - MIN CUR ! ; : +CUR CUR @ + !CUR ; : +.CUR +CUR .CUR ; : +LIN CUR @ XLEN / + XLEN * !CUR ; HEX 1B CONSTANT EXITFLAG 0A CONSTANT DOWNCURSOR 0D CONSTANT NEWLINE 7F CONSTANT BACKCURSOR DECIMAL : SETUPLIFE PAGE ." Enter starting pattern " ." push <ESC> when finished " CR 0 SETUPFLAG ! 0 CUR ! .CUR BEGIN KEY CASE EXITFLAG OF 1 SETUPFLAG ! ENDOF DOWNCURSOR OF XLEN +.CUR ENDOF BACKCURSOR OF -1 +.CUR ENDOF NEWLINE OF 1 +LIN .CUR ENDOF 32 OF 32 EMIT 0 CUR @ XLEN /MOD UNIVERSE C! 1 +.CUR ENDOF 42 OF 42 EMIT 1 CUR @ XLEN /MOD UNIVERSE C! 1 +.CUR ENDOF ENDCASE SETUPFLAG @ UNTIL ; --> ( THE GAME OF LIFE, CONTINUED ) : NORMALIZE YLEN 0 DO XLEN 0 DO I J UNIVERSE DUP C@ DUP 4 AND IF DROP 0 ELSE 3 AND IF 1 ELSE 0 ENDIF ENDIF SWAP C! LOOP LOOP ; : GENERATIONS 1 #GENERATION ! CLEAR SETUPLIFE 0 DO DISPLAY GENERATE NORMALIZE 1 #GENERATION +! LOOP DISPLAY XLEN YLEN GOTOXY ; ." Type 'n GENERATIONS <CR>' to play " ;S
