\ Forth 3.3 >>>> FORTH.BLK <<<< 22jun84tvm : ESC ( -- ) 27 EMIT ; : SET-ATT ( n -- ) 1 ?ENOUGH ESC ASCII G EMIT EMIT ; : NATT ( -- ) ESC ASCII G EMIT ASCII 0 EMIT ; VARIABLE VIDEO 0 VIDEO ! VARIABLE (VIDEO) 0 (VIDEO) ! : ?VIDEO ( -- flag ) VIDEO @ 0= ; \ True if Reverse Video : NVID ( -- ) ESC 100 EMIT 0 VIDEO ! ; : RVID ( -- ) ESC 98 EMIT 1 VIDEO ! ; : !VID ( -- ) VIDEO @ (VIDEO) ! ; : @VID ( -- ) (VIDEO) @ VIDEO ! ; EDITOR : KILL ( scr# --- ) 1 ?ENOUGH SCR ! ." Erasing Screen #" SCR ? ." ... " EDITOR WIPE FORTH ." Done." CR ; VARIABLE ?EDIT 0 ?EDIT ! FORTH \ Non-edit mode \ Forth 3.3 MISC. WORDS VARIABLE VARIABLE VARIABLE : S ( -- current scr# ) SCR @ ; : LS ( scr -- ) LIST ; 12750 CONSTANT 1SEC \ approx. : LD ( scr -- ) 1 ?ENOUGH SCR ! ." Loading Scr #" S DUP . ." ..." LOAD ." Done." CR ; : B: 2 BASE ! ; : END CR ." Exit" CR QUIT ; : O: 8 BASE ! ; : STAR 42 EMIT ; : BELL 7 EMIT ; : D: 10 BASE ! ; : WAIT 1 ?ENOUGH 0 DO LOOP ; : H: 16 BASE ! ; : ASC ( -- char ) KEY CR . ; : 1WORD ( pfa [i.e. ' WORD] -- ) 1 ?ENOUGH SPACE NFA ID. ; : !VOC CURRENT @ ! CONTEXT @ ! ; : @VOC @ CURRENT ! @ CONTEXT ! ; : !BASE BASE @ ! ; : @BASE @ BASE ! ; : !STAT !VOC !BASE ; : @STAT @VOC @BASE ; \ Forth 3.3 ADDS Cursor Addressing 12dec83tvm EDITOR DEFINITIONS : ADDS-AT ( X Y --- ) ESC 89 EMIT BL + EMIT BL + EMIT ; : ADDS-DARK ( -- ) 12 EMIT ; : ADDS-BLOT DROP ESC 75 EMIT ; : ADDS FORTH ['] ADDS-AT IS AT ['] ADDS-DARK IS DARK ['] ADDS-BLOT IS BLOT ; FORTH DEFINITIONS \ Forth 3.3 ADDS, ADM Cursor Control 10dec83tvmDEFERRED LFT DEFERRED RT DEFERRED UP DEFERRED DN : ADDS-LFT 1 + 1 DO 21 EMIT LOOP ; : ADDS-RT 1 + 1 DO 6 EMIT LOOP ; : ADDS-UP 1 + 1 DO 26 EMIT LOOP 21 EMIT ; : ADDS-DN 1 + 1 DO 10 EMIT LOOP 21 EMIT ; : ADM-LFT 1 + 1 DO 8 EMIT LOOP ; : ADM-RT 1 + 1 DO 12 EMIT LOOP ; : ADM-UP 1 + 1 DO 11 EMIT LOOP 8 EMIT ; : ADM-DN 1 + 1 DO 10 EMIT LOOP 8 EMIT ; : ADDS ['] ADDS-LFT IS LFT ['] ADDS-RT IS RT ['] ADDS-UP IS UP ['] ADDS-DN IS DN EDITOR ADDS FORTH ; : ADM ['] ADM-LFT IS LFT ['] ADM-RT IS RT ['] ADM-UP IS UP ['] ADM-DN IS DN EDITOR ADM FORTH ; \ Forth 3.3 FREEDOM Terminal Attributes : CUR/BLK ESC 46 EMIT 48 EMIT ; : CUR/OFF ESC 46 EMIT 49 EMIT ; : CUR/LINE ESC 46 EMIT 51 EMIT ; : BEL/OFF ESC 95 EMIT ; : BEL/ON ESC 94 EMIT ; : CLR 26 EMIT ; : KSTAT ESC 103 EMIT ; : DSTAT ESC 104 EMIT ; : WP/ON ESC 41 EMIT ; : WP/OFF ESC 40 EMIT ; : PROT/ON ESC 38 EMIT ; : PROT/OFF ESC 39 EMIT ; : UNRATT ASCII < SET-ATT ; : NATT/2 ASCII @ SET-ATT ; : UNRATT/2 ASCII L SET-ATT ; : RATT ASCII 4 SET-ATT ; : RATT/2 ASCII D SET-ATT ; : UNATT ASCII 8 SET-ATT ; : UNATT/2 ASCII H SET-ATT ; \ Forth 3.3 1/2RATT LOGIN ID? K WR .EOS *LINE : 1/2RATT ?VIDEO IF RATT/2 ELSE NATT/2 THEN ; EDITOR EDITOR DEFINITIONS : LOGIN EDITOR 0 ID C! GET-ID ; : ?ID ( -- ) ( display ID string ) CR !VOC EDITOR ID 10 TYPE CR @VOC ; : K ( -- ) >INSERT PAD 132 MOVE PAD >FIND 66 MOVE ; : -ID ( -- ) BEGINNING 54 + 10 BLANK MODIFIED ; : WR ( -- ) UPDATE FLUSH @R# ED !R# ; : .EOS ( Set Attribute for Editor Delimiter ) EDITOR DROP RATT DUP C@ EMIT 1+ NATT ; ' .EOS CFA ' .LINE 34 + ! \ ' DROP CFA ' .ALL 28 + ! FORTH FORTH DEFINITIONS \ Forth 3.3 CHOOSE XCHOOSE (Number Generators) 16may84tvm VARIABLE RND HERE RND ! : RAND RND @ 31421 * 6927 + DUP RND ! ; : CHOOSE ( u1 --- u2 ) RAND U* SWAP DROP ; VARIABLE LIM VARIABLE LAST : XCHOOSE ( u1 --- u2 ) 1 ?ENOUGH LIM ! BEGIN LIM @ CHOOSE DUP LAST @ = IF DROP FALSE ELSE TRUE THEN UNTIL DUP LAST ! ; : SEL-ASC ( -- char ) 94 XCHOOSE 1+ BL + ; \ Forth 3.3 TIDY UPPER LOOK (w/EDIT) PMOVE 16may84tvmVARIABLE COM VARIABLE ?ED DEFERRED MENU : TIDY ( -- ) DEPTH DUP 0= IF DROP NOOP ELSE 0 DO DROP LOOP THEN NOOP ( message patch point ) ; : UPPER ( n -- ) 1 ?ENOUGH DUP BL <> IF 95 AND THEN ; : LOOK-MENU CR SPACE ." Type: to advance, " ." B to move back, Cntl-E to edit (LOOK), Cntl-C to exit" ; : LOOK ( [1st scr] --- ) ['] LOOK-MENU IS MENU 0 ?ED ! DEPTH 1 < IF 1 SCR ! ELSE SCR ! THEN L MENU BEGIN KEY UPPER DUP COM ! BL = IF SCR @ 1+ SCR ! L MENU THEN COM @ 66 = IF SCR @ 1 = IF L MENU ELSE B L MENU THEN THEN COM @ 3 = IF END THEN COM @ 5 = IF 1 ?ED ! 1 ELSE 0 ?ED ! 0 THEN UNTIL ?ED @ 0= NOT IF ED THEN ; : PMOVE ( first scr, last scr --- ) 2 ?ENOUGH 1+ SWAP DO I LIST ?KEY IF LEAVE QUIT THEN LOOP ; \ Forth 3.3 System Extensions Load Screen \ To recompile FOR.COM, bring up BAKFOR.COM and type: OK \ Or.... Directly execute LFOR.COM (Automatic 'OK') EDITOR TELEVIDEO FORTH \ Set Editor Cursor Addr ' QUIT CFA ' COLD 127 + ! \ Re-Patch COLD (lfor.com) : <=== ; \ Dictionary Header 27 CONSTANT LAST-SCR \ Primary System Length CR CR 7 SPACES ." Loading Forth 3.3 ..." CR CR SPACE ." (Takes approx. one (1) minute...)" EDITOR 1 8 THRU 10 LAST-SCR THRU \ Load up Forth 3.3 ... 32 38 THRU \ Post-Disassembler SCR's CR CR 7 SPACES ." Forth 3.3 Loaded ..." \ That's it! ADM REV-AT \ Freedom 50, Decision 1 CR CP/M SAVE/COM FORTH COLD \ Write COM file to disk...? \ Forth 3.3 CASE# (Pascal CASE statement) 18nov83tvm : CASE# ?COMP CSP @ !CSP 4 ; IMMEDIATE : OF 4 ?PAIRS COMPILE OVER COMPILE = COMPILE ?BRANCH HERE 0 , COMPILE DROP 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 \ Forth 3.3 STORE PUT .PAGES 16may84tvm VARIABLE PADDR VARIABLE DEST : STORE ( scr# -- ) 1 ?ENOUGH BLOCK PAD DUP PADDR ! B/BUF CMOVE ; : PUT ( scr# -- ) 1 ?ENOUGH DUP SCR ! DEST ! PADDR @ DEST @ BLOCK B/BUF CMOVE UPDATE FLUSH ; : .PAGES ( -- ) \ System-size calculation (256 byte pages) HERE 0 256 U/ 1+ U. DROP ; \ Forth 3.3 STAT 16may84tvm HEX VARIABLE DRV VARIABLE USR : GET-DRV ( -- ) HEX 4 C@ 0F AND DECIMAL ; : GET-USR ( -- ) HEX 4 C@ F0 AND DECIMAL ; : STAT ( -- ) GET-DRV HEX 41 + DRV ! GET-USR 10 / USR ! DECIMAL CR ." Current Drive: " DRV @ EMIT CR ." Current User Area: " USR ? CR CR ; DECIMAL \ Forth 3.3 DRIVE A: B: XCOPY ?Y/N SAFE : DRIVE ( n -- ) \ access drive n 1 ?ENOUGH 14 BDOS DROP ; EDITOR : XCOPY ( source scr#, dest scr# --- ) ( erases source scr) SWAP DUP SCR ! BLOCK PAD B/BUF CMOVE BLOCK PAD SWAP B/BUF CMOVE UPDATE EDITOR WIPE FORTH FLUSH ; FORTH : ?Y/N ( -- f ) \ process a Yes/No response; leave a flag ." (Y/N)" BEGIN SPACE KEY DUP EMIT UPPER DUP DUP DUP ASCII Y = SWAP ASCII N = OR IF CASE# ASCII Y OF TRUE ENDOF ASCII N OF FALSE ENDOF ENDCASE# TRUE ELSE DROP FALSE THEN UNTIL ; : SAFE ( -- ) CR ." Are you sure...?? " ?Y/N NOT IF END THEN ; \ Forth 3.3 DIRR XDIR CONSTAT CP/M : XDIR ( drv# -- ) DEPTH 1 < IF GET-DRV THEN CP/M XDIR FORTH GET-DRV DRIVE 0 FILES ! ; : DIRR ( drv# -- ) DEPTH 1 < IF GET-DRV THEN CP/M DIR FORTH GET-DRV DRIVE 0 FILES ! ; CP/M 11 #BDOS CONSTAT \ Check Console Status FORTH \ Forth 3.3 IND 16may84tvm15 CONSTANT 1PAGE VARIABLE SCR1 VARIABLE ?LOOK : SCAN ( -- ) 1 INDEX ; : DISPLAY ['] LOOK-MENU IS MENU CR SCR1 @ DUP 1PAGE + INDEX MENU ; : INDSCR! DUP SCR ! 3 ; ' INDSCR! CFA ' INDEX 28 + ! \ Patch into INDEX : IND ( [1st scr#] --- ) DEPTH 0= IF 1 SCR1 ! ELSE SCR1 ! THEN DISPLAY \ default = 1 BEGIN KEY UPPER 0 ?LOOK ! CASE# 3 OF END ENDOF 5 OF 1 ?LOOK ! ENDOF BL OF 1PAGE SCR1 +! DISPLAY ENDOF ASCII B OF SCR1 @ 1PAGE 1+ < IF 1 SCR1 ! DISPLAY ELSE SCR1 @ 1PAGE - SCR1 ! DISPLAY THEN ENDOF ENDCASE# FALSE ?LOOK @ IF DROP 1 THEN UNTIL ?LOOK @ IF S LOOK THEN ; \ Forth 3.3 -T BS UNDO .M Editor EDITOR EDITOR DEFINITIONS : -T ( -- ) 1 ( # of lines ) C/L * @R# SWAP - BOL !R# ; : BS ( [n] -- ) \ Backspace for Editor -- Defaults to 1 DEPTH 1 < IF 1 THEN @R# SWAP - !R# ; : DEL ( -- ) \ Delete from carrot to end of current line SCR @ BLOCK @R# + @R# DUP BOL - C/L SWAP - BL FILL MODIFIED ; : UNDO ?I/D @ 1 = IF K @R# C/L / T D ELSE K I THEN ; FORTH DEFINITIONS DEFERRED 'EDSPECT VARIABLE PR# 0 PR# ! : .M 18 0 DO 64 FORTH I EDITOR AT FORTH I EDITOR 16 = NOT IF 60 EMIT THEN LOOP ; : ( 1/2RATT ) 1 ?EDIT ! (WHERE) EDITOR @R# PR# ! 'EDSPECT ['] QUERY 8 + ! ; FORTH ' CFA ' EDIT 4 + ! \ Patch over (WHERE) \ Forth 3.3 IN A MV V VI VAC Editor EDITOR EDITOR DEFINITIONS : IN ( -- ) 2 C ; \ indent 2 spaces : A ( -- ) \ moves carrot to BOL @R# BOL !R# ; : MV ( -- ) 1 C ; \ move carrot ahead 1 character (no write) : V ( -- ) 1 +T ; \ move carrot down 1 line : VI ( -- ) 1 +T IN ; \ move carrot down 1 line, in 2 spaces : VAC ( -- ) NATT CR 79 SPACES CR 79 SPACES ; FORTH DEFINITIONS : RETRY ( -- ) \ re-invoke edit mode and restore carrot EDITOR @R# ED !R# ; FORTH \ Forth 3.3 QBYE QLIST SCR>FIL REST : REST CUR/OFF ESC 100 EMIT CLR KEY DROP CUR/LINE ?VIDEO IF NVID ELSE RVID THEN ; : QBYE ( -- ) \ exit to CP/M without ' xxx Pages. ' SAVE-SYSTEM 0 HERE ! HERE 2+ EXECUTE ; : QLIST ( n -- ) 1 ?ENOUGH DECIMAL CR DUP SCR ! BLOCK 16 0 DO CR 6 SPACES DUP C/L -TRAILING TYPE C/L + ?KEY IF LEAVE THEN LOOP DROP CR QUIT ; CP/M : SCR>FIL ( source scr -- ) ( dest ufn ) 1 ?ENOUGH BLOCK B/BUF CP/M SAVE FORTH ; FORTH \ Forth 3.3 PAUSE* PAUSE ID> W : PAUSE* ( -- ) ?KEY IF KEY 13 = IF TIDY QBYE THEN 1000 WAIT BEGIN ?KEY UNTIL KEY 13 = IF TIDY QBYE THEN 2000 WAIT THEN ; : PAUSE ( -- ) ?KEY IF KEY 13 = IF TIDY END THEN 1000 WAIT BEGIN ?KEY UNTIL KEY 13 = IF TIDY END THEN 2000 WAIT THEN ; HEX : ID> ( nfa -- ) DUP 1+ DUP C@ ROT C@ 1F AND DUP 2+ \ length of next word 48 >OUT @ - ( length remaining) > IF CR THEN 0 DO DUP 7F AND EMIT 80 AND IF 0DF ( _ ) ELSE 1+ DUP C@ THEN LOOP 2DROP ; : W ( -- ) CR CONTEXT @ @ BEGIN DUP ID> 3 SPACES PFA LFA @ DUP PAUSE 0= UNTIL DROP ; DECIMAL \ CP/M BDOS Interface - UDIR \ Modified by T. Mackey CP/M : UDIR ( [drv#] -- ) CP/M DEPTH 1 < IF GET-DRV THEN \ Default to Current Drive 14 BDOS DROP FILE0 " ????????.???" (UFN) PAD SET-DMA 255 32 BDOS ( current user ) CR 16 0 DO CR ." User " I . CR I 32 BDOS DROP SEARCH0 BEGIN DUP CPM-ERR? NOT WHILE 32 * PAD + PAUSE UFN. SEARCH REPEAT DROP LOOP 32 BDOS DROP ; FORTH \ Forth 3.3 .DFLT DFLT= 16may84tvmVARIABLE NEW.BLK 10 ALLOT VARIABLE ORG.BLK 10 ALLOT : 'DFLT ['] DEFAULT 3 + ; \ Leave filename address : .DFLT ( -- ) \ Display default filename CR ." Current Storage Filename.BLK : " 'DFLT 8 -TRAILING TYPE ." .BLK" ; : @DFLT ( -- ) ( Fetch org filename) 'DFLT ORG.BLK 8 CMOVE ; : !DFLT ORG.BLK 'DFLT 8 CMOVE .DFLT ; : DFLT= ( -- ) \ Rename default filename 0 FILES ! @DFLT CR CR ." Enter New Storage Filename.BLK : " CR CR ." Type RETURN to default -- (FORTH.BLK)" 8 SPACES 8 0 DO ASCII . EMIT LOOP 8 0 DO 8 EMIT LOOP NEW.BLK 8 EXPECT NEW.BLK C@ 0= IF CR !DFLT CR CR ELSE NEW.BLK 'DFLT 8 CMOVE CR .DFLT CR THEN ; \ Forth 3.3 SIGNON BANNER INIT-SIGNON DEFERRED SIGNON EDITOR DECIMAL : BANNER ( -- ) CR CR ." ** 8080 Forth 3.3 **" CR ." Derived from Forth-79" CR ." Modified by Tom Mackey" CR ." Configured for FREEDOM 50" CR ." Last Modified: 04jul84" CR CR ; FORTH : INIT-SIGNON ( -- ) ['] BANNER IS SIGNON ['] SIGNON CFA ['] COLD 40 + ! ['] COLD 44 + 0 SWAP C! ['] COLD 45 + 22 RANGE DO ['] NOOP CFA I ! 2 +LOOP ; INIT-SIGNON \ Forth 3.3 XPECT ( recognizes Control-chars) : XPECT ( Addr len -- ) SWAP 0 >R BEGIN OVER R = IF + 0 SWAP ! R> DROP EXIT THEN KEY DUP 16 ( ^P ) = IF EPRINT 1 TOGGLE DROP BL THEN DUP 08 = OVER 127 = OR IF DROP R IF R> 1 - >R 8 EMIT SPACE 8 EMIT THEN ELSE DUP 24 ( ~X) = IF DROP I 0 > IF BEGIN R> 1 - >R 8 EMIT SPACE 8 EMIT I 0= UNTIL THEN ELSE DUP 05 ( ~E) = IF DROP ED ELSE DUP 03 ( ~C) = IF ." Exiting..." QBYE ELSE DUP 13 ( CR ) = IF DROP BL EMIT R> + 0 SWAP ! DROP EXIT ELSE DUP EMIT OVER R + C! R> 1+ >R THEN THEN THEN THEN THEN AGAIN ; ' XPECT CFA ' QUERY 8 + ! \ Forth 3.3 FILENAME= 16may84tvmVARIABLE ORG.COM 10 ALLOT VARIABLE NEW.COM 10 ALLOT : FILENAME ( -- ) ( Default Filename ) " FOR COM" ; : 'FILENAME ['] FILENAME 3 + ; \ Leave filename address : .FILENAME ( -- ) \ Display default filename 'FILENAME 8 -TRAILING TYPE ." .COM" ; : !FILENAME ( -- ) \ Store Orig. filename 'FILENAME ORG.COM 8 CMOVE ; : @FILENAME ORG.COM 'FILENAME 8 CMOVE ; : FILENAME= ( -- ) !FILENAME \ Rename default filename CR ." Enter new system filename: " CR CR ." (Type RETURN to default)" 8 SPACES 8 0 DO ASCII . EMIT LOOP 8 0 DO 8 EMIT LOOP NEW.COM 8 EXPECT NEW.COM C@ 0= IF CR @FILENAME ELSE NEW.COM 'FILENAME 8 CMOVE CR ." Current System Filename: " .FILENAME THEN CR ; \ Forth 3.3 COL ROW CARROT .CHR EDITOR EDITOR DEFINITIONS : COL ( n -- ) 1 ?ENOUGH EDITOR DUP BOL - 4 + ; : ROW ( n -- ) 1 ?ENOUGH EDITOR BOL C/L / 3 + ; : CARROT ( -- ) EDITOR RATT BEGINNING @R# + C@ EMIT ; : .CHR EDITOR @R# PR# @ = NOT IF PR# @ COL PR# @ ROW ADM-AT NATT BEGINNING PR# @ + C@ EMIT @R# COL @R# ROW ADM-AT CARROT ELSE @R# COL @R# ROW ADM-AT CARROT THEN ; FORTH DEFINITIONS EDITOR : ( -- ) 0 BLK ! [COMPILE] [ BEGIN RP! QUERY INTERPRET CRLF STATE @ 0= IF CONTEXT @ ['] EDITOR = IF ?EDIT @ IF EDITOR RATT .M .CHR FORTH UNATT 0 21 AT THEN ." ed" NATT ." > " ELSE FORTH NATT ." for" NATT ." > " ELSE NATT THEN THEN AGAIN ; FORTH \ Forth 3.3 QBORT" XT SAVE : QBORT" CR ; ' QBORT" CFA ' (ABORT") 42 + ! ' ' COLD 119 + ! \ patch into COLD ' 14 + EDITOR ' DONE 8 + ! \ patch into DONE ' 14 + ' (WHERE) 76 + ! EDITOR DEFINITIONS : XT ( -- ) ( Abandon Editor - No Changes ) ['] CRLF CFA [ ' 14 + ] LITERAL ! CURRENT @ CONTEXT ! 0 ?EDIT ! NATT ." No changes saved..." ['] XPECT CFA ['] QUERY 8 + ! ; FORTH FORTH DEFINITIONS : SAVE CR ." Saving Scr #" SCR ? ." ..." EDITOR NATT DONE UPDATE FLUSH ." and Saved." CR FORTH 0 ?EDIT ! ['] XPECT CFA ['] QUERY 8 + ! ; \ Forth 3.3 8080 DIS-ASSEMBLER ( DIS ) : V ; : VC@ ( addr -- n ) V C@ ; : V@ ( addr -- n ) DUP VC@ SWAP 1+ VC@ 256 * + ; : VOP ( n -- n' ) 16 * 1024 /MOD 28 + BLOCK + ; : @MNEMON ( opadr -- adr cnt' ) 3 + 13 -TRAILING ; : -ALPHA ( ADR CNT -- ADR CNT' ) BEGIN 1- 2DUP + C@ BL = IF 1+ 1 ELSE 0 THEN OVER 0= OR UNTIL ; : ALIGN ( OPADR N -- ) SWAP @MNEMON -ALPHA SWAP DROP + 8 SWAP - SPACES ; : .OP ADM 13 EMIT 40 RT C@ 1 .R ; : D ( VADR -- VADR1 ) DUP 4 U.R SPACE DUP VC@ VOP SWAP OVER DUP C@ 48 - DUP 0 = IF DROP 0 ALIGN 1 ELSE 1 = IF 3 ALIGN DUP 1+ VC@ 2 U.R SPACE 2 ELSE ( 2 ) 5 ALIGN DUP 1+ V@ 4 U.R SPACE 3 THEN THEN + SWAP @MNEMON TYPE ( DUP 1- .OP 2 SPACES ) ; : DIS ( adr -- adr+16) 1 ?ENOUGH 15 0 DO CR 2 SPACES D LOOP ; 0 NOP 2 B LXI 0 B STAX 0 B INX 0 B INR 0 B DCR 1 B MVI 0 RLC 0 -- 0 B DAD 0 B LDAX 0 B DCX 0 C INR 0 C DCR 0 C MVI 0 RRC 0 -- 2 D LXI 0 D STAX 0 D INX 0 D INR 0 D DCR 1 D MVI 0 RAL 0 -- 0 D DAD 0 D LDAX 0 D DCX 0 E INR 0 E DCR 1 E MVI 0 RAR 0 RIM 2 H LXI 2 SHLD 0 H INX 0 H INR 0 H DCR 1 H MVI 0 DAA 0 -- 0 H DAD 2 LHLD 0 H DCX 0 L INR 0 L DCR 1 L MVI 0 CMA 0 SIM 2 SP LXI 2 STA 0 SP INX 0 M INR 0 M DCR 1 M MVI 0 STC 0 -- 0 SP DAD 2 LDA 0 SP DCX 0 A INR 0 A DCR 1 A MVI 0 CMC 0 B B MOV 0 C B MOV 0 D B MOV 0 E B MOV 0 H B MOV 0 L B MOV 0 M B MOV 0 A B MOV 0 B C MOV 0 C C MOV 0 D C MOV 0 E C MOV 0 H C MOV 0 L C MOV 0 M C MOV 0 A C MOV 0 B D MOV 0 C D MOV 0 D D MOV 0 E D MOV 0 H D MOV 0 L D MOV 0 M D MOV 0 A D MOV 0 B E MOV 0 C E MOV 0 D E MOV 0 E E MOV 0 H E MOV 0 L E MOV 0 M E MOV 0 A E MOV 0 B H MOV 0 C H MOV 0 D H MOV 0 E H MOV 0 H H MOV 0 L H MOV 0 M H MOV 0 A H MOV 0 B L MOV 0 C L MOV 0 D L MOV 0 E L MOV 0 H L MOV 0 L L MOV 0 M L MOV 0 A L MOV 0 B M MOV 0 C M MOV 0 D H MOV 0 E M MOV 0 H M MOV 0 L M MOV 0 HLT 0 A M MOV 0 B A MOV 0 C A MOV 0 D A MOV 0 E A MOV 0 H A MOV 0 L A MOV 0 M A MOV 0 A A MOV 0 B ADD 0 C ADD 0 D ADD 0 E ADD 0 H ADD 0 L ADD 0 M ADD 0 A ADD 0 B ADC 0 C ADC 0 D ADC 0 E ADC 0 H ADC 0 L ADC 0 M ADC 0 A ADC 0 B SUB 0 C SUB 0 D SUB 0 E SUB 0 H SUB 0 L SUB 0 M SUB 0 A SUB 0 B SBB 0 C SBB 0 D SBB 0 E SBB 0 H SBB 0 L SBB 0 M SBB 0 A SBB 0 B ANA 0 C ANA 0 D ANA 0 E ANA 0 H ANA 0 L ANA 0 M ANA 0 A ANA 0 B XRA 0 C XRA 0 D XRA 0 E XRA 0 H XRA 0 L XRA 0 M XRA 0 A XRA 0 B ORA 0 C ORA 0 D ORA 0 E ORA 0 H ORA 0 L ORA 0 M ORA 0 A ORA 0 B CMP 0 C CMP 0 D CMP 0 E CMP 0 H CMP 0 L CMP 0 M CMP 0 A CMP 0 RNZ 0 B POP 2 JNZ 2 JMP 2 CNZ 0 B PUSH 1 ADI 0 0 RST 0 RZ 0 RET 2 JZ 0 -- 2 CZ 2 CALL 1 ADI 0 1 RST 0 RNC 0 D POP 2 JNC 1 OUT 2 CNC 0 D PUSH 1 SUI 0 2 RST 0 RC 0 -- 2 JC 1 IN 2 CC 0 -- 1 SBI 0 3 RST 0 RPO 0 H POP 2 JPO 0 XTHL 2 CPO 0 H PUSH 1 ANI 0 4 RST 0 RPE 0 PCHL 2 JPE 0 XCHG 2 CPE 0 -- 1 XRI 0 5 RST 0 RP 0 PSW POP 2 JP 0 DI 2 CP 0 PSW PUSH 1 ORI 0 6 RST 0 RM 0 SPHL 2 JM 0 EI 2 CM 0 -- 1 CPI 0 7 RST \ Forth 3.3 .SIZE SAVE/COM 16may84tvm: .SIZE ( -- ) CR CR 2 SPACES STAT ." System Length:" CR CR DECIMAL HERE 256 - . ." Bytes in Decimal" CR HERE 256 - HEX . ." Bytes in Hexadecimal" CR DECIMAL HERE 0 256 U/ 1+ SWAP DROP DUP U. ." 256-Byte Pages" 4 / DUP 2 /MOD DROP 0= NOT IF 1+ THEN CR U. 8 EMIT 75 EMIT 4 SPACES ." Bytes" CR CR ; CP/M CP/M DEFINITIONS : SAVE/COM ( -- ) CP/M .SIZE CR CR ." Do you want to write this version of FORTH to disk?" SPACE ?Y/N 1 = IF CR DFLT= FILENAME= CR SAVE-SYSTEM HERE 256 DUP ROT SWAP - ." Writing " .FILENAME ." to disk..." FILE0 FILENAME (UFN) DELETE DROP MAKE CPM-ERR? ABORT" File Make Error" RANGE DO I SET-DMA WRITE-SEQ ABORT" Disk Write Error" 128 +LOOP CLOSE CPM-ERR? ABORT" File Close Error" FORTH ELSE FORTH END THEN ; FORTH FORTH DEFINITIONS \ Forth 3.3 'ROW/COL REV-AT SYSGEN COOL EDITOR : 'ROW/COL ( -- ) EDITOR ['] ADM-AT 12 + ; : REV-AT ( -- ) EDITOR 'ROW/COL @ ['] NOOP CFA = NOT IF ['] NOOP CFA 'ROW/COL ! ELSE \ Reverse Row/Col Order ['] SWAP CFA 'ROW/COL ! THEN FORTH ; CP/M : SYSGEN ( -- ) \ Generate a new version of this FORTH system CP/M SAVE/COM FORTH ; FORTH : COOL ( -- ) INIT-VEC \ initialize boot vectors SCR @ DUP 1 < SWAP 512 > OR IF 9 SCR ! THEN \ initialize SCR NVID KSTAT NATT PROT/OFF \ Freedom 50/100 Attributes ESC ASCII < EMIT \ Kill keyclick (Freedom) WP/OFF ADM ; \ Decision 1 and Freedom 100/50 ' COOL CFA ' COLD 36 + ! \ patch over INIT-VEC into COLD \ Forth 3.3 ~A and ~F ( lft & rt 1 word ) EDITOR EDITOR DEFINITIONS VARIABLE N# ( offset +/-) VARIABLE N0$ ( current char) : @N0 ( -- addr ) EDITOR BEGINNING @R# + ; : @N- ( -- chr-1 ) EDITOR @N0 1- C@ -1 N# +! ; : @N+ ( -- chr+1 ) EDITOR @N0 1+ C@ 1 N# +! ; \ Forth 3.3 EDSPECT ( WordStar Emulator ) EDITOR EDITOR DEFINITIONS : !PR# EDITOR @R# PR# ! ; : EDSPECT ( addr len -- ) SWAP 0 >R BEGIN EDITOR !PR# FORTH OVER FORTH R EDITOR = IF + 0 SWAP ! R> DROP EXIT THEN KEY DUP 08 ( BKSPACE) = IF DROP FORTH R EDITOR IF R> 1 - >R 8 EMIT SPACE 8 EMIT THEN ELSE DUP 19 ( ~S) = IF DROP @R# 0 > IF @R# 1- !R# THEN R> + 0 SWAP ! DROP EXIT ELSE DUP 04 ( ~D) = IF DROP @R# 1023 < IF 1 C THEN R> + 0 SWAP ! DROP EXIT ELSE DUP 24 ( ~X) = IF DROP @R# 960 < IF @R# C/L + !R# THEN R> + 0 SWAP ! DROP EXIT ELSE DUP 05 ( ~E) = IF DROP @R# C/L 1- > IF @R# C/L - !R# THEN R> + 0 SWAP ! DROP EXIT \ Forth 3.3 EDSPECT #2 ( WordStar Emulator ) ELSE DUP 23 ( ~W) = IF DROP ['] XPECT CFA ['] QUERY 8 + ! SAVE R> + 0 SWAP ! DROP EXIT ELSE DUP 17 ( ~Q) = IF DROP ['] XPECT CFA ['] QUERY 8 + ! XT R> + 0 SWAP ! DROP EXIT ELSE DUP 1 ( ~A) = IF DROP @R# 0= NOT IF 0 N# ! @N0 C@ BL = IF BEGIN @N- C@ BL = NOT IF TRUE ELSE FALSE THEN UNTIL THEN BEGIN @N- C@ BL = @R# N# @ 1+ + 0= NOT OR IF N# @ 1+ C TRUE ELSE FALSE THEN UNTIL THEN R> + 0 SWAP ! DROP EXIT ELSE DUP 06 ( ~F) = IF DROP @R# 1016 < IF @R# !PR# 8 + !R# ELSE 1023 !R# !PR# THEN R> + 0 SWAP ! DROP EXIT ELSE DUP 07 ( ~G) = IF DROP @R# !PR# 1023 < IF LOCALLY @R# 1 -# MODIFIED THEN R> + 0 SWAP ! DROP EXIT ELSE DUP 127 ( DEL) = IF DROP !PR# @R# 0 > IF -1 C LOCALLY @R# 1 -# MODIFIED THEN R> + 0 SWAP ! DROP EXIT \ Forth 3.3 EDSPECT #3 ( WordStar Emulator ) ELSE DUP 25 ( ~Y) = IF DROP X R> + 0 SWAP ! DROP EXIT ELSE DUP 12 ( ~L) = IF DROP DEL R> + 0 SWAP ! DROP EXIT ELSE DUP 13 ( CR) = IF DROP BL EMIT R> + 0 SWAP ! DROP EXIT ELSE DUP 22 ( ~V) = IF DROP NOOP R> + 0 SWAP ! DROP EXIT ELSE DUP EMIT OVER FORTH R EDITOR + C! R> 1+ >R THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN AGAIN ; : ('EDSPECT) EDITOR ['] EDSPECT CFA ; ' ('EDSPECT) IS 'EDSPECT FORTH FORTH DEFINITIONS \ Forth 3.3 PATCH TRIM 04jul84tvm : PATCH ( pfa -- ) \ patch into PFA of QUIT/COLD 1 ?ENOUGH DUP CR CR ." Patching into COLD..." ['] COLD 119 + ! ['] NOOP CFA ['] COLD 40 + ! CR CR ." From CP/M, type: SAVE " .PAGES 8 EMIT 1WORD 8 EMIT ." .COM" QBYE ; : TRIM ( -- word ) ' DUP DUP CR ." Forget from" 1WORD ." on...? " ?Y/N CR IF LFA DUP 2- FENCE ! (FORGET) CR ." Done." ELSE TIDY CR END THEN ; \ forth 3.3 lost in space LOST.COM \ cheesy lost in space computer display... REV-AT cp/m \ 11 #bdos constat forth : set-attr esc ascii m emit esc ascii G emit ; : place 23 choose 80 choose at ; : select set-attr 3 choose 1+ case# 1 of ascii 0 emit endof 2 of ascii 4 emit endof 3 of ascii D emit endof endcase# ; : reset set-attr ascii 0 emit ; : lost ( -- ) cur/off adm clr begin place select space constat until clr cur/line editor televideo forth reset 8 emit qUIT ; \ ' lost patch \ Forth 3.3 BLOON version 3 : FOON ESC ASCII m EMIT ESC ASCII G EMIT 31 CHOOSE 48 + EMIT ; : PAPOON ESC ASCII G EMIT ESC ASCII 0 EMIT ; : BLOON ( -- ) CLR NVID 80 0 DO PAPOON SPACE LOOP 22 0 DO PAPOON 2 SPACES 76 0 DO FOON SEL-ASC EMIT LOOP PAPOON 2 SPACES LOOP PAPOON 2 SPACES 76 0 DO FOON SEL-ASC EMIT LOOP BLEEN PAPOON CLR QBYE ; ' BLOON PATCH \ CASE SWEAR Version 1.0 (A tribute to J.R.) : PLACE ( -- ) 23 CHOOSE 75 CHOOSE AT ; : ERAS ( -- ) 5 LFT 4 SPACES ; : DECIDE ( n -- ) DEPTH 1 < IF ?ENOUGH THEN CASE# 1 OF PLACE ." FUCK " ENDOF 2 OF PLACE ." SHIT " ENDOF 3 OF PLACE ." PISS " ENDOF 4 OF PLACE ." CUNT " ENDOF 5 OF PLACE ." JEFF " ENDOF ENDCASE# ; : SWEAR ( -- ) adm CLR BEGIN CUR/OFF 5 XCHOOSE 1+ DECIDE 1000 WAIT ERAS ?KEY 1000 WAIT UNTIL CUR/LINE CLR QBYE ; REV-AT ' swear patch \ Forth 3.3 PAINT Version 1.0 -- Load Screen 21jan84tvm23 CONSTANT LARGEST 2 CONSTANT TIME VARIABLE CHAR VARIABLE SIZE : COMPARE ( n -- ) SIZE @ - 2 / ; : INIT 60 COMPARE 2+ 24 COMPARE AT ; : RESET LARGEST SIZE ! INIT ; : TOP SIZE @ 0 DO CHAR @ EMIT TIME WAIT 1 RT LOOP ; : RIGHT SIZE @ 0 DO CHAR @ EMIT TIME WAIT 1 DN LOOP ; : BOTTOM SIZE @ 0 DO CHAR @ EMIT TIME WAIT 3 LFT LOOP ; : LEFT SIZE @ 0 DO CHAR @ EMIT TIME WAIT 1 UP LOOP ; : SEL-CHAR 94 XCHOOSE 33 + CHAR ! ; : -SIZE SIZE @ 2 - SIZE ! SIZE @ 1 < IF RESET THEN ; : (PAINT) ( -- ) CUR/OFF CLR RESET BEGIN SEL-CHAR TOP RIGHT BOTTOM LEFT 1 DN 3 RT -SIZE ?KEY UNTIL CUR/LINE QUIT ; : TST (PAINT) ; \ Forth 3.3 PAINT High level words 02jan84tvmVARIABLE (CHAR) : (SEL-CHAR) ( n -- ) DUP (CHAR) ! CASE# : RETN CR 8 SPACES ; : PAINT-MENU ( -- ) CLR 6 DN RETN ." Select one of the following:" RETN RETN ." (A) Random ASCII characters ( default )" RETN ." (B) Select a single ASCII character" RETN ." (C) Random decimal numbers" RETN ." (D) Random hexadecimal numbers" RETN 39 7 AT KEY CASE# 65 OF SEL-CHAR ENDOF 66 OF ; \ Forth 3.3 Hidden Message 04dec83tvm: CURSOR 80 CHOOSE 24 CHOOSE AT 1 UP ; : PAINT BEGIN CURSOR STAR ?KEY UNTIL ; : FILL-IN DARK PAINT ; \ Forth 3.3 Hidden Message Load Screen 07dec83tvmVARIABLE CHAR : PLACE 45 CHOOSE 18 + 24 CHOOSE AT 1 UP ; : FILL-IN BEGIN PLACE STAR ?KEY UNTIL PROT/OFF CUR/LINE QUIT ; : WRITE WP/ON 0 DO CHAR @ EMIT LOOP WP/OFF ; : RET CR 19 RT ; : RETN CR 18 SPACES ; : ILUV RET 11 WRITE 13 RT 3 WRITE 3 RT 3 WRITE RET ( line 1 ) 4 RT 3 WRITE 15 RT 13 WRITE RET ( line 2 ) 2 0 DO 4 RT 3 WRITE 14 RT 15 WRITE RET LOOP ( lines 3,4 ) 4 RT 3 WRITE 15 RT 13 WRITE RET ( line 5 ) 4 RT 3 WRITE 16 RT 11 WRITE RET ( line 6 ) 4 RT 3 WRITE 17 RT 9 WRITE RET ( line 7 ) 4 RT 3 WRITE 18 RT 7 WRITE RET ( line 8 ) 4 RT 3 WRITE 19 RT 5 WRITE RET ( line 9 ) 4 RT 3 WRITE 20 RT 3 WRITE RET ( line 10 ) 11 WRITE 17 RT 1 WRITE RET ( line 11 ) ; -->\ Forth 3.3 Hidden Message 02jan84tvm : IT RETN 2 0 DO 11 WRITE 5 RT 11 WRITE 5 RT 11 WRITE RETN LOOP 2 0 DO 3 0 DO 3 WRITE 5 RT LOOP 3 WRITE 9 RT 3 WRITE RETN LOOP 2 0 DO 11 WRITE 2 0 DO 5 RT 3 WRITE LOOP 9 RT 3 WRITE RETN LOOP 2 0 DO 3 WRITE 13 RT 11 WRITE 9 RT 3 WRITE RETN LOOP ; : SET-ATT ESC 112 EMIT 48 EMIT ; : HIDDEN 32 CHAR ! CLR PROT/ON CUR/OFF ILUV CR IT FILL-IN ; : TST CUR/OFF SET-ATT 42 CHAR ! CLR CR ILUV CR IT 32 CHAR ! CUR/LINE ; \ Forth 3.3 ART Version 4.0 VARIABLE COL VARIABLE ROW : POS 80 XCHOOSE COL @ + 80 MOD DUP COL ! 24 XCHOOSE ROW @ + 24 MOD DUP ROW ! AT 1 UP ; : PAINT BEGIN POS 5000 WAIT SEL-ASC EMIT ?KEY UNTIL ; : ART CLR PAINT ; \ SPIRAL Version 2.0 Load Screen tvm 10-2-83 VARIABLE LEN VARIABLE CNT VARIABLE DELAY VARIABLE SIZE : INIT 1 LEN ! 0 CNT ! 38 12 AT ; : POS 40 12 AT ; : ADVANCE CNT @ 1 + DUP 2 = IF 0 CNT ! LEN @ 1 + LEN ! DROP ELSE CNT ! THEN DELAY @ WAIT ; : SPIRE 0 DO LEN @ 0 DO 1 DN STAR LOOP 1 LFT ADVANCE LEN @ 1 + 0 DO 2 LFT STAR 1 LFT LOOP ADVANCE STAR LEN @ 0 DO 1 UP STAR LOOP 1 RT ADVANCE LEN @ 0 DO STAR SPACE LOOP STAR ADVANCE LOOP LEN @ 1 - 0 DO 1 DN STAR LOOP ; : =DELAY ( n -- ) DELAY ! ; 100 DELAY ! ( Default setting ) : =SIZE ( n -- ) SIZE ! ; 11 SIZE ! ( Default setting ) : (SPIRAL) ( -- ) INIT STAR POS STAR SIZE @ SPIRE ; : SPIRAL DARK (SPIRAL) ; --> \ XSPIRAL Version 2.0 tvm 10-2-83 : XSPIRE 0 DO LEN @ 0 DO 1 DN SPACE LOOP 1 LFT ADVANCE LEN @ 1 + 0 DO 2 LFT SPACE 1 LFT LOOP ADVANCE SPACE LEN @ 0 DO 1 UP SPACE LOOP SPACE ADVANCE LEN @ 0 DO 2 SPACES LOOP SPACE ADVANCE LOOP LEN @ 1 - 0 DO 1 DN SPACE LOOP ; : XSPIRAL ( -- ) INIT SPACE POS SPACE SIZE @ XSPIRE ; : GO CLR CUR/OFF SPIRAL XSPIRAL CUR/LINE QUIT ; : (GO+) BEGIN (SPIRAL) XSPIRAL ?KEY UNTIL QUIT ; : GO+ DARK (GO+) ; EXIT ( SPIRAL K.K. 7-7-83 ) VARIABLE LEN VARIABLE CNT : POS CLR CUR> 72 EMIT 44 EMIT ; : ADVANCE CNT @ 1 + DUP 2 = IF 0 CNT ! LEN @ 1 + LEN ! DROP ELSE CNT ! THEN 1000 WAIT ; : SPIRE 0 DO LEN @ 0 DO 1 DN STAR LOOP ADVANCE LEN @ 1 + 0 DO 1 LFT STAR 1 LFT LOOP ADVANCE STAR LEN @ 0 DO 1 UP STAR LOOP ADVANCE LEN @ 0 DO STAR LOOP ADVANCE LOOP ; : SPIRAL 1 LEN ! 0 CNT ! POS STAR 12 SPIRE 8 EMIT 32 EMIT CR 21 DN ; \ Forth 3.3 Example : FLAG ( -- ) CR ." --------------------------" CR 5 0 DO ." | |" CR LOOP ." --------------------------" CR 8 0 DO ." |" CR LOOP ; \ Forth 3.3 DICE 05jan84tvm : PLACE#1 38 12 AT ; : PLACE#2 42 12 AT ; : SEL-# 6 CHOOSE 49 + EMIT ; : ROLL ( -- ) CUR/OFF CLR BEGIN PLACE#1 SEL-# PLACE#2 SEL-# ?KEY UNTIL CUR/LINE QUIT ; : PLACE 40 12 AT ; : TST ( -- ) CUR/OFF CLR BEGIN PLACE SEL-ASC EMIT ?KEY UNTIL CUR/LINE QUIT ; \ Forth 3.3 DICE 05jan84tvm : PLACE#1 38 12 AT ; : PLACE#2 42 12 AT ; : SEL-# 6 CHOOSE 49 + EMIT ; : ROLL ( -- ) CUR/OFF CLR BEGIN PLACE#1 SEL-# PLACE#2 SEL-# ?KEY UNTIL CUR/LINE QUIT ; : PLACE 40 12 AT ; : TST ( -- ) CUR/OFF CLR BEGIN PLACE SEL-ASC EMIT ?KEY UNTIL CUR/LINE QUIT ; \ Forth 3.3 DICE Version 3.0 Load Screen : PLACE#1 12 30 AT ; : PLACE#2 12 48 AT ; : FRAME 2 UP 2 LFT ." ------- " 3 0 DO 1 DN ." |" LOOP 1 DN 7 LFT ." -------" 7 LFT 3 UP 3 0 DO ." |" 1 DN LOOP ; : SHADOW 3 UP 1 LFT ." /" 1 UP 1 RT ." _______" 1 RT 1 DN 1 LFT ." /" 4 0 DO ." |" 1 DN LOOP 1 LFT ." /" ; : SHAKE 6 CHOOSE 1+ CASE# 1 OF STAR ENDOF 2 OF 3 RT 1 UP STAR 2 DN 4 LFT STAR ENDOF 3 OF STAR 1 UP 2 RT STAR 2 DN 4 LFT STAR ENDOF 4 OF 3 RT 1 UP STAR 2 DN STAR 5 LFT STAR 2 UP STAR ENDOF 5 OF STAR 1 UP 2 RT STAR 2 DN STAR 5 LFT STAR 2 UP STAR ENDOF 6 OF 3 RT 1 UP STAR 1 DN STAR 1 DN STAR 5 LFT STAR 1 UP STAR 1 UP STAR ENDOF ENDCASE# ; --> \ Forth 3.3 DICE --- High level words : ROLL PLACE#1 FRAME PLACE#1 SHADOW PLACE#1 SHAKE PLACE#2 FRAME PLACE#2 SHADOW PLACE#2 SHAKE ; : POS 19 26 AT ; : PROMPT POS ." Type any key to ROLL again..." 21 29 AT ." Type Cntl-C to exit..." KEY ; : DICE ( -- ) ADM BEGIN CLR ROLL PROMPT 3 = IF CLR 20 26 AT ." So long, sucker...." TRUE ELSE DROP FALSE THEN UNTIL EDITOR TELEVIDEO FORTH QBYE ; ' DICE PATCH \ Forth 3.3 visual orgasm 1000 CONSTANT DELAY : CTR 40 12 AT ; : SEL-ATT 31 XCHOOSE BL + EMIT ; : BEAM ( -- ) CLR BEGIN CTR CUR/OFF ESC ASCII G EMIT SEL-ATT SEL-ASC EMIT CONSTAT DELAY WAIT UNTIL CUR/LINE CLR NATT QBYE ; \ ' BEAM PATCH \ Forth 3.3 DRAW -- etc. VARIABLE D# VARIABLE >DRAW 1920 ALLOT >DRAW 1920 BLANK : @D# D# @ ; : !D# ( n -- ) 1 ?ENOUGH D# ! ; : DRSPECT ( addr --) 0 D# ! BEGIN >DRAW 1920 BLANK KEY DUP 03 ( ~C) = IF DROP DROP CLR >DRAW 1920 BLANK END ELSE DUP 08 = IF DROP @D# 0= NOT IF @D# 1- !D# 8 EMIT THEN ELSE DUP 12 = IF DROP @D# 1919 < IF @D# 1+ !D# 12 EMIT THEN ELSE DUP 22 = IF DROP @D# 1839 < IF @D# 80 + !D# 22 EMIT THEN ELSE DUP 11 = IF DROP @D# 79 > IF @D# 80 - !D# 11 EMIT THEN ELSE DUP 23 = IF DROP FLUSH CLR EXIT END ELSE DUP EMIT 1 D# +! OVER @D# + C! THEN THEN THEN THEN THEN THEN AGAIN ; : ?INPUT ( -- ) 0 D# ! >DRAW DRSPECT 0 >IN ! ; : DRAW ( -- ) CLR 0 BLK ! [COMPILE] [ BEGIN RP! ?INPUT AGAIN ; : ECHO ( -- ) CLR >DRAW 1+ 1918 TYPE QUIT ; \ Forth 3.3 DRAW -- etc. (Disk Storage) EXIT : DRAW.BLK " DRAW.BLK" ; \ Forth 3.3 Hidden Message Load Screen 07dec83tvm VARIABLE CHAR VARIABLE LEN : PLACE 24 CHOOSE 45 CHOOSE 18 + AT 1 UP ; : FILL-IN BEGIN PLACE STAR CONSTAT UNTIL PROT/OFF CUR/LINE ; : WRITE WP/ON 0 DO CHAR @ EMIT LOOP WP/OFF ; : RET CR 19 RT ; : RETN CR 18 SPACES ; : ILUV RET 11 WRITE 13 RT 3 WRITE 3 RT 3 WRITE RET ( line 1 ) 4 RT 3 WRITE 15 RT 13 WRITE RET ( line 2 ) 2 0 DO 4 RT 3 WRITE 14 RT 15 WRITE RET LOOP ( lines 3,4 ) 13 LEN ! 21 15 DO 4 RT 3 WRITE I RT ( lines 5-10 ) LEN @ WRITE -2 LEN +! LEN @ RET LOOP ( " ) 11 WRITE 17 RT 1 WRITE RET ( line 11 ) ; --> \ Forth 3.3 Hidden Message 07dec83tvm : IT RETN 2 0 DO 11 WRITE 5 RT 11 WRITE 5 RT 11 WRITE RETN LOOP 2 0 DO 3 0 DO 3 WRITE 5 RT LOOP 3 WRITE 9 RT 3 WRITE RETN LOOP 2 0 DO 11 WRITE 2 0 DO 5 RT 3 WRITE LOOP 9 RT 3 WRITE RETN LOOP 2 0 DO 3 WRITE 13 RT 11 WRITE 9 RT 3 WRITE RETN LOOP ; : SET-ATTR ESC 112 EMIT 48 EMIT ; : TST SET-ATT 42 CHAR ! CLR CR ILUV CR IT 32 CHAR ! ; : THE-KIND ADM 32 CHAR ! CLR PROT/ON CUR/OFF ILUV CR IT FILL-IN EDITOR TELEVIDEO FORTH QBYE ; ' THE-KIND PATCH \ forth 3.3 8-bit hex input 16feb84tvmhex 31 constant mid 51 constant hi variable flag : decide hex dup 40 < if 30 - else dup 40 = if error else dup 47 < if 31 - else dup 60 > if then then then \ forth 3.3 8-bit hex input 16feb84tvmvariable val 2 allot hex : error cr ." Range error..." cr ; : convert ( n -- ) dup 46 > if 50 - else dup 66 > if error then then dup 47 < if 37 - then ; : signon hex cr cr cr ." Hex Input Program" cr ." c. 1984 Tom Mackey" cr cr ." Enter 8-bit hex value:" cr ." ( i.e. FF,A0,c5,etc..) key dup emit key dup emit swap ; decimal \ forth 3.3 Terminal Install Routine 16feb84tvm editor editor definitions \ forth 3.3 Terminal Installation Routine variable config 2 allot variable (at) : univ-at esc (at) @ emit config @ ascii 2 = if swap then bl + emit bl + emit ; : enter key dup space emit ; : initl kstat bel/off cr cr ." Forth Terminal Installation Program" cr ." ( c. 1984 Tom Mackey )" cr cr cr ." What type of computer are you running?" cr cr ." (1) Decision I" cr ." (2) Micro-Decision" cr cr ." Choose one:" enter config ! cr cr cr ." What type of terminal?" cr cr ." (1) Freedom 50,100" cr ." (2) ADM-20" cr ." (3) ADDS Viewpoint" cr cr ." Choose one:" enter config 2+ ! ; --> \ forth 3.3 Terminal Install Routine : cool initl config 2+ @ case# ascii 1 of adm kstat bel/off ascii = (at) ! endof ascii 2 of adm ascii = (at) ! endof ascii 3 of adds ascii Y (at) ! endof endcase# ['] univ-at is at cr ." forth 3.3 - tvm" cr cr ; \ Forth 3.3 BLUID version 3 08FEB84TVM: SEL-RAND ESC ASCII m EMIT ESC ASCII G EMIT 31 CHOOSE 48 + EMIT ; : RESET-ATT ESC ASCII G EMIT ESC ASCII 0 EMIT ; : WINDOW ESC ASCII G EMIT ASCII 1 EMIT ; : BLEEN 7400 1 DO WINDOW I WAIT RVID ?KEY IF LEAVE WINDOW THEN LOOP MANY ; : BACKGND CLR NVID 80 0 DO RESET-ATT SPACE LOOP 22 0 DO RESET-ATT 2 SPACES 76 0 DO SEL-RAND SEL-ASC EMIT LOOP RESET-ATT 2 SPACES LOOP RESET-ATT 2 SPACES 76 0 DO SEL-RAND SEL-ASC EMIT LOOP RESET-ATT ; : BLUID ( -- ) BACKGND BLEEN CLR QBYE ; ' BLUID PATCH \ forth 3.3 ROCKET : .rocket In this paper, we will prove without a doubt, that On the one hand, studies have shown that On the other hand, however, E.F. Hutton suggests that In summary, then, we insist that by abusing by applying brute force towards with random deployment of out of phase with damaged by offset by it is absolutely impossible for even the most it remains out of the question for all but the least it is unnecessary for any to malfunction as to misuse a high level of to completely avoid integrated management criteria total organizational flexibility systematized monitored capability parallel reciprocal mobility functional digital programming responsive logistical concepts optimal transistional time phasing synchronized incremental projections compatible third generation hardware qualified policy through-put partial decision engineering stand-alone undocumented outflow random context sensitive superstructures representative fail-safe interaction optional omnirange congruence transient unilateral utilities \ BUZZPHRASE GENERATOR III Load Screen 20nov83tvm 78 CONSTANT RMARGIN VARIABLE LINECOUNT VARIABLE HOMEBASE 2 ALLOT : IN @ HOMEBASE 2! ; : WRITE> HOMEBASE 2@ >IN ! BLK ! ; : CR CR 0 LINECOUNT ! ; : SPACE LINECOUNT @ IF SPACE 1 LINECOUNT +! THEN ; : .WORD ( addr ) COUNT DUP LINECOUNT @ + RMARGIN > IF CR ELSE SPACE THEN DUP LINECOUNT +! TYPE ; : ANOTHER ( lim -- lim adr ) BL WORD OVER >IN @ < NOT ; : WORDS ( u ) >IN @ + BEGIN ANOTHER WHILE .WORD REPEAT 2DROP ; 73 LOAD 74 LOAD \ BUZZPHRASE GENERATOR -- HIGH LEVEL WORDS " : BUZZ 16 CHOOSE 64 * + >IN ! 77 BLK ! 20 WORDS ; : 1ADJ 0 BUZZ ; : 2ADJ 20 BUZZ ; : NOUN 40 BUZZ ; : PHRASE 1ADJ 2ADJ NOUN ; : FILLER ( u ) [ 4 64 * ] LITERAL * 3 CHOOSE 64 * + >IN ! 70 BLK ! 64 WORDS ; : SENTENCE 4 0 DO I FILLER PHRASE LOOP 1 LFT SPACE 1 LFT ." ." CR ; : INTRO ( u ) 64 * >IN ! 69 BLK ! CR 64 WORDS ; : PAPR ; : TEST CR ' SPACE ; \ RETRIEVAL OF MORE SUCCESSFUL PAPERS VARIABLE SEED : 4POSTERITY RND @ SEED ! ; : PAPER 4POSTERITY PAPR ; : REDO SEED @ RND ! ; ( execute AFTER a paper, to reprint it. Usage: REDO PAPER ) : WOOD,EVELYN ( -- ) BEGIN PAPER ?KEY UNTIL CLR QUIT ; : 20SEC 20 0 DO 1SEC WAIT LOOP ; : READ ( -- ) BEGIN PAPER 20SEC ?KEY UNTIL CLR QUIT ; : TST ( -- ) PAPER QUIT ; \ Forth 3.3 POINTER Version 1.2 : LEFT 0 DO 2 LFT 3 0 DO ." -" 3 LFT LOOP ." <" 3 LFT LOOP ; : RIGHT 0 DO ." - - - > " LOOP ; : DOWN 0 DO 1 DN 1 RT 3 0 DO ." |" 1 DN LOOP ." v" 1 DN LOOP ; : UPP 0 DO 1 UP 3 0 DO ." |" 1 UP LOOP 94 EMIT 1 UP 1 RT LOOP ; : POINT DARK BEGIN 5 CHOOSE RIGHT 5 CHOOSE DOWN 5 CHOOSE LEFT 5 CHOOSE UPP CONSTAT 1000 WAIT UNTIL QBYE ; ' POINT PATCH \ Forth 3.3 DRAW DRSPECT 80 CONSTANT C/R VARIABLE D# VARIABLE >DRAW B/BUF 2* ALLOT : @D# ( -- n ) D# @ ; : !D# ( n -- ) 1 ?ENOUGH D# ! ; : !XPECT ( -- ) ['] XPECT CFA ['] QUERY 8 + ! ; : DRSPECT ( addr len -- ) DROP DROP >DRAW B/BUF 2* SWAP 0 >R BEGIN OVER R = IF + 0 SWAP ! R> DROP EXIT THEN KEY DUP 03 ( ~C) = IF DROP !XPECT R> DROP EXIT THEN DUP 08 ( lft) = IF DROP @D# 0= NOT IF @D# 1- !D# THEN ELSE DUP 12 ( rt) = IF DROP @D# 1919 < IF @D# 1+ !D# THEN ELSE DUP 22 ( dn) = IF DROP @D# 1839 < IF @D# C/R + !D# THEN ELSE DUP 11 ( up) = IF DROP @D# 79 > IF @D# C/R - !D# THEN ELSE DUP 23 ( ~W) = IF DROP FLUSH !XPECT R> + 0 SWAP ! DROP EXIT ELSE DUP EMIT OVER @D# + C! R> 1+ >R THEN THEN THEN THEN THEN AGAIN ; : DRAW ( -- ) CLR 0 !D# ['] DRSPECT CFA ['] QUERY 8 + ! ; : SKETCH ( -- ) CLR >DRAW 1920 TYPE ; ridiculously stuffed-shirt theories, trivial bureaucratic inflexibility, mafia-controlled unsupervised incapability, defunct reciprocal immobility, non-functional analog de-programming, unresponsive logistical long shots, worthless bio-degradable time phasing, asynchronous decremental speculations, non-compatible ninth generation firmware, unqualified constantly changing through-put, partial assymmetric engineering, environmental undocumented modes, randomly executed context insensitive gambling, representative failure-prone personnel, mandatory low-budget congruence, transient user-hostile disk utilities, \ BUZZPHRASE GENERATOR -- Version 1.0 : BUZZ 80 BLOCK + 10 CHOOSE 64 * + 20 -TRAILING TYPE ; : 1ADJ 0 BUZZ ; : 2ADJ 20 BUZZ ; : NOUN 40 BUZZ ; : PHRASE 1ADJ SPACE 2ADJ NOUN SPACE ; : PARA CR CR ." BY USING " PHRASE ." COORDINATED WITH " CR PHRASE ." IT IS POSSIBLE FOR EVEN THE MOST " CR PHRASE ." TO FUNCTION AS " CR PHRASE ." WITHIN THE CONSTRAINT OF " PHRASE ." . " CR ; : 3PARA CLR PARA PARA PARA QUIT ; INTEGRATED MANAGEMENT CRITERIA TOTAL ORGANIZATION FLEXIBILITY SYSTEMATIZED MONITORED CAPABILITY PARALLEL RECIPROCAL MOBILITY FUNCTIONAL DIGITAL PROGRAMMING RESPONSIVE LOGISTICAL CONCEPTS OPTIMAL TRANSITIONAL TIME PHASING SYNCHRONIZED INCREMENTAL PROJECTIONS COMPATIBLE THIRD GENERATION HARDWARE QUALIFIED POLICY THROUGH-PUT PARTIAL DECISION ENGINEERING STAND-ALONE UNDOCUMENTED OUTFLOW RANDOM CONTEXT SENSITIVE SUPERSTRUCTURES REPRESENTATIVE FAIL-SAFE INTERACTION OPTIONAL OMNIRANGE CONGRUENCE TRANSIENT UNILATERAL UTILITIES In this paper we will demonstrate that On the one hand, studies have shown that On the other hand, however, practical experience indicates that In summary, then, we propose that by using by applying available resources towards with structured deployment of coordinated with to offset balanced by it is possible for even the most it becomes not unfeasable for all but the least it is necessary for all to function as to generate a high level of to avoid integrated management criteria total organizational flexibility systematized monitored capability parallel reciprocal mobility functional digital programming responsive logistical concepts optimal transistional time phasing synchronized incremental projections compatible third generation hardware qualified policy through-put partial decision engineering stand-alone undocumented outflow random context sensitive superstructures representative fail-safe interaction optional omnirange congruence transient unilateral utilities \ BUZZPHRASE GENERATOR II (Load Screen) tvm 7-12-83 78 CONSTANT RMARGIN VARIABLE LINECOUNT VARIABLE HOMEBASE 2 ALLOT : IN @ HOMEBASE 2! ; : WRITE> HOMEBASE 2@ >IN ! BLK ! ; : CR CR 0 LINECOUNT ! ; : SPACE LINECOUNT @ IF SPACE 1 LINECOUNT +! THEN ; : .WORD ( addr ) COUNT DUP LINECOUNT @ + RMARGIN > IF CR ELSE SPACE THEN DUP LINECOUNT +! TYPE ; : ANOTHER ( lim -- lim adr ) BL WORD OVER >IN @ < NOT ; : WORDS ( u ) >IN @ + BEGIN ANOTHER WHILE .WORD REPEAT 2DROP ; 85 LOAD 86 LOAD \ BUZZPHRASE GENERATOR -- HIGH LEVEL WORDS " : BUZZ 16 CHOOSE 64 * + >IN ! 83 BLK ! 20 WORDS ; : 1ADJ 0 BUZZ ; : 2ADJ 20 BUZZ ; : NOUN 40 BUZZ ; : PHRASE 1ADJ 2ADJ NOUN ; : FILLER ( u ) [ 4 64 * ] LITERAL * 3 CHOOSE 64 * + >IN ! 82 BLK ! 64 WORDS ; : SENTENCE 4 0 DO I FILLER PHRASE LOOP ." ." CR ; : INTRO ( u ) 64 * >IN ! 81 BLK ! CR 64 WORDS ; : PAPR ; : TEST CR ' SPACE ; \ RETRIEVAL OF MORE SUCCESSFUL PAPERS " VARIABLE SEED : 4POSTERITY RND @ SEED ! ; : PAPER 4POSTERITY PAPR ; : REDO SEED @ RND ! ; ( execute AFTER a paper, to reprint it. Usage: REDO PAPER ) : TENSEC 10 0 DO 1SEC WAIT LOOP ; : READ ( -- ) BEGIN PAPER TENSEC ?KEY UNTIL CLR QUIT ; : TST ( -- ) PAPER ; \ CHARS Version 1.2 : PLACE 23 CHOOSE 80 CHOOSE AT ; : CHARS ( -- ) ADM CLR BEGIN PLACE SEL-ASC EMIT CONSTAT UNTIL CLR QBYE ; ' CHARS PATCH \ Forth 3.3 ART 02dec83tvmVARIABLE CHR VARIABLE TIME VARIABLE #TIMES VARIABLE SEED : =TIMES #TIMES ! ; 750 #TIMES ! ( DEFAULT SETTING ) : =SPEED TIME ! ; 2 TIME ! ( DEFAULT SETTING ) : CHAR? CR CR CR 10 0 DO SPACE LOOP ." CHARACTER?" KEY CHR ! ; : CURSOR 80 XCHOOSE 23 XCHOOSE AT ; : PAINT RND @ SEED ! #TIMES @ 0 DO CURSOR CHR @ EMIT TIME @ WAIT LOOP ; : DESTROY SEED @ RND ! #TIMES @ 0 DO CURSOR BL EMIT TIME @ WAIT LOOP ; : ART CLR CHAR? CLR PAINT DESTROY CLR QUIT ; \ Forth 3.3 number base conversions ver 1.0 24jan84tvm \ TIMER -- LOW LEVEL WORDS Version 1.4 02jan84tvm VARIABLE TIME 14750 TIME ! VARIABLE HOURS VARIABLE MINUTES VARIABLE #MIN VARIABLE #HR : TEST 2 TIME ! ; : CLK 14750 TIME ! ; : HOUR 1 0 AT HOURS @ . ." :" ; : MINUTE 5 0 AT MINUTES @ DUP 10 < IF ." 0" THEN . ." :" ; : HOURS+ HOURS @ 1 + HOURS ! 0 MINUTES ! 13 EMIT ; : MINUTES+ MINUTES @ 1 + MINUTES ! ; : RESET 0 HOURS ! 0 MINUTES ! DARK ; : ALARM 5 0 DO 7 EMIT LOOP ; 91 LOAD \ TIMER -- HIGH LEVEL WORDS Version 1.5 : LOSEC 10 0 AT ." 0" 9 0 DO I . TIME @ WAIT 11 0 AT LOOP 10 0 AT ; : HISEC 60 10 DO I . TIME @ WAIT 10 0 AT LOOP ; : SET #MIN ! #HR ! ; : TIMER ( -- ) adm CLR ." Hit any key to start timer..." KEY DROP CUR/OFF RESET #HR @ 1 + 0 DO HOUR 60 0 DO MINUTE ?KEY IF LEAVE CUR/LINE QBYE THEN LOSEC HISEC MINUTES+ LOOP HOURS+ LOOP BELL BELL CUR/LINE QBYE ; ' TIMER PATCH \ Forth 3.3 DRAW DRSPECT 80 CONSTANT C/R VARIABLE D# VARIABLE >DRAW B/BUF 2* ALLOT : @D# ( -- n ) D# @ ; : !D# ( n -- ) 1 ?ENOUGH D# ! ; : !XPECT ( -- ) ['] XPECT CFA ['] QUERY 8 + ! ; : DRSPECT ( addr len -- ) DROP DROP >DRAW B/BUF 2* SWAP 0 >R BEGIN OVER R = IF + 0 SWAP ! R> DROP EXIT THEN KEY DUP 03 ( ~C) = IF DROP !XPECT R> DROP EXIT THEN DUP 08 ( lft) = IF DROP @D# 0= NOT IF @D# 1- !D# THEN ELSE DUP 12 ( rt) = IF DROP @D# 1919 < IF @D# 1+ !D# THEN ELSE DUP 22 ( dn) = IF DROP @D# 1839 < IF @D# C/R + !D# THEN ELSE DUP 11 ( up) = IF DROP @D# 79 > IF @D# C/R - !D# THEN ELSE DUP 23 ( ~W) = IF DROP FLUSH !XPECT R> + 0 SWAP ! DROP EXIT ELSE DUP EMIT OVER @D# + C! R> 1+ >R THEN THEN THEN THEN THEN AGAIN ; : DRAW ( -- ) CLR 0 !D# ['] DRSPECT CFA ['] QUERY 8 + ! ; : SKETCH ( -- ) CLR >DRAW 1920 TYPE ; \ Forth 3.3 NEWSIGN ORGSIGN 'SIGNON SIGNON= 17mar84tvmVARIABLE NEWSIGN 22 ALLOT VARIABLE ORGSIGN 22 ALLOT : 'SIGNON ['] COLD 45 + ; \ Leave sign-on address : .SIGNON ( -- ) CR \ Display default filename ." Current sign-on display: " 'SIGNON 20 TYPE CR ; : @SIGNON ( -- ) \ Fetch original sign-on 'SIGNON ORGSIGN 20 CMOVE ; : !SIGNON \ Restore original sign-on ORGSIGN 'SIGNON 20 CMOVE .SIGNON ; : SIGNON= ( -- ) \ Modifiy sign-on display @SIGNON CR CR ." Enter new sign-on display: " CR CR ." (Type RETURN to abort)" 5 SPACES 20 0 DO ASCII . EMIT LOOP 20 0 DO 8 EMIT LOOP NEWSIGN 20 EXPECT NEWSIGN C@ 0= IF CR !SIGNON END CR ELSE NEWSIGN 'SIGNON 20 CMOVE .SIGNON THEN ; \ Forth 3.3 LAUNCH : CTR CR 40 RT ; : .ROCKET 2 0 DO CTR ASCII | EMIT LOOP CTR 1 LFT ASCII / EMIT 94 EMIT ASCII \ EMIT CTR 2 LFT ASCII | EMIT 3 0 DO ASCII - EMIT LOOP ASCII | EMIT 6 0 DO CTR 2 LFT ASCII | EMIT 3 SPACES ASCII | EMIT LOOP CTR 2 LFT ASCII / EMIT 3 0 DO ASCII _ EMIT LOOP ASCII \ EMIT CTR 1 LFT ASCII | EMIT ASCII V EMIT ASCII | EMIT 7 UP CTR ASCII N EMIT CTR ASCII A EMIT CTR ASCII S EMIT CTR ASCII A EMIT ; : LAUNCH CUR/OFF ADM CLR 1SEC WAIT 12 DN .ROCKET 13 EMIT 1SEC WAIT 28 1 DO I NEGATE 28 + 250 * WAIT CR LOOP EDITOR TELEVIDEO FORTH 0 0 AT CUR/LINE QBYE ; ' LAUNCH PATCH \ Forth 3.3 REDO -- re-executes previous input st EXIT VARIABLE ?REDO VARIABLE >TIB 80 ALLOT >TIB 80 BLANK : ?TIB LAST @ IF >TIB ELSE TIB @ THEN ; : 2 XCHOOSE IF TIB @ ELSE >TIB THEN 80 XPECT 0 >IN ! ; : 0 BLK ! [COMPILE] [ BEGIN CRLF RP! INTERPRET ?REDO @ IF LAST @ NOT LAST ! FALSE ?REDO ! THEN STATE @ 0= IF ." ok" THEN AGAIN ; : REDO ( -- ) \ Re-execute input command stream TRUE ?REDO ! ; ' WORD 18 + DUP ' ?TIB CFA SWAP ! 0 SWAP ! ' CFA ' (QUIT) 12 + !