\S CAM key-interpreter routines (c) Margolus/Toffoli 03Jul87cam \ CAM key-interpreter routines 03Jul87cam 2 CAPACITY 1- THRU \ Letting one Forth word be an alias for another 16Feb89nhm VARIABLE AKA ROOT DEFINITIONS : ALIASES CONTEXT AKA @! ; ALIASES : (ALIAS) WARNING @ WARNING OFF CURRENT @ AKA CURRENT @! LAST @ DUP NAME> CREATE , ?NEW SPACE LAST @ .NAME ." is alias for " .NAME CURRENT ! WARNING ! ; \ Different vocabularies for different kinds of keys 29Mar87nhm : ALIAS (ALIAS) DOES> @ DUP >NAME .NAME EXECUTE ; : ORDER ORDER CR ." Aliases: " AKA @ BODY> >NAME .NAME ; VOCABULARY GENERAL VOCABULARY EDITING,RUNNING VOCABULARY DISPLAY-CONTROL VOCABULARY PLANE-OPS VOCABULARY DOTS,SHIFTS VOCABULARY ALTERNATE ONLY FORTH ALSO DEFINITIONS GENERAL ALIASES : VOC-MENU { GENERAL DISPLAY-CONTROL EDITING,RUNNING PLANE-OPS DOTS,SHIFTS ALTERNATE } ; : .VOC CONTEXT @ BODY> >NAME .NAME ; \ Getting a key-press and finding its name 29Mar87nhm : INVERT (S addr -- ) DUP @ NOT SWAP ! ; : BACK BS EMIT ; ( back space ) : KGET (S -- string.addr) PCKEY BACK KNAME ?DUP 0= IF [ 1B KNAME ] LITERAL ( Esc ) THEN DUP DUP INTENSITY INVERT 0 K.ALT U< IF COUNT TYPE ELSE UNDERLINE INVERT COUNT TYPE UNDERLINE INVERT THEN INTENSITY INVERT SPACE ; \ Numeric arguments 24Sep85nhm 2VARIABLE NUMARG 2VARIABLE NUMARG' VARIABLE AFLAG VARIABLE AFLAG' : ARG? (S -- f ) AFLAG' @ ; : ARG (S -- n ) NUMARG' 2+ @ ; : 2ARG (S -- d ) NUMARG' 2@ ; : =ARG (S addr -- ) ARG? IF ARG SWAP ! ELSE DROP THEN ; : =2ARG (S addr -- ) ARG? IF 2ARG ROT 2! ELSE DROP THEN ; \ Get a key and execute it 29Mar87nhm : NEW-NUMARG NUMARG 2@ NUMARG' 2! AFLAG AFLAG' @! 0. NUMARG 2! AFLAG OFF ; NEW-NUMARG : KKEY NEW-NUMARG SP@ >R KGET DUP 0 K.ALT U< IF ONLY 5 0 DO I VOC-MENU ALSO LOOP ELSE ONLY ALTERNATE THEN FIND IF S-KEYS ON EXECUTE ELSE DROP ." is undefined " THEN SP@ R> - ?DUP IF NEGATE DUP 0< ABORT" Stack Underflow!" CR ." Stack length modified by " 2/ . THEN ; \ 23Mar87nhm: FACE ( happy face ) ?CR #OUT @ 0= IF SPACE THEN 50 BL V-EMIT STEPPING? @ 2+ EMIT F S-KEYS C! ; : CBORDER TRUE TEMP-SEG 0 C/8 1+ 2/ STORES R/8 8* 1- 1 DO 80 TEMP-SEG I C/8 * 2DUP 1 -ROT C!L C/8 + 1- 1 ORS LOOP TRUE TEMP-SEG #SQR 8* C/8 - C/8 1+ 2/ STORES 4 1 DO TEMP-SEG 0 TEMP-SEG #SQR 8* DUP I * SWAP LMOVE LOOP ; CODE SEG= (S seg1 offs1 seg2 offs2 len -- f ) CX POP DI POP ES POP AX POP BX POP DS PUSH SI PUSH AX SI MOV BX DS MOV REPZ BYTE CMPS = IF FFFF # AX MOV ELSE AX AX XOR THEN SI POP DS POP 1PUSH END-CODE \ Showing and hiding the cage 29Mar87nhm VARIABLE CFLAG CFLAG OFF VARIABLE DFLAG DFLAG OFF : TMP2-AREA CAGE-AREA TEMP-SEG 100 + IS A-SEG ; : TMP3-AREA TEMP-SEG 180 + 20 20 AREA ; : ?SHOW-CAGE CFLAG @ IF TMP2-AREA PLS>PBS 0 TEMP-SEG 0 400 STORES CAGE-AREA CBUF-SEG 0 TEMP-SEG 0 #SQR 20 * SEG= IF CBORDER TMP2-AREA A-SEG 0 TEMP-SEG 0 800 BUF-XOR TEMP-SEG R/8 C/8 AREA THEN PBS>PLS THEN ; : ?HIDE-CAGE CFLAG @ IF TMP2-AREA PBS>PLS THEN ; \ Dot editing, and running steps 29Mar87nhm : MOUSE/KEY DFLAG @ IF DOT-EDIT ELSE CFLAG @ IF CAGE-CORN BEGIN SHOW-CORN PEEK UNTIL ELSE BEGIN IDLE PEEK UNTIL THEN THEN ; : ?RUN-STEPS STEPPING? @ IF RUN-STEPS CFLAG @ IF ?XNORM ?SHOW-CAGE ?XSHOW THEN BACK FACE ELSE ?SHOW-CAGE ?XSHOW THEN XUPDATE OFF MOUSE/KEY ?XNORM XUPDATE @ IF MIDDLE-AREA PBS>PLS THEN ?HIDE-CAGE ; \ Key interpreter, main loop 29Mar87nhm : KEY-INTERPRETER STATE OFF BLK OFF SP0 @ DUP 'TIB ! SP! RP0 @ RP! NORMAL 33 RMARGIN ! FACE LOWR BEGIN IDLE PEEK IF DECIMAL WHOLE-AREA CAM-AB KKEY FACE LOWR THEN SP@ >R ?RUN-STEPS SP@ R> - ABORT" Run Error!" AGAIN ; 1 IS LMARGIN ( Used by FACE ) \ Escaping and trapping to Key interpreter 25Jul87nhm : CLR-FLAGS CFLAG OFF DFLAG OFF GFLAG OFF XFLAG OFF STEPPING? OFF COLOR-MASK OFF #IDLES OFF 0 INVISIBLE 200 DUP LAST-POS 2! NEW-NUMARG PC ; : KTRAP (TRAP) CLR-FLAGS KEY-INTERPRETER ; : GOTO-K ['] KTRAP IS TRAP KEY-INTERPRETER ; : ESC-KEY REVERSE OFF BACK-UP GOTO-K ; ' ESC-KEY CT-FORTH 1B ( Esc ) 2* + ! : TEN* (S d -- d' ) 2DUP D+ 2DUP 2DUP D+ 2DUP D+ D+ ; : >NUMARG (S n -- ) BACK 0 2ARG TEN* D+ NUMARG 2! AFLAG ON ; \ Numeric arguments 28Mar87nhm : Number: HEX BASE =ARG BL HERE 1+ DUP 3C UPPR EXPECTR SPAN @ DUP HERE C! + C! HERE NUMBER NUMARG 2! AFLAG ON ; ALIAS # GENERAL DEFINITIONS WARNING @ WARNING OFF : 9 9 >NUMARG ; : 8 8 >NUMARG ; : 7 7 >NUMARG ; : 6 6 >NUMARG ; : 5 5 >NUMARG ; : 4 4 >NUMARG ; : 3 3 >NUMARG ; : 2 2 >NUMARG ; : 1 1 >NUMARG ; : 0 0 >NUMARG ; FORTH DEFINITIONS WARNING ! \ Exiting to DOS and to Forth 28Mar89nhm : DOS... CR CR LOWR PC ." (Type `exit' to return)" COM ABORT ; ALIAS ~ : (ignored) ; ALIAS Esc : PTRAP (TRAP) PC ; : Forth... CR CR ." (Press `Esc' to return)" CR NORMAL 0 INVISIBLE 46 RMARGIN ! SET-BASE ['] PTRAP IS TRAP ONLY FORTH ALSO DEFINITIONS QUIT ; ALIAS F ALIAS f \ Printing menus and sub-menus 29Mar87nhm : ?POS #OUT @ IF #OUT @ 23 > IF CR ELSE 23 #OUT @ - SPACES THEN THEN ; HERE ALIAS DUMMY LAST @ NAME> @ SWAP (FORGET) EQU ACODE : ?ALIAS (S cfa -- ) DUP @ ACODE = IF >BODY @ >NAME .NAME ELSE DROP THEN ; : .ALIASES CONTEXT @ HERE #THREADS 2* CMOVE BEGIN HERE #THREADS LARGEST DUP WHILE DUP L>NAME DUP .NAME NAME> ?ALIAS ?POS @ SWAP ! REPEAT 2DROP ?POS CR ; \ Printing menus and sub-menus 29Mar87nhm : SUB-MENU (S n -- ) VOC-MENU .VOC CR CR .ALIASES CR ; : MENU ARG? IF ARG SUB-MENU ELSE CR CR 6 0 DO 10 SPACES I (.) TYPE ." m " I VOC-MENU .VOC CR LOOP CR THEN ; ALIAS M ALIAS m : CAM-EXPECTR CCR C@CAM CAMOUT AND -ROT PC (EXPECTR) SET-CCR ; ' CAM-EXPECTR IS EXPECTR DISPLAY-CONTROL ALIASES : Blue.on 0 +BEAM ; ALIAS F10 : Toggle.blue 0 *BEAM ; ALIAS f10 : Green.on 1 +BEAM ; ALIAS F8 : Toggle.green 1 *BEAM ; ALIAS f8 : Red.on 2 +BEAM ; ALIAS F6 : Toggle.red 2 *BEAM ; ALIAS f6 : Inten.on 3 +BEAM ; ALIAS F4 : Toggle.inten 3 *BEAM ; ALIAS f4 : Std.map SHOW-STATE COLOR-MASK OFF MAKE-CMAP STD-MAP ; ALIAS F2 : IRGB.map SHOW-STATE COLOR-MASK OFF MAKE-CMAP IRGB-MAP ; ALIAS f2 \ Keys: grid on/off 29Mar87nhm : Grid.off GFLAG OFF ; ALIAS " : Toggle.grid GFLAG @ NOT GFLAG ! ; ALIAS ' \ Display size, and sources 29Mar87nhm: X-FIX 0 INVISIBLE MOUSE-ROW 60 - 3F AND 60 + 4* MOUSE-COL 60 - 3F AND 60 + 4* LAST-POS 2! ; : Normal.size XFLAG OFF X-FIX ; ALIAS X : Toggle.expanded.view XFLAG @ NOT XFLAG ! X-FIX ; ALIAS x : CAM#ARG (S -- n ) ARG? IF ARG #CAMS 1- MIN ELSE CAM# @ THEN ; : Show.PC.display CAM#ARG CAM-SELECT PC ; ALIAS A : Toggle.display.source ARG? IF CAM#ARG CAM-SELECT CAM ELSE CCR C@CAM CAMOUT AND IF PC ELSE CAM THEN THEN ; ALIAS a \ Shifting the screen 29Mar87nhm VARIABLE SH-COUNT VARIABLE HMASK HMASK OFF : ALL&PHASES (S n --) FOR-ALL-CAMS DUP IS <&PHASES> NEXT-CAM DROP ; \ Shifting the screen 29Mar87nhm : SHIFT (S NSWE.mask -- ) DUP 1 AND IF 1 ALL&PHASES STEP THEN DUP 2 AND IF 0 ALL&PHASES STEP THEN DUP 4 AND IF 3 ALL&PHASES STEP THEN 8 AND IF 2 ALL&PHASES STEP THEN 1 SH-COUNT +! ; VARIABLE KDOWN KDOWN OFF CODE KREADY (S -- f ) 1 # AH MOV 16 INT FALSE # AX MOV 0<> IF TRUE # AX MOV THEN 1PUSH END-CODE : KCHECK KREADY DUP KDOWN @ OR KDOWN ! IF FF 6 BDOS DROP FF 6 BDOS DROP THEN ; \ Shifting the screen 29Mar87nhm VARIABLE SHFTNUM 8 IS SHFTNUM 0 ARRAY FIX-SMALL 0 , 8 , 8 , 9 , 8 , A , C , E , : SMULT SHFTNUM C@ DUP 8 < IF FIX-SMALL @ THEN ; : SHIFT-KEY (S dir -- ) SHFTNUM =ARG BEGIN-SERVICE-STEPS HMASK @ SEND-SHIFTS SH-COUNT OFF KDOWN OFF SHFTNUM @ 1FF AND 0 ?DO DUP SHIFT KCHECK LOOP KDOWN @ IF BEGIN KDOWN OFF SMULT 0 ?DO DUP SHIFT KCHECK LOOP KDOWN @ 0= UNTIL THEN DROP SH-COUNT @ . END-SERVICE-STEPS ; \ Shifting the cursor, and/or the screen 29Mar87nhm : MOUSE>ORG (S -- delta-row delta-col ) 80 MOUSE-ROW - 2/ 2* DUP 4* LAST-POS 2+ +! 80 MOUSE-COL - 2/ 2* DUP 4* LAST-POS +! ; : SHIFTS (S delta-row delta-col hold.mask -- ) BEGIN-SERVICE-STEPS SEND-SHIFTS DUP ABS 0 ?DO DUP SIG 1+ { 2 0 1 } SHIFT LOOP DROP DUP ABS 0 ?DO DUP SIG 1+ { 8 0 4 } SHIFT LOOP DROP END-SERVICE-STEPS ; DOTS,SHIFTS ALIASES : Insert.dot MOUSE-POS DOT-PLN @ CHANGE-NSPOT ; ALIAS Ins DOTS,SHIFTS DEFINITIONS : DnRt 5 SHIFT-KEY ; : DnLt 6 SHIFT-KEY ; : UpRt 9 SHIFT-KEY ; : UpLt A SHIFT-KEY ; : Right 1 SHIFT-KEY ; : Left 2 SHIFT-KEY ; : Down 4 SHIFT-KEY ; : Up 8 SHIFT-KEY ; FORTH DEFINITIONS \ Keys for shift-origin, hold/unhold, and dots on/off 29Mar87nhm : Shift.to.origin MOUSE>ORG 0 SHIFTS ; ALIAS O : Cursor.to.origin MOUSE>ORG 2DROP ; ALIAS o : Unhold HMASK @ ARG? IF ARG 2^N NOT ELSE 0 THEN AND HMASK ! ; ALIAS H : Hold.fixed HMASK @ ARG? IF ARG 2^N ELSE F THEN OR HMASK ! ; ALIAS h : Dots.off DOT-PLN =ARG DFLAG OFF ; ALIAS D : Toggle.dots CFLAG OFF ARG? IF DFLAG ON DOT-PLN =ARG ELSE DFLAG @ NOT DFLAG ! THEN ; ALIAS d EDITING,RUNNING ALIASES : GO STEPPING? ON ; : STOP STEPPING? OFF ; : Stop.running STOP ." (" STEP-NUMBER 2@ D. ." steps) " ; ALIAS Space : Fastest! #IDLES OFF ; ALIAS > : Faster #IDLES @ 1+ 2/ 1 MAX 1- #IDLES ! ; ALIAS . : Slowest! 7F #IDLES ! ; ALIAS < : Slower #IDLES @ 1+ 2* 80 MIN 1- #IDLES ! ; ALIAS , \ Running steps 29Mar87nhm : Continue.steps... STEP-NUMBER =2ARG GO ; ALIAS S : Step(s) ARG? IF 2ARG DNEGATE STEP-NUMBER 2! GO ELSE STOP NEXT-STEP SLOW-KEY THEN ; ALIAS s \ Tables to or from files 16Feb89nhm : Tab.<--.file: TAB-NAME FILE>TAB ; ALIAS -Tab : Tab.-->.file: TAB-NAME [ DOS ] FCB2 ?OVERWRITE IF TAB>FILE THEN ; ALIAS +Tab \ List all non-blank lines of a screen : XLIST CR L/SCR 0 DO DUP I LINE DUP IF CR 8 SPACES THEN TYPE-S LOOP DROP CR CR ; \ Edit screen, load screen 15Feb89nhm EDITOR ALSO : EXPERIMENT-NAME " *.EXP " 1+ FILE-NAME ; : KLOAD ONLY FORTH ALSO DEFINITIONS SET-BASE ARG IF SCR =ARG ARG LOAD ELSE ." (all screens) " 0 XLIST 1 CAPACITY 1- THRU THEN ; : ?IN-FILE-OK [ DOS ] PAD SET-DMA IN-FILE @ SEARCH0 ABORT" Default not found!" ; \ Edit screen, load screen 19Mar87nhm : Load.new.file: [ DOS ] EXPERIMENT-NAME FCB1 USE-FCB 1 SCR ! OPEN-FILE KLOAD ; ALIAS L : Load [ DOS ] ?IN-FILE-OK OPEN-FILE KLOAD ; ALIAS l : Edit.new.file: PC [ DOS ] EXPERIMENT-NAME (USING) NORMAL SCR DUP =ARG @ EDIT SPACE ; ALIAS E : Edit.screen PC [ DOS ] ?IN-FILE-OK NORMAL SCR =ARG ... SPACE ; ALIAS e ASCII E UEXT 2 + C! \ New default extension is ".EXP" ASCII X UEXT 3 + C! ASCII P UEXT 4 + C! PLANE-OPS ALIASES : C/W-AREA CFLAG @ IF CAGE-AREA ELSE WHOLE-AREA THEN ; : ?CAGE*PLNS CFLAG @ IF TMP2-AREA PLS>PBS CAGE-AREA PBS>PLS TEMP-SEG 1000 CBUF-SEG 0 800 LMOVE THEN ; DEFER PLF \ Note that some of these routines use 2nd half of TEMP-SEG \ when CAGE is active! (tmp2 and tmp3 areas, see above). : (PL-FN) (S fn-cfa -- ) IS PLF ARG? ARG 4 U< AND IF C/W-AREA ARG PLF ELSE ARG 5 U> ABORT" Illegal plane argument" ARG 3 MOD DUP { 4 2 4 } SWAP { 0 0 2 } DO C/W-AREA I PLF LOOP THEN SLOW-KEY ; \ Two kinds of plane functions 29Mar87nhm : PL-FN (S fn-cfa -- ) ?CAGE*PLNS (PL-FN) ?CAGE*PLNS ; : TURN-PL-FN (S cfa -- ) CFLAG @ IF ARG? C-HEIGHT @ C-WIDTH @ <> AND ABORT" Non-square single-plane op not supported" TMP3-AREA PLS>PBS CAGE-AREA PBS>PLS (PL-FN) C-HEIGHT @ C-WIDTH C-HEIGHT @! C-WIDTH ! CAGE-AREA PLS>PBS TMP3-AREA PBS>PLS ELSE (PL-FN) THEN ; \ Permute plane contents 20Mar87nhm 0 EQU P/8 VARIABLE PERM DECIMAL 0123 IS PERM HEX : TSS (S tn# -- seg offs r- c- #r #b inc ) TEMP-SEG SWAP #SQR * R- P/8 + C- B/C 8 / C/8 8 ; : PERMUTE (S new3 new2 new1 new0 -- ) 8 0 DO I IS P/8 4DUP 4 0 DO I TSS PDAT>BUF LOOP 4 0 DO I 2^N I TSS BUF>PDAT LOOP LOOP 2DROP 2DROP ; : Permute/copy.planes PERM =ARG C/W-AREA ?CAGE*PLNS PERM @ A /MOD A /MOD A /MOD PERMUTE ?CAGE*PLNS ; ALIAS ^ \ Random number generation 15Feb89nhm : Init.random.number.generator R-INIT ARG? IF ARG RAND-SEG 0 !L THEN 400 0 DO RND DROP LOOP ; ALIAS I ALIAS i VARIABLE #ONES 8000 EQU HALF HALF IS #ONES : ?HALF HALF #ONES @ = IF ." (half ones)" THEN ; : Number.of.ones HALF #ONES ! #ONES =ARG ?HALF ; ALIAS : : Random.configuration C/W-AREA #ONES @ TEMP-SEG 0 #SQR 8* RND>BUF ['] TEMP>PL PL-FN ; ALIAS ; : Percent.of.ones 32 ( 50% ) #ONES ! #ONES =ARG 0 #ONES @ 64 UM/MOD NIP #ONES ! ?HALF ; ALIAS % \ Keys: put, get, and exchange plane contents 29Mar87nhm : Exchange.display.and.buffer ['] P*BUF PL-FN ; ALIAS * : Put.image.into.the.file: [ DOS ] IMAGE-NAME ?PAT ?OVERWRITE IF ?PAT TEMP-SEG 0 2000 DISK-PUT REC0 ['] PL>REC (PL-FN) ?PAT CLOSE THEN ; ALIAS P : Put.image.into.buffer ['] PL>PB PL-FN ; ALIAS p : Get.image.from.the.file: IMAGE-NAME ['] FILE>PL (PL-FN) ; ALIAS G : Get.image.from.buffer ['] PB>PL PL-FN ; ALIAS g \ Keys: plane utilities 29Mar87nhm : NOT-plane(s) ['] NOT-PL PL-FN ; ALIAS - : XOR-plane(s) ['] XOR>PL PL-FN ; ALIAS $ : AND-plane(s) ['] AND>PL PL-FN ; ALIAS & : OR-plane(s) ['] OR>PL PL-FN ; ALIAS + : S/S-flip-plane(s) ['] S/S-PL PL-FN ; ALIAS | : T/B-flip-plane(s) ['] T/B-PL PL-FN ; ALIAS _ : /-flip-plane(s) ['] /-PL TURN-PL-FN ; ALIAS / : \-flip-plane(s) ['] \-PL TURN-PL-FN ; ALIAS \ : CCW-plane(s) ['] CCW-PL TURN-PL-FN ; ALIAS R : CW-plane(s) ['] CW-PL TURN-PL-FN ; ALIAS r \ Keys: fill/clear plane, cage on/off 29Mar87nhm : CLEAR (S val -- ) TEMP-SEG 0 1000 STORES ['] TEMP>PL PL-FN ; : Fill.plane(s) TRUE CLEAR ; ALIAS Z : Zero.plane(s) FALSE CLEAR ; ALIAS z : C-ARG ARG A < IF ARG ARG ELSE ARG A /MOD THEN 1 MAX 8 MIN C-WIDTH ! 1 MAX 8 MIN C-HEIGHT ! 0 CBUF-SEG 0 400 STORES ; : Cage.off ARG? IF C-ARG THEN CFLAG OFF ; ALIAS C : Toggle.cage DFLAG OFF ARG? IF CFLAG ON C-ARG ELSE CFLAG @ NOT CFLAG ! THEN ; ALIAS c \ New experiment 14Mar89nhm DEFER NEWX \ Fix to worry about erasing FCBs? : NEW-EXPERIMENT SAVE-BUFFERS NEWX RESET-CAMS CLR-FLAGS 61 PC@ FC AND 61 PC! ( Turn sound off ) PAT-FILE OFF TAB-FILE OFF DATA-FILE OFF HMASK OFF HALF #ONES ! 0. STEP-NUMBER 2! ;