( CAM 5.1 IBM-PC FORTH SOFTWARE 07/07/84 ) ( Initialization ) EX"INIT" START STEPPING : TASK ; 7 SCR ! K ( System messages ) empty stack dictionary full has incorrect address mode is redefined is undefined disk address out of range stack overflow disk error BASE must be DECIMAL missing decimal point PC/FORTH 2.0 Laboratory Microsystems ( System messages ) compilation only, use in definition execution only conditionals not paired definition not finished in protected dictionary use only when loading off current editing screen declare vocabulary illegal dimension in array definition negative array index array index too large ( 8086 Assembler messages ) 16 bit register not allowed 8 bt register not allowed address out of range immediate data value not allowed missing source register missing destination register illegal operation illegal operand instruction not implemented illegal destination register illegal source register illegal condition code register mismatch destination address missing ( *** Our extensions to PC/FORTH *** 05/03/84 ) HEX : EX"INIT" [COMPILE] FORTH DEFINITIONS LIT" INIT" FIND IF EXECUTE ELSE DROP THEN ; ' EX"INIT" 18A ! ( QUIT vector ) : CASE: CREATE ] DOES> SWAP 2* + @ EXECUTE ; : ARRAY ( length --) CREATE 2* ALLOT DOES> SWAP 2* + ; : CARRAY ( length --) CREATE ALLOT DOES> SWAP + ; : $. ( string.addr --) COUNT TYPE ; : READ-FILE READ ; : WRITE-FILE WRITE ; : INPUT-FILENAME REVERSE INPUT-FILENAME REVERSE-OFF SPACE ; : USERS ; LATEST 1+ DEFAULT-FILE 1+ 5 CMOVE FORGET USERS 1 BOOT-SCREEN ! --> ( Accesses to locations within reserved memory, 400 to 5FF ) : CAPS 40 40 17 C!L ; : LOWR 0 40 17 C!L ; : XPOS 40 40 62 C@L 50 + C@L ; : YPOS 40 40 62 C@L 51 + C@L ; : ?CR XPOS 3E > IF CR THEN ; ( CR if near end of line ) --> ( K.NAME list of named keys, in oder of appearance in MENU ) DECIMAL VARIABLE \NEXT : \ HERE \NEXT @ ! 2 \NEXT +! BL WORD HERE OVER C@ 1+ DUP ALLOT CMOVE ; 36 ARRAY K.NAME 0 K.NAME \NEXT ! \ Esc \ Enter \ f1 \ F1 \ f2 \ F2 \ f3 \ F3 \ f4 \ F4 \ f5 \ F5 \ f6 \ F6 \ f7 \ F7 \ f8 \ F8 \ f9 \ F9 \ f10 \ F10 \ Up \ Down \ Left \ Right \ Space \ BkSp \ +Tab \ -Tab \ Ins \ Del \ PgUp \ PgDn \ Home \ End --> ( K.SPECIAL list of named character codes in MENU order ) 0 CARRAY K.SPECIAL 27 C, 13 C, 59 C, 84 C, 60 C, 85 C, 61 C, 86 C, 62 C, 87 C, 63 C, 88 C, 64 C, 89 C, 65 C, 90 C, 66 C, 91 C, 67 C, 92 C, 68 C, 93 C, 72 C, 80 C, 75 C, 77 C, 32 C, 8 C, 9 C, 15 C, 82 C, 83 C, 73 C, 81 C, 71 C, 79 C, --> ( K.ORDINARY list of ordinary character codes in MENU order ) : | [COMPILE] ASCII C, ; 0 CARRAY K.ORDINARY | / | ? | a | A | b | B | c | C | d | D | e | E | f | F | g | G | h | H | i | I | j | J | k | K | l | L | m | M | n | N | o | O | p | P | q | Q | r | R | s | S | t | T | u | U | v | V | w | W | x | X | y | Y | z | Z | 1 | ! | 2 | @ | 3 | # | 4 | $ | 5 | % | 6 | ^ | 7 | & | 8 | * | 9 | ( | 0 | ) | - | _ | = | + | [ | { | ] | } | ; | : | ' | " | ` | ~ | \ | | | , | < | . | > : BS 8 EMIT ; ( Back Space ) : HF ?CR 2 EMIT ; ( Happy Face ) --> ( KGET returns ptr to countd name string, K tries to EXECUTE it) CREATE K.<> 3 C, | < | ? | > K.<> 2+ CONSTANT K.ASC VARIABLE NUMFLG 0 NUMFLG ! 2VARIABLE NUMARG 0 0 NUMARG 2! VARIABLE NUMKEY 0 NUMKEY ! : KGET ( -- string.addr ) PCKEY ?DUP DUP 0= OVER 27 = OR OVER 13 = OR OVER 32 = OR OVER 8 = OR SWAP 9 = OR IF 1 36 0 DO OVER I K.SPECIAL C@ = IF DROP I THEN LOOP K.NAME @ SWAP DROP ELSE K.ASC C! K.<> THEN DUP BS REVERSE $. REVERSE-OFF SPACE ; --> ( KGET returns ptr to countd name string, K tries to EXECUTE it) VARIABLE DNUM 0 DNUM ! ( DEMO step # ) : INCD 1 DNUM +! ; : ?CLRNUM NUMKEY @ DUP NUMFLG ! NOT IF 0 0 NUMARG 2! THEN 0 NUMKEY ! ; VARIABLE KSP VARIABLE KXIT : K 0 KXIT ! CR BEGIN SP@ KSP ! LOWR HF KGET FIND IF EXECUTE ELSE $. ." is undefined" CR THEN SP@ KSP @ <> IF CR ." Stack length modified: " .STACK THEN ?CLRNUM INCD KXIT @ UNTIL ; --> ( Utilities for help in defining keys: & ". ) : & ( compile the name of most recent FORTH word HERE ) LATEST N>LINK @ NAME> , ; IMMEDIATE ( : XYZ ". ; will print XYZ when executed. Note that ". MUST ) ( be the first word in the definition of XYZ for it to work! ) : ". ?CR R@ 4 - >NAME .NAME ; --> ( MENU of keys ) VARIABLE UNFLG : ?UNDEF UNFLG @ IF OUT @ SWAP $. OUT @ - 6 + SPACES ." is undefined" ELSE DROP THEN ; : K. ( string.addr --) FIND IF OUT @ OVER >NAME .NAME OUT @ - 6 + SPACES >BODY BEGIN DUP @ ['] ;S <> WHILE DUP @ >NAME .NAME 2+ REPEAT DROP ELSE ?UNDEF THEN ; : ?POS OUT @ IF OUT @ 35 > IF CR ELSE 35 OUT @ - SPACES THEN THEN ; : MENU CR CR 94 0 DO I K.ORDINARY C@ K.ASC C! K.<> K. ?POS LOOP 36 0 DO I K.NAME @ K. ?POS LOOP ?POS CR ; : Menu.of.all.keys -1 UNFLG ! MENU ; : & ; : Menu.of.defined.keys 0 UNFLG ! MENU ; : & ; --> ( Numeric.Argument , Escape.to.FORTH , Enter ) : Escape.to.FORTH... ". -1 KXIT ! CAPS DECIMAL ; : Esc & ; : Blank.line CR CR ; : Enter & ; 0 CONSTANT 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 4 CONSTANT 4 5 CONSTANT 5 6 CONSTANT 6 7 CONSTANT 7 8 CONSTANT 8 9 CONSTANT 9 : D10* 2DUP D+ 2DUP 2DUP D+ 2DUP D+ D+ ; : Numeric.Argument BS 0 NUMARG 2@ D10* D+ NUMARG 2! -1 NUMKEY ! ; : <0> 0 Numeric.Argument ; : <1> 1 Numeric.Argument ; : <2> 2 Numeric.Argument ; : <3> 3 Numeric.Argument ; : <4> 4 Numeric.Argument ; : <5> 5 Numeric.Argument ; : <6> 6 Numeric.Argument ; : <7> 7 Numeric.Argument ; : <8> 8 Numeric.Argument ; : <9> 9 Numeric.Argument ; --> ( Hexadecimal numeric argument ) : EXPECTR REVERSE EXPECT REVERSE-OFF ; BASE @ HEX : Hexadecimal.argument? ". BASE @ HEX PAD 9 EXPECTR 8 0 DO PAD I + DUP C@ DUP F0 AND 60 = IF 20 XOR THEN SWAP C! LOOP 0 0 PAD 1- CONVERT DROP NUMARG 2! -1 NUMKEY ! BASE ! CR ; : & ; : & ; BASE ! --> : INIT REVERSE-OFF 6 7 SET-CURSOR CONSOLE CAPS DECIMAL CR ; --> ( *** CAM driver routines *** 05/03/84 ) HEX : EQU CONSTANT ; 0 EQU WT -1 EQU RD 380 EQU PORTA 381 EQU PORTB 382 EQU PORTC 383 EQU PCTRL : OK PORTC PC@ 80 AND ; : ?OK BEGIN OK UNTIL ; : CTRL! PCTRL PC! ; ( : STROBE 1 CTRL! 0 CTRL! ;) : REQ 5 CTRL! 4 CTRL! ?OK ; : REL 7 CTRL! 6 CTRL! ; ( : DATA@ PORTA PC@ STROBE ; ) ( : DATA! PORTA PC! STROBE ;) : DATA>AL ASSEMBLER DX, # PORTA MOV AL, DX IN ; : AL>DATA ASSEMBLER DX, # PORTA MOV DX, AL OUT ; : STROBE ASSEMBLER DX, # PCTRL MOV AL, # 1 MOV DX, AL OUT AL, # 0 MOV DX, AL OUT ; CODE DATA@ DATA>AL AX PUSH STROBE NEXT, END-CODE CODE DATA! AX POP AL>DATA STROBE NEXT, END-CODE --> : IN8255 98 CTRL! REL ; : READ ( region--) 98 CTRL! PORTB PC! 3 CTRL! ; : WRITE ( region-) 88 CTRL! PORTB PC! ; : MSAV ( -- region dir) PORTB PC@ PORTC PC@ 2 AND ; : MSET ( region dir --) IF READ ELSE WRITE THEN ; : PLANE ( pl# --region) 10 OR ; : TABLE ( tb# --region) 18 OR ; : RG@ ( reg -- value) MSAV ROT RD MSET DATA@ ROT ROT MSET ; : RG! ( value reg --) MSAV 2SWAP WT MSET DATA! MSET ; : (TO) R> DUP 2+ >R @ >BODY ! ; : TO STATE @ IF COMPILE (TO) ELSE ' >BODY ! THEN ; IMMEDIATE 0 CONSTANT PL# ( Currnt plane#) 0 CONSTANT TB# ( Currnt table#) 0 CONSTANT ST# ( Currnt subtab) 0 CONSTANT P0# ( Plane0 channl) 0 CONSTANT P1# ( Plane1 channl) 0 CONSTANT PH# ( Global phase ) --> ( Low-level CAM words ) : CUR! ( bit.addr --) DUP 2 RG! >< 3 RG! ; : HC 0 CUR! ; : CR1! 1 RG! ; : P@REL ( --PadLast) FF CR1! DATA@ REL ; : P!REL ( PadLast --) FF CR1! DATA! REL ; : >PL PL# PLANE WRITE REQ HC ; : PD REL 0 WRITE ?OK REQ ; : DUP >R 2@ SWAP 1+ 2DUP <= IF DROP 0 THEN DUP ROT R> 2! ; ( can setup a CYCLEic variable with: count period addr 2! ) ( each time it is called, it will return count/mod period ) 1 CYCLE PERIOD ( use "n TO PERIOD" to control STEPPING speed ) --> ( CAM Stepping ) 2VARIABLE SNUM VARIABLE ?STEPPING VARIABLE LEVL 2 CONSTANT MARK : PUSH ( ch0 ch1 phase --) >PD F0 CR1! ROT DATA! SWAP DATA! P!REL 1 LEVL +! ; : INCR PH# 3 XOR TO PH# 1 0 SNUM 2@ D+ SNUM 2! ; : PULL IF PULL THEN ; : FINISH BEGIN LEVL @ 0> WHILE PULL REPEAT ; : ?S0 ( -- f ) SNUM 2@ OR 0= ; : STOP 0 ?STEPPING ! FINISH ; : GO -1 ?STEPPING ! ; : ?STOP ?S0 IF STOP THEN ; : STEP ( ch0 ch1 phase --) PUSH LEVL @ MARK > IF PULL THEN ; : STEPPING PERIOD 0= IF ?STEPPING @ IF P0# P1# PH# STEP INCR ?STOP ELSE ?PULL THEN THEN ; --> : SQR ( byte plane# --) PLANE WRITE REQ 110F F0F DO I CUR! DUP DATA! DUP DATA! 20 +LOOP REL DROP ; : HSEC ( 100ths --) 0 DO @TIME BEGIN 2DUP @TIME D- OR UNTIL 2DROP LOOP ; : FLSH REL 0 READ 4 0 DO 2 HSEC OK IF PULL THEN LOOP 0 LEVL ! ; : INIT INIT IN8255 FLSH 0 ?STEPPING ! 0 0 SNUM 2! 1 TO PERIOD ; --> --> ( == creates fast code words for picking out bits of variable X) VARIABLE X CODE X! AX POP X , AX MOV NEXT, END-CODE CODE X@ AX, X MOV AX PUSH NEXT, END-CODE CREATE ZPUSH ASSEMBLER 1$ JNZ AX, # 0 MOV AX PUSH NEXT, 1$: AX, # 1 MOV AX PUSH NEXT, : X? ( mask byt#-) ASSEMBLER AL, X + MOV AL, # TEST ZPUSH JMP ; 0 CARRAY 2^N 1 C, 2 C, 4 C, 8 C, 10 C, 20 C, 40 C, 80 C, : == ( bit# --) ( ---- name ) >R [COMPILE] CODE R> 8 /MOD SWAP 2^N C@ SWAP X? ASSEMBLER [COMPILE] END-CODE ; 1 == NORTH 3 == WEST 5 == N.WEST 7 == S.WEST 9 == CENTER1 2 == SOUTH 4 == EAST 6 == N.EAST 8 == S.EAST 0 == CENTER ( eg. NORTH will return bit #1 of X when executed ) --> : #DX! ASSEMBLER DX, # MOV ; : #AL! ASSEMBLER AL, # MOV ; : AL.IN ASSEMBLER AL, DX IN ; : AL.OUT ASSEMBLER DX, AL OUT ; : RD, ASSEMBLER ( uses AX and DX ) PORTB #DX! AL.IN AX PUSH PCTRL #DX! 98 #AL! AL.OUT 3 #AL! AL.OUT AX POP PORTB #DX! AL.OUT ; : WT, ASSEMBLER ( uses AX and DX ) PORTB #DX! AL.IN AX PUSH PCTRL #DX! 88 #AL! AL.OUT AX POP PORTB #DX! AL.OUT ; CODE TMERGE ( mask lowbit -- mask) RD, PORTA #DX! AL.IN BL, AL MOV AX POP AL, # 1 TEST AX POP AX PUSH IF BL, AL OR ELSE AL, # FF XOR BL, AL AND ENDIF WT, AL, BL MOV PORTA #DX! AL.OUT PCTRL #DX! 1 #AL! AL.OUT 0 #AL! AL.OUT NEXT, END-CODE --> : *RULE* CENTER ; ( initially ID rule ) : TAB! ( cfa st# tb# --) HC TABLE WRITE REQ 2^N C@ SWAP ['] *RULE* >BODY ! 400 0 DO I X! *RULE* TMERGE LOOP DROP REL ; : RULE.TAB! ( st# tb# --) LIT" RULE" FIND IF ROT ROT TAB! ELSE DROP ." No RULE defined" 2DROP THEN ; --> : O+S OVER + SWAP ; 0 == X0 1 == X1 2 == X2 3 == X3 4 == X4 5 == X5 6 == X6 7 == X7 : 8SHP ( mask byte -- mask ) X! X0 TMERGE X1 TMERGE X2 TMERGE X3 TMERGE X4 TMERGE X5 TMERGE X6 TMERGE X7 TMERGE ; : TSHP ( from.addr to.st# to.tb# --) HC TABLE WRITE REQ 2^N C@ SWAP 80 O+S DO I C@ 8SHP LOOP DROP REL ; : 8BIT ( addr.of.lo.bit -- byte) 0 8 0 DO OVER I + C@ IF I 2^N C@ OR THEN LOOP SWAP DROP ; --> CREATE KBUF 400 ALLOT CREATE TBUF 80 ALLOT HANDLE DF : DXIT DF CLOSE-FILE QUIT ; : ?ERR ?DUP IF .STATUS DXIT THEN ; : ?QUIT ?DUP IF .STATUS QUIT THEN ; --> CODE PORT>BUFF ( dest.seg dest.offset length --) CX POP DI POP DS POP 1$: DATA>AL [DI], AL MOV STROBE DI INC 1$ LOOP AX, CS MOV DS, AX MOV NEXT, END-CODE CODE BUFF>PORT ( src.seg src.offset length --) CX POP DI POP DS POP 1$: AL, [DI] MOV AL>DATA STROBE DI INC 1$ LOOP AX, CS MOV DS, AX MOV NEXT, END-CODE CODE >PORT ( byte count -- ) CX POP 1$: AX POP AX PUSH AL>DATA STROBE 1$ LOOP AX POP NEXT, END-CODE CODE >BUFF ( byte dest.seg dest.offset count --) CX POP DI POP DS POP BX POP 1$: [DI], BL MOV DI INC 1$ LOOP AX, CS MOV DS, AX MOV NEXT, END-CODE --> ( FMOVE -- functional intersegment move ) HEX 88 CONSTANT *MOV* ( fn = 0 ) 20 CONSTANT *AND* ( fn = 1 ) 08 CONSTANT *OR* ( fn = 2 ) 30 CONSTANT *XOR* ( fn = 3 ) CODE FMOVE ( fn s.seg s.off d.seg d.off length --) AX, SI MOV CX POP DI POP ES POP SI POP DS POP DX POP AX PUSH AL, # *XOR* MOV DX, # 3 CMP 1$ JE AL, # *OR* MOV DX, # 2 CMP 1$ JE AL, # *AND* MOV DX, # 1 CMP 1$ JE AL, # *MOV* MOV 1$: CS: HERE 5 + , AL MOV ( modify "[DI], AL MOV" ) 2$: LODS ES: [DI], AL MOV DI INC 2$ LOOP AX, CS MOV ES, AX MOV DS, AX MOV SI POP NEXT, END-CODE --> CODE FORTH.SEG CS PUSH NEXT, END-CODE : BUFF.SEG FORTH.SEG 1000 + ; 0 CONSTANT PL ( plane # ) 0 CONSTANT PB ( address ) : PL>PB ( pl# --) DUP PLANE READ REQ HC 2000 * BUFF.SEG SWAP 2000 PORT>BUFF REL ; : PB>PL ( pl# --) DUP PLANE WRITE REQ HC 2000 * BUFF.SEG SWAP 2000 BUFF>PORT REL ; : XCHNG ( pl# --) DUP TO PL 2000 * TO PB 2000 0 DO PL PLANE READ REQ I CUR! FORTH.SEG KBUF 400 PORT>BUFF PL PLANE WRITE REQ I CUR! BUFF.SEG I PB + 400 BUFF>PORT FORTH.SEG KBUF BUFF.SEG I PB + 400 CMOVEL 400 +LOOP REL ; --> : PL! ( byte pl# --) PLANE WRITE REQ HC 2000 >PORT REL ; : PB! ( byte pl# --) 2000 * BUFF.SEG SWAP 2000 >BUFF ; 0 CONSTANT FN ( boolean fn # ) : BITFN ( pl# fn# --) TO FN DUP TO PL 2000 * TO PB 2000 0 DO PL PLANE READ REQ I CUR! FORTH.SEG KBUF 400 PORT>BUFF FN BUFF.SEG PB I + FORTH.SEG KBUF 400 FMOVE PL PLANE WRITE REQ I CUR! FORTH.SEG KBUF 400 BUFF>PORT 400 +LOOP REL ; --> --> --> ( *** CAM Driver keys *** 05/05/84 ) --> : SQUARES ( byte --) NUMFLG @ IF NUMARG 2@ DROP SQR ELSE DUP 0 SQR 1 SQR THEN ; FF EQU FULL 00 EQU EMPTY : FULL SQUARES ; : EMPTY SQUARES ; : LSTEP ( ch# --) >R NUMFLG @ IF R@ C NUMARG 2@ DROP IF SWAP THEN ELSE R@ R@ THEN 0 STEP R> DROP ; : Negate ". D LSTEP ; : & ; : & ; : Zero.planes ". E LSTEP ; : & ; : One.planes ". F LSTEP ; : & ; : Step(s) ". NUMFLG @ IF NUMARG 2@ DNEGATE SNUM 2! GO ELSE STOP P0# P1# PH# STEP INCR THEN ; : & ; : Continue.steps... ". NUMFLG @ IF NUMARG 2@ SNUM 2! THEN GO ; : & ; --> : Echo ". 1 TO P1# ['] CENTER1 5 0 TAB! ['] CENTER 7 0 TAB! ; : f1 & ; : TRACE CENTER CENTER1 OR ; : Trace ". 1 TO P1# ['] TRACE DUP 5 0 TAB! 7 0 TAB! ; : f3 & ; : Identity ". 1 TO P1# ['] CENTER 5 0 TAB! ['] CENTER1 7 0 TAB! ; : f9 & ; CASE: LIFE 0 0 CENTER 1 0 0 0 0 0 ; : LRULE NORTH SOUTH + EAST + WEST + N.WEST + N.EAST + S.WEST + S.EAST + LIFE ; : 0STD! ( cfa.rule --) 1 TO P0# 1 0 TAB! ; : Life ". ['] LRULE 0STD! ; : f2 & ; --> VARIABLE SHFTNUM 8 SHFTNUM ! VARIABLE KDOWN 0 KDOWN ! CODE KREADY AH, # 1 MOV # 16 INT AX, # 0 MOV 1$ JZ AX, # FFFF MOV 1$: AX PUSH NEXT, END-CODE : KCHK KREADY DUP KDOWN C@ OR KDOWN C! IF 6 FF FDOS 2DROP 6 FF FDOS 2DROP THEN ; : SHIFT ( ch# --) NUMFLG @ IF NUMARG 2@ DROP SHFTNUM C! THEN BEGIN 0 KDOWN C! SHFTNUM C@ 0 ?DO DUP DUP 0 STEP KCHK LOOP KDOWN C@ 0= UNTIL DROP ; : Shift.up 8 SHIFT ; : Up & ; : Shift.down 9 SHIFT ; : Down & ; : Shift.left A SHIFT ; : Left & ; : Shift.right B SHIFT ; : Right & ; --> 0 == z 1 == w 2 == i 3 == j 4 == r3 5 == r1 28 CONSTANT BB# : w1 w r1 XOR ; : w3 w r3 XOR ; CASE: MARG z w1 w i w i j w3 w1 j i w i w w3 z ; : MRULE CENTER X@ F AND BB# X! MARG XOR ; : BB.rule ". NUMFLG @ IF NUMARG 2@ DROP TO BB# THEN 0 TO PH# ." (phase=0) " 0 TO P0# ['] MRULE 4 0 TAB! ; : f4 & ; CASE: HCASE 0 1 1 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 1 1 1 ; : HRULE X@ 1F AND HCASE ; : HGLASS ". ['] HRULE 0STD! ; : f6 & ; : QRULE NORTH SOUTH + EAST + WEST + 2 = CENTER1 XOR ; : Q2R ". ['] QRULE 0STD! ; : f8 & ; : WRULE NORTH EAST AND SOUTH WEST AND XOR CENTER1 XOR ; : Wires ". ['] WRULE 0STD! ; : f10 & ; --> : Put.image.into.buffer ". NUMFLG @ IF NUMARG 2@ DROP 3 AND PL>PB ELSE 0 PL>PB 1 PL>PB THEN ; :

& ; : Get.image.from.buffer ". NUMFLG @ IF NUMARG 2@ DROP 3 AND PB>PL ELSE 0 PB>PL 1 PB>PL THEN ; : & ; : Exchange.display.and.buffer ". NUMFLG @ IF NUMARG 2@ DROP 3 AND XCHNG ELSE 0 XCHNG 1 XCHNG THEN ; : & ; : & ; --> : OR.buffer.into.display ". NUMFLG @ IF NUMARG 2@ DROP 3 AND 2 BITFN ELSE 0 2 BITFN 1 2 BITFN THEN ; : & ; : XOR.buffer.into.display ". NUMFLG @ IF NUMARG 2@ DROP 3 AND 3 BITFN ELSE 0 3 BITFN 1 3 BITFN THEN ; : & ; : AND.buffer.into.display ". NUMFLG @ IF NUMARG 2@ DROP 3 AND 1 BITFN ELSE 0 1 BITFN 1 1 BITFN THEN ; : <+> & ; : <=> & ; --> : PL>FILE ( pl# --) PLANE READ HC REQ 8 0 DO FORTH.SEG KBUF 400 PORT>BUFF DF 400 KBUF WRITE-FILE ?ERR 400 <> IF ." DISK FULL?" DXIT THEN LOOP ; : Put.image.into.the.file: ". DF INPUT-FILENAME DF MAKE-FILE ?QUIT NUMFLG @ IF NUMARG 2@ DROP 3 AND PL>FILE ELSE 0 PL>FILE 1 PL>FILE THEN DF CLOSE-FILE ?ERR REL ; :

& ; --> : FILE>PL ( pl# --) PLANE WRITE HC REQ 8 0 DO DF 400 KBUF READ-FILE ?ERR 400 <> IF ." TRUNCATED?" DXIT THEN FORTH.SEG KBUF 400 BUFF>PORT LOOP ; : Get.image.from.the.file: ". DF INPUT-FILENAME DF OPEN-FILE ?QUIT NUMFLG @ IF NUMARG 2@ DROP 3 AND FILE>PL ELSE 0 FILE>PL DF DF ?OFFSET 2DUP DF ?FILESIZE D= IF 2DROP 0 0 THEN SEEK-ABS DROP 1 FILE>PL THEN DF CLOSE-FILE ?ERR REL ; : & ; --> ( Demonstration facilities 05/13/84 ) HEX : SRCE.SEG BUFF.SEG 800 + ; VARIABLE SPOINT : KSAV.SEG SRCE.SEG 100 + ; VARIABLE KPOINT : DEST.SEG KSAV.SEG 100 + ; VARIABLE DPOINT 142 EQU UKEY 144 EQU U?TERMINAL VARIABLE DLAST : INC ( offset.ptr --) DUP @ 1+ FFF AND SWAP ! ; : PUT ( byte segment offset.ptr --) DUP >R @ C!L R> INC ; : GET ( segment offset.ptr -- byte) DUP >R @ C@L R> INC ; : KPUT ( byte --) KSAV.SEG KPOINT PUT ; : KSAV (KEY) DUP KPUT ; : SAVE.INPUT ['] KSAV UKEY ! ['] (?TERMINAL) U?TERMINAL ! ; : DEST.INS KSAV.SEG 0 DEST.SEG DPOINT @ KPOINT @ CMOVEL DPOINT @ KPOINT @ + FFF AND DPOINT ! 0 KPOINT ! ; --> ( Demonstration facilities 05/13/84 ) : ERASE.KEY KPOINT @ 2- FFF AND KPOINT ! KSAV.SEG KPOINT @ C@L IF KPOINT INC THEN ; : SRCE BEGIN ?STEPPING @ (?TERMINAL) NOT AND WHILE STEPPING REPEAT (?TERMINAL) DLAST @ AND DNUM @ 0= OR SRCE.SEG SPOINT @ @L 0= OR IF SAVE.INPUT KSAV ELSE SRCE.SEG SPOINT GET DUP KPUT DUP DLAST C! THEN ; : DEMO.INPUT ( demo.step.number --) DNUM ! ['] SRCE UKEY ! ['] 1 U?TERMINAL ! ; : ?DEMO UKEY @ ['] SRCE = ; : (Stop.running) ERASE.KEY STOP SNUM 2@ D. ." steps " ; : Space & ; --> ( Demonstration facilities 05/13/84 ) : (Add.keys.to.new.DEMO) ". ERASE.KEY DEST.INS ; : Ins & ; : (Delete.captured.keys) CLEARSCREEN [ LATEST ] LITERAL .NAME CR 0 KPOINT ! ; : Del & ; : (DEMO.step) BS ERASE.KEY NUMFLG @ NUMKEY ! -2 DEMO.INPUT ; : & ; : (Run.DEMO) ". ERASE.KEY NUMFLG @ NUMKEY ! 0 DEMO.INPUT CR CR ; : & ; : Remark REVERSE ." ( " PAD 4C EXPECT 4E XPOS - SPACES ." )" REVERSE-OFF ; : <'> & ; : Remark.to.printer Remark PRINTER CR PAD SPAN @ TYPE CR CONSOLE ; : <"> & ; --> ( Demonstration facilities 05/13/84 ) KBUF EQU DISK.BUF VARIABLE SAVPNT : SAVE.DEMO ." filename? " DF INPUT-FILENAME DF MAKE-FILE ?QUIT 0 SAVPNT ! BEGIN SRCE.SEG SAVPNT @ FORTH.SEG DISK.BUF 400 CMOVEL DF 400 DISK.BUF WRITE-FILE ?ERR 400 <> IF ." DISK FULL?" QUIT THEN 400 SAVPNT +! DISK.BUF 3FE + @ 0= UNTIL DF CLOSE-FILE ?ERR ; : (Save.active.DEMO) ". CR CR ERASE.KEY KPOINT @ ." (use a name of the form *.dem) " SAVE.DEMO KPOINT ! ; : <*> & ; --> ( Demonstration facilities 05/13/84 ) : (Restart.DEMO) ". CR CR 0 SPOINT ! 0 KPOINT ! 0 DPOINT ! 0 DEST.SEG 0 1000 >BUFF ; : Home & ; : DEST>SRCE 0 KPOINT ! 0 SRCE.SEG 0 1000 >BUFF 0 SPOINT ! DEST.SEG 0 SRCE.SEG 0 DPOINT @ CMOVEL 0 DEST.SEG 0 1000 >BUFF 0 DPOINT ! ; : (Activate.new.DEMO) ". DEST>SRCE ; : End & ; : INIT INIT SAVE.INPUT 0 DPOINT ! DEST>SRCE ; --> ( Demonstration facilities 05/13/84 ) : LOAD.DEMO ." filename? " DF INPUT-FILENAME DF OPEN-FILE ?QUIT 0 SPOINT ! BEGIN DF 400 DISK.BUF READ-FILE ?ERR 400 <> IF ." TRUNCATED?" QUIT THEN FORTH.SEG DISK.BUF SRCE.SEG SPOINT @ 400 CMOVEL 400 SPOINT +! DISK.BUF 3FE + @ 0= UNTIL DF CLOSE-FILE ?ERR 0 SPOINT ! 0 KPOINT ! ; --> 0 ARRAY DRIVE 2020 , 3A41 , 3A42 , 3A43 , CREATE TSAV 9 ALLOT CREATE *.DEM BL C, BL C, | * | . | D | E | M BL C, BL C, : DDIR BLK @ 0 BLK ! NUMARG 2@ DROP 3 AND DRIVE @ *.DEM ! >IN @ #TIB @ 0 >IN ! A #TIB ! TIB TSAV 9 CMOVE *.DEM TIB 9 CMOVE DIR TSAV TIB 9 CMOVE #TIB ! >IN ! BLK ! ; : (Load.demonstration.program) ". STOP CR DDIR LOAD.DEMO ; : & ; : & ; --> : -S SNUM 2@ DNEGATE 2DUP SNUM 2! D. ." steps " ; : Swap.planes.&.reverse.count ". ?CR 7 7 0 STEP -S ; : & ; : Change.phase.&.reverse.count ". ?CR PH# 1 XOR TO PH# ." next phase = " PH# . -S ; : & ; : Send.RULE.to.table ". 1 0 RULE.TAB! 1 TO P0# 1 TO P1# ; : & ; : & ; 0 ARRAY XTAB 1 , 10 , 8 , 2 , 4 , 40 , 100 , 20 , 80 , 200 , CODE XROT ( -- rotated.X ) ( X is also changed ) DX, # 0 MOV CX, # A MOV BX, # 1 MOV AX, X MOV DI, # 0 XTAB MOV 1$: AX, [DI] TEST 2$ JZ DX, BX OR 2$: BX, 1 SHL DI INC DI INC 1$ LOOP X , DX MOV DX PUSH NEXT, END-CODE --> : ROT>BUF ( cfa --) ['] *RULE* >BODY ! KBUF 400 FF FILL 400 0 DO I KBUF + C@ FF = IF I X! *RULE* DUP 2DUP X@ KBUF + C! XROT KBUF + C! XROT KBUF + C! XROT KBUF + C! THEN LOOP ; : BUF>TAB ( st# tb# --) HC TABLE WRITE REQ 2^N C@ 400 0 DO I KBUF + C@ TMERGE LOOP DROP REL ; : TAB>BUF ( st# tb# --) HC TABLE READ REQ 2^N C@ 400 0 DO DUP DATA@ AND 0<> I KBUF + C! LOOP DROP REL ; : Rotationally.symmetric.rule ". LIT" RULE" FIND IF ROT>BUF 1 0 BUF>TAB 5 0 BUF>TAB 1 TO P0# 1 TO P1# ELSE DROP ." No RULE defined " 2DROP THEN ; : & ; : & ; --> : Get.table.from.file: ". DF INPUT-FILENAME DF OPEN-FILE ?QUIT DF 80 TBUF READ-FILE ?ERR 80 <> IF ." TRUNCATED?" DXIT THEN DF CLOSE-FILE ?ERR NUMFLG @ IF TBUF NUMARG 2@ DROP 7 AND 0 TSHP ELSE TBUF 1 0 TSHP TBUF 5 0 TSHP THEN ; : +Tab & ; : KBUF>TBUF 80 0 DO I 8 * KBUF + 8BIT TBUF I + C! LOOP ; : Put.table.into.file: ". 1 0 TAB>BUF DF INPUT-FILENAME KBUF>TBUF DF MAKE-FILE ?QUIT DF 80 TBUF WRITE-FILE ?ERR 80 <> IF ." DISK FULL?" DXIT THEN DF CLOSE-FILE ?ERR ; : -Tab & ; --> : Same.rule.as.plane.0 ". 1 0 TAB>BUF 1 TO P1# 5 0 BUF>TAB ; : f5 & ; : CHBIT ( pl# --) DUP PLANE READ REQ F0F CUR! DATA@ 80 XOR SWAP PLANE WRITE REQ F0F CUR! DATA! REL ; : Change.one.spot NUMFLG @ IF NUMARG 2@ DROP 3 AND CHBIT ELSE 0 CHBIT 1 CHBIT THEN ; : & ; : & ; : Faster ". ['] PERIOD >BODY @ 2/ 1 MAX TO PERIOD ; : <.> & ; : Fastest ". 1 TO PERIOD ; : <>> & ; : Slower ". ['] PERIOD >BODY @ 2* 80 MIN TO PERIOD ; : <,> & ; : Slowest ". 80 TO PERIOD ; : <<> & ; --> : SCREEN ( -- scr# ) NUMFLG @ IF NUMARG 2@ DROP DUP SCR ! ELSE SCR @ DUP ." ( screen " . ." ) " THEN ; : Load.screen ". DECIMAL SCREEN 0 0 NUMARG 2! 0 NUMFLG ! LOAD ; : & ; : & ; : Edit.screen ". CAPS SCREEN EDIT ; : & ; : & ; : First.lines.of.screens ". QX ; : & ; : & ; --> ( Random number generator ) HEX CREATE RLIST 13A , 729C , F8C5 , 28B , EEF2 , A8 , B8 , BC03 , 8984 , 37D5 , 10F3 , 9200 , A81C , 1112 , 90F7 , 27CD , 6D24 , 11 ARRAY RANDOM VARIABLE RX : R.INIT RLIST 0 RANDOM 22 CMOVE 20 RX ! ; : INIT INIT R.INIT ; --> ( Random number generator ) CODE DUMMY END-CODE FORGET DUMMY CREATE RND, ASSEMBLER BL INC BL INC BL, # 22 CMP 1$ JL BL, # 22 SUB 1$: BX PUSH AX, [BX+DI] MOV BL, # A SUB 2$ JNS BL, # 22 ADD 2$: BX, [BX+DI] MOV AX, BX ADD BX POP [BX+DI], AX MOV RET CODE RND ( -- rnd) DI, # 0 RANDOM MOV BX, RX MOV RND, CALL RX , BL MOV AX PUSH NEXT, END-CODE : Initialize.random.number.gen ". R.INIT NUMFLG @ IF NUMARG 2@ DROP 0 RANDOM ! 40 0 DO RND DROP LOOP THEN ; : & ; : & ; --> VARIABLE NUM.ONES 8000 TO NUM.ONES : ACMP ( mm -- ) 3B C, 06 C, , ; ( AX, mm CMP ) CODE RND>PL, DI, # 0 RANDOM MOV BX, RX MOV CX, # 2000 MOV 1$: DL, # 0 MOV RND, CALL NUM.ONES ACMP DL, 1 RCL RND, CALL NUM.ONES ACMP DL, 1 RCL RND, CALL NUM.ONES ACMP DL, 1 RCL RND, CALL NUM.ONES ACMP DL, 1 RCL RND, CALL NUM.ONES ACMP DL, 1 RCL RND, CALL NUM.ONES ACMP DL, 1 RCL RND, CALL NUM.ONES ACMP DL, 1 RCL RND, CALL NUM.ONES ACMP DL, 1 RCL AL, DL MOV AL>DATA STROBE 1$ LOOP RX , BL MOV NEXT, END-CODE : RND>PL ( pl# --) PLANE WRITE REQ HC RND>PL, REL ; --> CODE 8000RND, DI, # 0 RANDOM MOV BX, RX MOV CX, # 1000 MOV 1$: RND, CALL AL>DATA STROBE AL, AH MOV AL>DATA STROBE 1$ LOOP RX , BL MOV NEXT, END-CODE : 8000RND ( pl# --) PLANE WRITE REQ HC 8000RND, REL ; : ?RND>PL NUM.ONES @ 8000 = IF 8000RND ELSE RND>PL THEN ; : Random.configuration ". NUMFLG @ IF NUMARG 2@ DROP 3 AND ?RND>PL ELSE 0 ?RND>PL 1 ?RND>PL THEN ; : <;> & ; : Number.of.ones ". NUMFLG @ IF NUMARG 2@ DROP ELSE ." (half ones) " 8000 THEN NUM.ONES ! ; : <:> & ; --> 20 ARRAY BOX0 20 ARRAY BOX1 20 CYCLE BX : B0PUT 0 PLANE WRITE REQ 110F F0F DO I CUR! BX BOX0 C@ DATA! BX BOX0 C@ DATA! 20 +LOOP REL ; : B1PUT 1 PLANE WRITE REQ 110F F0F DO I CUR! BX BOX1 C@ DATA! BX BOX1 C@ DATA! 20 +LOOP REL ; : B0GET 0 PLANE READ REQ 110F F0F DO I CUR! DATA@ BX BOX0 C! DATA@ BX BOX0 C! 20 +LOOP REL ; : B1GET 1 PLANE READ REQ 110F F0F DO I CUR! DATA@ BX BOX1 C! DATA@ BX BOX1 C! 20 +LOOP REL ; : Load.boxes ". B0GET B1GET ; : & ; : Store.boxes ". B0PUT B1PUT ; : & ; --> ( Randomly chosen LIFE-like counting rules ) HEX A ARRAY LKUP 4000 CONSTANT TH1 8000 CONSTANT TH2 C000 CONSTANT TH3 : 4RND RND DUP TH1 U< IF 0 ELSE DUP TH2 U< IF 1 ELSE DUP TH3 U< IF 2 ELSE 3 THEN THEN THEN SWAP DROP ; : NOT.CENTER CENTER 1 XOR ; CASE: 4CASE 0 NOT.CENTER CENTER 1 ; : PREP A 0 DO 4RND DUP . I LKUP ! LOOP ; : TRUL NORTH SOUTH + EAST + WEST + N.EAST + N.WEST + S.EAST + S.WEST + LKUP @ 4CASE ; : Counting.rules ". PREP ['] TRUL ROT>BUF KBUF KBUF 200 + 200 CMOVE 1 0 BUF>TAB 5 0 BUF>TAB 1 TO P0# 1 TO P1# ; : & ; : & ; --> VARIABLE DSPL : I.DSPL 80 TO DSPL 80 7 RG! ; : INIT INIT I.DSPL ; : SET.DSPL ( f --) 3 VPAGE CLEARSCREEN 0 PLANE READ REQ DUP TO DSPL 7 RG! E HSEC 0 VPAGE REL ; : Alternate.display ". DSPL @ 80 XOR SET.DSPL ; : & ; : PC.display ". 80 SET.DSPL ; : & ; --> : Wait ". NUMFLG @ IF NUMARG 2@ DROP HSEC ELSE CR ." Hit any key to continue " (KEY) 0= IF (KEY) DROP THEN THEN ; : & ; : & ;