Camel99 Forth Information goes here

+Lee Stewart · September 6, 2022

11 hours ago, TheBF said:
The stuff people do with Forth still amazes me.

Over on Reddit an OP put up an alternative way to make CONSTANT and VARIABLE.
: CONSTANT ( x "name" -- ) >R : R> POSTPONE LITERAL POSTPONE ; ;

: VARIABLE ( "name" -- ) ALIGN HERE 0 , CONSTANT ;
It needs a few mods for FIG-Forth but I think it would work with POSTPONE -> [COMPILE] and ALIGN -> EVEN

For fbForth, these would be

\ : is an immediate definition (not sure why, but inherited from TI Forth)
\ "IS:" is "Input Stream:"
: CONSTANT ( x -- ) ( IS:"name" )  >R [COMPILE] : R> [COMPILE] LITERAL [COMPILE] ;  ;

: VARIABLE  ( IS:"name" )  ALIGN HERE 0 , CONSTANT  ;  \ <---no change

These work*, but I will have to pore over these definitions to have a clue why!

______________

* Though this certainly works in fbForth, it is inconsistent with fbForth’s pre-Forth83 definition of VARIABLE , which requires the initial value on the stack, rather than the implicit initializing of the variable represented above.

...lee

Edited September 7, 2022 by Lee Stewart
CLARIFICATION

+TheBF · September 7, 2022

The CONSTANT definition is literally making a colon definition like:

99 CONSTANT X

compiles to:

: X   99 ;

And VARIABLE takes the address of HERE, fills it with a zero and records the address as a CONSTANT.

Never in a million years would I think of these.

+Lee Stewart · September 7, 2022

1 hour ago, TheBF said:
The CONSTANT definition is literally making a colon definition like:
99 CONSTANT X 
compiles to:
: X   99 ; 
And VARIABLE takes the address of HERE, fills it with a zero and records the address as a CONSTANT.

Never in a million years would I think of these.

Though quite clever, to be sure, they wreak havoc with the traditional manipulation of both. This is especially perverse for VARIABLE because you cannot index an array in the traditional way with this definition:

VARIABLE XARRAY 18 ALLOT

would normally create a 20 byte array, but the definition under discussion would have the header and cfa of XARRAY between the first two bytes and the remaining 18 bytes of the array. :-o

...lee

+TheBF · September 7, 2022

Absolutely right. They are more mental exercises that anything.

I should have put a "Do not try this at home" warning on them.

+TheBF · September 9, 2022

After trying the DOLLAR benchmark program by @smp it made me wonder what would happen if we used VALUE instead of variable.

My new library for VALUEs is a re-write after I wondered why TurboForth was screaming faster on some numeric benchmarks.

I originally wrote TO so it compiled a LITERAL address and then it compiled !. Nothing special.

@Willsy was clever and made a special CODE primitive that put LITERAL and ! together. After I added that code primitive (TO) and (+TO) as well,

CF was the same as TF on that particular benchmark.

So what happened with DOLLAR?

With VARIABLEs the time was ~43 seconds

With VALUEs the time was 39.3, a 9% improvement.

\ Try it with values
INCLUDE DSK1.VALUES

 0 VALUE P
 0 VALUE N
 0 VALUE D
 0 VALUE Q
 0 VALUE C

DECIMAL
: DOLLAR2  \ 38.8 seconds
 CR
 0 TO C
 101 0 DO
     I TO P
     21 0 DO
        I TO N
        11 0 DO
           I TO D
           5 0 DO
              I TO Q
              P  N 5 *  D 10 *  Q 25 * + + + 100 =
              IF
                ." P=" P . ." N=" N . ." D=" D . ." Q=" Q . CR
                1 +TO C
              THEN
          LOOP
        LOOP
     LOOP
 5 +LOOP
CR . ." WAYS TO MAKE $1.00"
CR ;

+TheBF · September 10, 2022

@smp Mentioned making a program to say a number as text.

I have never done that. I was surprised by all the corner cases.

I think this one works.

I made cheaky use of EXIT in the word IGNORE to skip 0 values in the printing words.

Spoiler

\ number to dollars Camel99 Forth     Sept 2022 Brian Fox
INCLUDE DSK1.TOOLS
INCLUDE DSK1.FASTCASE

DECIMAL
\ unsigned slash mod
: U/MOD  ( n n -- r q) >R 0 R> UM/MOD ;

VARIABLE #DIGITS
\ variable stack output with # digits on top
: PARSE# ( n --  1 [10 100 1000 10000]  n )
  !CSP
  BEGIN  DUP WHILE  10 U/MOD  REPEAT DROP
  CSP @ SP@ - 2/ ;

: COMMA   ." , " ;
: HYPHEN  ." -"  ;

\ compile n vectors into memory
: VECTORS ( a...z  n -- ) 0 ?DO  COMPILE,  LOOP ;

\ create vectors on data stack
:NONAME ." nineteen" ;  :NONAME ." eighteen" ;  :NONAME ." seventeen" ;
:NONAME ." sixteen" ;   :NONAME ." fifteen" ;   :NONAME ." fourteen" ;
:NONAME ." thirteen" ;  :NONAME ." twelve" ;    :NONAME ." eleven" ;
:NONAME ." ten" ;       :NONAME ." nine" ;      :NONAME ." eight" ;
:NONAME ." seven" ;     :NONAME ." six" ;       :NONAME ." five" ;
:NONAME ." four" ;      :NONAME ." three" ;     :NONAME ." two" ;
:NONAME ." one" ;       :NONAME ." zero" ;
CASE: DIGIT ( 0..19 --) 20 VECTORS  ;CASE  \ compile into vector table

: BAD#  TRUE ABORT" Bad tens #" ;

:NONAME  ." ninety" ;   :NONAME  ." eighty" ;
:NONAME  ." seventy" ;  :NONAME  ." sixty" ;
:NONAME  ." fifty" ;    :NONAME  ." forty" ;
:NONAME  ." thirty" ;   :NONAME  ." twenty" ;
CASE: TENS  | BAD# | BAD#  8 VECTORS  ;CASE

\ jumps out of a running word
: IGNORE ( n ? -- n)  S" IF  DROP EXIT  THEN " EVALUATE ; IMMEDIATE


: .2DIGITS ( ones tens   --)
  DUP 0= IGNORE
  DUP 1 >
  IF   TENS DUP 0 >
       IF HYPHEN DIGIT THEN
  ELSE 10 * +  DIGIT
  THEN ;

: .HUNDREDS  ( n -- )
   DUP 0= IGNORE  DIGIT ."  hundred"  ;

: THOUSANDS
  DUP 0= IGNORE
  DUP 19 >
  IF   10 /
  ELSE DIGIT
  THEN  ;

: .THOUSANDS ( n -- )
    #DIGITS @ 5 =
    IF    .2DIGITS SPACE
    ELSE  THOUSANDS
    THEN ."  thousand"  ;

: .AND ( n n ) 2DUP + 0= IGNORE  ." and " ;

: SAY#
  CR
  PARSE# #DIGITS !
  #DIGITS @ 1 = IF  DIGIT                                   EXIT  THEN
  #DIGITS @ 2 = IF .2DIGITS                                 EXIT  THEN
  #DIGITS @ 3 = IF .HUNDREDS SPACE .AND .2DIGITS            EXIT  THEN
  #DIGITS @ 3 > IF .THOUSANDS SPACE .HUNDREDS SPACE .AND .2DIGITS THEN
;

image.png.1f1d8f2ab4ec9885bb4e31701eda3c99.png

Edited September 10, 2022 by TheBF
comment error

+TheBF · September 14, 2022

Found some more warts in the number to text program and took some time to re-factor it.

It is more in line with a Forth solution now because I re-use more definitions.

This also makes the code much simpler to understand (I think) and seems to handle all the corners.

It also removed the one variable that was in the previous version.

Spoiler

\ number to dollars Camel99 Forth     Sept 2022 Brian Fox
\ INCLUDE DSK1.TOOLS
INCLUDE DSK1.CASE
INCLUDE DSK1.FASTCASE

DECIMAL
\ unsigned slash mod
: U/MOD  ( n n -- r q) 0 SWAP UM/MOD ;
: 3DUP   ( a b c -- a b c a b c)  2 PICK 2 PICK 2 PICK ;

\ variable stack output with # digits on top
: PARSE# ( n --  1 [10 100 1000 10000]  n )
  !CSP
  BEGIN  DUP WHILE  10 U/MOD  REPEAT DROP
  CSP @ SP@ - 2/ ;

: HYPHEN  ." -"  ;

\ compile n vectors into memory
: VECTORS ( a...z  n -- ) 0 ?DO  COMPILE,  LOOP ;

\ create vectors on data stack
:NONAME ." nineteen" ;  :NONAME ." eighteen" ;  :NONAME ." seventeen" ;
:NONAME ." sixteen" ;   :NONAME ." fifteen" ;   :NONAME ." fourteen" ;
:NONAME ." thirteen" ;  :NONAME ." twelve" ;    :NONAME ." eleven" ;
:NONAME ." ten" ;       :NONAME ." nine" ;      :NONAME ." eight" ;
:NONAME ." seven" ;     :NONAME ." six" ;       :NONAME ." five" ;
:NONAME ." four" ;      :NONAME ." three" ;     :NONAME ." two" ;
:NONAME ." one" ;       :NONAME ." zero" ;
CASE: DIGIT ( 0..19 --) 20 VECTORS  ;CASE  \ compile into vector table

: BAD#  TRUE ABORT" Bad tens #" ;

:NONAME  ." ninety" ;   :NONAME  ." eighty" ;
:NONAME  ." seventy" ;  :NONAME  ." sixty" ;
:NONAME  ." fifty" ;    :NONAME  ." forty" ;
:NONAME  ." thirty" ;   :NONAME  ." twenty" ;
CASE: TENS  | BAD# | BAD#  8 VECTORS  ;CASE

\ jumps out of a running word
: IGNORE ( n -- n)  S" IF  DROP EXIT  THEN " EVALUATE ; IMMEDIATE

\ common factors
: "thousand"   SPACE ." thousand" ;
: .AND ( n n -- n n ) 2DUP OR IF  ." and" THEN  ;

\ output routines
: .ONES ( n --) DUP 0= IGNORE  DIGIT ;
: .HYPHENATED ( n n -- ) TENS DUP 0 > IF HYPHEN DIGIT THEN ;

: .2DIGITS ( ones tens   --)
  DUP 0= IF DROP .ONES  EXIT THEN  \ NO tens, drop & print ones & exit
  DUP 1 >                          \ tens>1  must 20,30 etc.
  IF   .HYPHENATED
  ELSE 10 * +  DIGIT               \ 10 .. 19
  THEN ;

: .3DIGITS  ( n n n -- )
   3DUP OR OR 0= IGNORE            \ all zeros on stack
   DUP 0= IF DROP                  \ NO hundreds, drop it
   ELSE DIGIT SPACE ." hundred"
   THEN SPACE .AND SPACE .2DIGITS  ;

: .4DIGITS ( n n n n --)      DIGIT "thousand" SPACE .3DIGITS ;
: .5DIGITS ( n n n n n --) .2DIGITS "thousand" SPACE .3DIGITS ;

: SAY#
  CR
  PARSE# ( -- #digits )
  CASE
    1 OF  DIGIT     ENDOF
    2 OF .2DIGITS   ENDOF
    3 OF .3DIGITS   ENDOF
    4 OF .4DIGITS   ENDOF
    5 OF .5DIGITS   ENDOF
  ENDCASE
;

Edited September 14, 2022 by TheBF
removed unused definition

smp · September 15, 2022

I dug up my fig-FORTH solution called SAYNUM from oh so many years ago:

( version that works in fig-FORTH )
( Create needed support functions )
: 0<> 0= IF 0
ELSE 1
ENDIF ;
: 0> DUP 0< IF DROP 0
ELSE
0= IF 0
ELSE 1
ENDIF
ENDIF ;
( Create all the individual number printing routines )
: ZE ." zero " ;
: ON ." one " ;
: TW ." two " ;
: TH ." three " ;
: FO ." four " ;
: FI ." five " ;
: SI ." six " ;
: SE ." seven " ;
: EI ." eight " ;
: NI ." nine " ;
: TE ." ten " ;
: EL ." eleven " ;
: TL ." twelve " ;
: 3T ." thirteen " ;
: 4T ." fourteen " ;
: 5T ." fifteen " ;
: 6T ." sixteen " ;
: 7T ." seventeen " ;
: 8T ." eighteen " ;
: 9T ." nineteen " ;
: 2Y ." twenty " ;
: 3Y ." thirty " ;
: 4Y ." forty " ;
: 5Y ." fifty " ;
: 6Y ." sixty " ;
: 7Y ." seventy " ;
: 8Y ." eighty " ;
: 9Y ." ninety " ;
( Setup jump tables )
0 VARIABLE UNITS -2 ALLOT ' ZE , ' ON , ' TW , ' TH , ' FO , ' FI , ' SI , ' SE , ' EI , ' NI ,
0 VARIABLE 10TO19 -2 ALLOT ' TE , ' EL , ' TL , ' 3T , ' 4T , ' 5T , ' 6T , ' 7T , ' 8T , ' 9T ,
0 VARIABLE TENS -2 ALLOT ' 2Y , ' 3Y , ' 4Y , ' 5Y , ' 6Y , ' 7Y , ' 8Y , ' 9Y ,
( Function sayunits )
( This function will print out the proper units digit )
: SAYUNITS ( n -- )
UNITS SWAP 2 * + @ 2 - EXECUTE ;
( Function say10to19 )
( This function will print out the proper number from 10 to 19 )
: SAY10TO19 ( n -- )
10TO19 SWAP 2 * + @ 2 - EXECUTE ;
( Function saytens )
( This function will print out the proper tens digit from 20 to 90 )
: SAYTENS ( n -- )
2 - ( adjust for 20 to 90 )
TENS SWAP 2 * + @ 2 - EXECUTE ;
( Function saynum )
( This function will assure the number on the stack is 32767, maximum, )
( then it will proceed to break the number down into thousands, hundreds, )
( etc., and print out the number in words instead of digits. )
: SAYNUM ( n -- , if n is 32767 or less )
( bounds check )
DUP 32767 - 0> IF (ABORT)
ENDIF ( number is 32767 or less )
DUP 0= IF DUP SAYUNITS ( special case for zero )
ENDIF
DUP 10000 /
DUP 0<> IF DUP 1 - 0> IF DUP SAYTENS ( have 2 to 9 )
10000 * -
DUP 1000 /
DUP 0<> IF DUP SAYUNITS
1000 * -
ELSE DROP
ENDIF
." thousand "
ELSE ( have 1 )
10000 * -
DUP 1000 /
DUP SAY10TO19
1000 * -
." thousand "
ENDIF
ELSE
DROP DUP 1000 /
DUP 0<> IF DUP SAYUNITS
1000 * -
." thousand "
ELSE DROP
ENDIF
ENDIF
DUP 100 /
DUP 0<> IF DUP SAYUNITS
100 * -
." hundred "
ELSE DROP
ENDIF
DUP 10 /
DUP 0<> IF DUP 1 - 0= IF 10 * - ( have 1 )
SAY10TO19
ELSE ( have 2 to 9 )
DUP SAYTENS
10 * -
DUP 0<> IF SAYUNITS
ELSE DROP
ENDIF
ENDIF
ELSE ( have 0 )
DROP
DUP 0<> IF SAYUNITS
ELSE DROP
ENDIF
ENDIF
;
( Test loop )
: COUNTER CR 101 0 DO I SAYNUM CR LOOP ;

- - - - -

Hopefully, I commented the code well enough back then. Let me know how elegant or ugly you think it is!

smp

Edited September 15, 2022 by smp

+TheBF · September 15, 2022

Thanks!

It's nice to have a new Forth face on the scene.

You did the same thing as I did creating those vector tables that called words in the dictionary. In Fig-Forth you had to "roll your own".

I have some words that help to do that for me.

(CASE: ;CASE ) and ANS Forth has :NONAME that lets me define a word with "no name" but instead it leaves the execution address on the stack. (This needs mods for Fig Forth)

: CASE:  ( -- <name> ) CREATE  ;
: |      ( <name> )  '   ,  ;
: ;CASE   ( n -- )  DOES> SWAP CELLS + PERFORM ;

( PERFORM is @ EXECUTE in a code word)

With those words I had a slightly easier way to do the same thing you did.

The logic part of the program is written in the way one normally writes a program in a procedural language.

Chuck Moore is fond of saying "Factor factor factor". So this is arguably not the best Forth "style" however it works and for a programmer used to this style it is understandable.

The downside of long IF ENDIF sequences is that you can't test them interactively.

Now for people smarter than me that is not a problem but I benefit from simple one level logic that I can test and then use with confidence.

You can read about it on page 174 here:

thinking-forth.pdf (utwente.nl)

+Lee Stewart · September 15, 2022

59 minutes ago, smp said:

( Create needed support functions )

: 0<>
   0= IF 0 
   ELSE 1 
   ENDIF  ;
: 0>
   DUP 0< IF 
      DROP 0
   ELSE
      0= IF 0
      ELSE 1
      ENDIF
   ENDIF  ;

Your younger self seems fraught with the same problem I have and that is that my first solution to a problem is often the most complicated. These are simpler definitions for the above:

: 0<>  0= 0=  ;
: 0>  0 >  ;

...lee

+TheBF · September 15, 2022

These definitions could be simpler/smaller/faster by avoiding IF and using existing comparison operators.

 : 0<>  0= IF 0 
           ELSE 1 
           ENDIF ;
           
 : 0>   DUP 0< IF DROP 0
               ELSE
                  0= IF 0
                     ELSE 1
                     ENDIF
               ENDIF ;

: 0<> ( n --?)  0=  0= ;   
: 0>  ( n --?)  0 >  ;

+TheBF · September 15, 2022

23 minutes ago, Lee Stewart said:
Your younger self seems fraught with the same problem I have and that is that my first solution to a problem is often the most complicated. These are simpler definitions for the above:
: 0<>  0= 0=  ;
: 0>  0 >  ;
...lee

LOL. We just posted them same thing!

smp · September 15, 2022

3 hours ago, Lee Stewart said:

Your younger self seems fraught with the same problem I have and that is that my first solution to a problem is often the most complicated.

Yes, that fits me perfectly. If there is a complicated way to do something, that's most likely the way I will be going! :lol:

Thanks very much, to both of you, for the nice simple ways to get those done!

smp

Edited September 15, 2022 by smp

+TheBF · September 16, 2022

So, every morning I read some headlines on Hacker News.

This lead me here: The Lost Ways of Programming: Commodore 64 BASIC (tomasp.net)

Which let me see a famous little program

10 PRINT CHR$(147);
20 PRINT CHR$(205.5 + RND(1));
30 GOTO 20
RUN

That creates a cool maze if you have the C64 graphics characters.

image.png.30df4da3d019bae976bfe8bbd3da540e.png

And that made me want those characters, so I searched the GIF files for PETSCII and it was there!

And that made me look at how best to import character sets.

Magellan exports .ASM data statements that I can edit a bit.

I have DATA and BYTE statements in a library file but they compile to RAM.

Wouldn't it be great if they compiled to VDP RAM?

And that lead me to updating the DATABYTE.FTH file to the code below.

Now with two directives RAM or VDP you can re-direct DATA and BYTE statements wherever you want.

Spoiler

\ databyte.fth  multi-memory version     Sept 2022 B Fox
\ DATA and BYTE directive with comma delimiting
\ directable to RAM or VDP with directives

\ Usage:
\ HEX
\ VDP DATA DEAD,BEEF,AABB
\ RAM DATA 0001,2200,3300,4440
\ VDP BYTE 00,01,02,03,FF,BEEF  (aborts on 'BEEF')

INCLUDE DSK1.DEFER
INCLUDE DSK1.VDPMEM

DEFER BYTE,
DEFER WORD,

: RAM    ['] C,  IS BYTE,   ['] ,   IS WORD, ;
: VDP    ['] VC, IS BYTE,   ['] V,  IS WORD, ;

HEX
: BYTE ( -- )
         BEGIN
           [CHAR] , PARSE-WORD  DUP
         WHILE
            EVALUATE  DUP FF00 AND  ABORT" Not a byte"
            BYTE,
         REPEAT
         2DROP ;

: DATA ( -- )
         BEGIN
            [CHAR] , PARSE-WORD  DUP
         WHILE
            EVALUATE WORD,
         REPEAT
         2DROP ;

The PETSCII characters are not ASCII so I only want them in the high characters.

So I set the VP (VDP pointer) variable to start at the PDT address of character 127.

With the new VDP & DATA directives I compile data directly to VDP RAM.

Spoiler

\ petscii.fth  make binary C64 Character set for Camel99 Forth  Sept 2022 Fox
\ Data came from font0010.gif to Magellan, exported .asm file

NEEDS DATA      FROM DSK1.DATABYTE
NEEDS LOAD-FONT FROM DSK1.LOADSAVE
NEEDS ]PDT      FROM DSK1.GRAFIX
\ ****************************************
\ * PETSCII C64 Patterns at 127
\ ****************************************
DECIMAL 127 ]PDT VP !  \ set pattern table start address

HEX
VDP ( compile data to VDP RAM )
DATA 3C66,6E6E,6062,3C00    \ PAT0
DATA 183C,667E,6666,6600    \
DATA 7C66,667C,6666,7C00    \
DATA 3C66,6060,6066,3C00    \
DATA 786C,6666,666C,7800    \
DATA 7E60,6078,6060,7E00    \
DATA 7E60,6078,6060,6000    \
DATA 3C66,606E,6666,3C00    \
DATA 6666,667E,6666,6600    \
DATA 3C18,1818,1818,3C00    \
DATA 1E0C,0C0C,0C6C,3800    \ PAT10
DATA 666C,7870,786C,6600    \
DATA 6060,6060,6060,7E00    \
DATA 6377,7F6B,6363,6300    \
DATA 6676,7E7E,6E66,6600    \
DATA 3C66,6666,6666,3C00    \
DATA 7C66,667C,6060,6000    \
DATA 3C66,6666,663C,0E00    \
DATA 7C66,667C,786C,6600    \
DATA 3C66,603C,0666,3C00    \
DATA 7E18,1818,1818,1800    \ PAT20
DATA 6666,6666,6666,3C00    \
DATA 6666,6666,663C,1800    \
DATA 6363,636B,7F77,6300    \
DATA 6666,3C18,3C66,6600    \
DATA 6666,663C,1818,1800    \
DATA 7E06,0C18,3060,7E00    \
DATA 3C30,3030,3030,3C00    \
DATA 0C12,307C,3062,FC00    \
DATA 3C0C,0C0C,0C0C,3C00    \
DATA 0018,3C7E,1818,1818    \ PAT30
DATA 0010,307F,7F30,1000    \
DATA 0000,0000,0000,0000    \
DATA 1818,1818,0000,1800    \
DATA 6666,6600,0000,0000    \
DATA 6666,FF66,FF66,6600    \
DATA 183E,603C,067C,1800    \
DATA 6266,0C18,3066,4600    \
DATA 3C66,3C38,6766,3F00    \
DATA 060C,1800,0000,0000    \
DATA 0C18,3030,3018,0C00    \ PAT40
DATA 3018,0C0C,0C18,3000    \
DATA 0066,3CFF,3C66,0000    \
DATA 0018,187E,1818,0000    \
DATA 0000,0000,0018,1830    \
DATA 0000,007E,0000,0000    \
DATA 0000,0000,0018,1800    \
DATA 0003,060C,1830,6000    \
DATA 3C66,6E76,6666,3C00    \
DATA 1818,3818,1818,7E00    \
DATA 3C66,060C,3060,7E00    \ PAT50
DATA 3C66,061C,0666,3C00    \
DATA 060E,1E66,7F06,0600    \
DATA 7E60,7C06,0666,3C00    \
DATA 3C66,607C,6666,3C00    \
DATA 7E66,0C18,1818,1800    \
DATA 3C66,663C,6666,3C00    \
DATA 3C66,663E,0666,3C00    \
DATA 0000,1800,0018,1830    \
DATA 0E18,3060,3018,0E00    \ PAT60
DATA 0000,7E00,7E00,0000    \
DATA 7018,0C06,0C18,7000    \
DATA 3C66,060C,1800,1800    \
DATA 0000,00FF,FF00,0000    \
DATA 081C,3E7F,7F1C,3E00    \
DATA 1818,1818,1818,1818    \
DATA 0000,00FF,FF00,0000    \
DATA 0000,FFFF,0000,0000    \
DATA 00FF,FF00,0000,0000    \
DATA 0000,0000,FFFF,0000    \ PAT70
DATA 3030,3030,3030,3030    \
DATA 0C0C,0C0C,0C0C,0C0C    \
DATA 0000,00E0,F038,1818    \
DATA 1818,1C0F,0700,0000    \
DATA 1818,38F0,E000,0000    \
DATA C0C0,C0C0,C0C0,FFFF    \
DATA C0E0,7038,1C0E,0703    \
DATA 0307,0E1C,3870,E0C0    \
DATA FFFF,C0C0,C0C0,C0C0    \
DATA FFFF,0303,0303,0303    \ PAT80
DATA 003C,7E7E,7E7E,3C00    \
DATA 0000,0000,00FF,FF00    \
DATA 367F,7F7F,3E1C,0800    \
DATA 6060,6060,6060,6060    \
DATA 0000,0007,0F1C,1818    \
DATA C3E7,7E3C,3C7E,E7C3    \
DATA 003C,7E66,667E,3C00    \
DATA 1818,6666,1818,3C00    \
DATA 0606,0606,0606,0606    \
DATA 081C,3E7F,3E1C,0800    \ PAT90
DATA 1818,18FF,FF18,1818    \
DATA C0C0,3030,C0C0,3030    \
DATA 1818,1818,1818,1818    \
DATA 0000,033E,7636,3600    \
DATA FF7F,3F1F,0F07,0301    \
DATA 0000,0000,0000,0000    \
DATA F0F0,F0F0,F0F0,F0F0    \
DATA 0000,0000,FFFF,FFFF    \
DATA FF00,0000,0000,0000    \
DATA 0000,0000,0000,00FF    \ PAT100
DATA C0C0,C0C0,C0C0,C0C0    \
DATA CCCC,3333,CCCC,3333    \
DATA 0303,0303,0303,0303    \
DATA 0000,0000,CCCC,3333    \
DATA FFFE,FCF8,F0E0,C080    \
DATA 0303,0303,0303,0303    \
DATA 1818,181F,1F18,1818    \
DATA 0000,0000,0F0F,0F0F    \
DATA 1818,181F,1F00,0000    \
DATA 0000,00F8,F818,1818    \ PAT110
DATA 0000,0000,0000,FFFF    \
DATA 0000,001F,1F18,1818    \
DATA 1818,18FF,FF00,0000    \
DATA 0000,00FF,FF18,1818    \
DATA 1818,18F8,F818,1818    \
DATA C0C0,C0C0,C0C0,C0C0    \
DATA E0E0,E0E0,E0E0,E0E0    \
DATA 0707,0707,0707,0707    \
DATA FFFF,0000,0000,0000    \
DATA FFFF,FF00,0000,0000    \ PAT120
DATA 0000,0000,00FF,FFFF    \
DATA 0303,0303,0303,FFFF    \
DATA 0000,0000,F0F0,F0F0    \
DATA 0F0F,0F0F,0000,0000    \
DATA 1818,18F8,F800,0000    \
DATA F0F0,F0F0,0000,0000    \
DATA F0F0,F0F0,0F0F,0F0F    \ PAT127

DECIMAL
15 SCREEN
0 31 15 1 COLORS \ all charsets to gray/transparent
: .CHARSET  CR  255 0 DO I EMIT LOOP ;
 PAGE 
.CHARSET

S" DSK2.FNT4+C64" SAVE-FONT

Which gives you this in Camel99 Forth.

And now I can play.

image.png.96218f6577ddce4548a29cb6a9911c1c.png

+TheBF · September 16, 2022

After all that here is the maze on TI-99.

Camel99 RND gives a number between 0 and the argument but never returns the argument so, 2 RND outputs ones and zeros.

INCLUDE DSK1.RANDOM

: MAZE   PAGE BEGIN  203 2 RND +  EMIT   ?TERMINAL UNTIL ;

smp · September 19, 2022

OK, Forth Masters, I have another one for you.

Long ago, I used to enjoy seeing the copyright year for movies or TV shows when they printed them out in the credits in Roman Numerals (perhaps not so much since 2000).

Here's another program from the past that takes a number (over 2 or 3 thousand gets pretty silly) and returns that number in Roman Numerals:

( fig-FORTH version )

: >=   ( N1 N2 -- 0/1 )
  < IF 0 ELSE 1 THEN ; 

: RN   ( N -- )
  CR
  BEGIN DUP 1000 >= WHILE ." M" 1000 - REPEAT
  DUP 900 >= IF ." CM" 900 - THEN
  DUP 500 >= IF ." D" 500 - THEN
  DUP 400 >= IF ." CD" 400 - THEN
  BEGIN DUP 100 >= WHILE ." C" 100 - REPEAT
  DUP 90 >= IF ." XC" 90 - THEN
  DUP 50 >= IF ." L" 50 - THEN
  DUP 40 >= IF ." XL" 40 - THEN
  BEGIN DUP 10 >= WHILE ." X" 10 - REPEAT
  DUP 9 = IF ." IX" 9 - THEN
  DUP 5 >= IF ." V" 5 - THEN
  DUP 4 = IF ." IV" 4 - THEN
  BEGIN DUP 1 >= WHILE ." I" 1 - REPEAT
  DROP CR ;

I'm sure others will enjoy playing with this, but I certainly probably did not come up with an efficient way to do it. What can you Forth Masters come up with?

smp

+Lee Stewart · September 19, 2022

1 hour ago, smp said:
: >=   ( N1 N2 -- 0/1 )
  < IF 0 ELSE 1 THEN ;
What can you Forth Masters come up with?

For starters:

: >=  ( n1 n2 -- 0|1 )
   < 0=  ;

...lee

GDMike · September 19, 2022

somewhere, but I don't remember which book, but I saw an example program for Roman numerals. But I'm thinking it was more of a graphic display rather than characters? I can't remember now.

Edited September 19, 2022 by GDMike

+TheBF · September 20, 2022

I put this one up on Rossetta Code some years ago.

It is the opposite direction, Roman to Arabic numbers.

The three variables put in the bad books with the Forth gurus.

\ decode roman numerals using Forth methodology
\ create words to describe and solve the problem
\ ANS/ISO Forth

\ state holders
VARIABLE OLDNDX
VARIABLE CURNDX
VARIABLE NEGFLAG

DECIMAL
CREATE VALUES ( -- addr) 0 , 1 , 5 , 10 , 50 , 100 , 500 , 1000 ,

: NUMERALS ( -- addr len)  S"  IVXLCDM" ;        \ 1st char is a blank
: []       ( n addr -- addr') SWAP CELLS +  ;    \ array address calc.
: INIT     ( -- )         CURNDX OFF  OLDNDX OFF  NEGFLAG OFF ;
: REMEMBER ( ndx -- ndx ) CURNDX @ OLDNDX !  DUP CURNDX !  ;
: ]VALUE@  ( ndx -- n )   REMEMBER VALUES [] @ ;
HEX
: TOUPPER ( char -- char ) 05F AND ;

DECIMAL
: >INDEX   ( char -- ndx) TOUPPER >R  NUMERALS TUCK R> SCAN NIP -
                          DUP 7 > ABORT" Invalid Roman numeral" ;

: >VALUE   ( char -- n ) >INDEX ]VALUE@ ;
: ?ILLEGAL ( ndx --  )   CURNDX @ OLDNDX @ =  NEGFLAG @ AND ABORT" Illegal format" ;

: ?NEGATE ( n -- +n | -n) \ conditional NEGATE
           CURNDX @ OLDNDX @ <
           IF   NEGFLAG ON  NEGATE
           ELSE ?ILLEGAL  NEGFLAG OFF
           THEN ;

: >ARABIC  ( addr len -- n )
           INIT
           0  -ROT            \ accumulator under the stack string args
           1- BOUNDS          \ convert addr len to two addresses 
           SWAP DO            \ index the string from back to front
                  I C@ >VALUE ?NEGATE +    
          -1 +LOOP ;

Their are two Rosetta code Roman encoder versions.

https://rosettacode.org/wiki/Roman_numerals/Encode#Forth

You can see that per Forth thinking nested IF statements are not preferred but some clever bastidge used recursion.

+TheBF · September 20, 2022

7 hours ago, smp said:
OK, Forth Masters, I have another one for you.

Long ago, I used to enjoy seeing the copyright year for movies or TV shows when they printed them out in the credits in Roman Numerals (perhaps not so much since 2000).

Here's another program from the past that takes a number (over 2 or 3 thousand gets pretty silly) and returns that number in Roman Numerals:
( fig-FORTH version )

: >=   ( N1 N2 -- 0/1 )
  < IF 0 ELSE 1 THEN ; 

: RN   ( N -- )
  CR
  BEGIN DUP 1000 >= WHILE ." M" 1000 - REPEAT
  DUP 900 >= IF ." CM" 900 - THEN
  DUP 500 >= IF ." D" 500 - THEN
  DUP 400 >= IF ." CD" 400 - THEN
  BEGIN DUP 100 >= WHILE ." C" 100 - REPEAT
  DUP 90 >= IF ." XC" 90 - THEN
  DUP 50 >= IF ." L" 50 - THEN
  DUP 40 >= IF ." XL" 40 - THEN
  BEGIN DUP 10 >= WHILE ." X" 10 - REPEAT
  DUP 9 = IF ." IX" 9 - THEN
  DUP 5 >= IF ." V" 5 - THEN
  DUP 4 = IF ." IV" 4 - THEN
  BEGIN DUP 1 >= WHILE ." I" 1 - REPEAT
  DROP CR ;
I'm sure others will enjoy playing with this, but I certainly probably did not come up with an efficient way to do it. What can you Forth Masters come up with?

smp

To be perfectly frank, I find your version easier to understand than the Rosetta code versions.

Well done IMHO.

And BTW it works perfect on Mac Swiftforth. (no need for >= it's in the system.

: RN   ( N -- )
  CR
  BEGIN DUP 1000 >= WHILE ." M" 1000 - REPEAT
  DUP 900 >= IF ." CM" 900 - THEN
  DUP 500 >= IF ." D" 500 - THEN
  DUP 400 >= IF ." CD" 400 - THEN
  BEGIN DUP 100 >= WHILE ." C" 100 - REPEAT
  DUP 90 >= IF ." XC" 90 - THEN
  DUP 50 >= IF ." L" 50 - THEN
  DUP 40 >= IF ." XL" 40 - THEN
  BEGIN DUP 10 >= WHILE ." X" 10 - REPEAT
  DUP 9 = IF ." IX" 9 - THEN
  DUP 5 >= IF ." V" 5 - THEN
  DUP 4 = IF ." IV" 4 - THEN
  BEGIN DUP 1 >= WHILE ." I" 1 - REPEAT
  DROP CR ;

And here is what if compiles to in intel code.

see RN 
3B49F   442F ( CR ) CALL                E88B8FFCFF
3B4A4   3E8 # EBX CMP                   81FBE8030000
3B4AA   3B4C8 JL                        0F8C18000000
3B4B0   4E5F ( (S") ) CALL              E8AA99FCFF
3B4B5   "M"
3B4B8   43AF ( TYPE ) CALL              E8F28EFCFF
3B4BD   3E8 # EBX SUB                   81EBE8030000
3B4C3   3B4A4 JMP                       E9DCFFFFFF
3B4C8   384 # EBX CMP                   81FB84030000
3B4CE   3B4E8 JL                        0F8C14000000
3B4D4   4E5F ( (S") ) CALL              E88699FCFF
3B4D9   "CM"
3B4DD   43AF ( TYPE ) CALL              E8CD8EFCFF
3B4E2   384 # EBX SUB                   81EB84030000
3B4E8   1F4 # EBX CMP                   81FBF4010000
3B4EE   3B507 JL                        0F8C13000000
3B4F4   4E5F ( (S") ) CALL              E86699FCFF
3B4F9   "D"
3B4FC   43AF ( TYPE ) CALL              E8AE8EFCFF
3B501   1F4 # EBX SUB                   81EBF4010000
3B507   190 # EBX CMP                   81FB90010000
3B50D   3B527 JL                        0F8C14000000
3B513   4E5F ( (S") ) CALL              E84799FCFF
3B518   "CD"
3B51C   43AF ( TYPE ) CALL              E88E8EFCFF
3B521   190 # EBX SUB                   81EB90010000
3B527   64 # EBX CMP                    83FB64
3B52A   3B545 JL                        0F8C15000000
3B530   4E5F ( (S") ) CALL              E82A99FCFF
3B535   "C"
3B538   43AF ( TYPE ) CALL              E8728EFCFF
3B53D   64 # EBX SUB                    83EB64
3B540   3B527 JMP                       E9E2FFFFFF
3B545   5A # EBX CMP                    83FB5A
3B548   3B55F JL                        0F8C11000000
3B54E   4E5F ( (S") ) CALL              E80C99FCFF
3B553   "XC"
3B557   43AF ( TYPE ) CALL              E8538EFCFF
3B55C   5A # EBX SUB                    83EB5A
3B55F   32 # EBX CMP                    83FB32
3B562   3B578 JL                        0F8C10000000
3B568   4E5F ( (S") ) CALL              E8F298FCFF
3B56D   "L"
3B570   43AF ( TYPE ) CALL              E83A8EFCFF
3B575   32 # EBX SUB                    83EB32
3B578   28 # EBX CMP                    83FB28
3B57B   3B592 JL                        0F8C11000000
3B581   4E5F ( (S") ) CALL              E8D998FCFF
3B586   "XL"
3B58A   43AF ( TYPE ) CALL              E8208EFCFF
3B58F   28 # EBX SUB                    83EB28
3B592   A # EBX CMP                     83FB0A
3B595   3B5B0 JL                        0F8C15000000
3B59B   4E5F ( (S") ) CALL              E8BF98FCFF
3B5A0   "X"
3B5A3   43AF ( TYPE ) CALL              E8078EFCFF
3B5A8   A # EBX SUB                     83EB0A
3B5AB   3B592 JMP                       E9E2FFFFFF
3B5B0   9 # EBX CMP                     83FB09
3B5B3   3B5CA JNZ                       0F8511000000
3B5B9   4E5F ( (S") ) CALL              E8A198FCFF
3B5BE   "IX"
3B5C2   43AF ( TYPE ) CALL              E8E88DFCFF
3B5C7   9 # EBX SUB                     83EB09
3B5CA   5 # EBX CMP                     83FB05
3B5CD   3B5E3 JL                        0F8C10000000
3B5D3   4E5F ( (S") ) CALL              E88798FCFF
3B5D8   "V"
3B5DB   43AF ( TYPE ) CALL              E8CF8DFCFF
3B5E0   5 # EBX SUB                     83EB05
3B5E3   4 # EBX CMP                     83FB04
3B5E6   3B5FD JNZ                       0F8511000000
3B5EC   4E5F ( (S") ) CALL              E86E98FCFF
3B5F1   "IV"
3B5F5   43AF ( TYPE ) CALL              E8B58DFCFF
3B5FA   4 # EBX SUB                     83EB04
3B5FD   1 # EBX CMP                     83FB01
3B600   3B61B JL                        0F8C15000000
3B606   4E5F ( (S") ) CALL              E85498FCFF
3B60B   "I"
3B60E   43AF ( TYPE ) CALL              E89C8DFCFF
3B613   1 # EBX SUB                     83EB01
3B616   3B5FD JMP                       E9E2FFFFFF
3B61B   0 [EBP] EBX MOV                 8B5D00
3B61E   4 # EBP ADD                     83C504
3B621   442F ( CR ) JMP                 E9098EFCFF ok

smp · September 20, 2022

16 minutes ago, TheBF said:

To be perfectly frank, I find your version easier to understand than the Rosetta code versions.

Well done IMHO.

Wow. Thanks very much!

smp

+TheBF · September 20, 2022

Here is an idea that makes these kind of things go a bit faster. I do not know how to do this in Fig-Forth.

The ANS word EXIT pops the address of the running word from the Rstack and then runs next.

By using EXIT THEN it is like a GOTO the semi-colon, so all the if statements don't have to run.

This works on my ANS SwiftForth on my mac laptop. (not in the shop this week)

( ANS/ISO FORTH version )

: >=   ( N1 N2 -- 0/1 ) < 0= ; 

: M1000
  BEGIN DUP 1000 >= WHILE ." M" 1000 - REPEAT
  DUP 900 >= IF ." CM" 900 -  EXIT  THEN
  DUP 500 >= IF ." D"  500 -  EXIT  THEN
  DUP 400 >= IF ." CD" 400 -  EXIT  THEN ; 
  
: C100    
  BEGIN DUP 100 >= WHILE ." C" 100 - REPEAT
  DUP 90 >= IF ." XC" 90 - EXIT  THEN
  DUP 50 >= IF ." L" 50 -  EXIT  THEN
  DUP 40 >= IF ." XL" 40 - EXIT  THEN ;  

: X10 
  BEGIN DUP 10 >= WHILE ." X" 10 - REPEAT
  DUP 9 = IF ." IX" 9 -  EXIT  THEN
  DUP 5 >= IF ." V" 5 -  EXIT  THEN
  DUP 4 = IF ." IV" 4 -  EXIT  THEN ;
  
: I1
  BEGIN DUP 1 >= WHILE ." I" 1 - REPEAT DROP  ;  

: RN   ( n -- )   CR M1OOO C100 X10 I1  CR ;

A lot of guys today use this so much that THEY define the word END to replace EXIT THEN

: END POSTPONE EXIT POSTPONE THEN ; IMMEDIATE

+Lee Stewart · September 20, 2022

1 hour ago, TheBF said:

Here is an idea that makes these kind of things go a bit faster. I do not know how to do this in Fig-Forth.

The ANS word EXIT pops the address of the running word from the Rstack and then runs next.

That word in FIG-Forth is

;S

...lee

+TheBF · September 24, 2022

So to finish this conversation here is code that implements END in FbForth and implements @SMP 's roman numeral code.

\ Roman Numerals in Fig-Forth with early escape from IF 

: >=   ( n1 n2 -- 0/1 ) < 0= ;
: END    COMPILE ;S  [COMPILE] ENDIF ;  IMMEDIATE

: M1000
  BEGIN DUP 1000 >= WHILE ." M" 1000 - REPEAT
  DUP 900 >= IF ." CM" 900 -  END
  DUP 500 >= IF ." D"  500 -  END
  DUP 400 >= IF ." CD" 400 -  END ;

: C100
  BEGIN DUP 100 >= WHILE ." C" 100 - REPEAT
  DUP 90 >= IF ." XC" 90 - END
  DUP 50 >= IF ." L" 50 -  END
  DUP 40 >= IF ." XL" 40 - END ;

: X10
  BEGIN DUP 10 >= WHILE ." X" 10 - REPEAT
  DUP 9 = IF ." IX" 9 -  END
  DUP 5 >= IF ." V" 5 -  END
  DUP 4 = IF ." IV" 4 -  END ;

: I1
  BEGIN DUP 1 >= WHILE ." I" 1 - REPEAT DROP ;

: RN   ( n -- )   CR M1000 C100 X10 I1  CR ;

+TheBF · September 24, 2022

While working on vi99 I wanted a way to know the last disk accessed. I had some code that was based on some ASM code that I found that returned the disk number.

However, when you look inside the headers on the disk card, the strings are in perfect Forth format as byte counted strings.

So why not just grab the string, since that is what I really want anyway?

I will be adding this code to vi99 to let me know the disk that the program was booted from.

(It is so handy I might add it to my START file in CAMEL99 Forth as well)

Spoiler

\ get current drive#
DECIMAL
24 USER 'R12

HEX
83D0 CONSTANT DISKCARD
83D2 CONSTANT DEVLIST

CODE 0SBO  ( -- ) 1D00 ,  NEXT, ENDCODE
CODE 0SBZ  ( -- ) 1E00 ,  NEXT, ENDCODE

: ?DISKS    4000 C@ AA <> IF 0SBZ TRUE ABORT" No disk" THEN ;

: DSK$  ( -- $addr)
         DISKCARD @ 'R12 !
         0SBO
         ?DISKS 
         DEVLIST @ 4 + COUNT PAD PLACE
         0SBZ
         PAD
;

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