√── ( AUTHOR ) *** ELCOMP FORTH *** VERSION FOR ATARI BY E. FLOEGEL H.C. WAGNER ELCOMP PUBLISHING INC. ( ERROR MESSAGES ) EMPTY STACK COMPILATION ONLY EXECUTION ONLY ISN'T UNIQUE CONDITIONALS NOT PAIRED FULL STACK ( ERROR MESSAGES ) DEFINITION NOT FINISHED IN PROTECTED DICTIONARY USE ONLY WHEN LOADING OFF CURRENT EDITING SCREEN DECLARE VOCABULARY ISN'T A COLONDEFINITION ( UTILITIES ) ." UTILITIES LOADING" CR CREATE DOS HEX 6C C, 0A C, 00 C, SMUDGE : CASE SWAP 2 * + @ EXECUTE ; --> ( UTILITIES DUMP ) : .HEX <# # # #> TYPE ; : .ASC C@ 7F AND DUP 20 < IF DROP 2E ENDIF 1B EMIT EMIT ; : .ADR <# # # # # #> TYPE ; : DUMP CR HEX 1 - 8 / 1+ 0 DO DUP 0 .ADR SPACE 8 0 DO DUP I + C@ 0 .HEX SPACE LOOP 8 0 DO DUP I + .ASC LOOP 8 + CR LOOP DROP ; DECIMAL --> ( UTILITIES DECOMPILER ) : U.R 0 SWAP D.R ; : NOT 0= ; : GETPFA [COMPILE] ' ; ' QUIT CFA @ CONSTANT DOCOL : ?COLONDEF DUP CFA @ DOCOL = NOT 30 ?ERROR CR ." : DEFINITION" ; : PFA->ID. DUP 8 U.R DUP @ DUP 8 U.R 2 SPACES DUP 560 < OVER LATEST PFA CFA > OR IF . ELSE 2+ NFA ID. THEN CR ; --> ( UTILITIES DECOMPILER ) : ?;CODE DUP @ ' (;CODE) CFA = ; : ?;S DUP @ ' ;S CFA = ; : ?; ( pfa --> nfa f ) >R R @ ' (;CODE) CFA = R @ ' ;S CFA = OR R> SWAP ; : ;: ( ;: name - ) GETPFA ?COLONDEF CR BEGIN PFA->ID. ?; ?TERMINAL OR NOT WHILE 2+ REPEAT DROP ; --> ( UTILITIES ) : 'S SP@ ; : DEEP S0 @ 'S - 2 / 1 - ; : .S CR DEEP NOT 1 ?ERROR 'S 2 - S0 @ 2 - DO I @ . -2 +LOOP ; DECIMAL : LOAD-ED 50 LOAD ; : LOAD-IO 15 LOAD ; : LOAD-FLOAT 60 LOAD ; : LOAD-PM 30 LOAD ; --> ( UTILITIES SECTORCOPY ) 1 VARIABLE SEC 1 VARIABLE SECW HEX : READ B800 7000 DO I SEC @ 1 R/W 1 SEC +! SEC @ 2CF > IF LEAVE THEN 80 +LOOP ; : ?SECW SECW @ 2CF > IF ." OK" QUIT THEN ; : WRITE B800 7000 DO I SECW @ 0 R/W 1 SECW +! ?SECW 80 +LOOP ; --> ( UTILITIES SECTORCOPY ) : DISKCOPY 1 DUP SEC ! SECW ! CR BEGIN ." INSERT SOURCE, TYPE RETURN" KEY DROP CR CR READ ." INSERT DEST, TYPE ретурн" KEY DROP CR CR WRITE AGAIN ; : DR1->DR2 2D0 1 DO 7000 I 1 R/W 7000 I 2D0 + 0 R/W LOOP ; DECIMAL ;S ( IO-PACKAGE ) FORTH DEFINITIONS HEX ." IO-PACKAGE LOADING...." CREATE (CIO) 86 C, C5 C, A2 C, 60 C, A5 C, C7 C, 20 C, 56 C, E4 C, 85 C, C7 C, A6 C, C5 C, 4C C, 42 C, 20 C, SMUDGE : CIO C7 C! (CIO) C7 C@ ; --> ( IO-PACKAGE ) 60 VARIABLE IOCB : +IONO IOCB @ + ; : ICCOM 342 +IONO ; : ICSTA 343 +IONO ; : ICBAD 344 +IONO ; : ICBLE 348 +IONO ; : ICAX1 34A +IONO ; : ICAX2 34B +IONO ; --> ( IO-PACKAGE ) : TO# 10 * DUP IOCB ! ' (CIO) 3 + C! ; : FILE 0 VARIABLE -2 ALLOT ; FILE K: 4B C, 3A C, 9B C, FILE S: 53 C, 3A C, 9B C, FILE E: 45 C, 3A C, 9B C, FILE P: 50 C, 3A C, 9B C, FILE C: 43 C, 3A C, 9B C, --> ( IO-PACKAGE ) : ?ICERR ICSTA C@ DUP 7F > IF ." IO-ERROR " DECIMAL . CR QUIT ELSE DROP ENDIF ; --> ( IO-PACKAGE ) : OPEN TO# 3 ICCOM C! ICAX2 C! ICAX1 C! ICBAD ! (CIO) ?ICERR ; : CLOSE TO# 0C ICCOM C! (CIO) ?ICERR ; --> ( IO-PACKAGE ) : GET TO# 0 7 ICCOM C! 0 ICBLE ! CIO ?ICERR ; : PUT TO# 0B ICCOM C! 0 ICBLE ! CIO DROP ?ICERR ; --> ( IO-PACKAGE ) : PR-ON 4 CLOSE P: 8 0 4 OPEN ; : PR-OFF 4 CLOSE E: 8 0 4 OPEN ; --> ( IO-PACKAGE ) : SOUND 0232 C@ 07 AND D20F C! 0 D208 C! DUP 3 > IF ." NOT SUCH CHANNEL" QUIT ENDIF 2 * D200 + >R >R 10 * OR EF AND 100 * R> OR R> ! ; : RESSND D208 D200 DO 0 I C! LOOP ; DECIMAL --> ( IO-PACKAGE ) : GRN 6 OPEN ; : GR. 6 CLOSE >R S: 8 16 OR R> 6 OPEN ; : GR.16 6 CLOSE >R S: 8 R> 6 OPEN ; HEX : SETCOLOR DUP 4 > IF ." NO SUCH COLOR" . . . ELSE 02C4 + >R 10 * OR R> C! THEN ; --> ( IO-PACKAGE ) 0 VARIABLE COLR : COLOR COLR ! ; : DRAWTO COLR @ 02FB C! 54 C! 55 ! 6 TO# 11 ICCOM C! 0 ICBLE ! (CIO) ?ICERR ; : 2DUP OVER OVER ; : PLOT 2DUP 2DUP DUP 0= IF 1+ ELSE 1 - ENDIF 5A C! 5B ! DRAWTO DRAWTO ; --> ( IO-PACKAGE ) : POSITION 54 C! 55 ! ; : TYPE#6 -DUP IF OVER + SWAP DO I C@ 6 TO# 0B ICCOM C! 0 ICBLE ! CIO ?ICERR DROP LOOP ELSE DROP ENDIF ; --> ( IO-PACKAGE ) : (.#6") R COUNT DUP 1+ R> + >R TYPE#6 ; : .#6" 22 STATE @ IF COMPILE (.#6") WORD HERE C@ 1+ ALLOT ELSE WORD HERE COUNT TYPE#6 ENDIF ; IMMEDIATE DECIMAL --> ( IO-PACKAGE ) : STICK1 632 C@ ; : STICK2 633 C@ ; : STICK3 634 C@ ; : STICK4 635 C@ ; CASE STICK STICK1 STICK2 STICK3 STICK4 ; : STRIG1 644 C@ ; : STRIG2 645 C@ ; : STRIG3 646 C@ ; : STRIG4 647 C@ ; CASE STRIG STRIG1 STRIG2 STRIG3 STRIG4 ; DECIMAL ;S ( PM-GRAPHICS HCW ) CR ." PM-GRAPHICS LOADING .." HEX : NEXT 4C C, 42 C, 20 C, ; CREATE (PUP) HEX A0 C, 01 C, ( LDY #1 ) B1 C, C9 C, ( LDA [PT],Y ) 88 C, ( DEY ) 91 C, C9 C, ( STA [PT],Y ) C8 C, ( INY ) C8 C, ( INY ) D0 C, F7 C, ( BNE *-7 ) NEXT ( JMP NEXT ) SMUDGE --> ( PM-GRAPHICS HCW ) CREATE (PDOWN) HEX A0 C, FE C, ( LDY #254 ) B1 C, C9 C, ( LDA [PT],Y ) C8 C, ( INY ) 91 C, C9 C, ( STA [PT],Y ) 88 C, ( DEY ) 88 C, ( DEY ) D0 C, F7 C, ( BNE *-7 ) NEXT ( JMP NEXT ) SMUDGE --> ( PM GRAPHICS HCW ) CREATE (MDWN) HEX A0 C, FE C, ( LDY #254 ) B1 C, C9 C, ( LDA [PT],Y ) 29 C, 03 C, ( AND #MSK1 ) 48 C, ( PHA ) C8 C, ( INY ) B1 C, C9 C, ( LDA [PT],Y ) 29 C, FC C, ( AND #MSK2 ) 91 C, C9 C, ( STA [PT],Y ) 68 C, ( PLA ) 11 C, C9 C, ( ORA [PT],Y ) 91 C, C9 C, ( STA [PT],Y ) 88 C, 88 C, ( DEY DEY ) D0 C, EB C, ( BNE *-19 ) NEXT ( JMP ) SMUDGE --> ( PM GRAPHICS HCW ) CREATE (MUP) HEX A0 C, 01 C, ( LDY #1 ) B1 C, C9 C, ( LDA [PT],Y ) 29 C, 03 C, ( AND #MSK1 ) 48 C, ( PHA ) 88 C, ( DEY ) B1 C, C9 C, ( LDA [PT],Y ) 29 C, FC C, ( AND #MSK2 ) 91 C, C9 C, ( STA [PT],Y ) 68 C, ( PLA ) 11 C, C9 C, ( ORA [PT],Y ) 91 C, C9 C, ( STA [PT],Y ) C8 C, C8 C, ( INY INY ) D0 C, EB C, ( BNE *-19 ) NEXT ( JMP ) SMUDGE --> ( PM GRAPHICS HCW ) : INIT1 D0 DUP ' (PUP) 9 + C! ' (MUP) 15 + C! FE DUP ' (PDOWN) 1+ C! ' (MDWN) 1+ C! ; : INIT2 10 DUP ' (PUP) 9 + C! ' (MUP) 15 + C! 7E DUP ' (PDOWN) 1+ C! ' (MDWN) 1+ C! ; --> ( PM GRAPHICS HCW ) HEX 0 VARIABLE PMOFFSET 0 VARIABLE PMBASE 22F CONSTANT DMACTL D01D CONSTANT GRACTL D407 CONSTANT PMBAS C9 CONSTANT PT 0 VARIABLE MSIZ --> ( PM GRAPHICS HCW ) : PMG1 3 GRACTL C! 3E DMACTL C! 6A C@ 28 - DUP PMBAS C! 100 * 200 + PMBASE ! 100 PMOFFSET ! INIT1 ; : PMG2 3 GRACTL C! 2E DMACTL C! 6A C@ 28 - DUP PMBAS C! 100 * 100 + PMBASE ! 80 PMOFFSET ! INIT2 ; : PMG0 0 GRACTL C! 22 DMACTL C! ; CASE PMG PMG0 PMG1 PMG2 ; --> ( PM GRAPHICS HCW ) : PMADR DUP 4 < IF 2+ PMOFFSET @ * PMBASE @ + ELSE DROP PMOFFSET @ PMBASE @ + THEN ; : PMCLR PMADR PMOFFSET @ 00 FILL ; --> ( PM GRAPHICS HCW ) DECIMAL : DIM SWAP 2 * + ; 4 DIM 4^ 4 DIM MSK1 4 DIM MSK2 1 0 4^ ! 4 1 4^ ! 16 2 4^ ! 64 3 4^ ! 2 BASE ! 00000011 0 MSK1 ! 00001100 1 MSK1 ! 00110000 10 MSK1 ! 11000000 11 MSK1 ! 11111100 0 MSK2 ! 11110011 1 MSK2 ! 11001111 10 MSK2 ! 00111111 11 MSK2 ! HEX --> ( PM GRAPHICS HCW ) : MWIDTH 4 - DUP 4^ @ ROT * SWAP MSK2 @ MSIZ @ AND OR DUP MSIZ ! D00C C! ; : PWIDTH D008 + C! ; : PMWIDTH DUP 4 < IF PWIDTH ELSE MWIDTH THEN ; --> ( PM GRAPHICS HCW ) : PDOWN SWAP PT ! 0 DO (PDOWN) LOOP ; : PUP ABS SWAP PT ! 0 DO (PUP) LOOP ; : PUPDOWN DUP 0< IF PUP ELSE PDOWN THEN ; : PVMOVE PMADR SWAP DUP 0= IF DROP DROP ELSE PUPDOWN THEN ; : PMOVE SWAP OVER D000 + C! PVMOVE ; --> ( PM GRAPHICS HCW ) : MUP ABS SWAP PT ! 0 DO (MUP) LOOP ; : MDOWN SWAP PT ! 0 DO (MDWN) LOOP ; : MUPDOWN DUP 0< IF MUP ELSE MDOWN THEN ; : MVMOVE PMADR SWAP DUP 0= IF DROP DROP ELSE MUPDOWN THEN ; --> ( PM GRAPHICS HCW ) : MMOVE SWAP OVER D000 + C! >R R 4 - MSK1 @ DUP ' (MDWN) 5 + C! ' (MUP) 5 + C! R 4 - MSK2 @ DUP ' (MDWN) 0B + C! ' (MUP) 0B + C! R> MVMOVE ; : PMMOVE DUP 4 < IF PMOVE ELSE MMOVE THEN ; --> ( PM GRAPHICS HCW ) : PMCOLOR DUP 4 > IF ." NO SUCH COLOR" . . . ELSE 02C0 + >R 10 * OR R> C! THEN ; : SHAPE 0 VARIABLE DUP 1+ 0 DO C, LOOP DOES> DUP C@ SWAP 1+ ROT ROT CMOVE ; DECIMAL 28 16 16 16 56 60 63 56 56 16 24 28 24 126 24 15 SHAPE COWBOY --> ( PM GRAPHICS HCW ) : NULL 0 ; : ONE 1 ; : MONE -1 ; CASE VERT NULL NULL NULL NULL NULL ONE MONE NULL NULL ONE MONE NULL NULL ONE MONE NULL ; CASE HORI NULL NULL NULL NULL NULL ONE ONE ONE NULL MONE MONE MONE NULL NULL NULL NULL ; : HSTICK STICK HORI ; : VSTICK STICK VERT ; --> ( PM GRAPHICS HCW ) : MISSILE >R R PMADR + DUP ROT 1 - + SWAP R> 4 - ROT ROT DO I C@ OVER MSK1 @ XOR I C! LOOP DROP ; --> ( PM GRAPHICS HCW ) HEX 4 DIM MSK3 1 0 MSK3 ! 2 1 MSK3 ! 4 2 MSK3 ! 8 3 MSK3 ! : MASK MSK3 @ AND ; --> ( PM GRAPHICS HCW ) : PFBUMP SWAP 8 - SWAP D004 + C@ SWAP MASK ; : PPBUMP D00C + C@ SWAP MASK ; : MPBUMP 4 - D008 + C@ SWAP MASK ; : MFBUMP 4 - SWAP 8 - SWAP D000 + C@ SWAP MASK ; : PBUMP OVER 4 < IF PPBUMP ELSE PFBUMP THEN ; : MBUMP OVER 4 < IF MPBUMP ELSE MFBUMP THEN ; --> ( PM GRAPHICS HCW ) : HITCLR D01E C! ; : BMP DUP 4 < IF PBUMP ELSE MBUMP THEN ; : BUMP OVER OVER OR 0= IF HITCLR DROP ELSE BMP 0= 0= THEN ; DECIMAL ;S ( LINE EDITOR ) VOCABULARY EDITOR IMMEDIATE EDITOR DEFINITIONS HEX ." LOADING EDITOR" CR : TEXT ( --> ) CR ." " PAD 1+ C/L EXPECT C/L 0 DO PAD 1+ I + C@ 0= IF PAD 1+ I + C/L BLANKS LEAVE ENDIF LOOP C/L PAD C! ; : LINE ( n --> addr ) DUP FFF0 AND 17 ?ERROR SCR @ (LINE) DROP ; : -MOVE LINE C/L CMOVE UPDATE ; --> ( EDITOR CONT ) : H ( n --> ) LINE PAD 1+ C/L DUP PAD C! CMOVE ; : L LEER SCR @ LIST ; : E ( n --> ) LINE C/L BLANKS UPDATE ; DECIMAL : S ( n --> ) DUP 1 - 14 DO I LINE I 1+ -MOVE -1 +LOOP E L ; : D ( n --> ) DUP H 15 DUP ROT DO I 1+ LINE I -MOVE LOOP E L ; --> ( EDITOR CONT ) : "R ( --> ) PAD 1+ SWAP -MOVE ; : P ( n --> ) TEXT "R ; : M ( n --> ) P L ; : CLEAR SCR ! 16 0 DO I E LOOP ; DECIMAL --> ( EDITOR END ) : COPY B/SCR * OFFSET @ + SWAP B/SCR * B/SCR OVER + SWAP DO DUP I BLOCK 2 - ! 1+ UPDATE LOOP DROP FLUSH ; : -> 1 SCR +! L ; : <- -1 SCR +! L ; FORTH DEFINITIONS ;S ( DEMO GAME HCW ) 0 VARIABLE POINTS 0 VARIABLE XM 0 VARIABLE YM 0 VARIABLE YV 0 VARIABLE XV 0 VARIABLE X 0 VARIABLE YM1 126 126 126 3 SHAPE RACKET HERE VARIABLE RND : RANDOM RND @ 31421 * 6972 + DUP RND ! ; : RNDNR RANDOM U* SWAP DROP ; : PFINI 5 GR. 0 0 2 SETCOLOR 1 COLOR 0 0 PLOT 79 0 DRAWTO 79 39 DRAWTO 0 39 DRAWTO 0 0 DRAWTO ; --> ( DEMO GAME HCW ) : PLINI 2 PMG 15 5 0 PMCOLOR 0 PMCLR 1 0 PMWIDTH 0 PMADR 85 + RACKET 120 X ! 0 120 0 PMMOVE ; : INIT PFINI PLINI 0 POINTS ! ; : INITM 4 PMCLR 1 19 4 MISSILE ; : MVECT 2 RNDNR 1+ YV ! 2 RNDNR 2 + MINUS XV ! 19 DUP YM ! YM1 ! 120 XM ! ; --> ( DEMO GAME HCW ) : SETP 0 HSTICK 2 * DUP 0< IF X @ 47 > * ELSE X @ 193 < * THEN X +! 0 X @ 0 PMMOVE ; : MXY XV @ XM +! YV @ YM +! ; : MM YM @ YM1 ! MXY XM @ 50 < XM @ 205 > OR IF 15 20 10 0 SOUND RESSND XV @ MINUS XV ! MXY MXY ENDIF YM @ 19 < YM @ 92 > OR IF 15 20 10 0 SOUND RESSND YV @ MINUS YV ! MXY MXY ENDIF ; --> ( DEMO GAME HCW ) : SETM YM @ YM1 @ - XM @ 4 PMMOVE ; : .SCORE ." SCORE " POINTS ? ; : WAIT BEGIN 0 STRIG 0= UNTIL ; : GAME INIT BEGIN INITM MVECT 0 0 BUMP BEGIN SETP SETM MM 0 4 BUMP UNTIL 1 POINTS +! LEER .SCORE WAIT ?TERMINAL UNTIL ; ;S ( DEMO HSTICK VSTICK HCW ) 4 DIM X : MOV >R R HSTICK 2 * R X +! R VSTICK 2 * R X @ R> PMMOVE ; : INI 120 0 X ! 150 1 X ! 2 PMG 10 5 0 PMCOLOR 10 13 1 PMCOLOR 1 PMCLR 0 PMCLR 0 PMADR 60 + COWBOY 1 PMADR 60 + COWBOY 0 120 0 PMMOVE 0 150 1 PMMOVE ; : DEMO INI BEGIN 0 MOV 1 MOV ?TERMINAL UNTIL ;