Jump to content
TheBF

Camel99 Forth Information goes here

Recommended Posts

"Everything is easy if you understand it. If it isn't easy, you don't understand it"

Old Arabic saying

 

Well this compiler building is a bigger deal than i thought it was but I have come to a more or less a stable format for programs which is shown here.

 

I have created a number interpreter (H#) to compile a literal number into the code, because I have not yet created a full compiler loop that reads the program.

I still using vanilla PC Forth as an interpreter to compile the text into machine code.

I have yet to fully grok the potential of using the literal stack for arguments so the emitted code is not as optimal as it Thomas Almy's white paper describes, but it seems to compile a lot of different things now.

 

The NATIVE99 compiler, at startup, now dynamically compiles the compiling words, intrinsic routines (inline 1 to 4 instruction stuff) and the new versions of colon and semi-colon that compile 9900 sub-routines. This allows me to tweak them when I break them without re-compiling the whole compiler. The foundation stuff is pretty solid because it came from CAMEL99 Forth.

 

You can do a lot of computing without the runtime library but you can't put it on the screen. I have KSCAN and from that KEY and KEY?

I need to beat up the VDP routines and create EMIT, CR, TYPE, etc. so that I can hit the screen.

It's rather daunting to consider tweaking all my programs so the goal it is make this thing swallow them as they are as much as possible.

 

My next challenge is to create a very small HELLO WORLD. ;) I have one here in HsForth "meta-compiler" that compiles to 127 bytes as a .COM file. That's the benchmark.

 

Edit: fixed un-cropped screen save

\ Native99 test format

CROSS-COMPILING
         START.                \ sets a timer
         NEW.                  \ init target memory to FFFF
         A000 ORIGIN.
         TI-99.EA5
         REPORT ON
    \     STAY ON
    \     OPTIMIZE ON

[CC] HEX
CROSS-ASSEMBLING
 VARIABLE X
 VARIABLE Z

: MAIN
       H# 2 X !
       BEGIN
         H# 100 FOR
             X @  I *  Z !
         NEXT
       AGAIN ;

PROGRAM: NCMULT              \ we are interpreting at this point
         8300 WORKSPACE       
         FF00 RSTACK         \ make the Forth VM
         FF80 DSTACK
         MAIN RUN            \ call the main program
         BYE
END.

[CC]  \ switch to cross-compiler vocabulary, do some commands

SAVE.EA5

\ *optional commands can go here. Copy image , show memory dump etc...
// copy NCMULT  cc9900\clssic99\dsk1\
   HEX A000 50 TDUMP

STOP.

post-50750-0-63701900-1559162065.jpg

Edited by TheBF
  • Like 1

Share this post


Link to post
Share on other sites

Hello World from a Compiler in 160 154 bytes

 

Although I have not got the push/pop optimizer on (found some bug conditions) we have a very small hello world binary.

It could of course be a bit smaller but it's not too bad.

 

EDIT: Found an unnecessary DUP and DROP in my TYPE routine.

\ Small hello world in Native 99 Forth

CROSS-COMPILING
HEX
\ Compiler pre-amble
         START.                \ sets a timer
         NEW.                  \ init target memory to FFFF
         A000 ORIGIN.
         TI-99.EA5
         REPORT ON   \ print final report


CROSS-ASSEMBLING
\ simple VDP write driver
8C00 CONSTANT VDPWD     \ vdp ram write data
8C02 CONSTANT VDPWA     \ vdp ram read/write address
     VARIABLE VPOS      \ screen position tracker

: TYPE   ( addr len -- )
         VPOS @  h# 4000 +   \ convert to vdp write address
         DUP VDPWA C!        \ write low byte
             VDPWA  !        \ write high byte
         1+ FOR
           DUP [email protected] VDPWD C!   \ VDP auto increments address, so write away!
           1+                \ advance to next char in string
         NEXT
         VPOS +!             \ update screen tracker
;

\ ==========================================
  : MAIN      S" Hello World!" TYPE   ;

PROGRAM: HELLO
         8300 WORKSPACE  \ setup Forth VM
         FFFF RSTACK
         FF00 DSTACK
         MAIN RUN
         BEGIN AGAIN
END.

[CC] SAVE.EA5   \ FILENAME$ was set by PROGRAM:

// copy HELLO cc9900\clssic99\dsk1\

STOP.

post-50750-0-09314000-1559156428.jpg

post-50750-0-24864400-1559156440.jpg

Edited by TheBF
  • Like 3

Share this post


Link to post
Share on other sites

Nope! I didn't over complicate it

 

While pondering the ins and outs of turning Forth source code into native 9900 code I was concerned that I was missing something, some secret sauce that made it all simple.

 

"I wonder if Tom Almy is still around..." thought I last night

 

He sure is and after one email he sent me the source code for CF86 which he wrote in 1985 and improved until 1995.

After studying the source code, which is a little bit tricky, (ok very tricky) I came to some conclusions:

  1. Using the literal stack during compilation requires using conditionals like I started doing to make decisions about how best to compile the arguments. There are no short-cuts short of making Forth into a compiler language that you understand to abstract some detail.
  2. I have a pretty good foundation using HsForth for DOS, the TI-Forth based cross-assembler and the cross-compiler built for CAMEL99.
    (Tom used LMI Forth which was a competitor to HsForth at the time)
  3. I will have many opportunities to play with/invent optimization once the compiler is reliable
  4. And OMG the 9900 is so much nicer to use than Intel 86!

So it looks like there are no short cuts just a lot of editing of Forth primitives so they get some smarts about when to grab args at compile time and when to do it at run time.

 

So much code, so little time...

 

0xBF

 

 

  • Like 3

Share this post


Link to post
Share on other sites

It is remarkable how much freedom I have with this native code concept. I was writing a screen clearing routine and I thought I can write this all in Forth now.

I noticed that using the Forth operators to write a byte took extra instructions so I used ALC inside a Forth FOR/NEXT loop!

Heresy I hear you say but look at the tight loop. :) ( I omitted the code that calls VDPWA!)

 

Original code: (Edit: corrected VDPWD address in R1)

: PAGE   ( -- )
          VTOP @ VDPWA!       \ set the VDP write address
          R0 2000 LI,         \ use free registers :-)
          R1 8C00 LI,  

          H# 300             \ bytes in 32 column mode screen
          FOR
             R0 *R1 MOVB,
          NEXT
;

Compiled code:

   A076  0200  li   R0,>2000    
   A07A  0201  li   R1,>8C00 
   A07E  0646  dect R6
   A080  C584  mov  R4,*R6 
   A082  0204  li   R4,>0300   \ >300 to Forth TOS register
   A086  0647  dect R7         \ FOR... sets the index register
   A088  C5C9  mov  R9,*R7     \ push current loop index to rstack
   A08A  C244  mov  R4,R9      \ load new index register
   A08C  C136  mov *R6+,R4     \ refill Forth TOS register

* >>This is the entire loop<<
>  A08E  D440  movb R0,*R1     \ move the byte to VDP screen           
   A090  0609  dec  R9         \ decrement loop counter
   A092  1301  jeq  >a096      \ this exits the loop           
   A094  10FC  jmp  >a08e      \ NEXT 
Edited by TheBF
  • Like 2

Share this post


Link to post
Share on other sites

Looking at those 2 jumps in the FOR NEXT loop woke me up early. :-)

 

I had modeled the NEXT code on the WHILE REPEAT loop in the TI-Forth Assembler.

That is waaay over complicated for NEXT. So the code that compiles NEXT changed from:

: NEXT      R9 DEC,
            NE CJMP AHEAD 2+  \ while *RP<>0
            >R BACK JMP,
            R> 2- RESOLVE
            R9 RPOP,
;

To this:

: NEXT      R9 DEC,
            BACK JNE, 
            R9 RPOP,
;

Now I can go back to sleep. :)

  • Like 2

Share this post


Link to post
Share on other sites

Implementing DO/LOOP in Native Code.

(Edit: added final code)

 

After making a decision to use R9 as the system loop index register, similar to the way ECX is used in x86 code, it came time to implement the DO/LOOP.

It was much simpler than I thought. Since R9 is used by FOR/NEXT and DO/LOOP the Forth word I is very simple.

Push the TOS register and move R9 into the TOS register.

HOST: I    ( -- n)  
           ?TOSPUSH,     \ optimizer decides is we push or not
           R9 TOS MOV, 
;HOST
FOR/NEXT is simple because it decrements R9 to zero. DO/LOOP has to increment I until it hits a LIMIT value.

 

Fortunately we have the return stack to hold the LIMIT value and the 9900 lets us compare memory to register very easily.

So we "RPUSH" the limit value but we must first "RPUSH" the current value in R0 because some earlier loop might be using it.

All that considered and "DO" compiles this code. the HOST: means this ALC will be compiled inline (ie DO is a macro)

HOST: DO   ( limit index -- )  ( r: -- limit old-R9)
       R9 RPUSH,
       TOS R9 MOV,
       *SP+ RPUSH,
       TOS POP,
       BEGIN 
;HOST
And LOOP does this:

HOST: LOOP ( -- )
       R9 INC,
       R9 *RP CMP, \ test LIMIT vs value on return stack
       BACK JNE,
       RP INCT,   \ drop the limit on the return stack
       R9 RPOP,   \ restore prev. R9 value
;HOST
However thIs simple native code loop runs 64k loops at about the same speed as CAMEL Forth's DO/LOOP because of a trick used by Camel Forth.

(about 3 seconds)

 

So when I incorporate that trick of using the JNO instruction this improved version runs 64k loops in < 1 second. :-)

Here is the ANS Forth version of the do loop in native code.

 

(DO) is a sub-routine to save space on very use but the concept works great.

 

LOOP is a macro that codes the 4 instructions inline. I will have to give some thought about how best to make LOOP work as a sub-routine because the address to jump back to is calculate as the code compiles. The spoiler has the final code

 

 

 

CROSS-ASSEMBLING
\ This is a subroutine. Reduces code size of using do/loops
: (DO)      ( limit indx -- ) \ sub-rotuine that sets up the DO loop
              R0  8000 LI,      \ load "fudge factor" to RO
             *SP+ R0  SUB,      \ Pop limit, compute 8000h-limit "fudge factor"
              R0  TOS ADD,      \ loop ctr = index+fudge
              R9 RPUSH,         \ save current R9
              R0  RPUSH,        \ rpush limit
              TOS R9 MOV,       \ index to R9
              TOS POP,          \ refill TOS
;

\ macro the runs the setup and returns the start address of the loop
HOST: DO  ( -- loopaddr)
         (DO)  BEGIN
;HOST

\ Inline Macro gives full speed but takes 10 bytes.
HOST: LOOP   (  loopaddr -- )
              R9 INC,           \ increment loop
              BACK JNO,         \ if no overflow then loop again
              RP  INCT,
              R9  RPOP,
;HOST

\ *warning* used with DO/LOOP only!
: I    ( -- n)
          ?TOSPUSH,
          R9 TOS MOV,
         *RP TOS SUB,     \ index = loopindex - fudge
;


: J    ( -- n)
           ?TOSPUSH,
           2 (RP) TOS MOV,
           4 (RP) TOS SUB, \ index = loopindex - fudge
;


HOST: I+!  ( n -- )  \ NON-STANDARD: allows changing the loop index
           LDEPTH
           CASE
            0 OF   TOS R9 ADD,
                   TOS POP,         ENDOF

                   POPARG @@ R9 ADD,
           ENDCASE
;HOST

 

Edited by TheBF
  • Like 2

Share this post


Link to post
Share on other sites

I updated the previous post with the final DO/LOOP code. It is working very well now. With this I can complete my VDPIO library and will be able to write quite normal Forth programs.

One of the challenges with a native code Forth compiler that I see with Tom Almy's version is:

How can the compiler know how many arguments are input to a sub-routine and how many outputs are returned?

Why is this is hard in Forth? The reason is because arguments are un-named and simply reside on the data stack as do outputs. So the compiler has no idea how to handle this in Forth.
Contrast this to a conventional language that uses named variables where the compiler knows what goes in by name and typically can only return one value. That is easy to compile.

Tom created a "compiler directive" call IN/OUT. You give it 2 numbers. For example '+' would be defined as

2 1 IN/OUT 
: +      ( ...code to add numbers... )  ; 

I don't want to have to do that for every word so I am looking into commandeering the bracketed stack diagram to compute these values for the compiler. This would mean that the code
MUST have a stack picture for every definition but this is considered good Forth coding practice and it means existing code would compile as expected... if the stack comments are correct!

So I prefer that the code looks like this:

: +  ( n n -- n)  
     ( ...code to add numbers... )  
; 

That is a design goal for NATIVE99.

Edited by TheBF
  • Like 2

Share this post


Link to post
Share on other sites

Compiling Forth IF is a Dilemma

Traditional Forth uses the top of stack value as the condition flag. Zero if false, -1 is a proper true flag but usually any non-zero value is considered true.
The 9900 of course uses the status register and jump instructions.

If I implemented the Forth mechanism of setting or resetting the top of stack it takes a compare instruction, the conditional jump, the TOS CLR, the TOS SETO, and another JMP, instruction.
That's 4 instructions if compiled inline or I can call the comparison operations as a sub-routine. This felt so wrong when the object of the native code is to go faster.
Nevertheless a standard Forth program expects to be able to manipulate the top of stack value with comparison operations, so I may have to relent BUT...

In the meantime, I have figured out how to compile native 9900 branching using Forth's "IF/ELSE/THEN" syntax and preliminary testing shows the code is pretty much what I would code by hand. :-)

The key was to use a variable to hold a value that leverages a little compiler from the TI-Forth assembler call CJMP.
There were two challenges:

  • how to deal with the legal syntax of using IF without '=' or '>' etc.
  • How to code 0=, 0> etc.

The solution is not hard when you can do work at compile time.
For problem one we can simply test the COMPARATOR variable when we compile 'IF' and if is not set, default to 0<>.
For problem two we simply push a zero onto the stack (TOS CLR,) and then set the appropriate operation in COMPARATOR.

Here is a short test program:

VARIABLE FLAG

: MAIN
        ." Equal Operator test:"
        H# 1  H# FFFF <
        IF   FLAG ON
        ELSE FLAG OFF
        THEN
        KEY DROP
;


And here is the resulting code:

A362  0646  DECT R6            * TOS PUSH
A364  C584  MOV  R4,*R6
A366  0204  LI   R4,>0001      *  H# 1
A36A  0646  DECT R6            * TOS PUSH
A36C  C584  MOV  R4,*R6
A36E  0204  LI   R4,>FFFF      *  H# FFFF
A372  8136  C    *R6+,R4
A374  1501  JGT  >A378         *  < IF
A378  0720  SETO @>A330        *      FLAG ON
A37C  1002  JMP  >A382         *  ELSE
A37E  04E0  CLR  @>A330        *      FLAG OFF
A382  C136  MOV  *R6+,R4       *  THEN
A384  06A0  BL   @>A2FA        *  KEY
A388  C136  MOV  *R6+,R4       *  DROP
A38A  C2F7  MOV  *R7+,R11      *  ;
A38C  045B  B    *R11

Spoiler shows how it was done.

 

Note: The big optimization will come later when I figure out how to reference more stack arguments in 9900 registers vs only one register at this time.

 

\ NCIFTHEN.FTH

\       *** For Reference ***
\ Assembler jump tokens used with CJMP
\ NOTE: They are opposite of what the mnemonic says because IF jumps if the
\       condition is NOT true. :-)
\ HEX
\ 0                    Unconditional jump
\ 1 CONSTANT GTE     \ if GT OR EQUAL
\ 2 CONSTANT HI      \ if HI
\ 3 CONSTANT NE      \ if NOT equal
\ 4 CONSTANT LO      \ if low
\ 5 CONSTANT LTE     \ if less than or equal
\ 6 CONSTANT EQ      \ if equal
\ 7 CONSTANT OC      \ if on carry flag set
\ 8 CONSTANT NC      \ if no carry flag set
\ 9 CONSTANT OO      \ if on overflow
\ A CONSTANT HE      \ if high or equal
\ B CONSTANT LE      \ if low or equal
\ C CONSTANT NP      \ if no parity
\ D CONSTANT LT      \ if less than  (SIGNED)
\ E CONSTANT GT      \ if greater than (SIGNED)
\ F CONSTANT NO      \ if no overflow
\ 10 CONSTANT OP     \ if ODD parity

CROSS-COMPILING
VARIABLE COMPARATOR   \ holds the comparison operator [1..F]

host: comparator!  COMPARATOR ! ;host

\ called "comparators"  They control which JUMP operation is compiled by 'IF'
CROSS-ASSEMBLING
HOST: =        EQ COMPARATOR! ;HOST
HOST: <>       NE COMPARATOR! ;HOST
HOST: >        GT COMPARATOR! ;HOST
HOST: <        LT COMPARATOR! ;HOST

HOST: U>=     GTE COMPARATOR! ;HOST
HOST: <=      LTE COMPARATOR! ;HOST
HOST: U>       HI COMPARATOR! ;HOST
HOST: U<       LO COMPARATOR! ;HOST
HOST: U<=      LE COMPARATOR! ;HOST
HOST: U>=      HE COMPARATOR! ;HOST

\ these compile a zero to TOS and then compare
host: 0=       ?tospush,  tos clr,  =   ;HOST
host: 0<>      ?tospush,  tos clr,  <>  ;HOST

\ 9900 specific comparisons
HOST: .OP.     OP COMPARATOR! ;HOST
HOST: .NO.     NO COMPARATOR! ;HOST
HOST: .NP.     NP COMPARATOR! ;HOST
HOST: .OVR.    OO COMPARATOR! ;HOST
HOST: .OC.     OC COMPARATOR! ;HOST
HOST: .NC.     NC COMPARATOR! ;HOST

\ =====================================
\ define IF,ELSE,THEN for the compiler
HOST: IF    ( n n --)
\      arg>tos
      *SP+ TOS  CMP,               \ compile comparison code
[CC]  COMPARATOR @  0=             \ is a comparator set?
      IF 0<> THEN                  \ no, so default to 0<>
      COMPARATOR @ CJMP AHEAD      \ compile correct jump for the operation
      COMPARATOR OFF               \ reset the comparator
;HOST

HOST: ELSE  ( -- )
       0  CJMP AHEAD              \ compile a JMP instruction to THEN
       SWAP RESOLVE               \ resolve the IF jump
;HOST

HOST: THEN  ( addr -- )
       RESOLVE                    \ resolve the IF or ELSE jump
       TOS POP,                   \ refill TOS
;HOST

 

 

Edited by TheBF
  • Like 1

Share this post


Link to post
Share on other sites

CREATE DOES> in a directed threaded code (DTC) Forth

 

My head was hurting with the native code project so I re-visited a "hanging chad" in my code. I had never figured out how to make CREATE DOES> work with CAMEL99 DTC version. There are not many people who will care to grok this but I put it here for that wayward soul who decides to make their own. :woozy:

 

I am starting with a simple example. This an example defining word that let's you make a Forth constant:

: CONS    CREATE , DOES> @ ;   \ This is the "defining word"

And this is how it could be used:

99 CONS X                     \ This is the "defined word"

When X is invoked it will return the value 99 by 'fetching' it with the operator '@' that we see after DOES>.

 

Here is a step by step explanation of what has to happen in my implementation where I use the BL instruction to call direct threaded Forth words.

  • When the defined word (X) is invoked is does a BL to the DOES> part of CONS
  • The Forth IP (interpreter pointer) has not moved at this point
  • After X runs via BL instruction , R11 points to the address just past the BL instruction and address. (X's data field address)
  • We just push that onto the Forth stack
  • We push the current IP onto the return stack (edit: this was out of order & removed confusing duplicate line)
  • We decrement R11 by 2 to point to the address of DOES> in CONS Edit: indexed addressing removed "R11 DECT"
  • Make that address our new IP
  • Advance the new IP past the branch instruction in DOES> which points to the "payload" in DOES> which is the execution token of '@'
  • Now we run NEXT, the Forth interpreter, which runs fetch (@) which takes the value of the address on the TOS.
  • And when NEXT runs again, we are back at the IP address we save previously

    Whew!

Here's the code.

l: _DODOES  ( -- a-addr)
            TOS PUSH,       \ save TOS reg on data stack
            R11 TOS MOV,    \ After BL R11 has defined word's PFA. Move to TOS
            IP  RPUSH,      \ save current IP on return stack
 
                                                       \ B @@ _dodoes
                                                                      ^
     \ R11 now points to just after defining word code:      >>>>>>>>>^   
           -2 (R11) IP MOV, \ get the address of _dodoes as Forth IP. 
            IP  4 ADDI,     \ advance past branch to defining word's PFA
            NEXT,

For the insanely curious: ;)

 

My problem was that I was using BL inside DOES> .

When invoked, X did a BL to DOES> which did a 2nd BL to _DODOES and that corrupted the value in R11 that I really needed.

By changing DOES> to do a simple BRANCH to _DODOES, R11 was maintained when I entered _dodoes and it let me find a way to the DOES> part later by computation.

Edited by TheBF
  • Like 2

Share this post


Link to post
Share on other sites

So now that DTC Forth is completely working.

 

Well it's not quite that simple. I had to make a new version of DSK1.SYSTEM, because things like >BODY are offset by 4 bytes instead of 2 bytes. And CODE words don't have a code field. The machine code starts right after the Dictionary header.

 

However once that was fixed many programs just worked, as long as I had stuck to standard Forth. That's an improvement over the old days in Forth.

 

Anyway here is a pair of shoot-out videos of the Dijkstra Dutch flag problem using his Algorithm with various randomization as the starting points.

 

In this test, DTC Forth versus vanilla ITC CAMEL Forth, the DTC version is ~15% faster.

 

Spoiler has the source code that was compiled un-changed in both systems

 

 

\ Dutch flag DEMO using CAMEL99 Forth using Dijkstra's Algorithm
\ *SORTS IN PLACE FROM Video MEMORY*

\ INCLUDE DSK1.TOOLS.F   ( for debugging)
 INCLUDE DSK1.GRAFIX
 INCLUDE DSK1.RANDOM
 INCLUDE DSK1.CASE
 INCLUDE DSK1.ELAPSE


\ TMS9918 Video chip Specific code
HEX
FFFF FFFF FFFF FFFF PATTERN: SQUARE

\ define colors and characters
DECIMAL
24 32 *  CONSTANT SIZE     \ flag will fill GRAPHICS screen
SIZE 3 / CONSTANT #256     \ 256 chars per segment of flag
1        CONSTANT REDSQR   \ red character
9        CONSTANT WHTSQR   \ white character
19       CONSTANT BLUSQR   \ blue character
28       CONSTANT PTR1

\ color constants
1        CONSTANT TRANS
7        CONSTANT RED
5        CONSTANT BLU
16       CONSTANT WHT

SQUARE REDSQR CHARDEF
SQUARE BLUSQR CHARDEF
SQUARE WHTSQR CHARDEF
SQUARE PTR1   CHARDEF

\ charset  FG    BG
  0        RED TRANS COLOR
  1        WHT TRANS COLOR
  2        BLU TRANS COLOR

\ screen fillers
: RNDI    ( -- n ) SIZE 1+ RND ; \ return a random VDP screen address

: NOTRED    (  -- n ) \ return rnd index that is not RED
           BEGIN  
              RNDI DUP [email protected] REDSQR = 
           WHILE 
              DROP  
           REPEAT ;

: NOTREDWHT    ( -- n ) \ return rnd index that is not RED or BLU
           BEGIN  RNDI DUP
              [email protected]  DUP REDSQR =  
              SWAP WHTSQR = OR
           WHILE
              DROP
           REPEAT ;

: RNDRED  (  -- ) \ Random RED on VDP screen
          #256 0 DO   REDSQR NOTRED VC!   LOOP ;

: RNDWHT (  -- ) \ place white where there is no red or white
          #256 0 DO   WHTSQR NOTREDWHT VC!   LOOP ;

: BLUSCREEN ( -- )  
           0 768 BLUSQR VFILL ;

\ load the screen with random red,white&blue squares
: RNDSCREEN ( -- )
            BLUSCREEN  RNDRED  RNDWHT ;

: CHECKERED  ( -- ) \ red,wht,blue checker board
         SIZE 0
         DO
            BLUSQR I VC!
            WHTSQR I 1+ VC!
            REDSQR I 2+ VC!
         3 +LOOP ;

: RUSSIAN  \ Russian flag
            0  0 WHTSQR 256 HCHAR
            0  8 BLUSQR 256 HCHAR
            0 16 REDSQR 256 HCHAR ;

: FRENCH  \ kind of a French flag
           0  0 BLUSQR 256 VCHAR
          10 16 WHTSQR 256 VCHAR
          21  8 REDSQR 256 VCHAR ;


\ Algorithm Dijkstra(A)  \ A is an array of three colors
\ begin
\   r <- 1;
\   b <- n; 
\   w <- n;
\ while (w>=r)
\       check the color of A[w]
\       case 1: red
\               swap(A[r],A [w]);
\                r<-r+1
\       case 2: white
\               w<-w-1
\       case 3: blue
\               swap(A[w],A[b]);
\               w<-w-1;
\               b<-b-1
\ end


: XCHG  ( adr1 adr2 -- )
      OVER [email protected] OVER [email protected]        \ read the chars in VDP RAM
      SWAP ROT VC! SWAP VC!    ;  \ exchange the characters

\ address pointer variables
VARIABLE R
VARIABLE B
VARIABLE W

: DIJKSTRA ( -- )
           0 R !
           SIZE 1- DUP  B !  W !
           BEGIN
               W @  R @  1- >
           WHILE
               W @ [email protected]
               CASE
                 REDSQR OF  R @ W @  XCHG
                            1 R +!           ENDOF

                 WHTSQR OF -1 W +!           ENDOF

                 BLUSQR OF  W @ B @  XCHG
                           -1 W +!
                           -1 B +!           ENDOF
               ENDCASE
           REPEAT ;

: WAIT   11 11 AT-XY ." Finished!" 1500 MS ;

: TITLE ( -- )
         PAGE
         CR ."     DIJKSTRA DUTCHFLAG DEMO"
         CR ."     -----------------------"
         CR
         CR ."  Using the 3 colour algorithm"
         CR ."  translated to hi-level Forth"
         CR
         CR ."  Sorted in-place in Video RAM"

         0 23 AT-XY ."   Press any key to begin"
         KEY DROP ;

: RUN ( -- ) \ test with different input patterns
         TITLE
         TICKER OFF
         RNDSCREEN  DIJKSTRA \ WAIT
         CHECKERED  DIJKSTRA \ WAIT
         RUSSIAN    DIJKSTRA \ WAIT
         FRENCH     DIJKSTRA \ WAIT
         0 23 AT-XY .ELAPSED
         CR ." Completed"
;

 

 

ITC FORTH DEMO.mp4

DTC FORTH DEMO.mp4

  • Like 2

Share this post


Link to post
Share on other sites

Trying the new Artiage UI

 

I was wondering how hard it would be to use MIDI values to play notes on Forth. Although I have used MIDI for many years for music production I never looked under the hood.

So as an exercise I found a table on a web site, stuck the table in Excel and then re-worked the columns to give me what I needed and pasted it into a source file. 🙂

With a little Forth compiler word called MIDI, I compiled the table of notes from midi 45 to midi 108, a usable musical range.

 

The fastest way I have found to get values from the table is with indexed addressing so the word MIDI takes a midi# and returns the 9919 code that plays the note.

I tested it with a little play routine to play the entire table in sequence and it works well.

\ fastest array access on 9900 uses indexed addressing
CODE MIDI   ( midi# -- Fcode)
             TOS TOS ADD,                \ compute midi#->table_offset
             MIDI-TABLE (TOS) TOS MOV,   \ fetch the value
             NEXT,
             ENDCODE

 

And to test out my screen capture routine I wrote a MIDI-DUMP that output the data as Assembly language data statements for anybody who might find this useful.

\ dump midi data as text table

: <####>   ( n -- ) ( ud n --) 0  <#  # # # #  #>  ;

: .FCODE   ( i --) MIDI ." >" <####> TYPE  ;

: DUMP-MIDI  CR
             109 45
             DO
               ." DATA  "  I 3 +  I DO I .FCODE ." , " LOOP  I .FCODE CR
             4 +LOOP
;

 

 

The spoiler has the table Forth code.

 

Spoiler
\ Notes by midi number in the range of the TMS9919 chip

\ NEEDS DUMP   FROM DSK1.TOOLS   ( debugging only)
NEEDS MOV,   FROM DSK1.ASM9900
NEEDS HZ     FROM DSK1.SOUND

\ word to pre-calculate 9919 freq. code and compile into memory
: MIDI,  ( freq -- ) HZ>CODE ,  ;

\ Create midi table that can hold all 127 midi notes.
DECIMAL
CREATE MIDI-TABLE      127 CELLS ALLOT

\ ********************************
\ *   BEGIN COMPILE TIME MAGIC   *
\ ********************************
\ pre-fill entire table ZERO
\ in case we try to access an invalid note for the 9919
MIDI-TABLE  127 CELLS  0 FILL

\ Save the current dictionary address on data stack
HERE
\ Set the dictionary pointer (DP) to midi[45] in the table
MIDI-TABLE  45 CELLS +  DP !

\ Now fill in the table with notes from #45 to #108
\ *Freq        Midi#    Note
\ -----        -----    ------------
  110  MIDI, \  45	A2
  117  MIDI, \  46	A#2/Bb2
  123  MIDI, \  47	B2
  131  MIDI, \  48	C3
  139  MIDI, \  49	C#3/Db3
  147  MIDI, \  50	D3
  156  MIDI, \  51	D#3/Eb3
  165  MIDI, \  52	E3
  175  MIDI, \  53	F3
  185  MIDI, \  54	F#3/Gb3
  196  MIDI, \  55	G3
  208  MIDI, \  56	G#3/Ab3
  220  MIDI, \  57	A3
  233  MIDI, \  58	A#3/Bb3
  247  MIDI, \  59	B3
  262  MIDI, \  60	C4 (middle C)
  277  MIDI, \  61	C#4/Db4
  294  MIDI, \  62	D4
  311  MIDI, \  63	D#4/Eb4
  330  MIDI, \  64	E4
  349  MIDI, \  65	F4
  370  MIDI, \  66	F#4/Gb4
  392  MIDI, \  67	G4
  415  MIDI, \  68	G#4/Ab4
  440  MIDI, \  69	A4 concert pitch
  466  MIDI, \  70	A#4/Bb4
  494  MIDI, \  71	B4
  523  MIDI, \  72	C5
  554  MIDI, \  73	C#5/Db5
  587  MIDI, \  74	D5
  622  MIDI, \  75	D#5/Eb5
  659  MIDI, \  76	E5
  698  MIDI, \  77	F5
  740  MIDI, \  78	F#5/Gb5
  784  MIDI, \  79	G5
  831  MIDI, \  80	G#5/Ab5
  880  MIDI, \  81	A5
  932  MIDI, \  82	A#5/Bb5
  988  MIDI, \  83	B5
  1047 MIDI, \  84	C6
  1109 MIDI, \  85	C#6/Db6
  1175 MIDI, \  86	D6
  1245 MIDI, \  87	D#6/Eb6
  1319 MIDI, \  88	E6
  1397 MIDI, \  89	F6
  1480 MIDI, \  90	F#6/Gb6
  1568 MIDI, \  91	G6
  1661 MIDI, \  92	G#6/Ab6
  1760 MIDI, \  93	A6
  1865 MIDI, \  94	A#6/Bb6
  1976 MIDI, \  95	B6
  2093 MIDI, \  96	C7
  2217 MIDI, \  97	C#7/Db7
  2349 MIDI, \  98	D7
  2489 MIDI, \  99	D#7/Eb7
  2637 MIDI, \ 100	E7
  2794 MIDI, \ 101	F7
  2960 MIDI, \ 102	F#7/Gb7
  3136 MIDI, \ 103	G7
  3322 MIDI, \ 104	G#7/Ab7
  3520 MIDI, \ 105	A7
  3729 MIDI, \ 106	A#7/Bb7
  3951 MIDI, \ 107	B7
  4186 MIDI, \ 108	C8
\ ----------- END --------------
\ *frequencies have been rounded up/down to closest integer
\ Note values from:
\ http://www.inspiredacoustics.com/en/MIDI_note_numbers_and_center_frequencies

\ restore the old dictionary pointer
DP !

\ fastest array access on 9900 uses indexed addressing
CODE MIDI   ( midi# -- Fcode)
             TOS TOS ADD,                \ compute midi#->table_offset
             MIDI-TABLE (TOS) TOS MOV,   \ fetch the value
             NEXT,
             ENDCODE

 

 

MIDIDATA.jpg

mididata.asm

  • Like 3

Share this post


Link to post
Share on other sites

Checking in

 

I have been distracted lately by nice weather, grandchildren and a cousin with a bunch of vintage vacuum tube guitar amplifiers that need serious attention.

 

I have been trying to find out why my RS232 Forth does not like to have the output vectored to other devices on real hardware. That is proving to be a challenge. 

 

All that to say I am still lurking but have a few other things to deal with.  Hope to get a current copy of the system up on Github before end of July.

(no promises) 🙂

 

0xBF

  • Like 3

Share this post


Link to post
Share on other sites

Things that make me say Hmmm?

 

On the weekend I was reviewing code and found this cute little XB demo. It's very clever IMHO.

1 ! Smart Programming Guide for Sprites
2 ! by Craig Miller
3 !(c) 1983 by Miller Graphics
100 CALL CLEAR
110 CALL SCREEN(2)
120 CALL CHAR(46,"0000001818")
130 CALL SPRITE(#2,94,16,180,1,0,5)
140 FOR N=0 TO 25
150     X=RND*192+1
160     Y=RND*255+1
170     CALL SPRITE(#3,65+N,16,Y/2+1,X+1)
180     CALL SOUND(-60,660,8)
190     CALL POSITION(#3,Y,X,#2,R,C)
200     CALL SPRITE(#1,46,16,R,C,(Y-R)*.49,(X-C)*.49)
210     CALL SOUND(476,-3,14)
220     CALL SOUND(120,110,6)
230     CALL DELSPRITE(#1)
240     CALL PATTERN(#3,35)
250     CALL SOUND(100,220,6)
260 NEXT N
270 GOTO 140

I took a run at it using directly controlled sprites in Forth and it was "challenging". 

I wondered, how hard would it be to use the interrupt driven motion control anyway? After all it's sitting there in the ROMs.

After a bit I had working code... kind of.

I  had  sprites moving on the screen with  "AUTOMOTION"  but for some reason the bottom of my screen image, which starts at VDP >0000 was contaminating the sprite motion table after I turned on the AUTOMOTION.

 

I checked all my VDP register settings for Graphics mode and they seem ok.  I am really at a loss as to what is going on.

 

Here is all it took to use automotion in Forth after loading the grafix and dirsprit libraries.

Spoiler
\ Interrupt Driven Sprite motion (like Extended BASIC)  BJF July 21 2019

NEEDS SPRITE      FROM DSK1.DIRSPRIT

HEX
0780 CONSTANT SMT       \ SPRITE motion table VDP address
83C2 CONSTANT AMSQ      \ interrupt software DISABLE bits

\ AMSQ bit meaning:
\ 80 all interrupts disabled
\ 40 motion disabled
\ 20 Sound disabled
\ 10 quit key disabled

\ access the sprite tables in VDP like arrays
: ]SMT    ( spr# -- VDP-addr) 4* SMT + ;
: ]SAT    ( spr# -- VDP-addr) 4* SAT + ;

: MOVING  ( n -- ) 837A C! ;   \ # of sprites moving automatically

: INITMOTION ( -- )
          0 MOVING                          \ no moving sprites
          20 0 DO  D000 I ]SAT V!  LOOP ;   \ init all sprites

: STOPMOTION ( -- ) AMSQ [email protected] 40 OR  AMSQ C! ; \ stop all sprite motion

: AUTOMOTION ( -- )
              SPR# @ 1+ MOVING
              AMSQ [email protected] 7 AND 30 AND  AMSQ C! ;

: >SCHAR  ( c -- c') FF AND  ;  \ convert c to signed CHAR

: MOTION  ( spx spy spr# -- ) >R  >SCHAR SWAP >SCHAR FUSE   R> ]SMT V!  ;

 

 

 

  • Like 1

Share this post


Link to post
Share on other sites

I will need to peruse your DIRSPRIT code before I can attempt to divine what might be the problem, but I am curious about the need for >SCHAR here. In fbForth, only the LSB of the stack value is used by single-byte write words like C! and VSBW , so a word like >SCHAR would be unnecessary.

 

...lee

Share this post


Link to post
Share on other sites

It's academic really.  Just a reminder to me that signed chars are used in the motion control table and protection from non-byte values getting used by FUSE which "fuses" bytes together into a CELL.

 

Here is the sprite control code (but it doesn't do anything special)

So I included the GRAFIX file too which dirsprit uses.

 

But I just noticed a difference between my CLEAR word(for BASIC friendliness) and PAGE. It's no doubt something very stupid that I did long ago. 😐

 

Spoiler
NEEDS HCHAR  FROM DSK1.GRAFIX  \ must be in Graphics 1 mode

HERE
CR .( compiling direct sprite control)
HEX
8802   CONSTANT VDPSTS   \ vdp status register memory mapped address
300    CONSTANT SAT      \ sprite descriptor table VDP RAM base address
20 4*  CONSTANT SATsize  \ size of the table, 32 sprites x 4 bytes/record
1F     CONSTANT MAX.SP   \ 32 sprites, 0 .. 31

\ hi speed memory addresses are actually variables
83D4   CONSTANT VDPR1    \ MEMORY for VDP Register 1, TI SYSTEM address

VARIABLE SPR#            \ holds the last sprite defined by SPRITE

\ Sprite descriptor table array CODE word is 2X faster, same size as Forth
\ *** SP.Y is the base address of the 4 byte sprite record
 CODE SP.Y ( spr# -- vaddr) \ 4* SAT +
           0A24 ,         \  TOS  2 SLA,
           0224 , SAT ,   \  TOS SAT AI,
           NEXT,
           ENDCODE

CODE SP.X ( spr# -- vaddr) \ 4* SAT + 1+
           0A24 ,         \  TOS  2 SLA,
           0224 , SAT ,   \  TOS SAT AI,
           0584 ,         \  TOS INC,
           NEXT,
           ENDCODE

\ These words are the fastest way access sprite decr. table
: [email protected]  ( spr# -- sprx) SP.X [email protected] ;    \ fetch X
: [email protected]  ( spr# -- spry) SP.Y [email protected] ;    \ fetch Y

: SP.X!  ( n spr# -- ) SP.X VC! ;      \ store X
: SP.Y!  ( n spr# -- ) SP.Y VC! ;      \ store Y

: SP.PAT  ( n spr# -- vaddr) SP.X 1+ ; \ address of pattern byte
: SP.COLR ( n spr# -- vaddr) SP.X 2+ ; \ address of colr byte

\ finger trouble protection. Runtime array index test.
: ?NDX  ( n -- n ) MAX.SP OVER < ABORT" Bad SPR#" ;

CR .( .)
\ INIT SPRITES: You must run DELALL before using sprites*
: DELALL  ( -- )
          1 ?MODE               \ test for graphics mode
          1 6 VWTR              \ vdp reg 6 = 1, puts ]PDT @ $800
          SAT SATsize BL VFILL  \ init the sprite desc. table with blanks
          SPR# OFF ;            \ #sprites=0

\ The following words are named like Extended BASIC
\ (remove ?NDX if you need more speed, but you loose protection)
: POSITION  ( sprt# -- dx dy )  SP.Y [email protected] SPLIT ;
: LOCATE    ( dx dy sprt# -- ) ( ?NDX)  SP.Y >R FUSE R> V! ;
: PATTERN   ( char sprt# -- )  ( ?NDX)  SP.PAT VC! ;
: SP.COLOR  ( col sprt# -- )   ( ?NDX)  SP.COLR >R  1-  R> VC! ;

\ CODE DUP>R ( n -- ) ( r-- n)
\          0647 , C5C4 ,    \ TOS RPUSH,
\          NEXT,
\          ENDCODE
.( .)
: SPRITE  ( char colr x y sp# -- ) \ create a SPRITE, sp# = 0..31
          ?NDX
          DUP >R                \ copy spr# to rstack
          LOCATE                \ set screen position
          [email protected] SP.COLOR           \ set the sprite color
          [email protected] PATTERN            \ set the character pattern to use
          R>  SPR# @ MAX  SPR# ! ; \ update last spr#

\ like Extended BASIC Magnify
: MAGNIFY  ( mag-factor -- ) VDPR1 [email protected] 0FC AND +  DUP 1 VWTR  VDPR1 C! ;
.( .)
HEX
CODE RANGE? ( n n n -- n') \ FORTH: OR OR 8000 AND
          E136 ,          \ *SP+ TOS SOC,
          E136 ,          \ *SP+ TOS SOC,
          0244 , 8000 ,   \ TOS 8000 ANDI,
          NEXT,
          ENDCODE

CODE DXY  ( x2 y2 x1 y1 --- dx dy )   \ Common factor for SP.DIST,SP.DISTXY
          C036 ,  \ *SP+ R0 MOV,      \ pop x1->R0
          6136 ,  \ *SP+ TOS SUB,     \ pop y1-y2->tos
          6016 ,  \ *SP  R0 SUB,      \ x1-x2->R0, keep stack location
          C0C4 ,  \  TOS R3 MOV,      \ dup tos in r3, MPY goes into R4
          38C4 ,  \  TOS R3 MPY,      \ r3^2, result->r4 (tos)
          C080 ,  \  R0  R2  MOV,     \ dup R0
          3802 ,  \  R2  R0  MPY,     \ RO^2
          C581 ,  \  R1 *SP  MOV,     \ result to stack
          NEXT,                       \ 16 bytes
          ENDCODE
.( .)
\ factored DIST out for re-use
\ With new machine code words and no Rstack operations it is 2X faster
: DIST     ( x2 y2 x1 y1 -- distance^2) \ distance between 2 coordinates
            DXY  2DUP +                  \ sum the squares
            DUP RANGE?                   \ check if out of range
            IF  DROP 7FFF                \ throw away the copy, return 32K
            THEN ;                       \ otherwise return the calculation

: SP.DIST   ( spr#1 spr#2 -- dist^2 ) POSITION ROT POSITION DIST ;

: SP.DISTXY ( x y spr# -- dist^2 ) POSITION DIST ;

.( .)
\ text macros for clarity and speed of coicidence detection
: 2(X^2)   ( n -- 2(n^2) S" DUP * 2*" EVALUATE ;  IMMEDIATE
: <=       ( n n -- ? )  S" 1- <" EVALUATE ; IMMEDIATE

\ VDP status bit set if any two sprites overlap
: COINCALL  ( -- ? ) VDPSTS [email protected] 20 AND ;

\ 0 means no coincidence
: COINC     ( sp#1 sp#2 tol -- ? )
            2(X^2) -ROT SP.DIST > ;

: COINCXY   ( dx dy sp# tol -- ? )
            2(X^2) >R    \ convert tolerance  to squares, push to rstack
            SP.DISTXY    \ compute sprite dist from dx dy
            R> <= ;      \ compare dist to tolerance

HERE SWAP -
CR
CR .( Sprites used ) DECIMAL . .( bytes)

 

 

Spoiler
\ GRAPHIX.FTH for CAMEL99 V2

\ define vdp tables as arrays
HEX
 0380 CONSTANT CTAB      \ colour table
 0800 CONSTANT PDT       \ "pattern descriptor table"

\ access VDP tables like arrays. Usage:  9 ]CTAB returns VDP addr
 : ]CTAB  ( set# -- 'ctab[n])   CTAB + ;    \ 1 byte fields
 : ]PDT   ( char# -- 'pdt[n] )  8* PDT + ;  \ 8 byte fields

\ ABORT to Forth with a msg if input is bad
: ?MODE  ( n -- )      VMODE @ <>   ABORT" Bad mode" ;
: ?COLOR ( n -- n )    DUP 16 U>    ABORT" Bad Color" ;
: ?SCR   ( vdpadr -- ) C/SCR @ CHAR+ > ABORT" too many chars"  ;

( takes fg nibble, bg nibble, convert to TI hardware #s)
( test for legal values, and combine into 1 byte)
: >COLR ( fg bg -- byte) 1- ?COLOR SWAP 1- ?COLOR  04 LSHIFT + ;

\ TI-BASIC SUB-PROGRAMS BEGIN
: CLEAR  ( -- )  PAGE  0 17 AT-XY  ;   ( just because you love it )
: COLOR  ( character-set fg-color bg-color -- )
          1 ?MODE  >COLR SWAP ]CTAB  VC! ;

\ ascii value SET# returns the character set no.
: SET#  ( ascii -- set#) 3 RSHIFT ;

( *NEW*  change contiguous character sets at once)
: COLORS  ( set1 set2 fg bg  -- )
          1 ?MODE
          >COLR >R
          SWAP ]CTAB SWAP ]CTAB OVER - R> VFILL ;

: SCREEN ( color -- )
         1 ?MODE             \ check for MODE 1
         1- ?COLOR ( -- n)   \ TI-BASIC color to VDP color and test
         7 VWTR  ;           \ set screen colour in Video register 7

 : GRAPHICS  ( -- )
             1 VMODE !        \ call this video mode 1
             0 380  0 VFILL   \ erase the entire 40 col. screen space
             E0 DUP 83D4 C!   \ KSCAN re-writes VDP Reg1 with this byte
      ( -- E0) 1 VWTR         \ VDP register 1  bit3 = 0 = Graphics Mode
             0E 3 VWTR
             01 4 VWTR
             06 5 VWTR
             01 6 VWTR         \ set sprite descriptor table to 1x$800=$800

             CTAB 10 10 VFILL \ color table: black on transparent [1,0]
             8 SCREEN         \ cyan SCREEN
             20 C/L!          \ 32 chars/line
             CLEAR ;

\ CHAR sub-program is renamed to CHARDEF
: CHARDEF  ( addr char# --)  ]PDT      8 VWRITE ; \ ti basic call char
: CHARPAT  ( addr char# --)  ]PDT SWAP 8 VREAD ;  \ ti basic call charpat

: PATTERN: ( u u u u -- )
\ USAGE:  HEX 0000 FF00 AABB CCDD PATTERN: SHAPE1
           CREATE
              >R >R >R
           ,  R> , R> , R> , ;

: GCHAR ( col row -- char) VROW [email protected] >VPOS [email protected] ;

\ NOTES:
\ 1. Unlike BASIC HCHAR & VCHAR must have the cnt parameter
\ 2. col and row do not affect AT-XY, VCOL or VROW
: HCHAR  ( col row char cnt -- )
          SWAP 2>R           \ swap char & cnt, push to return stack
          >VPOS              \ ( -- vdp_addr)
          R>  2DUP + ?SCR    \ add count to Vadr and test
          R>  VFILL ;        \ get char, FILL Vmemory

: VCHAR  ( col row char cnt -- ) \ parameter order not ideal so we shuffle
          2>R                \ ( -- x y )
          >VPOS              \ ( -- vdp_addr)
          C/SCR @ 1- SWAP    \ ( -- lim vdpaddr)
          R> SWAP            \ ( -- lim char vadr)
          R> 0               \ ( -- lim char vadr
          ?DO                \ ( -- lim char vadr)
             2DUP VC!
             C/[email protected] +  VCLIP
          LOOP
          2DROP DROP ;


GRAPHICS CR .( GRAPHICS 1 Mode READY)

 

 

Share this post


Link to post
Share on other sites

Other than that CLEAR puts the cursor at the beginning of the last screen line and that PAGE does nothing with the cursor, I do not see anything untoward yet.

 

...lee

Share this post


Link to post
Share on other sites

Ya it's a head scratcher.  I had to move back to the amp repair so I did nothing else with it.  Gotta be something I am configuring wrong in the 9918.

Anyway. It was a good exercise making the automotion work.  

 

Thanks for your help.

 

B

Share this post


Link to post
Share on other sites
1 hour ago, Lee Stewart said:

Other than that CLEAR puts the cursor at the beginning of the last screen line and that PAGE does nothing with the cursor, I do not see anything untoward yet.

 

...lee

Here is the code for PAGE.  It actually does work on the cursor position.

 

: PAGE   ( -- )
          VTOP @
          DUP C/SCR @ OVER -
          BL VFILL
          0 SWAP C/[email protected] / AT-XY ;

 

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...

  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...