Camel99 Forth Information goes here

+Lee Stewart · January 12, 2023

1 hour ago, TheBF said:

DUH!

I think it's just X 8 MOD is the same as 7 AND.

OK That will remove 3 more instructions.

I am pretty sure the fbForth DOT word for Bitmap graphics does something like this, but I should probably revisit the code to make sure. As I recall, it was pretty painful working with that code and it will surely take me a little time to reorient myself to it. :ponder:

...lee

+TheBF · January 16, 2023

I was reading the site and saw @RXB 's post about how GCHAR in BASIC is being a pain the *ss in getting sped up.

Out of curiosity I took this program in TI-BASIC

10 CALL GCHAR(24,1,X)
20 GOTO 10

And looked at the Classic99 Heatmap to see how much code was running. OMG.

That's a lot of stuff.

image.png.835f22ef58154c0a1711ddce0668c026.png

BASIC code heat map

My only point of reference of course is my system which I know does a lot less stuff than BASIC has to accomplish.

(parsing multiple reads in one call, floating point conversions, re0interpreting each time)

The equivalent Camel99 Forth code is below.

It also calls the ROM "BREAK" routine with the ?TERMINAL key-word to be closer to the BASIC code.

All that to say I am amazed that this so much harder for BASIC do faster than the stock code.

But I know Jack Squat about the innards of the GPL interpreter.

VARIABLE X
: GCHAR ( x y -- char) >VPOS  VC@  ;
: RUN   
    BEGIN  
       0 23 GCHAR X !  
       ?TERMINAL 
    UNTIL ;

image.png.6e47a3c6646f1f6021d303e5b7a947f1.png

Forth code heat map

+TheBF · January 20, 2023

Here is something I have just started using that is almost as convenient as a cartridge.

I compiled my Super-Cart development system version (tools, assembler, vocabularies, elapse and ANS-Files) as UTIL1,UTIL2

If you put these two files on DSK1 you can start Forth with four keystrokes under Editor/Assembler in Classic99 or on real hardware with Supe-Cart installed.

From the title screen press 2,2,5,<enter>

CAMEL99-UTIL1.ZIP

+TheBF · January 31, 2023

I put in a lot of work on the vi99 project but one vi function it doesn't have yet is jumping the cursor from word to word, backwards or forwards.

I remember over 30 years ago adding that feature to an editor I wrote for MVP Forth for the PC.

I remember it being harder than I thought it should be and I think I used something like a state machine with a variable.

It was hard coded for the editor and not useful for anything else.

(I actually just found the code because I ported that block editor to HsForth. It used a lot of DO LOOPS and LEAVE)

I am happy to say that after only 30 something years I have learned something.

Find next word Going Forward:

The word SKIP lets you skip past the char that you specify.

The word SCAN lets you look for the presence of the char that you specify.

Find next word Going Backward:

The word -TRAILING scans a string backwards

There is no "standard" function to scan backward past anything that is NOT a space.

Here is mine. (couldn't think of a better name)

: -ASCII ( addr len -- addr len') \ scan back until BL
    1-
    OVER +  ( -- start end )
    BEGIN 2DUP <>    \ test end of string 
    WHILE      
        DUP C@ BL <> 
    WHILE            \ test for blank 
        1-           \ dec address 
    REPEAT 
    THEN 
    OVER - 0 MAX 
;

I am testing this out on the VIBE block editor because it's a simpler system to play with.

Without going into all the dirty details inside the editor it works like this:

Treat the block like a big string.
From the cursor position, compute the bytes "after the cursor" and make a stack string (addr,len)
Just do BL SKIP BL SCAN and you have a new string that begins with the next word!
to go backwards create string from the beginning of the block to the cursor address in the form (addr,len)
do -TRAILING -ASCII and the ~~first~~ LAST word in the string is the previous word.

After that it's just some address math to convert the address to the col and row for the cursor.

It's nice to know that it only took me 30+ years to grok Forth.

Inside VIBE it looks like this:

Spoiler

\ VIBE Release 2.2 
\ Copyright (c) 2001-2003 Samuel A. Falvo II
\ All Rights Reserved
\   Highly portable block editor --

\ * Use with written permission for Camel99 Forth *

\ USAGE: VI <filepath> opens BLOCK FILE,
\        VI (no parameter) goto last used block
\        VIBE ( n -- ) Edits block 'n'.  Sets SCR variable to 'n'.
\
\ 2.1 -- Fixed stack overflow bugs; forgot to DROP in the non-default
\        key handlers.
\
\ 2.2 Ported to CAMEL99 Forth B. Fox 2019
\     Removed some character constants to save space.
\     Changed TYPE for VTYPE.
\     Removed shadow block function
\     Added some block navigation commands

\ 2.3 Fixed keyboard bugs for TI-99/4A
\     VI command takes a filename parameter like real VI
\     simplfied wipe screen logic and saved bytes
\     Add $ command: goto end of line
\     Add PC delete KEY for Classic99

\ 2.4 Change CMOVE, CMOVE>  to MOVE for Camel99 2.69

\ 2.5 Changed [ ]  key bindings to ^f ^b like vi
\     Added w and b commands for word jumping 

( libary includes for Camel99 Forth)
NEEDS WORDLIST  FROM DSK1.WORDLISTS

ONLY FORTH DEFINITIONS 
NEEDS DUMP      FROM DSK1.TOOLS
NEEDS 80COLS    FROM DSK1.80COL
NEEDS RKEY      FROM DSK1.RKEY
NEEDS BLOCK     FROM DSK1.BLOCKS
NEEDS -TRAILING FROM DSK1.TRAILING
NEEDS MARKER    FROM DSK1.MARKER

MARKER /VIBE

VOCABULARY EDITOR 

ONLY FORTH ALSO EDITOR DEFINITIONS 

HERE

( Editor Constants )
CHAR i  CONSTANT 'i   \ Insert mode
CHAR c  CONSTANT 'c   \ Command mode
\ camel99 values
DECIMAL
       64 CONSTANT WIDTH
 WIDTH 1- CONSTANT LENGTH
       80 CONSTANT MAXBLKS
 1024     CONSTANT 1K

( Editor State )
 VARIABLE SCR       \ Current block
 VARIABLE X         \ Cursor X position 0..LENGTH
 VARIABLE Y         \ Cursor Y position 0..15
 VARIABLE MODE      \ current mode: INSERT or command ( 'i OR 'c

\ CMDNAME the command string, is built, found and executed
CREATE CMDNAME    5 C,  CHAR $ C, CHAR $ C,  0 C, 0 C, 0 C,

( Editor Display )
 DECIMAL
: BLANKS   BL FILL ; \ BF add
: MODE.    LENGTH 0 AT-XY MODE @ EMIT ;
: VTYPE    ( addr len -- ) TUCK  VPOS SWAP VWRITE   VCOL +! ;
: SCR.     0 0 AT-XY
           S" Block: " VTYPE  SCR @ . ( S"      " VTYPE ) ;
: HEADER   SCR. MODE. ;
: 16-S     S" ----------------" VTYPE ;
: WIDTH-S  16-S 16-S 16-S ;
: BORDER   SPACE WIDTH-S CR ;
: ROW      ( addr -- addr') DUP LENGTH VTYPE 64 + ; \ FAST
\ : ROW    ( addr -- addr') DUP LENGTH TYPE LENGTH + ;   \ SLOW
: LINE     ( addr -- addr') [CHAR] | (EMIT)  ROW CR ;
: 4LINES   ( addr -- ) LINE LINE LINE LINE ;
: 'BLOCK   ( -- addr) SCR @ BLOCK ;
: 16LINES  'BLOCK  4LINES 4LINES 4LINES 4LINES DROP ;
: CARD     0 1 AT-XY BORDER 16LINES BORDER ;
: CURSOR   X @ 1+  Y @ 2+ AT-XY ;
: SCREEN   HEADER CARD  CURSOR ;

( Editor State Control )
: INSERT   'i MODE !  30 CURS ! ; \ change cursor character to show mode 
: REPLACE   [CHAR] r MODE ! ;
: CMD       'c MODE ! 31 CURS ! ;

: BOUNDED   ( addr n -- ) 0 MAX MAXBLKS MIN SWAP ! ;
: PREVBLOCK  SCR DUP @ 1- BOUNDED ;
: NEXTBLOCK  SCR DUP @ 1+ BOUNDED ;
\ : TOGGLESHADOW 1 SCR @ XOR SCR ! ;

( Editor Cursor Control )
: FLUSHLEFT  X OFF ;
: BOUNDX     X @  0 MAX LENGTH MIN X ! ;
: BOUNDY     Y @  0 MAX 15 MIN Y ! ;
: BOUNDXY    BOUNDX BOUNDY ;
: LEFT       X 1-! BOUNDXY ;
: RIGHT      X 1+! BOUNDXY ;
: UP         Y 1-! BOUNDXY ;
: DOWN       Y 1+! BOUNDXY ;
\ : beep     7 EMIT ;
: NEXTLINE   Y @ 15 < IF FLUSHLEFT DOWN THEN ;
: NEXT       X @ LENGTH = IF NEXTLINE EXIT  THEN RIGHT ;

( Editor Insert/Replace Text )
: 64*        6 LSHIFT ;  \  x64 
: WHERE ( col row -- addr) 64* +  'BLOCK + ;
: WH         X @ Y @ WHERE ;
: SOL        0  Y @ WHERE ;
: EOL        LENGTH Y @ WHERE ;
: PLACE      WH C! UPDATE NEXT ;
: -EOL?      X @ LENGTH < ;
: OPENR      WH DUP 1+ LENGTH X @ - MOVE ;
: OPENRIGHT  -EOL? IF OPENR THEN ;
: INSERTING?  MODE @ 'i = ;
: CHR         INSERTING? IF OPENRIGHT THEN PLACE ;
: EOTEXT      SOL LENGTH -TRAILING NIP X ! ;

: BELOW   ( -- n) 'BLOCK 1K + WH - ; \ n=bytes below cursor 
: NXTWRD  ( addr n -- addr' )  BL SKIP BL SCAN  DROP ;
: >OFFSET ( addr n -- n') 'BLOCK -  1K 1- MIN ;
: ADR>XY  ( addr --) WIDTH /MOD   Y !  1+ X ! BOUNDXY ;

\ scans entire block for next word 
: NEXTWORD   WH BELOW  NXTWRD  >OFFSET ADR>XY ; 

: -ASCII ( addr len -- addr len') \ scan back until BL
    1-
    OVER +  ( start end )
    BEGIN 2DUP <> 
    WHILE           \ test end of string 
          DUP C@ BL <> 
    WHILE           \ test for blank 
          1-        \ dec address 
    REPEAT 
    THEN 
    OVER - 0 MAX 
;    

: PRVWRD    -TRAILING  -ASCII  ;
: PREVWORD  'BLOCK WH OVER - PRVWRD NIP  ADR>XY  ;    

( Editor Keyboard Handler CMDWORD encoding)
\ CMD name key: $ $ _ _ _
\                    | | |
\ 'c'=command mode --+ | |
\ 'i"=ins/repl mode    | |
\                      | |
\ Key code (hex#) -----+-+
\
\ Called with ( k -- ) where k is the ASCII key code.

( Editor COMMANDS: Quit, cursor, block, et. al. )
( Modified for Ti-99 keyboard )
: $$c30  DROP FLUSHLEFT ;         \ 0  goto start of line     
: $$c24  DROP EOTEXT ;            \ $  goto end of line
: $$c69  DROP INSERT ;            \ i
: $$c49  DROP FLUSHLEFT INSERT ;  \ I
: $$c52  DROP REPLACE ;           \ R
: $$i0F  DROP 31 CURS ! CMD ;     \ (esc) GOTO command mode
: $$c68  DROP LEFT ;              \ h
: $$c6A  DROP DOWN ;              \ j
: $$c6B  DROP UP ;                \ k
: $$c6C  DROP RIGHT ;             \ l
: $$c06  DROP NEXTBLOCK ;         \ ^F  ( CHANGE FROM VIBE )
: $$c02  DROP PREVBLOCK ;         \ ^B  ( CHANGE FROM VIBE )
\ : $$c5C  DROP TOGGLESHADOW ;    \ \
: $$c77  DROP NEXTWORD  ;         \ w
: $$c62  DROP PREVWORD  ;         \ b  
: $$c5E  DROP X OFF Y OFF CURSOR ; \ ^

( Editor Backspace/Delete )
: PADDING  BL EOL C! UPDATE ;
: DEL      WH DUP 1+ SWAP LENGTH X @ - MOVE ;
: DELETE   -EOL? IF DEL THEN PADDING ;
: BS        LEFT DELETE ;
: BACKSPACE  X @ 0 > IF BS THEN ;
( Editor Carriage Return )
: NEXTLN    EOL 1+ ;
: #CHRS     'BLOCK 1K + NEXTLN - WIDTH - ;
: COPYDOWN  Y @ 14 < IF NEXTLN DUP WIDTH + #CHRS MOVE THEN ;
: BLANKDOWN NEXTLN WIDTH BLANKS UPDATE ;
: SPLITDOWN WH NEXTLN 2DUP SWAP - MOVE ;
: BLANKREST WH NEXTLN OVER -  BLANKS ;
: OPENDOWN  COPYDOWN BLANKDOWN ;
: SPLITLINE OPENDOWN SPLITDOWN BLANKREST ;
: RETRN     INSERTING? IF SPLITLINE THEN FLUSHLEFT NEXTLINE ;
: RETURN    Y @ 15 < IF RETRN THEN ;

( Editor Wipe Block ) \ simplified by BFox
HEX
: >UPPER  ( c -- c')  5F AND ;
DECIMAL
: PROMPT      0 19 AT-XY ;
: MSG         PROMPT ." Are you sure? (Y/N) " ;
: CLRMSG      PROMPT  WIDTH SPACES ;
: NO?         MSG KEY >UPPER CLRMSG [CHAR] Y <> ;
: ?CONFIRM    NO? IF R> DROP THEN ;
: WIPE        ?CONFIRM 'BLOCK 1K BLANKS 
              UPDATE X OFF  Y OFF ;

( Editor Commands: backspace, delete, et. al. )
: $$i04       DROP DELETE ;                 \ ^D
: $$i03       DROP DELETE ;                 \ PC delete key
: $$i08       DROP BACKSPACE ;              \ Backspace
\ : $$i7F       DROP BACKSPACE ;             \ DEL -- for Unix
: $$i0D       DROP RETURN ;                 \ Enter
: $$c5A       DROP WIPE ;                   \ Z
: $$c6F       DROP OPENDOWN DOWN $$c49 ;    \ o
: $$c4F       DROP OPENDOWN ;               \ O
: $$i15       DROP X OFF  Y OFF ;           \ i INSERT mode

: >FORTH  PROMPT ." Forth" CR .S  QUIT ;
: $$c51  DROP >FORTH ; \ Q -- quit editor, enter Forth 
: $$c3A  DROP >FORTH ; \ ':' for vi compatibility 

HEX
  0F CONSTANT $0F
  F0 CONSTANT $F0

: KEYBOARD    RKEY 7F AND ;  \ for TI-99 we need to mask upper bit
DECIMAL
: CMD?        MODE @ 'c = ;
: INS?        MODE @ 'i =   MODE @ [CHAR] r =  OR ;
: MODE!       INS? 'i AND CMD? 'c AND OR  CMDNAME 3 + C! ;
: >HEX        DUP 9 > IF 7 + THEN [CHAR] 0 + ;
: H!          DUP $F0 AND  4 RSHIFT >HEX  CMDNAME 4 + C! ;
: L!          $0F AND >HEX CMDNAME 5 + C! ;
: NAME!       MODE! H! L! ;

: NOMAPPING   ['] HONK CMD? AND   ['] CHR INS? AND  OR ;

\ : .CMDNAME    68 0 AT-XY CMDNAME COUNT TYPE ; \ debugging
: HANDLERWORD
  NAME!  CMDNAME FIND 0= IF DROP DROP NOMAPPING THEN ;

: HANDLER  DUP  HANDLERWORD EXECUTE ;

: EDITLOOP 
  'c MODE !  31 CURS ! 
  BEGIN  KEYBOARD HANDLER  SCREEN  AGAIN ;

: VIBE ( n -- ) DECIMAL SCR ! PAGE SCREEN EDITLOOP ;
: EDIT   SCR @ VIBE ;
\ \\\\\\\\\\\\\\\\\\\\\\\\\\ VIBE ENDS \\\\\\\\\\\\\\\\\\\\\\\\\\


\ VI command additions
: USE ( <path>) \ open a block file to use 
  PARSE-NAME DUP 0> IF  OPEN-BLOCKS  SCR OFF  THEN ;

: LIST    ( n -- ) SCR ! PAGE SCREEN 50 18 AT-XY ;
: INDEX   ( from to -- )
  1+ SWAP ?DO  CR I 4 .R 2 SPACES I BLOCK 64 TYPE ?BREAK  LOOP ;

SCR OFF
HERE SWAP - DECIMAL . .( bytes)

USE DSK7.BLOCKS

Edited January 31, 2023 by TheBF
changed first to last

+Lee Stewart · January 31, 2023

12 hours ago, TheBF said:

Here is mine. (couldn't think of a better name)

: -ASCII ( addr len -- addr len') \ scan back until BL
    1-
    OVER +  ( -- start end )
    BEGIN 2DUP <>    \ test end of string 
    WHILE      
        DUP C@ BL <> 
    WHILE            \ test for blank 
        1-           \ dec address 
    REPEAT 
    THEN 
    OVER - 0 MAX 
;

What’s the matter with just inverting the logic in -TRAILING ?

\ -ASCII from -TRAILING code
: -ASCII   ( addr len --- addr len' )
   DUP 0 DO
      OVER OVER + 1- 
      \ Inversion of IF..ELSE..THEN is only change to -TRAILING
      C@ BL - IF       
         1-
      ELSE
         LEAVE
      THEN
   LOOP  ;

...lee

+TheBF · January 31, 2023

4 hours ago, Lee Stewart said:

What’s the matter with just inverting the logic in -TRAILING ?

\ -ASCII from -TRAILING code
: -ASCII   ( addr len --- addr len' )
   DUP 0 DO
      OVER OVER + 1- 
      \ Inversion of IF..ELSE..THEN is only change to -TRAILING
      C@ BL - IF       
         1-
      ELSE
         LEAVE
      THEN
   LOOP  ;

...lee

That would work just as well. I have -TRAILING as code version in a library file so I just needed a Forth way to do what you have here.

I hate to admit it but I have grown accustomed to those weird double WHILE statements.

For the longest time I thought they were an abomination, but now I just see them as jumps like you would see in ALC.

However I think your version uses less instructions so mine might be changing. 🙂

Thanks

+TheBF · February 1, 2023

I wanted to update some fonts and realized that the source I had was for previous ways that I defined patterns.

Wouldn't it by nice to read the font out of VDP RAM and generate the source code?

I made a BASIC version just because it was possible.

\ font2src.fth generates CALLCHAR statements FORTH & BASIC  Feb 1, 2023

INCLUDE DSK1.TOOLS 
INCLUDE DSK1.OUTFILE \ redefines TYPE EMIT  CR 
INCLUDE DSK1.UDOTR 

HEX 800 CONSTANT PDT 

DECIMAL 
: ]PDT  ( c-- Vaddr) 8* PDT + ;
\ character markup 
: <BL>    BL EMIT ;
: <">     [CHAR] " EMIT ;
: <\>     [CHAR] \ EMIT  <BL> ; 
: <S">    [CHAR] S EMIT  <">  <BL>  ;
: <(>     [CHAR] ( EMIT ;
: <)>     [CHAR] ) EMIT ;
: <,>     [CHAR] , EMIT ;

: V@++  ( Vaddr -- VAddr++, n) DUP V@  SWAP 2+  SWAP  ;
: .####  ( ) 
  BASE @ >R  HEX  0 <# # # # # #> TYPE  R> BASE !  ;

: .PATTERN ( char -- ) 
  ]PDT V@++ .#### V@++ .#### V@++ .#### V@++ .#### DROP ;

: FTH.PATTERN ( char -- )  
  CR <S"> DUP .PATTERN <"> <BL> DUP 3 .R  S"  CALLCHAR " TYPE <\>  EMIT  ;

: BASIC.PATTERN 
 CR  DUP 2000 + 4 .R  <BL> S" CALL CHAR" TYPE 
 <(> DUP 3 .R <,>  
 <"> .PATTERN <"> <)> ;

: FTH.FONT   ( 1st last --)
     1+ SWAP ?DO  I FTH.PATTERN  LOOP CR   ; 
: BASIC.FONT ( 1st last --) 
     1+ SWAP ?DO I BASIC.PATTERN  LOOP CR   ;

DECIMAL 

S" DSK7.FONT0230-S" MAKE-OUTPUT 
0 126 FTH.FONT 
CLOSE-OUTPUT 

S" DSK7.BASIC230-S" MAKE-OUTPUT 
0 126 BASIC.FONT 
CLOSE-OUTPUT

+TheBF · February 8, 2023

VIBE updated

After all my work on VI99 I am much more familiar with the vi key commands so I went back into VIBE by Sam Falvo and made it a bit more vi-like even with a ':" command that takes you to an interpreted command line. I tried to use Sam's writing style with the extensions.

The results are in a separate repository bfox9900/VIBE99: A vi like editor for Forth BLOCK files for TI-99 (github.com)

The one thing I don't like about the architecture is that every keystroke goes through the Forth interpreter.

This is fine for commands but when typing it slows down the speed at which you can type.

Dictionary searches are not super speedy on TI-99.

The other thing is that this editor is now huge.

Other than that it makes serviceable block editor, especially if you prefer vi.

This version has a pretty big command set:

\    Forth                        VIBE Key
: $$c06  DROP NEXTBLOCK ;         \ ^F  ( CHANGE FROM VIBE )
: $$c02  DROP PREVBLOCK ;         \ ^B  ( CHANGE FROM VIBE )
: $$c1A  DROP PAGE .NOTSAVED CONSOLE ; \ ^Z to command shell 
: $$c24  DROP EOTEXT ;            \ $  goto end of line
: $$c30  DROP FLUSHLEFT ;         \ 0  goto start of line   
: $$c41  DROP EOTEXT REPLACE ;    \ A  append at end of line 
: $$c47  DROP FLUSHLEFT 15 Y ! ;  \ G  bottom line 
: $$c48  DROP FLUSHLEFT Y OFF ;   \ H  goto home, top left
: $$c49  DROP FLUSHLEFT INSERT ;  \ I
: $$c4D  DROP WIDTH 2/ X ! ;      \ M  middle of line 
: $$c52  DROP REPLACE ;           \ R  replace 1 char at cursor
: $$c50  DROP PASTE ;             \ P  paste before cursor line 
: $$c61  DROP NEXT REPLACE ;      \ a  append after cursor  
: $$c62  DROP PREVWORD  ;         \ b  
: $$c64  DROP DELINE ;            \ d  delete line 
: $$c68  DROP LEFT ;              \ h
: $$c69  DROP INSERT ;            \ i
: $$c6A  DROP DOWN ;              \ j
: $$c6B  DROP UP ;                \ k
: $$c6C  DROP RIGHT ;             \ l
: $$c72  DROP KEY PUTC UPDATE ;   \ r replace char at cursor 
: $$c75  DROP EMPTY-BUFFERS SCREEN ;  \ u undo since last flush
: $$c77  DROP NEXTWORD  ;         \ w
: $$c78  DROP DELETE ;            \ x delete char at cursor 
: $$c79  DROP KEY 'y = IF YANK THEN ; \ yy yank line

"colon" commands execute at command line have aliases in upper and lower case

: Q!    .FORTH  CR .NOTSAVED CONSOLE ;
: q!    Q! ;  

: w     FLUSH  SCREEN ;
: W     w ; 

: wq    FLUSH .FORTH CONSOLE ;
: WQ    wq ; 

: vibe  ( n -- ) VIBE ;
: G     ( n -- ) VIBE ;
: KC    TP OFF ;  \ kill clipboard 
: edit  EDIT ;

Utility Commands

: USE ( <path>)  close then open block file, open new path
: LIST ( n -- )  list a block but stay in Forth 
: INDEX ( n n2 -- ) show top line of blocks from n to n2

I cheated by using 80 column mode just to get everything working smoothly.

I don't think I will go any further with it.

And of course, when I tried to save VIBE99 as a binary image something is not working correctly even though two other editors I made save perfectly.

It may have something to do with initializing the BLOCK file system since I have never saved that as a program image, so I will have to look into that.

+TheBF · February 8, 2023

It is always a welcome surprise when a big project compiles on a different compiler.

I had to update DSK1.BLOCKS to my newer version and I updated DSK1.80COL as well on spec. and it compiled and ran under the direct-threaded compiler.

VIBE99 with the required libraries, uses almost 10K of dictionary under DTC but with super cart that still gives 13.8K remaining for the programmer.

+TheBF · February 10, 2023

With @Retrospect making a new game everyday it seems, I thought I would try to drink some of my own Koolaid.

I have long thought that the Forth task system was up to the job but as one who never played games much I was never motivated to prove it.

I have very little visual imagination so I stole some resources that @Retrospect generated a year ago or so and turned them into a simple game.

The unique thing about this game is that it combines multi-tasking sprite motion and interrupt driven sprite motion.

The Asteroid field which just flies across the screen is Auto-motion. (it started on a task but I changed it)

In my sprite system you can state how many sprites are moving with the word MOVING.

By putting the asteroids first and saying 4 MOVING, the AUTOMOTION only tries to move 4 sprites, saving processor time.

The bouncing and rotation of the ball figures are four separate tasks, two for each ball.

The flying comet weapon is running on a task that is started and runs until the comet hits the screen edge, at which point it puts itself to sleep.

The sound that runs when an asteroid is struck is another task.

The 6th task is sequencing the asteroid patterns. (that could be made better looking but I just wanted to see if this could be done)

I found it took more planning to put things together this way in the beginning but once you decide on "who" is doing what its a nice way to make a game.

Like having trained dogs to move things for you.

I should add that there are no sound lists used. Sound is created with Forth code and simple primitives.

Spoiler

\ BILLYBALL XB256 DEMO by @Retrospect on atariage.com   Nov 1 2021
\ Used for Multi-tasking Game Demo for Camel99 Forth  B Fox

INCLUDE DSK1.TOOLS    \ DEBUG ONLY
INCLUDE DSK1.MARKER
INCLUDE DSK1.MALLOC
INCLUDE DSK1.GRAFIX
INCLUDE DSK1.RANDOM
INCLUDE DSK1.SOUND
INCLUDE DSK1.DIRSPRIT \ direct control sprites
INCLUDE DSK1.AUTOMOTION 
INCLUDE DSK1.MTASK99
INCLUDE DSK1.MTOOLS   \ DEBUG ONLY
INCLUDE DSK1.RANDOM
INCLUDE DSK1.JOYST 
INCLUDE DSK1.UDOTR 

 1 CONSTANT Transparent
 2 CONSTANT Black
 5 CONSTANT Blue
 7 CONSTANT DKRed 
 8 CONSTANT Cyan 
 9 CONSTANT Red
11 CONSTANT Yellow
16 CONSTANT White

\ ***********************
\ task management 
\ ***********************
\ A TASK: returns its process ID  (PID) (ie: an address)
\ USIZE = 192 bytes, for workspace, task variables and 2 stacks 
: TASK: ( n -- ) USIZE MALLOC DUP FORK CONSTANT  ; 

\ stop a running task and give control to next task 
: STOP  ( pid -- ) SLEEP PAUSE ; 

DECIMAL
TASK: JOB1    \ Billy ball rotator
TASK: JOB2    \ Bill ball  mover
TASK: JOB3    \ Bobby ball rotator
TASK: JOB4    \ Bobby ball mover
TASK: JOB5    \ cannon
TASK: JOB6    \ (Unused) former Asteroid mover
TASK: JOB7    \ Asteroid spinner   
TASK: PLAYER  \ sound code player 

\ Background player takes the execution token of a Forth word. 
: BG-SOUND  ( xt -- )  PLAYER ASSIGN  PLAYER RESTART ;   

\ ***********************
\ Local variables for each task 
\ ***********************
HEX
50 USER SPIN   \ user variable for rotation speed
52 USER SPEED  \ speed of motion


\ ***********************
\ Fast mulitplier: R4 5 SLA, 
\ ***********************
HEX
CODE 32* ( n -- n')  0A54 , NEXT, ENDCODE  


\ ***********************
\ CHAR DEFINITION HELPERS
\ ***********************
DECIMAL
\ def 2 chars at once (32 bytes) 
: CHARDEF32 ( data[] ascii# -- ) ]PDT 32 VWRITE ; 

\ Convert long text string to 16 bit HEX numbers at COMPILE time 
\ Compile each number into memory sequentially
: HEX#, ( addr len --)
        BASE @ >R        \ save radix
        HEX              \ converting string to hex numbers
        BEGIN DUP
        WHILE            \ while len<>0
           OVER 4        \ used 4 digits from left end of string
           NUMBER? ?ERR  \ convert string to number
           ,             \ compile the integer into memory
           4 /STRING     \ cut 4 digits off left side of string
        REPEAT          
        2DROP
        R> BASE !        \ restore radix
;


\ *********************
\ *     ASTEROIDS     *
\ *********************
DECIMAL
CREATE ASTEROIDS
S" 000F191032434964504C23100C0700000000C020501098CC1272941CF0000000" HEX#,
S" 000000050A10121410181C13110D03000000F008104844CC9A12648418600000" HEX#,
S" 00000001020509181F10100E07000000000000F02804E4063EE2020CF0000000" HEX#,
S" 00000000031C382E212018070000000000000070888C5262828C90E000000000" HEX#,
S" 0000000007182F2524150E000000000000000000E01078C4042CD80000000000" HEX#,
S" 00000000000F18282F28311E0000000000000000E05844C43C0428F000000000" HEX#,
S" 000000000304041D161414181108070000000000789412729A06024438C08000" HEX#,

\ array of 7 asteroid patterns (0..6)
: ]ASTEROID ( n -- addr) 32* ASTEROIDS + ; 

: ROCK-SPINNER ( char speed -- )
    SPIN !
    BEGIN
      7 0 
      DO
        I ]ASTEROID OVER CHARDEF32
        SPIN @ MS
        PAUSE
      LOOP
    AGAIN ;

\ ************************
\ *      THE GROUND      *
\ ************************
251 CONSTANT DIRT.CHAR
CREATE EARTH
S" 10183C3C7E7EFFFF0000001010387CFF0000000000000FFF08080818387C7EFF" HEX#,
EARTH DIRT.CHAR CHARDEF32

: .DIRT 
  DIRT.CHAR SET# 15 1 COLOR 
  3 18 252 26 HCHAR 
  2 19 252 28 HCHAR 
  1 20 252 30 HCHAR 
  0 21 252 32 HCHAR  
;


\ ***********************
\ * BALL ANIMATION DEFS *
\ ***********************
\ Compile contiguos data for each frame of Ball animation
CREATE BALLS ( patterns for 23 chars )
S" 00030F1F3F3C787A787F7F3C3E1F0F0300E0F8FCFE9E8FAF8FFFFF1E3EFCF8E0" HEX#,
S" 00030F1F3F397175717F7F383C1F0F0300E0F8FCFE3E1F5F1FFFFF3E7EFCF8E0" HEX#,
S" 00030F1F3F32626A627F7F30381F0F0300E0F8FCFE7E3FBF3FFFFF7EFEFCF8E0" HEX#,
S" 00030F1F3F244455447F7F20311F0F0300E0F8FCFEFE7F7F7FFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F09082A087F7F01231F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F131155117F7F03071F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F27232B237F7F070F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F0F4757477F7F0F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F1F0F2F0F7F7F1F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F1F1F5F1F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFCFCFDFCFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFCF8FAF8FFFFFCFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEF8F1F5F1FFFFF8FEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEF2E2EAE2FFFFF0F8FCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEE4C4D5C4FFFFE0F0FCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEC888AA88FFFFC0E2FCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFE92115511FFFF82C6FCF8E0" HEX#,
S" 00030F1F3F3F7E7E7E7F7F3F3F1F0F0300E0F8FCFE2623AB23FFFF068EFCF8E0" HEX#,
S" 00030F1F3F3E7C7D7C7F7F3E3F1F0F0300E0F8FCFE4E475747FFFF0E1EFCF8E0" HEX#,

\ expose BALLS as an array of 32 byte records
\ Animate the BALL by sequencing from 0 ]BALL  to 22 ]BALL OR reverse
: ]BALL ( n -- addr )  32* BALLS +  ;


CREATE EXPLOSION
S" 0030787C3E1C0070FCF8F83103030100000E1E1C382000071F0F8680C0E08000" HEX#,

\ ********************************
\ * BILLY BALL'S MAGICAL MISSILE *
\ ********************************
S" 0000000000000211AF02000000000000000000000034FDDFEFF6280000000000"
136 CALLCHAR

\ **************
\ * STAR CHR'S *
\ **************
DECIMAL
CREATE STARS  160 , 168 , 176 , 184 , 192 , 200 , 208 ,
: ]STAR ( n -- addr) CELLS STARS + ;

PAD CHAR . CHARPAT     \ read '.' char pattern
PAD  0 ]STAR CHARDEF   \ assign to star characters
PAD  1 ]STAR CHARDEF
PAD  2 ]STAR CHARDEF
PAD  3 ]STAR CHARDEF
PAD  4 ]STAR CHARDEF
PAD  5 ]STAR CHARDEF
PAD  6 ]STAR CHARDEF

\ *****************************
\ MAKE SPRITES
\ *****************************
DECIMAL
\ Characters used 
128 CONSTANT Billy
132 CONSTANT Bobby
136 CONSTANT Missle
140 CONSTANT Rock

\ sprite numbers begin with #
 0  CONSTANT #Rock 
 1  CONSTANT #Rock2 
 2  CONSTANT #Rock3 
 3  CONSTANT #Rock4 

 5  CONSTANT #Bill
 6  CONSTANT #Bob
 7  CONSTANT #Weapon

: CREATE_SPRITES 
( char   colr    x   y   sp# -- )
  Rock   DKRed  127  10 #Rock    SPRITE 
  Rock   DKRed  112  40 #Rock2   SPRITE 
  Rock   DKRed  134  80 #Rock3   SPRITE 
  Rock   DKRed  106 100 #Rock4   SPRITE 

  Billy  White   10  10 #Bill    SPRITE
  Bobby  Blue   215  10 #Bob     SPRITE
  Missle  1      20  20 #Weapon  SPRITE
; 

\ *****************************
\ Multi-Task actions must be in an endless loop. Control with WAKE/SLEEP
\ *****************************

DECIMAL
: SPIN-RATE ( n spr# -- ) SPIN LOCAL ! ;

: ROTATOR ( char speed -- )
    SPIN !
    BEGIN
      23 0 
      DO
        I ]BALL OVER CHARDEF32
        SPIN @ MS
        PAUSE
      LOOP
    AGAIN ;


DECIMAL
: BOUNCER ( spr# speed --)
    SPEED !  \ each task has it's own bounce speed
    BEGIN
      130 10 DO  PAUSE  I OVER SP.Y VC!   SPEED @ MS      LOOP
      10 130 DO  PAUSE  I OVER SP.Y VC!   SPEED @ MS  -1 +LOOP
    AGAIN ;

\ INC/DEC byte in VDP RAM
: +!V   ( n Vaddr -- ) S" TUCK VC@ +  SWAP VC!" EVALUATE ; IMMEDIATE

DECIMAL
: LASER-ON    GEN1 115 HZ 12 DB     GEN2 117 HZ 12 DB ;
: LASER-OFF   GEN1 MUTE             GEN2 MUTE ;


DECIMAL
: EXPLODE ( -- )
    5 NOISE 0 DB         \ impact sound
    LASER-OFF            \ kill the laser beam
    100 MS
    6 NOISE
    16 0 DO
        PAUSE
        I DB               \ fade impact noise
        I #Bob SP.COLR VC! \ change Bobby's color
        4000 TICKS
    LOOP
    Blue #Bob SP.COLOR
    SILENT
;

\ increment/decrement sprite x,y values in VDP RAM 
: SP.X++    ( n spr# -- ) SP.X +!V  ;
: SP.Y++    ( n spr# -- ) SP.Y +!V  ;

: FIRE_THE_LASER 
    6 NOISE  0 DB                  \ initial shot
    LASER-ON
    200 TICKS                      \ brief ontime
    GEN4 14 DB                     \ reduce noise to cruise volume.
;

VARIABLE YVECT  
VARIABLE XVECT   

: AIM  ( x y --) YVECT !  XVECT ! ; \ sets dir/speed weapon travels 

: MOVE-WEAPON ( -- )
    XVECT @ #Weapon SP.X++     
    YVECT @ #Weapon SP.Y++ ;

\ *****************************
\ sound loops that run as a task must end with STOP 
\ *****************************

: BLEEP   
    SILENT 
    GEN1 
    31 2
    DO
      200 I * HZ  I DB 
      200 TICKS 
    LOOP  
    MYSELF STOP 
; 
' BLEEP PLAYER ASSIGN \ runs this as task. It's simpler

: FADE-BLAST 
    SILENT 
    5 NOISE 
    GEN4
    31 6
    DO
       I DB
      50 MS
    LOOP 
;

: Y.DELTA  ( spr1 spr2 -- c) 
    SP.Y VC@ SWAP SP.Y VC@ -  ( difference in Y position)
    DUP 0> IF      2 MIN         EXIT THEN 
    DUP 0< IF  ABS 2 MIN NEGATE  EXIT THEN 
    0 ; ( bounces straight back )

VARIABLE POINTS  
VARIABLE SHOTS 

: COLLISION ( spr# -- ) \ test ROCK collision with #weapon 
    #Weapon OVER 9 COINC 0= IF  DROP EXIT THEN 
    
    #Weapon Y.DELTA  YVECT ! \ change y direction proportional to hit 
    XVECT @ NEGATE        XVECT ! \ reverse X direction 
    MOVE-WEAPON MOVE-WEAPON MOVE-WEAPON
    POINTS 1-! 
    PLAYER RESTART 
;

DECIMAL 
: LAUNCHER  ( -- )
    #Bill POSITION #Weapon LOCATE \ #Weapon on top of #bill sprite 
    FIRE_THE_LASER 
    5 0 AIM 
    SHOTS 1-!  
    \ polling loop for coincidence      
    BEGIN       
      PAUSE
      Red #Weapon SP.COLOR       \ give it a color
      MOVE-WEAPON 

      #Weapon #Bob  10 COINC    
      IF ( we hit Bobby)
        Transparent #Weapon SP.COLOR \ #Weapon goes invisible
        -3 XVECT +! 
        2 JOB3 SPIN-RATE       \ change Bobby's spin rate
        EXPLODE                \ make some sound and change Bobby's color
        60 JOB3 SPIN-RATE      \ make Bobby slowdown again
        POINTS 1+!  
        MYSELF STOP            \ we are done with this for now 
      THEN PAUSE  
      Yellow #Weapon SP.COLOR    \ change color while fire travels

      #Rock  COLLISION 
      #Rock2 COLLISION 
      #Rock3 COLLISION 
      #Rock4 COLLISION 

      #Weapon SP.X VC@ 248 10 WITHIN  \ test for #Weapon at edge of screen
    UNTIL
    Transparent #Weapon SP.COLOR

    LASER-OFF
    FADE-BLAST
    60 JOB3 SPIN-RATE           \ make Bobby slowdown again
    Blue #Bob SP.COLOR           \ reset Bobby's color

    MYSELF STOP  
;

\ ********************
\ Motion Code  runs in separate tasks  
\ ********************
\             Char   Speed ( big is slower)
\             -----  -----
: SPIN-BILL   Billy   60 ROTATOR ;
: SPIN-BOB    Bobby   60 ROTATOR ;
: SPIN-ROCK   Rock    70 ROCK-SPINNER ;

\             Sprite Speed 
\             -----  -----
: BOUNCE-BILL  #Bill 25 BOUNCER ;
: BOUNCE-BOB   #Bob   9 BOUNCER ; \ faster movement, harder to hit
: BOUNCE-ROCK  #Rock 12 BOUNCER ;

\ ********************
\ Assign routines to tasks 
\ ********************
: ASSIGN-JOBS 
    ['] SPIN-BILL   JOB1 ASSIGN
    ['] BOUNCE-BILL JOB2 ASSIGN

    ['] SPIN-BOB    JOB3 ASSIGN
    ['] BOUNCE-BOB  JOB4 ASSIGN

    ['] LAUNCHER    JOB5 ASSIGN   \ this is your blaster 

    ['] SPIN-ROCK   JOB7 ASSIGN 
;

: WAKE-TASKS 
    JOB1 WAKE 
    JOB2 WAKE
    JOB3 WAKE 
    JOB4 WAKE 
    JOB7 WAKE
;

\ asteroids move under automotion 
: ASTEROID_BELT 
( bug in my negative vertical motion, need the 1)
    -21 1 #Rock  MOTION  
    -23 1 #Rock2 MOTION
    -24 1 #Rock3 MOTION
    -25 1 #Rock4 MOTION
;

: .TITLE   5  0 AT-XY ." Billy's Space Balls" ;

: .SCORE   
   0  23 AT-XY ." Points: " POINTS @ 3 .R 
   15 23 AT-XY ." Ammo: "   SHOTS  @ 3 .R  ;

: SETUP 
   CLEAR
    0 19 White 1 COLORS 
    1 SCREEN 
    .TITLE .DIRT  .SCORE
    2 MAGNIFY
    CREATE_SPRITES  4 MOVING  ASTEROID_BELT 
    ASSIGN-JOBS
    MULTI 
    WAKE-TASKS 
    AUTOMOTION 
;

: FINISH    
    STOPMOTION DELALL 
    SINGLE 
    8 SCREEN 
    0 19  Black Cyan COLORS 
;

\ shoot by waking up the launcher TASK
: FIRE   JOB5 RESTART  500 MS ; 

: ?BREAK ?TERMINAL IF  FINISH  ABORT  THEN ;

\ *********************
\  GAME PROCESS  
\ *********************
: GAME 
    SETUP  
    50 SHOTS ! 
    POINTS OFF 
    BEGIN 
      SHOTS @  
    WHILE 
      0 JOYST 1 = IF FIRE THEN .SCORE 
      PAUSE
      ?BREAK 
    REPEAT 
    SILENT 
    6 11 AT-XY ." O U T  O F  A M M O"
    BEGIN KEY? UNTIL 
    FINISH 
;

Retrospect · February 10, 2023

@TheBF this is great! Forth seems quite fast to be able to handle all that and you did good, it doesn't miss a single coincidence.

Edit: And that's the only source code I've ever seen that clearly states "expose balls" and doesn't even have any hidden meaning!

+TheBF · February 11, 2023

3 hours ago, Retrospect said:

@TheBF this is great! Forth seems quite fast to be able to handle all that and you did good, it doesn't miss a single coincidence.

Edit: And that's the only source code I've ever seen that clearly states "expose balls" and doesn't even have any hidden meaning!

Thanks.

The BASIC compiler is actually using the same technology as Forth to link the various routines together. (called threaded code)

I think when we did the sevens test the @willsy started, compiled BASIC was faster but the Forth version was not ideal Forth code.

Once @Lee Stewart re-wrote the Forth version, Forth was quicker.

So it probably depends on the coder which one is faster.

The COINC routine used here is one I wrote that just does a comparison of the X,Y values for each sprite, not fancy but faster than the one in TI Forth.

Retrospect · February 11, 2023

2 hours ago, TheBF said:

comparison of the X,Y values for each sprite

And can't fail either by the sound of that ... nice one

+TheBF · February 12, 2023

On 2/10/2023 at 10:41 PM, Retrospect said:

And can't fail either by the sound of that ... nice one

After thinking about this I realize that part of the reason COINC is working well is because I am not using AUTOMOTION for the weapon sprite _AND_ my multi-tasker is cooperative.

This means that nothing is "interrupting" a task in the middle of something. The programmer controls when the code gives up control.

The coincidence loop is part of a single task that launches the weapon so that's even better control.

If we look the cleaned up version of the coincidence loop we see this:

\ polling loop for coincidence      
    BEGIN       
      PAUSE
      Red #Weapon SP.COLOR     \ give it a color
      MOVE-WEAPON 

      ENEMY-HIT
      ASTEROID-HIT       
      SELF-DESTRUCT             \ test if weapon bounced back at shooter

      Yellow #Weapon SP.COLOR   \ change color while fire travels
      #Weapon SP.X VC@ 
      248 1 WITHIN              \ test for #Weapon at edge of screen
    UNTIL

Notice we MOVE-WEAPON then we test for an ENEMY-HIT, ASTEROID-HIT and a new feature, you can accidently kill yourself from the rebound.

Since the weapon can't move while these three tests are underway, COINC has a much easier time of it to catch a hit.

So in short... I cheated.

Edited February 12, 2023 by TheBF
typo

+TheBF · February 13, 2023

One of the problems with using your own tools is that you have to learn how to use them.

I spent some time making the BillyBall game usable to the masses and had to deal with handling all these tasks that I thought were so cool.

The short story is it is probably advisable to create some way of messaging to allow tasks to know what the others are doing.

In an earlier post I showed a way to give each task a mailbox and send and receive code but that is overkill until you really need something that fancy.

For a simple game like this you can get away with global variables.

The message I needed was called DEAD so the main task could know that the user killed themselves, which happens in the launcher task.

Something else that needed work was starting up all these tasks from a cold machine.

I made the choice to instantiate each task in low RAM to save dictionary space.

If I put the tasks in the dictionary they would need to be saved in the program files which is waste.

Fortunately the word FORK lets us dynamically create a task workspace.

The key was to use VALUEs to hold each task's address (PID) when they are created at boot time.

You can see how that's done with word NEW-TASK and CREATE-TASKS.

Another interesting thing I had to do was restart the game from within the game.

There is a lot of initializing with these tasks.

It took me a few minutes to realize that the best way was to just call COLD. duh!

Since the program start word is patched to the BOOT variable, COLD kicks it off just fine.

So attached are the program files and little readme DV80 file and the source code is in the spoiler. (567 lines)

It's a lazy man's game because there is only button! The joystick fire button. (tab key on Classic99)

BUT... it is harder than it looks. I give you 50 shots. The highest score I have gotten is 12. (But I suck at games)

Spoiler

\ BILLYBALL XB256 DEMO by @Retrospect on atariage.com   Nov 1 2021
\ Used for Multi-tasking Game Demo for Camel99 Forth  B Fox

INCLUDE DSK1.TOOLS    \ DEBUG ONLY
INCLUDE DSK1.MARKER
INCLUDE DSK1.MALLOC
INCLUDE DSK1.GRAFIX
INCLUDE DSK1.RANDOM
INCLUDE DSK1.SOUND
INCLUDE DSK1.DIRSPRIT \ direct control sprites
INCLUDE DSK1.AUTOMOTION 
INCLUDE DSK1.MTASK99
\ INCLUDE DSK1.MTOOLS   \ DEBUG ONLY
INCLUDE DSK1.RANDOM
INCLUDE DSK1.JOYST 
INCLUDE DSK1.UDOTR 
INCLUDE DSK1.VALUES 


 1 CONSTANT Transparent
 2 CONSTANT Black
 3 CONSTANT Green
 5 CONSTANT Blue
 7 CONSTANT DKRed 
 8 CONSTANT Cyan 
 9 CONSTANT Red
11 CONSTANT Yellow
16 CONSTANT White

\ ***********************
\ task management 
\ ***********************
\ NEW-TASK returns a Process ID (PID) (ie: an address) in LOW RAM HEAP 
\ USIZE = 192 bytes, for workspace, task variables and 2 small stacks 
: NEW-TASK ( -- pid) USIZE MALLOC DUP FORK ;


\ ******************************************
\ reset the HEAP memory pointer before allocating memory 
HEX 
: RESET-HEAP   2000 H ! ;

\ QUIT key enable/disable
HEX
: QUIT-OFF ( -- ) 83C2 DUP C@ 70 AND 10 OR SWAP  C! ;
: QUIT-ON  ( -- ) 83C2 DUP C@ 60 AND SWAP C! ;

6 CONSTANT REDO \ fctn 8 KEY 

: WAIT-FOR-QUIT   
  QUIT-ON  
  BEGIN  
    KEY? REDO = 
    IF  COLD 
    THEN PAUSE  
  AGAIN ;   

\ *******************************************
\ task PIDs are saved in VALUEs
DECIMAL
0 VALUE JOB1   0 VALUE JOB2 
0 VALUE JOB3   0 VALUE JOB4 
0 VALUE JOB5   0 VALUE JOB7 
0 VALUE SOUND 

\ allocate memory in HEAP for all the tasks in the game
: CREATE-TASKS 
  RESET-HEAP 
  NEW-TASK TO JOB1    \ Billy ball rotator
  NEW-TASK TO JOB2    \ Bill ball  mover
  NEW-TASK TO JOB3    \ Bobby ball rotator
  NEW-TASK TO JOB4    \ Bobby ball mover
  NEW-TASK TO JOB5    \ cannon
\ NEW-TASK JOB6    \ (Unused) former Asteroid mover
  NEW-TASK TO JOB7    \ Asteroid spinner   
  NEW-TASK TO SOUND   \ sound code SOUND 
;

\ stop a running task and give control to next task 
: STOP  ( pid -- ) SLEEP PAUSE ; 

\ ***********************
\ Local variables for each task 
\ ***********************
HEX
50 USER SPIN   \ user variable for rotation speed
52 USER SPEED  \ speed of motion


\ ***********************
\ Fast mulitplier: R4 5 SLA, 
\ ***********************
HEX
CODE 32* ( n -- n')  0A54 , NEXT, ENDCODE  


\ ***********************
\ CHAR DEFINITION HELPERS
\ ***********************
DECIMAL
\ def 2 chars at once (32 bytes) 
: CHARDEF32 ( data[] ascii# -- ) ]PDT 32 VWRITE ; 

\ COMPILER Extension: Makes stealing BASIC code easier :-)
\ Convert long text string to 16 bit HEX numbers at COMPILE time 
\ Compile each number into memory sequentially
: HEX#, ( addr len --)
        BASE @ >R        \ save radix
        HEX              \ converting string to hex numbers
        BEGIN DUP
        WHILE            \ while len<>0
           OVER 4        \ used 4 digits from left end of string
           NUMBER? ?ERR  \ convert string to number
           ,             \ compile the integer into memory
           4 /STRING     \ cut 4 digits off left side of string
        REPEAT          
        2DROP
        R> BASE !        \ restore radix
;


\ *********************
\ *     ASTEROIDS     *
\ *********************
DECIMAL
CREATE ASTEROIDS
S" 000F191032434964504C23100C0700000000C020501098CC1272941CF0000000" HEX#,
S" 000000050A10121410181C13110D03000000F008104844CC9A12648418600000" HEX#,
S" 00000001020509181F10100E07000000000000F02804E4063EE2020CF0000000" HEX#,
S" 00000000031C382E212018070000000000000070888C5262828C90E000000000" HEX#,
S" 0000000007182F2524150E000000000000000000E01078C4042CD80000000000" HEX#,
S" 00000000000F18282F28311E0000000000000000E05844C43C0428F000000000" HEX#,
S" 000000000304041D161414181108070000000000789412729A06024438C08000" HEX#,

\ array of 7 asteroid patterns (0..6)
: ]ASTEROID ( n -- addr) 32* ASTEROIDS + ; 


: ROCK-SPINNER ( char speed -- )
    SPIN !
    BEGIN
      7 0 
      DO
        I ]ASTEROID OVER CHARDEF32
        SPIN @ MS
     \   PAUSE
      LOOP
    AGAIN ;


\ ***********************
\ * BALL ANIMATION DEFS *
\ ***********************
\ Compile contiguos data for each frame of Ball animation
CREATE BALLS ( patterns for 23 chars )
S" 00030F1F3F3C787A787F7F3C3E1F0F0300E0F8FCFE9E8FAF8FFFFF1E3EFCF8E0" HEX#,
S" 00030F1F3F397175717F7F383C1F0F0300E0F8FCFE3E1F5F1FFFFF3E7EFCF8E0" HEX#,
S" 00030F1F3F32626A627F7F30381F0F0300E0F8FCFE7E3FBF3FFFFF7EFEFCF8E0" HEX#,
S" 00030F1F3F244455447F7F20311F0F0300E0F8FCFEFE7F7F7FFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F09082A087F7F01231F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F131155117F7F03071F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F27232B237F7F070F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F0F4757477F7F0F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F1F0F2F0F7F7F1F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F1F1F5F1F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFEFFFFFFFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFCFCFDFCFFFFFEFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEFCF8FAF8FFFFFCFEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEF8F1F5F1FFFFF8FEFCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEF2E2EAE2FFFFF0F8FCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEE4C4D5C4FFFFE0F0FCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFEC888AA88FFFFC0E2FCF8E0" HEX#,
S" 00030F1F3F3F7F7F7F7F7F3F3F1F0F0300E0F8FCFE92115511FFFF82C6FCF8E0" HEX#,
S" 00030F1F3F3F7E7E7E7F7F3F3F1F0F0300E0F8FCFE2623AB23FFFF068EFCF8E0" HEX#,
S" 00030F1F3F3E7C7D7C7F7F3E3F1F0F0300E0F8FCFE4E475747FFFF0E1EFCF8E0" HEX#,

\ expose BALLS as an array of 32 byte records
\ these patterns are written to VDP continuosly to rotate the faces
\ Animate the BALL by sequencing from 0 ]BALL  to 22 ]BALL OR reverse
: ]BALL ( n -- addr )  32* BALLS +  ;


\ character patterns are recorded in RAM as integers using a string and HEX#, 
\ This is smaller that storing a string in the program 
CREATE EXPLOSION
\ S" 0030787C3E1C0070FCF8F83103030100000E1E1C382000071F0F8680C0E08000" HEX#,
 S" 0004281208294723" HEX#,
 S" 4703290026100A00" HEX#, 
 S" 0000288A24508AC0" HEX#, 
 S" C0E2942046104800" HEX#, 

\ ********************************
\ * BILLY BALL'S MAGICAL MISSILE *
\ ********************************
CREATE COMET 
S" 0000000000000211AF02000000000000000000000034FDDFEFF6280000000000" HEX#, 


\ ************************
\ *      THE GROUND      *
\ ************************
251 CONSTANT DIRT.CHAR
CREATE EARTH
S" 10183C3C7E7EFFFF0000001010387CFF0000000000000FFF08080818387C7EFF" HEX#,

: .DIRT 
  DIRT.CHAR SET# 15 1 COLOR 
  3 18 252 26 HCHAR 
  2 19 252 28 HCHAR 
  1 20 252 30 HCHAR 
  0 21 252 32 HCHAR  
;

\ ********************************
\ put patterns in VDP RAM 
\ *****************************
: WRITE-PATTERNS 
  EARTH DIRT.CHAR CHARDEF32
  COMET 136 CHARDEF32
;

DECIMAL
\ Characters used 
128 CONSTANT Billy
132 CONSTANT Bobby
136 CONSTANT Missle
140 CONSTANT Rock

\ sprite numbers begin with #
 0  CONSTANT #Rock 
 1  CONSTANT #Rock2 
 2  CONSTANT #Rock3 
 3  CONSTANT #Rock4 

 5  CONSTANT #Bill
 6  CONSTANT #Bob
 7  CONSTANT #Weapon

\ *****************************
\ MAKE SPRITES
\ *****************************
: CREATE_SPRITES 
( char      colr    x   y   sp# -- )
  Rock      DKRed  127 188 #Rock    SPRITE 
  Rock 1+   Red    112 189 #Rock2   SPRITE 
  Rock 2+   Green  134 192 #Rock3   SPRITE 
  Rock 3 +  Yellow 106 190 #Rock4   SPRITE 

  Billy     White   10  10 #Bill    SPRITE
  Bobby     Blue   215  10 #Bob     SPRITE
  Missle    2      20  20 #Weapon  SPRITE
; 


\ *****************************
\ Multi-Task actions must be in an endless loop. Control with WAKE/SLEEP
\ *****************************

DECIMAL
: SPIN-RATE ( n spr# -- ) SPIN LOCAL ! ;

: ROTATOR ( char speed -- )
    SPIN !
    BEGIN
      23 0 
      DO
        PAUSE
        I ]BALL OVER CHARDEF32
        SPIN @ MS
      LOOP
    AGAIN ;


DECIMAL
: BOUNCER ( spr# speed --)
    SPEED !  \ each task has it's own bounce speed
    BEGIN
      130 10 DO  PAUSE  I OVER SP.Y VC!   SPEED @ MS      LOOP
      10 130 DO  PAUSE  I OVER SP.Y VC!   SPEED @ MS  -1 +LOOP
    AGAIN ;

\ INC/DEC byte in VDP RAM
: +!V   ( n Vaddr -- ) S" TUCK VC@ +  SWAP VC!" EVALUATE ; IMMEDIATE

DECIMAL
: LASER-ON    GEN1 141 HZ 14 DB     GEN2 143 HZ 14 DB ;
: LASER-OFF   GEN1 MUTE             GEN2 MUTE ;


DECIMAL
: EXPLODE ( spr# -- )
    5 NOISE 0 DB         \ impact sound
    LASER-OFF            \ kill the laser beam
    150 MS
    6 NOISE 4 DB
    17 1 DO
        PAUSE
        GEN4 I DB        \ fade impact noise
        I OVER SP.COLOR  \ change spr# color
        3400 TICKS
    LOOP
    DROP 
    SILENT
;


: FIRE_THE_LASER 
    4 NOISE 0 DB                  \ initial shot NOISE
    300 TICKS                     \ brief ontime
    LASER-ON
    4 NOISE 10 DB                 \ HISS noise at cruise volume.
;

VARIABLE YVECT  
VARIABLE XVECT   

: AIM  ( x y --) YVECT !  XVECT ! ; \ sets dir/speed weapon travels 

\ increment/decrement sprite x,y values in VDP RAM 
: SP.X++    ( n spr# -- ) SP.X +!V  ;
: SP.Y++    ( n spr# -- ) SP.Y +!V  ;

: MOVE-WEAPON ( -- )
    XVECT @ #Weapon SP.X++     
    YVECT @ #Weapon SP.Y++ ;

\ *****************************
\ sound loops that run as a task must end with STOP 
\ *****************************

: BLEEP   
    SILENT 
    GEN1 
    31 2
    DO
      200 I * HZ  I DB 
      200 TICKS 
    LOOP  
    MYSELF STOP 
; 

\ : TINK  GEN3 2200 HZ  16 0 DO  GEN3 I DB LOOP  GEN3 MUTE ;
: THUMP    
    GEN4 0 DB 
    16 0 DO  5 NOISE  6 NOISE  5 NOISE  GEN4 I DB  16 TICKS  LOOP  
    GEN4 MUTE ;

: DEFLECTED ( -- ) SILENT  THUMP  MYSELF STOP  ; 

: FADE-BLAST 
    SILENT 
    5 NOISE 
    GEN4
    31 6
    DO PAUSE 
       I DB 50 MS
    LOOP 
;

: Y.DELTA  ( spr1 spr2 -- c) 
    SP.Y VC@ SWAP SP.Y VC@ - 
    DUP 0> IF      2 MIN         EXIT THEN 
    DUP 0< IF  ABS 2 MIN NEGATE  EXIT THEN 
    0 ; ( bounces straight back )

VARIABLE POINTS  
VARIABLE SHOTS 
VARIABLE HITFLAG

: COLLISION ( spr# -- ) \ test ROCK collision with #weapon 
    #Weapon OVER 9 COINC 0= IF  DROP EXIT THEN 
    EXPLOSION 136 CHARDEF32
    HITFLAG ON 
    #Weapon Y.DELTA  YVECT ! \ change y direction proportional to hit 
    XVECT @ NEGATE   XVECT ! \ reverse X direction 
    MOVE-WEAPON MOVE-WEAPON MOVE-WEAPON
    SOUND RESTART 
;

: ENEMY-HIT 
    #Weapon #Bob  10 COINC    
    IF ( we hit Bobby)
        Transparent #Weapon SP.COLOR \ #Weapon goes invisible
        -3 XVECT +!            \ reverse weapon X direction & speed (bounce)
        0 JOB3 SPIN-RATE       \ change Bobby's spin rate
        #Bob EXPLODE           \ make some sound and change Bobby's color
        60 JOB3 SPIN-RATE      \ make Bobby slowdown again
        POINTS 1+!  
        Blue #Bob SP.COLOR           \ reset Bobby's color
        MYSELF STOP            \ we are done with this for now 
    THEN PAUSE  
;

: ASTEROID-HIT 
    #Rock  COLLISION 
    #Rock2 COLLISION 
    #Rock3 COLLISION 
    #Rock4 COLLISION ;

: .SCORE 
   0  23 AT-XY ." Points: " POINTS @ 3 .R 
   15 23 AT-XY ." Ammo: "   SHOTS  @ 3 .R ;

VARIABLE DEAD   \ dead is a message that you are dead 

: SELF-DESTRUCT 
    #Weapon #Bill 11 COINC  
    HITFLAG @ AND    
    IF  
     Transparent #Weapon SP.COLOR
      0 JOB1 SPIN-RATE 
      #Bill EXPLODE 
      5 11 AT-XY ." S H O T   Y E R S E L F"  
      POINTS OFF .SCORE 
      DEAD ON 
    THEN 
;

DECIMAL 
: LAUNCHER  ( -- )
    #Bill POSITION #Weapon LOCATE \ #Weapon on top of #bill sprite 
    FIRE_THE_LASER 
    5 0 AIM 
    SHOTS 1-!  
    HITFLAG OFF 
    COMET 136 CHARDEF32
  \ polling loop for coincidence      
    BEGIN       
      PAUSE
      Red #Weapon SP.COLOR     \ give it a color
      MOVE-WEAPON 
      ENEMY-HIT
      ASTEROID-HIT       
      SELF-DESTRUCT             \ test if weapon bounced back at shooter
      Yellow #Weapon SP.COLOR   \ change color while fire travels
      #Weapon SP.X VC@ 
      248 1 WITHIN              \ test for #Weapon at edge of screen
    UNTIL
    
    Transparent #Weapon SP.COLOR
    LASER-OFF
    FADE-BLAST
    60 JOB3 SPIN-RATE            \ make Bobby slowdown again
    Blue #Bob SP.COLOR           \ reset Bobby's color

    MYSELF STOP  
;

\ ********************
\ Motion Code  runs in separate tasks  
\ ********************
\             Char   Speed ( big is slower)
\             -----  -----
: SPIN-BILL   Billy   60 ROTATOR ;
: SPIN-BOB    Bobby   60 ROTATOR ;
: SPIN-ROCK   Rock    70 ROCK-SPINNER ;

\             Sprite Speed 
\             -----  -----
: BOUNCE-BILL  #Bill 25 BOUNCER ;
: BOUNCE-BOB   #Bob   9 BOUNCER ; \ faster movement, harder to hit
: BOUNCE-ROCK  #Rock 12 BOUNCER ;

\ ********************
\ Assign routines to tasks 
\ ********************
\ *IMPORTANT*
\ When building a binary program it is simplest to ASSIGN code to all tasks.
\ If a task will be assiged later in the program assign it STOP at boot-time.
\ STOP will put itself to sleep and pass control. 

: ASSIGN-JOBS 
    ['] SPIN-BILL   JOB1 ASSIGN
    ['] BOUNCE-BILL JOB2 ASSIGN

    ['] SPIN-BOB    JOB3 ASSIGN
    ['] BOUNCE-BOB  JOB4 ASSIGN

    ['] LAUNCHER    JOB5 ASSIGN   \ this is your blaster 

    ['] SPIN-ROCK   JOB7 ASSIGN 
    ['] DEFLECTED  SOUND ASSIGN 
;

\ RESTART re-assigns the local BOOT variable & resets the stacks before
\ waking the task 
: START-TASKS 
    JOB1  RESTART
    JOB2  RESTART
    JOB3  RESTART 
    JOB4  RESTART 
   \ JOB5  RESTART  \ launcher is re-started by the fire button
    JOB7  RESTART
  \  SOUND RESTART  \ sound is re-started when a collision occurs
;

\ asteroids move under automotion 
: ASTEROID_BELT 
( bug in my negative vertical motion, need the 1)
    -21 1 #Rock  MOTION  
    -23 1 #Rock2 MOTION
    -24 1 #Rock3 MOTION
    -25 1 #Rock4 MOTION
;

\ NOTES 
147 CONSTANT D1 
185 CONSTANT F#1 
220 CONSTANT A1 

: HAPPY
    GEN1 
    D1  HZ 2 DB 80 MS 
    F#1 HZ  80 MS 
    A1  HZ  200 MS 
    MUTE ;

: .TITLE   5  0 AT-XY ." Billy's Space Balls" ;

: SETUP 
    DECIMAL 
    QUIT-OFF  DEAD OFF 
    CLEAR
    HAPPY 
    0 19 White 1 COLORS 
    1 SCREEN 
    WRITE-PATTERNS 
    .TITLE .DIRT  .SCORE
    2 MAGNIFY
    CREATE_SPRITES  4 MOVING  ASTEROID_BELT 
    CREATE-TASKS 
    ASSIGN-JOBS
    MULTI 
    START-TASKS 
    AUTOMOTION 
;

\ shoot by waking up the launcher TASK
: FIRE   JOB5 RESTART  650 MS ; 

\ *********************
\  GAME PROCESS  
\ *********************
: GAME 
    SETUP  
    50 SHOTS ! 
    POINTS OFF 
    BEGIN 
      SHOTS @  
    WHILE 
      0 JOYST 1 = IF FIRE THEN .SCORE 
      PAUSE
      DEAD @ IF  WAIT-FOR-QUIT THEN 
    REPEAT 
    6 11 AT-XY ." O U T  O F  A M M O"
    SINGLE SILENT MULTI 
    WAIT-FOR-QUIT
;

: RUN   WARM  GRAPHICS  INIT-MULTI GAME ;

 LOCK
 INCLUDE DSK1.SAVESYS 
 ' RUN SAVESYS DSK7.BILLYBALL

BILLYBALL.ZIP

Edited February 13, 2023 by TheBF
Fixed spoiler

+TheBF · February 19, 2023

ASMFORTH II

Revenge of the Registers

As the old saying goes "If you can't beat 'em, join 'em"

After looking over the efficiency of @Reciprocating Bill 's sieve code I had an epiphany.

What if I just stop trying to force the square peg of the stack machine into the round hole of machine Forth on the TMS9900?

(OK That sounded dirty but get your mind out the gutter) 🙂

So here is what I have prototyped:

What if we say that in ASM Forth the registers can be explicitly accessed just like we do in Assembly language? In fact we make it mandatory.

Yes we keep the data stack and the return stack and we can even keep an accumulator, a TOS register.

So now the top of stack is not explicit. It has a name TOS.

So does the next on stack, NOS.

With indexed addressing we can get further down as well, 3RD 4TH 5TH ...

but we won't need to because we have scratch registers that we can use.

In this scheme you manage the stack as needed but if you want performance you just "load" registers and operate on them.

Load a register now has Forth arg order but uses the LI instruction

HEX 
BEEF R5 LD

Some cool things happen when we accept the architecture as is:

Many of the 9900 instructions are one-to-one with their Forth instructions ( ABS INVERT NEGATE 1+ 2+ 1- 2- etc.)
We can explicitly use the different addressing mode that 9900 provides
Registers are directly referenced like local variables
! is just a MOV,
C! is just a MOVB,
@ replaces the ** indirect addressing word to fetch via a register
@+ becomes a "fetch" with with auto-increment
@@ operator is still used for symbolic addressing
Registers in brackets are indexed addressing: (R1) (R2) etc.
TOS register is used as the accumulator for computation
DATA stack is available with PUSH POP DUP DROP SP Register
Return stack is available with RPUSH RPOP R@ RP register

We also can use the immediate operators easily. Names have been changed to Forth names with square brackets

HEX
1234 R0 LD 
R0 00FF [AND] 
R0 0080 [OR] 
R0 F000 [+]

You get the idea. It's just a heck of lot simpler. And if we need the stacks they're there as always.

I have not solidified how to do math yet. It is so easy to push args onto the stack and add them up or use other math operations.

I think I have to keep that for the complex operations like UM* * and /

That will mean I need to keep + for stack math and something like ADD for register addition I guess.

I am also going to keep Chuck's FOR NEXT loop structure because we all do the same thing in Assembler. Count a register down to zero.

The difference is that I am using the top of the return stack for the index so these loops are nest-able.

Example:

ASMFORTH 
DECIMAL
CODE FORNEXT  \ .9 seconds
      65535 # FOR  NEXT
;CODE

CODE UPCOUNT \ 1.2 seconds
    0 #        ( counter in TOS register )
    65535 # FOR
      TOS 1+  ( this is: INC R4 )
    NEXT
    DROP
;CODE     

\ 1,000,000 iterations 
CODE FORNEST  \ 13.5 seconds
    1000 # FOR
      1000 # FOR
      NEXT
    NEXT
;CODE

CODE NESTED  \ 14.5 seconds
    100 # FOR
      100 # FOR
          100 # FOR
           NEXT
        NEXT
    NEXT
;CODE

Using memory

ASMFORTH 
\ code words are callable from Forth as normal
CODE FILL ( addr len char -- )
    TOS R0 !   
    R0 ><         \ reverse bytes  
    TOS POP       \ len in TOS register 
    R2  POP
    FOR            \ FOR takes TOS register as its count argument
      R0 R2 @+ C!  \ write R0 to byte location and auto-inc 
    NEXT
;CODE

FILL compiles to:

DA78  C004  mov  R4,R0
DA7A  06C0  swpb R0
DA7C  C136  mov  *R6+,R4
DA7E  C0B6  mov  *R6+,R2
DA80  0647  dect R7
DA82  C5C4  mov  R4,*R7
DA84  C136  mov  *R6+,R4
DA86  DC80  movb R0,*R2+
DA88  0617  dec  *R7
DA8A  18FD  joc  >da86
DA86  DC80  movb R0,*R2+
DA88  0617  dec  *R7
DA8A  18FD  joc  >da86
DA8C  05C7  inct R7
DA8E  045A  b    *R10   ( return to Forth )

There is still a bit of stack shuffling to get a parameter to FOR and to push it onto the Rstack, but the loop is tight and the indirect auto-inc. is just what you would code by hand.

I will try my hand at converting Bill's code to this form and see what happens.

Comments and ideas are welcome.

+TheBF · February 19, 2023

I re-wrote the Forth Assembler version of the sieve benchmark, based on @Reciprocating Bill 's code, in ASMFORTH II.

For ASM Forth I have resolved to keep CMP and CMPB. Just like in Assembler if you can jump on the status register then the = <> etc operators work fine.

If you need to compare two things then use the machine's way to do that.

Changes from the original:

uses the main Forth workspace at >8300.
FILLW is a nest-able SUB: that takes parameters off the Forth stack. feed parameters to stack with '#'.
Replaced outer loop with ASMFORTH FOR/NEXT. Loop counts down on the return stack saving a register
Put the primes counter on the Forth data stack so it passed to the display code automatically

So here is the sieve in ASMFORTH. It uses Conventional Forth for the screen I/O.

I think ASMFORTH makes a pretty good machine Forth compiler since it is specially tailored to the 9900 rather than catering to one of Chuck's machines.

The decision to keep the registers explicit means we can get all the advantages the old machine can give us.

Spoiler

\ SIEVE in ASMFORTH for Camel99 Forth                 Mar 1 2023 Brian Fox
\ based on code by @Reciprocating Bill atariage.com 

\ Original notes by BIll.
\ * SIEVE OF ERATOSTHENES ------------------------------------------
\ * WSM 4/2022
\ * TMS9900 assembly adapted from BYTE magazine 9/81 and 1/83 issues
\ * 10 iterations 6.4 seconds on 16-bit console
\ * ~10 seconds on stock console

\ Removed use of size in R8. Used immediate compare 

HOST 
DECIMAL 
8190 CONSTANT SIZE
HEX 
2000 CONSTANT FLAGS   \ array in Low RAM 

ASMFORTH 
SUB: FILLW ( addr size char --) \ nestable sub-routine 
    R0 POP            \ size 
    R1 POP            \ base of array
    BEGIN
        TOS R1 @+ !   \ write ones to FLAGS
        R0 2-
    NC UNTIL  
    DROP 
;SUB 

HEX
CODE DO-PRIME ( -- n)  
  FLAGS # SIZE # 0101 # FILLW

\ inits 
   R0 OFF        \ clear loop index 
   R3 OFF        \ 0 constant
   FLAGS R5 #!   \ array base address 
   0 #           \ counter on top of Forth stack 
   SIZE # FOR 
    R5 @+ R3 CMPB       \ FLAGS C@+ byte-compared to R3 (ie: 0)
    <> IF               \ not equal to zero ? 
          R0 R1 !       \ I -> R1
          R1 2*  R1 3 #+ 
          R0 R2 !       \ I -> R2 ( R2 is K index) 
          R1 R2 +       \ PRIME K +! 
          BEGIN  
            R2 SIZE #CMP  \ K SIZE compare 
          < WHILE  
            R3 FLAGS (R2) C! \ reset byte FLAGS(R2)
            R1 R2 +     \ PRIME K +! 
          REPEAT 
          TOS 1+         \ increment count of primes
    THEN 
    R0 1+                \ bump index register
  NEXT 
;CODE  

DECIMAL 
: PRIMES ( -- )
   PAGE ."  10 Iterations"
   10 0 DO   DO-PRIME  CR . ." primes"  LOOP
   CR ." Done!"
;

EDIT: Mar1, Replaced code with updated, ASMForthII version. Remove 1 instruction from Bill's original and used immediate compare.

Added Dis-assembler output for sieve loop from Classic99 with comments

Spoiler

   DAEA  0646  dect R6             * parameters onto DATA stack         
   DAEC  C584  mov  R4,*R6                 
   DAEE  0204  li   R4,>2000              
   DAF2  0646  dect R6                    
   DAF4  C584  mov  R4,*R6                 
   DAF6  0204  li   R4,>1ffe              
   DAFA  0646  dect R6                    
   DAFC  C584  mov  R4,*R6              
   DAFE  0204  li   R4,>0101              
   DB02  06A0  bl   @>dac0          * CALL FILLW 

  *************** sieve program *****************
   DB06  04C0  clr  R0                     (14)
   DB08  04C3  clr  R3                     (14)
   DB0A  0205  li   R5,>2000               (20)
   DB0E  0646  dect R6                     (14)
   DB10  C584  mov  R4,*R6                 (30)
   DB12  0204  li   R4,>0000               (20)
>  DB16  0646  dect R6                    
   DB18  C584  mov  R4,*R6         * loop index on DATA stack        
   DB1A  0204  li   R4,>1ffe              
   DB1E  0647  dect R7             * FOR loop push TOS cache onto return stack 
   DB20  C5C4  mov  R4,*R7                
   DB22  C136  mov  *R6+,R4        * refill TOS cache from DATA stack        
   DB24  90F5  cb   *R5+,R3               
   DB26  130E  jeq  >db44                 
   DB28  C040  mov  R0,R1                 
   DB2A  0A11  sla  R1,1                  
   DB2C  0221  ai   R1,>0003              
   DB30  C080  mov  R0,R2        
   DB32  A081  a    R1,R2                  (18)
   DB34  0282  ci   R2,>1ffe               (22)
   DB38  1504  jgt  >db42                  (12)
   DB3A  D883  movb R3,@>2000(R2)          (38)
   DB3E  A081  a    R1,R2                  (18)
>  DB40  10F9  jmp  >db34                 
   DB42  0584  inc  R4                    
   DB44  0580  inc  R0                    
   DB46  0617  dec  *R7           * NEXT loop        
   DB48  18ED  joc  >db24             
   DB4A  05C7  inct R7            * pop index from return stack         
   DB4C  045A  b    *R10          * return to Forth

+TheBF · February 20, 2023

The current version of ASMFORTH II is now on github for anybody who wants to see the source code.

Let me know if you want binary program to play with.

At this time the only docs are the source code and the examples programs.

bfox9900/ASMFORTH: Experimental Assembler using Forth like syntax (github.com)

+TheBF · February 22, 2023

I couldn't resist taking a look at @Vorticon 's combat project.

I won't be submitting XB code but I might make some fighting tanks in Forth.

When I looked at the code it is really cool to see the structure brought to the game with the new editor.

When I tried to translate the code to build the screen I realized the entire screen was defined in the data statements.

So with some name constants and the BYTE compiler extension I coded it so you can see the map in the code.

Spoiler

\ Named characters make it easier to remember the shapes
DECIMAL 
 96 CONSTANT BKG
BKG CONSTANT ---   ( alias for bkg character )
 97 CONSTANT TANKUP
 98 CONSTANT TANKR
 99 CONSTANT TANKDN
100 CONSTANT TANKL

101 CONSTANT SQR 
102 CONSTANT BULLET 
103 CONSTANT BOX 

CREATE ScreenData
BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR
BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---
BYTE ---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,---,---,---,---,---
BYTE ---,---,---,---,---,SQR,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,SQR,SQR,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,SQR,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,SQR,SQR,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,SQR,SQR,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,SQR,SQR,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,SQR,SQR,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,SQR,SQR,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,SQR,SQR,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,SQR,SQR,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,SQR,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,---,---,---,---,---
BYTE ---,---,---,---,---,SQR,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---
BYTE ---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR
BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR
BYTE BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL 
BYTE BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL

With the data organized so well by @Vorticon you can write it to the screen as a block.

: .BATTLEFIELD ( -- ) ScreenData  VPG @  C/SCR @ VWRITE ;

It just needs a few patterns defined to finish it off

: INITS
CLEAR
RANDOMIZE
S" 0000000000000000" --- CALLCHAR 
S" 1818DBFFFFFFC3C3" TANKUP CALLCHAR
S" FCFC383F3F38FCFC" TANKR  CALLCHAR 
S" C3C3FFFFFFDB1818" TANKDN CALLCHAR
S" 3F3F1CFCFC1C3F3F" TANKL  CALLCHAR
S" FFFFFFFFFFFFFFFF" SQR    CALLCHAR 
S" 0000001818000000" BULLET CALLCHAR 
S" FFFFC3C3C3C3FFFF" BOX    CALLCHAR 

14 SCREEN
96 SET# 11 9 COLOR
.BATTLEFIELD ;

+TheBF · February 24, 2023

Ok so I have a platform that I can work with.

Here it is running four tanks in what I have read is called "alpha intelligence".

This is the running program for each tank 🙂

If it's clear move ahead otherwise try a different direction.

: ALPHA-TANK ( --)
    BEGIN 
      PAUSE 
      .TANK 
      CLEAR-AHEAD? 
      IF 
        ADVANCE 
      ELSE 
        BOINK  
        8 RND DIRECTION  
      THEN 
      DELAY @ MS 
    AGAIN 
;

There is more stuff of course to get things set up but once configured that's all a tank does at the moment.

I chose not to use sprites to see how that would go. In theory I could pack the battlefield with tanks.

Colour of course would be limited per normal color set rules

Spoiler has the full code to date. Now I have to think about scanning for the enemy and shooting on detection.

Might be fun to give one tank to a human with some ammunition.

Thanks to @Vorticon for the inspiring idea. My visual brain is bankrupt.

Spoiler

\ COMBAT.FTH 
\  CCOMBAT HOST PROGRAM
\  Version 02.14.23 
\ by @VORTICON on Atariage.com 

\  PORTED & MODIFIED for Camel99 Forth  2023 Brian Fox 

NEEDS DUMP      FROM DSK1.TOOLS 
NEEDS BYTE      FROM DSK1.DATABYTE 
NEEDS RND       FROM DSK1.RANDOM 
NEEDS COLOR     FROM DSK1.GRAFIX 
NEEDS U.R       FROM DSK1.UDOTR   \ right justified numbers 
NEEDS HZ        FROM DSK1.SOUND 
NEEDS TASK:     FROM DSK1.MTASK99
NEEDS .TASKS    FROM DSK1.MTOOLS 
NEEDS MALLOC    FROM DSK1.MALLOC 

\ create a task in heap, fork it, assign Execution token & name 
: SPAWN ( xt -- pid) USIZE MALLOC DUP>R FORK R@ ASSIGN R>  ;

: TASK: ( xt -- ) SPAWN CONSTANT ;


\ Named characters make it easier to remember the shapes
DECIMAL 
128 CONSTANT BKG   ( background character)
BKG CONSTANT ---   ( alias for bkg character )
129 CONSTANT TANK1
130 CONSTANT SQR 
131 CONSTANT BULLET 
132 CONSTANT BOX 

\ named colors for Graphics programs
: ENUM  ( 0 <text> -- n) DUP CONSTANT  1+ ;

1 ENUM TRANS
  ENUM BLACK
  ENUM MEDGRN
  ENUM LTGRN
  ENUM BLUE
  ENUM LTBLU
  ENUM RED
  ENUM CYAN
  ENUM MEDRED
  ENUM LTRED
  ENUM YELLOW
  ENUM LTYEL
  ENUM GREEN
  ENUM MAGENTA
  ENUM GRAY
  ENUM WHITE
DROP

TANK1 8 + CONSTANT TANK2   
TANK2 8 + CONSTANT TANK3 
TANK3 8 + CONSTANT TANK4 


\ --------------------------------------
\ user variables are local for each tank task
\ 6 VARIABLES define the tank 
HEX 
60 USER Y 
62 USER X 
64 USER DY      \ dx and dy can be accessed as a 2variable 
66 USER DX
68 USER PANZER   \ tank character 
42 USER HEADING  \ compass heading is the direction control 
\ --------------------------------------
\ words to access the tank data 
: XY@      ( -- x y) Y 2@  ;
: XY!      ( x y --) Y 2! ;
: POSITION ( -- Vaddr) XY@ >VPOS ;

: DXDY!    ( x y --) DY 2! ;
: DXDY@    ( -- X Y) DY 2@ ;

\ battlefield layout 
CREATE ScreenData
BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR
BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---
BYTE ---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,---,---,---,---,---
BYTE ---,---,---,---,---,SQR,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,SQR,SQR,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,SQR,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,SQR,SQR,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,SQR,SQR,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,SQR,SQR,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,SQR,SQR,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,SQR,SQR,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,SQR,SQR,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,---,SQR,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,---,---,---,SQR
BYTE SQR,---,---,SQR,SQR,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,SQR,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,---,---,---,---,---
BYTE ---,---,---,---,---,SQR,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---
BYTE ---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,---
BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR
BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR
BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR
BYTE BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL
BYTE BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL

: .BATTLEFIELD ( -- ) ScreenData  VPG @  C/SCR @ VWRITE ;

\ ----------------------------
\ tank patterns for 8 compass headings 
HEX
CREATE NORTH[]    1010 , 547C , 7C7C , 7C44 , 
CREATE NE[]       0012 , 3478 , FE3C , 1810 ,
CREATE EAST[]     0000 , FC78 , 7F78 , FC00 , 
CREATE SE[]       1018 , 3CFE , 7834 , 1200 ,
CREATE SOUTH[]    447C , 7C7C , 7C54 , 1010 , 
CREATE SW[]       0818 , 3C7F , 1E2C , 4800 ,
CREATE WEST[]     0000 , 3F1E , FE1E , 3F00 ,
CREATE NW[]       0090 , 583C , FE78 , 3010 ,

DECIMAL 
CREATE TANKS ( -- addr) \ an array of patterns 
   NORTH[] , NE[] , EAST[] , SE[] ,
   SOUTH[] , SW[] , WEST[] , NW[] , 

\ select a pattern with a heading 
: ]TANK  ( heading -- Pattern-addr) CELLS  TANKS + @  ; 

: TANK-SHAPE ( heading -- ) \ set pattern based on HEADING variable
  \ RAM address   VDP address    bytes 
   ]TANK         PANZER @ ]PDT   8  VWRITE ;

\ compass headings in clockwise order 
   0 CONSTANT NORTH
   1 CONSTANT NE
   2 CONSTANT EAST
   3 CONSTANT SE
   4 CONSTANT SOUTH
   5 CONSTANT SW
   6 CONSTANT WEST
   7 CONSTANT NW


\ random number funcions 
: RNDX    ( -- x)  23 RND ;
: RNDY    ( -- y)  33 RND ;
: RANDOM  ( -- 0..7)  8 RND ; 
: RNDV    ( -- -1 0 1 ) 3 RND 1- ;

\ constant array of vectors, rotating clockwise 
CREATE VECTORS  ( -- addr) 
 \   Y    X  
 \  ---  ---
    -1 ,  0 ,  \ north 
    -1 ,  1 ,  \ NE 
     0 ,  1 ,  \ east 
     1 ,  1 ,  \ SE 
     1 ,  0 ,  \ south 
     1 , -1 ,  \ SW 
     0 , -1 ,  \ west 
    -1 , -1 , \ NW

\ return the correct vectors for a given heading 
: ]VECTOR ( heading -- dx dy)  2 CELLS *  VECTORS + 2@ ;

: ?LEGAL  ( n -- n ) DUP 8 0 WITHIN ABORT" Illegal heading" ;

: DIRECTION  ( heading  -- ) 
   ?LEGAL 
   DUP HEADING !        \ remember the new heading       
   DUP ]VECTOR  DXDY!   \ set tank's vectors for this heading 
       TANK-SHAPE       \ set the graphic for this heading 
;     

\ add coordinates to a vector 
: VECT+      ( x y dx dy -- x' y') >R ROT + SWAP R> +  ;

: PUT-CHAR   ( c -- ) POSITION VC! ;
: ERASE-TANK ( -- )   BKG PUT-CHAR ;
: .TANK      ( --) PANZER @ PUT-CHAR ;

: NEXT-POS   ( -- x y) XY@  DXDY@ VECT+  ;
: ADVANCE    ( -- )  ERASE-TANK   NEXT-POS XY!  .TANK ;


VARIABLE DELAY  50 DELAY ! 

: DECAY ( n -- )
  -10 DB DUP MS \ CALL SOUND(165,1165,0)::
  -18 DB DUP MS \ CALL SOUND(165,1165,8):: 
  -22 DB DUP MS \ CALL SOUND(165,1165,16)::
  -24 DB  MS \ CALL SOUND(165,1165,24)
   MUTE  ;

: RADAR    GEN1 1165 HZ  DELAY @ 2/  DECAY ; 
: BOINK    GEN1  200 HZ  DELAY @ 2/  DECAY ; 

: CLEAR-AHEAD?  ( -- ?) NEXT-POS GCHAR  BKG = ;
: CLIP   ROT MIN MAX  ;


: ALPHA-TANK ( --)
    BEGIN 
      PAUSE 
      .TANK 
      CLEAR-AHEAD? 
      IF 
        ADVANCE 
      ELSE 
        BOINK  
        8 RND DIRECTION  
      THEN 
      DELAY @ MS 
    AGAIN 
;

\  Score display
VARIABLE P1SCORE  
VARIABLE P2SCORE 

: .P1SCORE   P1SCORE @  3 U.R ;
: .P2SCORE   P2SCORE @  4 U.R ;

: .SCORE
  2 23 AT-XY ." TANK 1: " .P1SCORE  ."     TANK 2: " .P2SCORE
;

: INITS
   CLEAR
   RANDOMIZE
   S" 0000000000000000" BKG CALLCHAR 
   S" FFFFFFFFFFFFFFFF" SQR    CALLCHAR 
   S" 0000001818000000" BULLET CALLCHAR 
   S" FFFFC3C3C3C3FFFF" BOX    CALLCHAR 

   MAGENTA SCREEN
   .BATTLEFIELD .SCORE
;

: GOOD-GUY
   NORTH DIRECTION  
   TANK1 PANZER ! 
   15 12 XY! 
   PANZER @ SET# YELLOW RED COLOR 
   ALPHA-TANK ;

: BAD-GUY1 
   TANK2 PANZER ! 
   PANZER @ SET# GRAY RED COLOR 
   15 12 XY! 
   SE DIRECTION  
   ALPHA-TANK ;

: BAD-GUY2 
   TANK3 PANZER ! 
   PANZER @ SET# GREEN RED COLOR 
   15 12 XY! 
   NW DIRECTION  
   ALPHA-TANK ;

: BAD-GUY3
   TANK4 PANZER ! 
   PANZER @ SET# CYAN RED COLOR 
   15 12 XY! 
   NE DIRECTION  
   ALPHA-TANK ;

\ assign the configured tank programs to tasks
  ' GOOD-GUY TASK: TASK1 
  ' BAD-GUY1 TASK: TASK2 
  ' BAD-GUY2 TASK: TASK3 
  ' BAD-GUY3 TASK: TASK4 


: RUN  
    INITS  
    50 DELAY !  \ mS.  controls traveling speed 
    MULTI  
    TASK1 RESTART  500 MS 
    TASK2 RESTART  500 MS 
    TASK3 RESTART  500 MS 
    TASK4 RESTART  500 MS 

\ console task just updates the score and waits for break key 
    BEGIN 
      .SCORE 
       ?TERMINAL 
       PAUSE 
    UNTIL
    SINGLE SILENT  
    ABORT 
;

+Vorticon · February 24, 2023

You need this book 🙂 I used it as the basis of my Musings in AI program a few years ago (https://tigameshelf.net/edu.htm).

+TheBF · February 25, 2023

Just order this.

I believe I borrowed this from our local library ~~some 30+~~ almost 40 years ago. 🤯

Edited February 26, 2023 by TheBF
corrected years

+TheBF · February 26, 2023

I knew there was a reason I try to emulate ideas from other programmers.

Trying to duplicate the things I see people with do with the various BASIC dialects may seem silly but it really exercises my homebrew system and many times uncovers things I missed. (which is quite common)

While playing with the Combat battlefield I came to realize that I had made some bad decisions in my sound library for multi-tasking.

The program requirement was to have two types of Tanks make different "boink" sounds while running under different tasks.

I quickly found out there was a problem that revolves around two variables.

VARIABLE OSC 
VARIABLE ATT

These variables hold the current sound channel (OSC) and the current Attenuator for the active channel. I chose to use variables so you could state the "generator" that was in use in your program (GEN1, GEN2, GEN3, GEN4) once and then the sound commands would use that channel until you change the channel. All great in a single task. But when to tasks try to make sounds on different channels they each need their own copy.

The tempatation would be to use an array but don't go there.

Solution

The answer here is to leverage Forth's internal architecture. Forth's has something called USER variables.

They were invented because Forth was originally a multi-user system. (PolyForth circa 1975?)

They are part of the Fig-Forth model but for some reason, maybe fear of a law-suit from Forth Inc, the Fig-Forth authors did not finish the job with the tasking system.

USER variables exist in a memory block that is local to each task. In Camel99 I chose to simply extend the workspace to include the registers, the user variables, the return stack and the data stack. The default size for this is a constant called USIZE which is 192 bytes, but you can make it bigger or smaller as long as you know how a task will use the space. (be careful)

So all I did was change those variables to USER variables:

\ "ACTIVE CHANNEL" control with these USER variables, LOCAL to each task

\ These are in consecutive addresses in memory

HEX

42 USER ATT \ holds the active ATTENUATOR value

44 USER OSC \ holds the active OSC value

The numbers represent the distance in bytes from Register '0' in a task's workspace.

Now if TASK1 references OSC or ATT it is working with a completely different "variable" than TASK2's copy.

All this magic is seamless to the programmer. Once the USER variables are defined they automagically return the correct address inside a task.

Here is what we have so far. One hunter (yellow) and three drone tanks.

This is extra fast because I reduced the delay times so things would collide faster.

+TheBF · February 28, 2023

Animating Characters and Sprites in Forth by Extending the Language

@Retrospect sent me a note inviting me to try my hand at his Avaris game in Forth.

(No pressure) I know it can be done but I may not have the mental stamina to see it through.

G.E.M. has some really cool pixel scrolling that I don't have as well.

However when I looked at the BASIC code I realized there was an opportunity to make some

compiler tools that simplifies some things that take a lot of code in BASIC.

As I said to Joe, in Forth you write the language then you write the program.

This long winded post gives an example of my process to do that.

If I wanted to use Joe's work I need a way to compile all his strings of pattern data easily.

Many of the patterns are animations made of many patterns.

Also integers are way more compact way to store the data we'll compile the strings as integers.

I re-worked the guts of CALLCHAR to make this:

: HEX,  ( addr len --)    \ n is a record counter 
        BASE @ >R         \ save radix
        HEX               \ we are converting hex numbers in the string
        BOUNDS
        DO
           I    C@ >DIG  4 LSHIFT \ convert, move to right nibble
           I 1+ C@ >DIG  OR C,    \ combine with left nibble and compile to RAM
        2 +LOOP
        R> BASE !          \ restore radix 
;

: FRAME" ( <hexdata> ) [CHAR] " PARSE ( -- tib len ) HEX, ;

This data, written in vanilla Forth, can be used to make a character appear to explode.

But's it dumb. It gives you nothing but the address of the data. You do the rest.

HEX 
CREATE SHRAPNEL  \ :-) 
    0000 , 125C , 1E2C , 0000 , 
    0042 , 1498 , 0250 , 1400 ,
    1084 , 2200 , 1280 , 2400 ,
    2002 , 8001 , 0000 , 8104 ,
    0000 , 0000 , 0000 , 0000 , \ completely disappears

This is better in that we can see that each pattern is a frame and the strings can be "borrowed" from BASIC as is.

We can't access each frame without some math however.

HEX 
CREATE SHRAPNEL 
   FRAME" 0000125C1E2C0000"
   FRAME" 0042149802501400"
   FRAME" 1084220012802400"
   FRAME" 2002800100008104"
   FRAME" 0000000000000000"

These magic brackets give us a way to measure how much data was compiled into memory.

\ dictionary memory managers. Mark beginning and compute length of compiled data
: {  ( -- addr) HERE  !CSP ;   \ mark the dictionary address, record data stack    
: }  ( addr -- addr n ) ?CSP  HERE OVER - ; \ return data address & compute the size

{  FRAME" 0000125C1E2C0000"
   FRAME" 0042149802501400"
   FRAME" 1084220012802400"
   FRAME" 2002800100008104"
   FRAME" 0000000000000000"
}

With these simple tools, after the closing '}' we will have the address of the 1st frame and the size of the data in bytes.

This can be thought of as Forth's "stack string" pair, a very useful data structure. In this case it is a "string" of binary bytes not ASCII.

We can store those two numbers in a 2CONSTANT and give it a name.

Camel99 doesn't have 2CONSTANT.

No worries.

\ 2CONSTANT  holds 2 numbers and returns both onto the data stack when invoked 
: 2CONSTANT ( addr len -- )  CREATE  ,  ,  DOES> 2@ ;

Now we can say this:

{  FRAME" 0000125C1E2C0000"
   FRAME" 0042149802501400"
   FRAME" 1084220012802400"
   FRAME" 2002800100008104"
   FRAME" 0000000000000000"
} 2CONSTANT EXPLOSION

To animate a character we still need to access this "EXPLOSION" and apply it to the character.

This has a bit of stack juggling but it works.

(4TH is a Camel99 code word that gets the 4th item on the data stack up to the top)

DECIMAL 
\ animate a single character 
: ANIMATE ( addr len char speed) 
    >R                \ save the speed on return stack 
    ]PDT -ROT         \ get the PDT address and put under addr len 
    BEGIN 
        DUP           \ dup the length 
    WHILE             \ while <> 0  
        OVER 4TH 8 VWRITE   \ write 8 bytes to PDT address 
        8 /STRING           \ cut the string by 8 bytes 
        R@ MS               \ delay by speed milli-seconds 
    REPEAT 
    R> DROP     \ clean up both stacks
    2DROP DROP                
;

Now in our program we can say:

EXPLOSION  CHAR A 70 ANIMATE

And it doesn't matter how many frames we put in our data.

ANIMATE keeps chopping away at the data until there is nothing left.

In the next post we will show sprites that animate themselves.

+TheBF · March 1, 2023

We can use the same concepts to animate a magnified sprite. We just need to work with 32 bytes in each frame.

Here is one of @Retrospect 's flying saucers. It has 13 frames.

DECIMAL 
{ FRAME" 00000000030F005F9F9F00030000000000000000C0F000FEFFFF00C000000000"
  FRAME" 00000000030F006FCFCF00030000000000000000C0F000FEFFFF00C000000000"
  FRAME" 00000000030F0077E7E700030000000000000000C0F000FEFFFF00C000000000"
  FRAME" 00000000030F007BF3F300030000000000000000C0F000FEFFFF00C000000000"
  FRAME" 00000000030F007DF9F900030000000000000000C0F000FEFFFF00C000000000"
  FRAME" 00000000030F007EFCFC00030000000000000000C0F000FEFFFF00C000000000"
  FRAME" 00000000030F007FFFFF00030000000000000000C0F0007E3F3F00C000000000"
  FRAME" 00000000030F007FFFFF00030000000000000000C0F000BE9F9F00C000000000"
  FRAME" 00000000030F007FFFFF00030000000000000000C0F000DECFCF00C000000000"
  FRAME" 00000000030F007FFFFF00030000000000000000C0F000EEE7E700C000000000"
  FRAME" 00000000030F007FFFFF00030000000000000000C0F000F6F3F300C000000000"
  FRAME" 00000000030F007FFFFF00030000000000000000C0F000FAF9F900C000000000"
  FRAME" 00000000030F007FFFFF00030000000000000000C0F000FEFFFF00C000000000"
} 2CONSTANT FLYING_SAUCER

We need a slightly different program to animate it because of the larger records.

This works. It's the same as ANIMATE but it use 32 byte records.

One could make a universal "ANIMATOR" by adding a user variable to handle the the size or do a lot more stack juggling.

As before we could add as many records as we want and ANIMATE4 just keeps cutting off 32 byte sections until it all gone.

DECIMAL 
\ animate a 4 char sprite to the number of patterns in the array 
: ANIMATE4  ( addr len char speed) 
    >R 
    ]PDT -ROT 
    BEGIN 
        DUP 
    WHILE 
        PAUSE              \ give time to another task 
        OVER 4TH 32 VWRITE 
        32 /STRING 
        R@ MS 
    REPEAT 
    R> DROP 
    2DROP DROP                
;

Here is something a bit different. What if we create a way to make an animation that contains the data and the program to animate it.

This is advanced Forth so it looks pretty confusing but we are extending the compiler to record the information a compile name.

At runtime, in other words what it "DOES" when invoked, is the word reaches into it's memory area, get the parameters and runs ANIMATE4.

\ animator object does it's thing when invoked
: ANIMATOR:  ( addr len char speed)
  CREATE  2SWAP  ,  ,   ,   ,   \ compile the arguments 
  DOES> DUP 2 CELLS +       ( pfa+4 pfa )
        SWAP 2@            ( -- pfa+4 addr len )
        2@                 ( -- addr len char speed )
        ANIMATE4  ;

The words ANIMATION1 and ANIMATION2 would be useful for animations that just run once and stop.

If we had a lot of ANIMATIONS these word creators can save a lot of space.

\ make objects that animate themselves
\ Frame-data    char speed    
  FLYING_SAUCER 128   10 ANIMATOR: ANIMATION1
  FLYING_SAUCER 132   10 ANIMATOR: ANIMATION2

If we wanted to keep those animations going all the time, we need to put each one in a task.

First we package them up in an endless loop along with the code to make their sprite.

They look funny because they are in an endless loop. The secret is that ANIMATOR4 runs PAUSE inside its loop.

This gives time to other tasks in the system after each frame is written.

To control them we RESTART the jobs or put them to SLEEP.

: SAUCER1   
  128  BLACK 127 90  0 SPRITE 
  BEGIN  
    ANIMATION1
  AGAIN ;

: SAUCER2    
  132  RED   200 50  1 SPRITE  
  BEGIN  
    ANIMATION2 
  AGAIN ;
  
\ assign the spinners to background tasks
' SAUCER1 TASK: JOB1 
' SAUCER2 TASK: JOB2

Camel99 Forth Information goes here

Recommended Posts

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Join the conversation

Recently Browsing 0 members