Camel99 Forth Information goes here

+TheBF · September 25, 2022

Over in Optical Illusions @sometimes99er posted one of his signature tiny programs that do a lot of stuff.

I am usually a bit jealous of just how concise BASIC can be. 🤢

The version I threw together used raw coordinates to place the sprites so I wondered what it would take to compute the circle in Forth.

After all I have a fancy TRIG table in a library file. Truth be told I had never used it.

I tried translating the BASIC code literally but guess what? It didn't work because TI BASIC takes the angle in RADIANS.

I never noticed that before. Only took me 40 years.

I also decided I should at least format the program in a Forth appropriate style, so I used many constants for clarity and factored sections of the program as words.

Anyway, here is a Forth version that computes the circle using only integers. (Anybody could do it with floating point)

\ translation to camel99 Forth
NEEDS SIN    FROM DSK1.TRIG
NEEDS SPRITE FROM DSK1.DIRSPRIT

DECIMAL
  01 CONSTANT invisible   14 CONSTANT magenta    15 CONSTANT gray
  92 CONSTANT Xbias      122 CONSTANT Ybias     130 CONSTANT Scale
 128 CONSTANT BALL

: SIN(X) ( n -- x) 30 * SIN  Scale / Xbias + ;
: COS(Y) ( n -- y) 30 * COS  Scale / Ybias + ;
: CIRCLE  12 0 DO  BALL magenta  I COS(Y)  I SIN(X)  I SPRITE  LOOP ;
: BLINKER 12 0 DO  invisible I SP.COLOR  120 MS   magenta I SP.COLOR   LOOP ;

: RUN
CLEAR  gray SCREEN    2 MAGNIFY  16 12 AT-XY ." +"
S" 00071F3F3F7F7F7F7F7F3F3F1F07000000E0F8FCFCFEFEFEFEFEFCFCF8E00000" BALL CALLCHAR
CIRCLE   BEGIN BLINKER ?TERMINAL UNTIL ;

image.png.49bda570a073a8a1bbfc6b0efa23841e.png

Edited September 25, 2022 by TheBF
fixed comment

D-Type · September 25, 2022

https://nbickford.wordpress.com/2011/04/03/the-minsky-circle-algorithm/

I think this might be Minsky's quick elipse algorithm. Worth a look?

D-Type · September 25, 2022

https://scratch.mit.edu/projects/249324997/

And this is Graham Toal's Scratch version of the algorithm. Graham is one of the 6809 Vectrex community.

+Lee Stewart · September 26, 2022

12 hours ago, TheBF said:

The version I threw together used raw coordinates to place the sprites so I wondered what it would take to compute the circle in Forth.

After all I have a fancy TRIG table in a library file. Truth be told I had never used it.

I tried translating the BASIC code literally but guess what? It didn't work because TI BASIC takes the angle in RADIANS.

I never noticed that before. Only took me 40 years.

I also decided I should at least format the program in a Forth appropriate style, so I used many constants for clarity and factored sections of the program as words.

Anyway, here is a Forth version that computes the circle using only integers. (Anybody could do it with floating point)

Of course, I could not resist porting this to fbForth! I did use floating point |:) for the trig calculations, so it is not ported exactly—sorry.

I added the capability of making the balls any color. I also added all the colors as constants with uppercase names to facilitate user typing of colors. Code is in the spoiler:

Spoiler

\ Translation from Camel99 Forth to fbForth with embellishments

DECIMAL
  0 CONSTANT INVISIBLE
  1 CONSTANT BLACK
  2 CONSTANT MEDIUM_GREEN
  3 CONSTANT LIGHT_GREEN
  4 CONSTANT DARK_BLUE
  5 CONSTANT LIGHT_BLUE
  6 CONSTANT DARK_RED
  7 CONSTANT CYAN
  8 CONSTANT MEDIUM_RED
  9 CONSTANT LIGHT_RED
 10 CONSTANT DARK_YELLOW
 11 CONSTANT LIGHT_YELLOW
 12 CONSTANT DARK_GREEN
 13 CONSTANT MAGENTA
 14 CONSTANT GRAY
 15 CONSTANT WHITE
 MAGENTA CONSTANT color

128 CONSTANT BALL

122 CONSTANT Xbias       
 92 CONSTANT Ybias     
>F 0.52359877559830 FCONSTANT AngleInc \ 30 deg in FP radians
>F 80 FCONSTANT radius           \ radius in FP dots

: X_coord ( n -- x) 
   S->F AngleInc F*              \ ball# to FP angle
   COS  radius F* F->S           \ FP x-distance to integer
   Xbias +   ;                   \ add x-offset
: Y_coord ( n -- y) 
   S->F AngleInc F*              \ ball# to FP angle
   SIN  radius F* F->S           \ FP y-distance to integer
   Ybias +   ;                   \ add y-offset
: (color)   ( n|[] -- ) \ store new color if stack not empty
   DEPTH 0> IF                   \ if not empty stack
      1 MAX                      \ at least 1
      15 MIN                     \ at most 15
      ' color !                  \ store new color
   THEN   ;
: CIRCLE  
   12 0 DO  
      I X_coord  I Y_coord  color  BALL I SPRITE  
   LOOP ;
: DELAY  ( n -- )  
   0 DO 
      I DROP                     \ do something n times
   LOOP  ;
: BLINKER 
   12 0 DO  
      INVISIBLE I SPRCOL         \ blank a ball
      1200 DELAY                 \ delay for blank ball
      color I SPRCOL             \ restore ball color
   LOOP  ;
HEX 
\ Run with or without a color on the stack
: RUN  ( color|[] -- )
   (color)                       \ see if color change
   VDPMDE @                      \ current VDP mode to stack
   GRAPHICS GRAY SCREEN          \ make it gray
   CLS                           \ clear screen
   COLTAB 020 04E VFILL          \ all color sets dark blue on gray
   2 MAGNIFY                     \ use 4-char, unmagnified sprites
   010 0C GOTOXY ." +"           \ put '+' at col 16, row 12
   DELALL                        \ initialize sprite table
   \ Pattern data for characters 128-131, 4 for each ball sprite
   DATA[ 0007 1F3F 3F7F 7F7F 
         7F7F 3F3F 1F07 0000 
         00E0 F8FC FCFE FEFE 
         FEFE FCFC F8E0 0000 ]DATA
   BALL DCHAR                    \ define BALL char   
   CIRCLE                        \ set up balls in a circle
   BEGIN 
      BLINKER                    \ blink one ball at a time
      ?TERMINAL                  \ hold down FCTN-4 to quit
   UNTIL 
   VMODE  ;                      \ restore VDP mode from value on stack
DECIMAL

...lee

+TheBF · September 26, 2022

Very nice. You sounded a bit Canadian there. (Sorry)

Ya, it's a fun exercise. That TI-99 floating point is still great after all these years.

+TheBF · September 27, 2022

A while back I played with higher order functions (HOF) to emulate some Python capabilities. Part of that exercise was due to a LOGO demonstration created by @pixelpedant.

I really like the way logo lets you feed a set of numbers to a function. This is possible because LOGO is based on lists like it's grandfather LISP.

My previous HOFs were a bit more complicated than they deserve for manipulating groups of sprites, so I tried to make something simpler.

I also wanted to be able to compile the HOF into a definition.

I think I have something here that will work, and the syntax is easy to understand. (?)

There is a bit of overhead in this version because I wanted a data set to return an (add,len) pair in two cases:

When the data is defined with [[ ]] for interpretation while testing
When the data is named with SET:

This version treats data sets like variables and arrays; they must be defined at compile time.

To use a data set in a definition you must name it with SET: That might be a needless complication but that will become clear when I try to use data sets in a real program.

MAP in this case does not create new data as before. It just does something to the data in the set. That can be any word that operates on single CELL of memory.

With these I will create some sprite control words that take a "set" of parameters I see if I can emulate the LOGO functions.

To process the data in a set I purposely use EVALUATE so that a data set can include Forth variables or constants.

At the moment they cannot contain another data set. That would require that a data set returns a single address and FOREACH would have to be recursive. (Could be fun)

Here is what the test code looks like:

\ DATA SETS test code ...
: ? ( addr -- )  @ . ;   \ print contents of an address

 DECIMAL
 [[ 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 ]] SET: EVENS
 [[ 1 3 5 7 9 11 13 15 17 19 21 23 25 27 29 31 ]] SET: ODDS

EVENS MAP ?
ODDS  MAP ?

ODDS 2DUP MAP 1+!  MAP ?
ODDS 2DUP MAP 1-!  MAP ?

: TEST   EVENS MAP ? ;  \ Compiling test
TEST

image.png.b963cf113dfc54d04465b63e81b367f6.png

Spoiler

\ logo style data sets and FOREACH                  Sep 2022 Brian Fox

INCLUDE DSK1.COMPARE

DECIMAL
2 CELLS CONSTANT 2CELLS

: 2CELLS+  2CELLS + ;

: 2LITERAL  ( d -- )
            ?COMP SWAP
            POSTPONE LITERAL
            POSTPONE LITERAL ; IMMEDIATE

\ end a set. Return the address of the data and length in bytes
: ]]   ( here -- addr len )
  DUP
  HERE OVER - 2CELLS -  DUP>R  OVER 2!
  2CELLS+  R>
  EXIT   \ EXIT forces evaluation to stop at ]]
;

: PARSE-DATA ( addr -- addr' len)
         BEGIN
           BL PARSE-WORD
           2DUP S" ]]" COMPARE WHILE ( <>"]]")
            DUP WHILE ( len<>0)
           EVALUATE  ,  \ evaluate can handle named data also
         REPEAT
         THEN
         2DROP ;

\ create a data-set with 2 cell header
: [[ ( -- )  HERE  0 , 0 ,  PARSE-DATA ]] ;

\ name a data set. Return the data address and length in bytes
: SET: ( addr len -- )
  CREATE
    ,  ,
  DOES> 2@  ;

: FOREACH ( addr size xt-- )
        >R
        BOUNDS ( 'end '1st)
        BEGIN 2DUP >
        WHILE
          DUP ( addr )  \ addr of a set element
          R@  ( addr xt) EXECUTE
          2+
        REPEAT
        R> DROP
        2DROP ;

: MAP ( <word> ) \ state smart so it can be used in definitions
   '           ( look up the word )
   STATE @ IF  ( compiling action)
     POSTPONE LITERAL
     POSTPONE FOREACH
     EXIT
   THEN ( interpreting action )
   FOREACH ; IMMEDIATE

\ literal is state smart so these can be used in definitions
: SIZEOF ( -- n)  '  >BODY  @      POSTPONE LITERAL ; IMMEDIATE
: #ITEMS ( -- N)  '  >BODY  @  2/  POSTPONE LITERAL ; IMMEDIATE

+TheBF · September 28, 2022

So, you learn a lot when you try to do real work with your clever language enhancement.

I was using FOREACH to get the address of the data in a dataset, not the actual data. That's fixed.
If you want to use the Forth data stack for parameters for mapped functions, you can't use the data stack to iterate on the dataset. DUH!
I made a variant of FOREACH called ALTER. This lets you change the contents of a dataset. Not sure if that would be needed but it was simple to add.

#2 meant that I needed to rework FOREACH to use an "action" variable and I iterate with a DO/LOOP so the dataset addresses reside on the return stack.

Next problem: I needed a way have enough parameters on the data stack to map onto all the elements in a given dataset.

You could go crazy and get the number of elements in the data and make enough copies on the stack for all iterations, but I decided to keep it simple and just do the correct dups on each call.

This also means that after one of these dataset mappings you must clean the parameters from the data stack. I could automate that but have not yet.

I landed on a syntax like this:

[1]   means there is one argument to be duplicated 
[2]   means there are two arguments to be duplicated

For any sprite function that operates on a single sprite you need to make a definition it with the parameter "dupper" in it.

Example:

: SP.XY  ( x y --) [2] LOCATE ;

This little video shows some operations. It works pretty fast.

With these tools I can add dataset functions for motion very simply.

Here is the test code

Spoiler

INCLUDE DSK1.TOOLS
INCLUDE DSK1.AUTOMOTION
INCLUDE DSK1.RANDOM
INCLUDE DSK2.DATASETS

: SPRITES
   26 0
   DO
     I [CHAR] A +   16 RND 1+  6 I *   6 I *  I  SPRITE
   LOOP ;

DECIMAL
[[ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 28 28 29 30 31 ]]
SET: :ALL

[[ 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 ]] SET: EVENS
[[ 1 3 5 7 9 11 13 15 17 19 21 23 25 27 29 31 ]] SET: ODDS

: [1] ( n set -- n n set )  >R  DUP  R>  ;
: [2] ( n n set -- n n n n set ) >R 2DUP R> ;

: VC+!  ( n Vadr -- ) DUP>R VC@ +  R> VC! ;

: SP.Y+ ( n -- ) [1] SP.Y VC+! ;
: SP.X+ ( n -- ) [1] SP.X VC+! ;

: COLOR  ( n -- )  [1] SP.COLOR ;
: SP.XY  ( x y --) [2] LOCATE ;


CLEAR SPRITES

Here is the new dataset code

Spoiler

\ logo style data lists and FOREACH                  Sep 2022 Brian Fox

INCLUDE DSK1.TOOLS
HERE
INCLUDE DSK1.COMPARE

DECIMAL
\  ** EXPERIMENTAL DATA STRUCTURE:  COUNTED DATA ARRAYS IN DICTIONARY **
2 CELLS CONSTANT 2CELLS
: 2CELLS+  2CELLS + ;

: 2LITERAL  ( d -- )
            ?COMP SWAP
            POSTPONE LITERAL
            POSTPONE LITERAL ; IMMEDIATE

\ end a set. Return the address of the data and length in bytes
: ]]   ( here -- addr len )
  DUP
  HERE OVER - 2CELLS -  DUP>R  OVER 2!
  2CELLS+  R>
  EXIT   \ EXIT forces evaluation to stop at ]]
;

: PARSE-DATA ( addr -- addr' len)
         BEGIN
           BL PARSE-WORD
           2DUP S" ]]" COMPARE WHILE ( <>"]]")
            DUP WHILE ( len<>0)
           EVALUATE  ,  \ evaluate can handle named data also
         REPEAT
         THEN
         2DROP ;

\ create a data-set with 2 cell header
: [[ ( -- )  HERE  0 , 0 ,  PARSE-DATA ]] ;

\ name a data set. Return the data address and length in bytes
: SET: ( addr len -- )
  CREATE
  ,  ,
  DOES> 2@  ;

VARIABLE ACTION
: ALTER ( addr size xt-- ) \ changes DATA set itself
  ACTION !  BOUNDS DO  I ( addr) ACTION PERFORM  2 +LOOP ;

: FOREACH ( addr size xt-- )
  ACTION !  BOUNDS DO  I @ ( data) ACTION PERFORM  2 +LOOP ;

: MAP ( <word> ) \ state smart so it can be used in definitions
   '           ( look up the word )
   STATE @ IF  ( compiling action)
     POSTPONE LITERAL
     POSTPONE FOREACH
     EXIT
   THEN ( interpreting action )
   FOREACH ; IMMEDIATE

\ literal is state smart so these can be used in definitions
: SIZEOF ( -- n)  '  >BODY  @      POSTPONE LITERAL ; IMMEDIATE
: #ITEMS ( -- N)  '  >BODY  @  2/  POSTPONE LITERAL ; IMMEDIATE
HERE SWAP - DECIMAL .

+TheBF · September 28, 2022

This is pretty fun.

I added a dataset ready MOTION word, and I copied the LOGO command FREEZE.

: MOTION ( dx dy -- ) [2] MOTION  ;

: FREEZE    0 0 :ALL MAP MOTION 2DROP ;

+TheBF · October 3, 2022

Sound Markup Language

I have been out of the shop for the last 5 days, but I been noodling on finishing something that I have wanted to get done.

The project was a way to tame the creation of sound lists by making a lexicon of Forth words.

I had most of the bits and pieces but never settled on something that I liked. and I think I have something now.

Here is an example of a sound list using the markup language. The curly brackets demarcate a list of sound-bytes as a counted string.

the <xxxx> words are commands in the markup language. It is Forth so parameters come before the command if there are any.

DECIMAL
SOUND: KABOOM
      { 4 NOISE, 0 DB, }  6 <FRAMES>
      <MUTE>  3 <FRAMES>
      { 6 NOISE, 0 DB, } 50 <FRAMES>
      9 1 15 <FADE>
      <MUTE>
;SOUND

Parameters for fade are: ( fade_speed, 1st_volume, last_volume)

Here is the data that KABOOM compiles to VDP RAM

1000: 02 E4 F0 06 01 FF 03 02 ........
1008: E6 F0 32 01 F1 09 01 F2 ..2.....
1010: 09 01 F3 09 01 F4 09 01 ........
1018: F5 09 01 F6 09 01 F7 09 ........
1020: 01 F8 09 01 F9 09 01 FA ........
1028: 09 01 FB 09 01 FC 09 01 ........
1030: FD 09 01 FE 09 01 FF 09 ........
1038: 01 FF 00 00 00 00 00 00 ........

To do this I used my standard sound library (DSK1.SOUND) and a small VDP memory manager (DSK1.VPDMEM).

SOUND gave me the primitives to convert Hz to chip sound code and words to set and manage the active sound generators and VDPMEM turns VDP memory into a Forth-like memory area with V, VC, so you can compile data into VDP RAM easily.

There are commands to control envelope called <FADE>, <SWELL>, <FADEALL>, <SWELLALL> as well as <MUTE> (the last used voice> and <MUTEALL>

The SOUND: word creates the VDP data structure at compile time but when you invoke the name of the "SOUND:" it fetches the address and runs the ISR sound list player called VDP-PLAY.

SOUND: uses the CREATE/DOES> structure to do that.

The rest of the detail is in the code for the curious. The video has some examples executed from the console.

Library files for reference:

Spoiler

\ TMS9919 SOUND CHIP DRIVER and CONTROL LEXICON     Jan 2017 BJF
\ TMS9919 is a memory mapped device on the TI-99 @ >8400
\ SND! is in the CAMEL99 Kernel as  : SND!    PAUSE 8400 C! ;
HERE
\ frequency code must be ORed with these numbers to create a sound
HEX
  8000 CONSTANT OSC1      A000 CONSTANT OSC2   ( oscillators take 2 nibbles)
  C000 CONSTANT OSC3        E0 CONSTANT OSC4   ( noise takes 1 nibble)

\ Attenuation values are ORed with these values to change volume
( 0= max, 15 = off)
    90 CONSTANT ATT1         B0 CONSTANT ATT2
    D0 CONSTANT ATT3         F0 CONSTANT ATT4  ( OSC4 volume adjust)

DECIMAL
\ f(clk) for sound chip is 111,860.8 Hz. Round it up to 111,861 works ok.
\ create a 32bit LITERAL from primitives
: f(clk) ( -- d)  [ 0 0  S" 111861" >NUMBER 2DROP SWAP ] LITERAL LITERAL ;

\ >FCODE re-arranges freq. value nibbles (4bits) for the TMS9919
HEX
 CODE >FCODE ( 0abc -- 0cab) \ version by Farmer Potato Atariage
             0B44 , \ TOS 4 SRC,    \ C0AB
             C204 , \ TOS W MOV,    \ DUP
             0948 , \  W 4 SRL,     \ 0C0A
             D108 , \  W TOS MOVB,  \ 0CAB
            NEXT,    \  28 uS
            ENDCODE

\ we set the "ACTIVE CHANNEL" with these variables
 VARIABLE OSC               \ holds the active OSC value
 VARIABLE ATT               \ holds the active ATTENUATOR value

\ convert freq. to 9919 chip code
DECIMAL
: HZ>CODE  ( freq -- fcode ) f(clk) ROT UM/MOD NIP >FCODE ;

HEX
\ **for testing**  print sound data to screen AND make sound
\ : SND!  ( c -- )  ." >"  BASE @ >R  HEX DUP U. 8400 C! R> BASE ! ;

\ Set the sound "GENerator that is active.
: GEN! ( osc att -- )  ATT !  OSC ! ;

\ ================================================================
\ S C I E N T I F I C   S O U N D   C O N T R O L   L E X I C O N
\ sound generator selectors
: GEN1    ( -- )  OSC1  ATT1  GEN! ;
: GEN2    ( -- )  OSC2  ATT2  GEN! ;
: GEN3    ( -- )  OSC3  ATT3  GEN! ;
: GEN4    ( -- )  OSC4  ATT4  GEN! ;

: (NOISE)   ( n -- n) 0F AND  GEN4  OSC @ OR  ;

: (HZ)    ( f -- n)   HZ>CODE  OSC @ OR  ;          \ convert freq. add OSC
: (DB)    ( level -- c)  ABS 2/  0F MIN  ATT @ OR ; \ DB to attenuation

: HZ      ( f -- ) (HZ) SPLIT SND!  SND! ;
: DB      ( level -- ) (DB)  SND! ; \ Usage: -6 DB
: NOISE   ( n --) (NOISE) SND! ;
: MUTE    ( -- )  -30 DB ;
: SILENT  ( --)  9F SND!  BF SND!  DF SND!  FF SND! ;

GEN1
HERE SWAP - DECIMAL . .( bytes)

Spoiler

\ vdp memory manager lexicon    BJF     Jan 29 2021

\ VDP Memory Usage in Camel99 Forth when this file is loaded
\ |  VDP screen   |  VDP >0000
\ + --------------|
\ |   RESERVED    |    sprites, patterns color tables
\ |---------------|
\ |  >460..7FF    |  *FREE 928 bytes in TEXT mode only*
\ |---------------|
\ |  >800..       |  *Pattern descriptor table*
\ +---------------+  HEX 1000, VDP HEAP start
\ |    VHERE      |  VDP heap moves upwards
\ |      .        |
\ |      .        |
\ |      .        |
\ |      .        |
\ |               |
\ |               |
\ |               |        ^^^^^^^
\ |   ^^^^^^^     |  move downwards
\ |  PAB stack    |  PABs start here
\ +---------------+ <-- VDPTOP returns this address
\ | 99 O/S space  |
\ |---------------| VDP >3FFF

\ INCLUDE DSK1.TOOLS  \ debugging only

\ VARIABLE VP    ( moved to kernel for V2.55 )

HEX 1000 VP !   \ "VDP pointer" start of free VDP RAM
: VHERE   ( -- addr) VP @ ;   \ FETCH the value in VDP pointer
: VALLOT  ( n -- )   VP +! ;  \ add n to the value in VDP pointer
: VC,     ( n -- )   VHERE VC!  1 VALLOT ;
: V,      ( n -- )   VHERE V!   2 VALLOT ;
: VCOUNT  ( vdp$adr -- vdpadr len ) DUP 1+ SWAP VC@ ;
: VCREATE ( <text> -- ) VHERE CONSTANT  ; \ address when <text> invoked
\ : VPLACE   ( $addr len Vaddr -- )  \ like PLACE for VDP RAM. In KERNEL 2.6
\           2DUP VC! 1+ SWAP VWRITE ;

The sound compiler with demo sound lists.

Spoiler

\ TI sound list assembler                            Aug 22 2022 Brian Fox
\ Assembles TI sound lists in VDP RAM

NEEDS .S      FROM DSK1.TOOLS
NEEDS HZ      FROM DSK1.SOUND
NEEDS VHERE   FROM DSK1.VDPMEM

HEX
: NEWVDP ( addr len -- ) OVER VP !   0 VFILL ;

 83C2 CONSTANT AMSQ      \ interrupt DISABLE bits

CODE 0LIMI ( -- )  0300 , 0000 , NEXT, ENDCODE
CODE 2LIMI ( -- )  0300 , 0002 , NEXT, ENDCODE

\  ISR Sound List Player in Forth
HEX
: VDP-PLAY ( Vaddr -- )
             0LIMI
             83CC !                  \ Vaddr -> sound table
             5 AMSQ C@ AND  AMSQ C!  \ enable sound interrupts
             1 83FD C@ OR   83FD C!  \ set VDP as sound source
             1 83CE C!               \ trigger sound processing
             2LIMI ;

\ Compile time parameter testers
DECIMAL
: ?FREQ  ( n -- n)  DUP 110  50000 WITHIN 0= ABORT" Bad frequency" ;
: ?LEVEL ( n -- n)  DUP   0     17 WITHIN 0= ABORT" Bad level" ;
: ?DUR   ( n -- n)  DUP   1    256 WITHIN 0= ABORT" Bad duration" ;

\ sound byte "assembler" commands compile values for the last sound generator used.
\ Select ACTIVE sound generator with: GEN1 GEN2 GEN3
: HZ,     ( f -- ) ?FREQ (HZ) SPLIT VC, VC,  ;    \ compiles 2 bytes
: DB,     ( level -- ) ?LEVEL  ATT @ OR VC, ;

\ noise channel selects generator 4 by default
: NOISE,  ( n -- ) GEN4 (NOISE) VC,  ;

\ Start a counted string of bytes in VDP RAM
: {    ( -- vaddr1)   VHERE  0 VC, ;

\ back-fill string length in the list of bytes
: }   ( vaddr1 vaddr2 -- )  VHERE OVER -  1-  SWAP VC! ;

\ =====================================================================
\ sound creator. Plays when executed
DECIMAL
: SOUND: ( <text> -- )
        CREATE               \ create name in dictionary
        VHERE ,              \ remember the VDP address
        !CSP                 \ record stack position
        DOES> @ VDP-PLAY  ;  \ feed address to player

\ mark end of sound list, check for clean DATA stack
: ;SOUND ( Vaddr -- ) 0 VC,  ?CSP ;

HEX
: <MUTE>    ( -- )  01 VC,  0F DB,  ;           \ mutes the ACTIVE generator
: <MUTEALL> ( -- ) { 9F VC,  BF VC,  DF VC,  FF VC, } ;
: <FRAMES>  ( n -- ) ?DUR VC, ;                 \ duration in video Frames
: <MS>      ( mS -- frames) 4 RSHIFT <FRAMES> ; \ mS/16 = FRAMES

HEX \ wait until sound list is completed
: <WAIT>  ( -- ) BEGIN  83CE C@ WHILE PAUSE REPEAT  ;

DECIMAL
: <FADE> ( duration start end  -- )
  1+ SWAP DO   { I  DB, } DUP <FRAMES>   LOOP  DROP  ;

: <FADEALL> ( duration start end  -- )
  1+ SWAP
  DO
       { GEN1 I DB, GEN2 I DB,  GEN3 I DB,  GEN4 I DB, }  DUP <FRAMES>
  LOOP
  DROP ;

: <SWELL> ( duaration start end -- )
  SWAP  DO   { I DB, } DUP <FRAMES>  -1 +LOOP DROP ;

: <SWELLALL> ( duaration start end -- )
  SWAP
  DO
     { GEN1 I DB, GEN2 I DB,  GEN3 I DB,  GEN4 I DB, }  DUP <FRAMES>
  -1 +LOOP
  DROP ;


HEX 1000 2000 NEWVDP \ reset 8K of VDP memory @>1000

DECIMAL
SOUND: WEIRD
     { GEN1 120 HZ, 15 DB,
       GEN2 121 HZ, 15 DB,
       GEN3 122 HZ, 15 DB,
       GEN4 6 NOISE 15 DB, } 1 <FRAMES>
       5 15 0 <SWELLALL>
       5  0 15 <FADEALL>
     <MUTEALL>
;SOUND
\ HEX ' WEIRD >BODY @ B0 VDUMP

DECIMAL
SOUND: A440
       { GEN1 440 HZ, 0 DB, } 1000 <MS>
       <MUTE>
;SOUND
\ HEX ' A440 >BODY @ 30 VDUMP

SOUND: SONAR
      { GEN1 995 HZ, 0 DB, } 150 <MS>
      7 3 15 <FADE>
      <MUTE>
;SOUND

DECIMAL
SOUND: SHOOP
      { 4 NOISE, 15 DB, }  1 <FRAMES>
       9 15 0 <SWELL>  <MUTE>
;SOUND
\ HEX ' SHOOP >BODY @  70 VDUMP

DECIMAL
SOUND: KABOOM
      { 4 NOISE, 0 DB, }  6 <FRAMES>
      <MUTE>  3 <FRAMES>
      { 6 NOISE, 0 DB, } 50 <FRAMES>
      9 1 15 <FADE>
      <MUTE>
;SOUND


\ HEX ' CHABOOM >BODY @  70 VDUMP

GDMike · October 3, 2022

Quote

Sounds...

The SID99 can be programmed in Forth for sound. It has, like 8 I think registers. I was just reading the manual yesterday and I've already forgotten how many, but that's because there's a bit more to it than just setting those up.

But a question came to mind, could both the SID99 AND the TI's internal sound chip be used together and at the same time? Or is it redundant?

Maybe @Ksarul would know that.

Edited October 3, 2022 by GDMike

Willsy · October 4, 2022

Yes. They can be both be used together.

TurboForth has as library (on block 5 of the companion disk) for SID support. I actually have a SID card so I wrote it in conjunction with Marc Hull back in the day. The code say's it's untested code. I can't remember if I tested it or not, but this would be be a good starting place for SID support for other Forth's too.

 
--BLOCK-00005---------
\ SID chip support code. M.Wills, May 16th, 2011
$5800 CONSTANT SID
: DUMMY ( -- ) [ SID $32 + ] LITERAL 0 C! ;
: W>SID ( addr word --) DUP 2+ 2 PICK >< SWAP C! C! DUMMY ;
: B>SID ( addr byte --) SWAP C! ;
: SIDF ( freq  ch# --) 14 * [ SID ]      LITERAL + W>SID ;
: SIDP ( pulse ch# --) 14 * [ SID 4 +  ] LITERAL + W>SID ;
: SIDW ( wform ch# --) 14 * [ SID 8 +  ] LITERAL + B>SID ;
: SIDA ( atdec ch# --) 14 * [ SID 10 + ] LITERAL + B>SID ;
: SIDS ( susrl ch# --) 14 * [ SID 12 + ] LITERAL + B>SID ;
: SFIL ( value --) [ SID $2A + ] LITERAL W>SID ;
: SRES ( reson --) [ SID $2E + ] LITERAL B>SID ;
: SVOL ( vol   --) [ SID $30 + ] LITERAL B>SID ;
CR
.( SID support loaded.)
.( Note: This is un-tested code)

+TheBF · October 4, 2022

Very nice. I didn't know about the chip. Had to do some reading. It's quite a step up from what we have in the 99.

Here is your code with a little trick word that I first saw in gForth.

--BLOCK-00005---------
\ SID chip support code. M.Wills, May 16th, 2011
: ]L    ]  [COMPILE] LITERAL ;

$5800 CONSTANT SID
: DUMMY ( -- ) [ SID $32 + ]L 0 C! ;
: W>SID ( addr word --) DUP 2+ 2 PICK >< SWAP C! C! DUMMY ;
: B>SID ( addr byte --) SWAP C! ;
: SIDF ( freq  ch# --) 14 * [ SID ]L + W>SID ;
: SIDP ( pulse ch# --) 14 * [ SID 4 +  ]L + W>SID ;
: SIDW ( wform ch# --) 14 * [ SID 8 +  ]L + B>SID ;
: SIDA ( atdec ch# --) 14 * [ SID 10 + ]L + B>SID ;
: SIDS ( susrl ch# --) 14 * [ SID 12 + ]L + B>SID ;
: SFIL ( value --) [ SID $2A + ]L W>SID ;
: SRES ( reson --) [ SID $2E + ]L B>SID ;
: SVOL ( vol   --) [ SID $30 + ]L B>SID ;
CR
.( SID support loaded.)
.( Note: This is un-tested code)

Unfortunately, it adds 14 bytes to the code, but if ]L was in the system it would be the same size.

GDMike · October 4, 2022

Sweet surprise. But can't be tested using classic99 obviously, but I can move my code back and forth to the real machine through TIPI, so not so bad. I'm glad you incorporated that into forth, and we get a breakdown of that>5xxx address range use. Now maybe I can make more sense of the manual..thx

GDMike · October 5, 2022

Oh . this is the same code I already use for my sound utility on my TI-99.. and yes, it does work.. I've been using it for years. But now it looks like I've got to put together another output wire for my monitor from my TI. I don't know what happened to my original wire but it's missing... until that happens I have no sound....duh...but, yes this works for my TI but i haven't plugged in the SID99 yet to test with , and now gotta make a wire ..

Edited October 5, 2022 by GDMike

+TheBF · October 5, 2022

Forth Nerd Code of Interest

While searching the inter-web for things Forth I found this code by Sam Falvo regarding a bubble sort challenge in a wiki.

I think sometimes I have got the hang of Forth style programming but when I see this, I am not so sure.

The unique idea here is that by composing the strings as Forth words and compiling the array as a list of their "execution tokens",

you get a smart array that gives you the contents by "executing" ~~the code in the Forth word.~~ the contents of the array.

I had heard about this kind of thing in Forth circles but never had example code.

\ bubble sort challenge by Sam Falvo  Circa 2008
\ https://wiki.c2.com/?BubbleSortChallenge

( source code case changed for Camel99 Forth )

INCLUDE DSK1.COMPARE

 : Perl          S" Perl" ;
 : Python        S" Python" ;
 : Ruby          S" Ruby" ;
 : JavaScript    S" JavaScript" ;
 : Java          S" Java" ;
 : Fortran       S" Fortran" ;
 : C             S" C" ;
 : C++           S" C++" ;
 : Basic         S" Basic" ;
 : Pascal        S" Pascal" ;
 : Lisp          S" Lisp" ;

 CREATE POINTERS
   ' Perl , ' Python , ' Ruby , ' JavaScript , ' Java ,
   ' Fortran , ' C , ' C++ , ' Basic ,
     HERE ' Pascal , ' Lisp ,

 ( -- here ) CONSTANT PENULTIMATE

 : NAME      @ EXECUTE ;  \ resolve a table entry to a name string

 \ swap adjacent table entries
 : SWP       >R R@ @ R@ CELL+ @ SWAP R@ CELL+ ! R> ! ;

 : PAIR      DUP NAME ROT CELL+ NAME ;    \ two adjacent names

 : ARRANGE   DUP PAIR COMPARE 0> IF SWP EXIT THEN DROP ;

 \ bubbles from end of list towards the beginning.
 : BUBBLE    PENULTIMATE BEGIN 2DUP U> IF 2DROP EXIT THEN
             DUP ARRANGE [ 1 CELLS ] LITERAL - AGAIN ;

 : SORT      POINTERS BEGIN DUP PENULTIMATE U> IF DROP EXIT
             THEN DUP BUBBLE CELL+ AGAIN ;

 : E         DUP NAME TYPE SPACE CELL+ ;

 \ display current table state
 : SHOW      POINTERS E E E E E E E E E E E DROP CR ;
 : DEMO      SHOW SORT SHOW ;
 DEMO

Edited October 5, 2022 by TheBF
Clarification

GDMike · October 5, 2022

Oh, wow. Well that's snazzy.

+Lee Stewart · October 6, 2022

10 hours ago, TheBF said:

Forth Nerd Code of Interest

While searching the inter-web for things Forth I found this code by Sam Falvo regarding a bubble sort challenge in a wiki.

I think sometimes I have got the hang of Forth style programming but when I see this, I am not so sure.

The unique idea here is that by composing the strings as Forth words and compiling the array as a list of their "execution tokens",

you get a smart array that gives you the contents by "executing" ~~the code in the Forth word.~~ the contents of the array.

I had heard about this kind of thing in Forth circles but never had example code.

As usual, you have inspired me to port this to fbForth. Here it is after adding some words missing from fbForth and accounting for the facts that ' returns the pfa instead of Camel99 Forth’s cfa, and that S" returns only the address of the count byte of a counted string instead of Camel99 Forth’s address of the first character and the character count:

Spoiler

\ bubble sort challenge by Sam Falvo  Circa 2008
\ https://wiki.c2.com/?BubbleSortChallenge

( source code case changed for Camel99 Forth )
( ---ported to fbForth )

: Perl          S" Perl" ;
: Python        S" Python" ;
: Ruby          S" Ruby" ;
: JavaScript    S" JavaScript" ;
: Java          S" Java" ;
: Fortran       S" Fortran" ;
: C             S" C" ;
: C++           S" C++" ;
: Basic         S" Basic" ;
: Pascal        S" Pascal" ;
: Lisp          S" Lisp" ;

: 2DUP OVER OVER ;
: 2DROP DROP DROP ;

\ ASM: U>
\    *SP+ *SP C,
\    *SP CLR,
\    L IF,
\       *SP INC,
\    THEN,
\    ;ASM
HEX
CODE: U>                                                        
   8679 04D9 1401 0599
   ;CODE                                       
DECIMAL

\ compare 2 counted strings
: COMPARE   ( adr1 adr2 -- -1|0|+1 )
   OVER C@ OVER C@         \ get char counts
   2DUP - SGN >R           \ get sign of diff to return stack
   MIN 1+ 0 SWAP           \ calc loop limit; 0 to stack
   1 DO                    \ loop by the smaller count
      DROP                 \ drop last sign
      OVER I + C@          \ next char of 1st string
      OVER I + C@          \ next char of 2nd string 
      - SGN                \ sign of diff
      DUP IF LEAVE THEN    \ leave loop if not 0
   LOOP
   R>                      \ get char count diff from return stack
   OVER 0= IF              \ compared chars =?
      OR                   \ yes..leave sign of char-count diff
   ELSE
      DROP                 \ no..leave only last char diff
   THEN
   >R 2DROP R>             \ clean up
   ;

: 'CFA [COMPILE] ' CFA ;   \ get CFA from instream token

0 VARIABLE POINTERS -2 ALLOT
  'CFA Perl , 'CFA Python , 'CFA Ruby , 'CFA JavaScript ,
  'CFA Java , 'CFA Fortran , 'CFA C , 'CFA C++ , 'CFA Basic ,
   HERE 'CFA Pascal , 'CFA Lisp ,

( -- here ) CONSTANT PENULTIMATE

: NAME      @ EXECUTE ;  \ resolve a table entry to a name string

\ swap adjacent table entries
: SWP       >R R @ R 2+ @ SWAP R 2+ ! R> ! ;

: PAIR      DUP NAME ROT 2+ NAME ;    \ two adjacent names

: ARRANGE   DUP PAIR COMPARE 0> IF SWP ;S THEN DROP ;

\ bubbles from end of list towards the beginning.
: BUBBLE    PENULTIMATE BEGIN 2DUP U> IF 2DROP ;S THEN
            DUP ARRANGE [ 2 ] LITERAL - AGAIN ;

: SORT      POINTERS BEGIN DUP PENULTIMATE U> IF DROP ;S
            THEN DUP BUBBLE 2+ AGAIN ;

: E         DUP NAME COUNT TYPE SPACE 2+ ;

\ display current table state
: SHOW      POINTERS E E E E E E E E E E E DROP CR ;
: DEMO      SHOW SORT SHOW ;

DEMO

...lee

+TheBF · October 6, 2022

Nicely done.

You have the brains to write your own COMPARE.

I found that challenging.

For a Forth version, I used one by Neil Baud. I think I posted this before and you commented on the "non-union" use of COUNT.

I think it would be workable with FbForth with a preface like:

: $EXPAND ( $addr $addr -- addr len addr len)   SWAP COUNT ROT COUNT ;

\ Neil Baud's compare in Forth
: COMPARE ( a1 n1 a2 n2 -- -1|0|1 )
    ROT  2DUP - >R            ( a1 a2 n2 n1)( R: n2-n1)
    MIN                       ( a1 a2 n3)
    BOUNDS ?DO                ( a1)
        COUNT  I C@  -        ( a1 diff)
        DUP
        IF
            NIP  0< 1 OR      ( -1|1)
            UNLOOP
            R> DROP
            EXIT              ( a1 diff)
         THEN  DROP           ( a1)
    LOOP 
    DROP                      ( )
    R>  DUP IF  0> 1 OR  THEN  \  2's complement arith.
 ;

(Just tried it and it seems to work with byte-counted strings)

I have a dim memory of somebody doing this technique (embedded code in data structure) with a binary tree.

Might have been the late Jeff Fox who worked with Chuck Moore. (no relation)

It was running on one of Chuck's CPUs and so the "Forth" code was actually machine instructions embedded in the binary tree.

Additions and deletions to the tree were reported to be crazy fast.

We might be able to that with some carefully chosen ALC words.

+Lee Stewart · October 6, 2022

8 hours ago, TheBF said:

Nicely done.

You have the brains to write your own COMPARE.

I found that challenging.

For a Forth version, I used one by Neil Baud. I think I posted this before and you commented on the "non-union" use of COUNT.

It seems I wrote that ~6 years ago—and...it took a while to get it right as I recall.

Re Neil Baud’s COMPARE , I will definitely incorporate features of that into my COMPARE . I must be very careful with true-value usage because fbForth returns 1 (FIG-Forth) for a true result. I believe -1 was first used in Forth-83. It seems some of Neil’s code depends on the -1 result.

...lee

+TheBF · October 7, 2022

18 hours ago, Lee Stewart said:

It seems I wrote that ~6 years ago—and...it took a while to get it right as I recall.

Re Neil Baud’s COMPARE , I will definitely incorporate features of that into my COMPARE . I must be very careful with true-value usage because fbForth returns 1 (FIG-Forth) for a true result. I believe -1 was first used in Forth-83. It seems some of Neil’s code depends on the -1 result.

...lee

6 years! OMG.

Yes, as I recall he was a big proponent of Forth 94 ANS version and wrote a ton of text processing stuff for work that he was doing with large documents.

So TRUE was definitely -1 and if it was handy he used it.

The use of COUNT to index through the bytes of a string is really very sensible after you think about. I think the name gets in the way of thinking about it in a different way.

I used it to re-write my TYPE primitive after I saw this compare.

: (TYPE) ( addr cnt -- addr')  0 ?DO   COUNT CPUT IF CR THEN   LOOP ;

: TYPE ( addr cnt --) PAUSE (TYPE) DROP ;

Edited October 7, 2022 by TheBF
Wrong comment in code

+Lee Stewart · October 8, 2022

OK—I updated my COMPARE with elements of Baud’s COMPARE . I purposely did not use 2DUP , 2DROP , NIP , UNLOOP because I must use it in un-embellished fbForth. Oh, and MINUS is your NEGATE . I used it to reverse c2-c1 to c1-c2:

Spoiler

\ compare 2 counted strings
: COMPARE   ( $adr1 $adr2 -- -1|0|+1 )
   SWAP COUNT ROT COUNT    \ S:a1' c1 a2' c2
   ROT OVER OVER -         \ S:a1' a2' c2 c1 c2-c1
   SGN                     \ S:a1' a2' c2 c1 -1|0|1
   MINUS >R                \ S:a1' a2' c2 c1       R:1|0|-1
   MIN                     \ S:a1' a2' c3          R:1|0|-1
   \ loop limit and index
   OVER + SWAP             \ S:a1' c3+a2' a2'      R:1|0|-1
   DO                      \ S:a1'                 R:lim idx 1|0|-1
      COUNT I C@ -         \ S:a1" c1'-c2'         R:lim idx 1|0|-1
      SGN                  \ S:a1" -1|0|1          R:lim idx 1|0|-1
      DUP                  \ S:a1" -1|0|1 -1|0|1   R:lim idx 1|0|-1
      IF                   \ S:a1" -1|0|1          R:lim idx 1|0|-1
         SWAP DROP         \ S:-1|1                R:lim idx 1|0|-1
         \ UNLOOP..drop loop index and limit before exit
         R> DROP R> DROP   \ S:-1|1                R:1|0|-1
         R> DROP           \ S:-1|1   ..don't need count diff
         \ exit COMPARE with result on stack
         ;S                \ S:-1|1
      THEN  
      DROP                 \ S:a1"                 R:lim idx 1|0|-1
   LOOP
   \ if we get this far, all checked chars matched,
   \ so return stack has the answer
   DROP R>                 \ S:1|0|-1   
   ;

...lee

GDMike · October 8, 2022

This is a powerful word now. Nice

+TheBF · October 8, 2022

10 hours ago, Lee Stewart said:

OK—I updated my COMPARE with elements of Baud’s COMPARE . I purposely did not use 2DUP , 2DROP , NIP , UNLOOP because I must use it in un-embellished fbForth. Oh, and MINUS is your NEGATE . I used it to reverse c2-c1 to c1-c2:

Hide contents

\ compare 2 counted strings
: COMPARE   ( $adr1 $adr2 -- -1|0|+1 )
   SWAP COUNT ROT COUNT    \ S:a1' c1 a2' c2
   ROT OVER OVER -         \ S:a1' a2' c2 c1 c2-c1
   SGN                     \ S:a1' a2' c2 c1 -1|0|1
   MINUS >R                \ S:a1' a2' c2 c1       R:1|0|-1
   MIN                     \ S:a1' a2' c3          R:1|0|-1
   \ loop limit and index
   OVER + SWAP             \ S:a1' c3+a2' a2'      R:1|0|-1
   DO                      \ S:a1'                 R:lim idx 1|0|-1
      COUNT I C@ -         \ S:a1" c1'-c2'         R:lim idx 1|0|-1
      SGN                  \ S:a1" -1|0|1          R:lim idx 1|0|-1
      DUP                  \ S:a1" -1|0|1 -1|0|1   R:lim idx 1|0|-1
      IF                   \ S:a1" -1|0|1          R:lim idx 1|0|-1
         SWAP DROP         \ S:-1|1                R:lim idx 1|0|-1
         \ UNLOOP..drop loop index and limit before exit
         R> DROP R> DROP   \ S:-1|1                R:1|0|-1
         R> DROP           \ S:-1|1   ..don't need count diff
         \ exit COMPARE with result on stack
         ;S                \ S:-1|1
      THEN  
      DROP                 \ S:a1"                 R:lim idx 1|0|-1
   LOOP
   \ if we get this far, all checked chars matched,
   \ so return stack has the answer
   DROP R>                 \ S:1|0|-1   
   ;

...lee

Very nice. I have to take off today but I will get back to this.

Do you see any performance improvement?

One little machine code word ( RDROP) might make it a bit faster and even smaller maybe.

GDMike · October 8, 2022

I'll see if TF can run this tonight, it should as is. I'm pretty sure TF already has a string search, but maybe not like this...I don't know the definition of mark's existing word.. but I'll try this.

Edited October 8, 2022 by GDMike

+TheBF · October 8, 2022

1 hour ago, GDMike said:

I'll see if TF can run this tonight, it should as is. I'm pretty sure TF already has a string search, but maybe not like this...I don't know the definition of mark's existing word.. but I'll try this.

It's not compatible with TF which is Forth 83 standard.

FbForth is the slightly older Forth Interest Group (FIG) standard.

And it is not actually a search just the comparison. It's more like:

A$="THIS STRING"

TF has it's own details when getting out of a DO LOOP.

You can also load the string library blocks but that's pretty big if you don't need all of it.

Or take a look in the string blocks and see how Willsy did a string comparison.

I will see if I can get COMPARE to work under TF.

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