+Lee Stewart Posted September 6, 2022 Share Posted September 6, 2022 (edited) 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 1 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 7, 2022 Author Share Posted 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. 2 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 7, 2022 Share Posted 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. ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 7, 2022 Author Share Posted 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. 1 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 9, 2022 Author Share Posted 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 ; 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 10, 2022 Author Share Posted September 10, 2022 (edited) @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 ; Edited September 10, 2022 by TheBF comment error 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 14, 2022 Author Share Posted September 14, 2022 (edited) 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 1 Quote Link to comment Share on other sites More sharing options...
smp Posted September 15, 2022 Share Posted September 15, 2022 (edited) 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 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 15, 2022 Author Share Posted 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) 3 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 15, 2022 Share Posted 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 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 15, 2022 Author Share Posted 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 > ; 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 15, 2022 Author Share Posted 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! 3 Quote Link to comment Share on other sites More sharing options...
smp Posted September 15, 2022 Share Posted September 15, 2022 (edited) 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! Thanks very much, to both of you, for the nice simple ways to get those done! smp Edited September 15, 2022 by smp 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 16, 2022 Author Share Posted 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. 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. 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 16, 2022 Author Share Posted 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 ; 3 Quote Link to comment Share on other sites More sharing options...
smp Posted September 19, 2022 Share Posted 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 2 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 19, 2022 Share Posted 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 4 Quote Link to comment Share on other sites More sharing options...
GDMike Posted September 19, 2022 Share Posted September 19, 2022 (edited) 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 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 20, 2022 Author Share Posted 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. 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 20, 2022 Author Share Posted 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 2 1 Quote Link to comment Share on other sites More sharing options...
smp Posted September 20, 2022 Share Posted 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 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 20, 2022 Author Share Posted 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 2 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 20, 2022 Share Posted 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 1 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 24, 2022 Author Share Posted 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 ; 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 24, 2022 Author Share Posted 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 ; 2 Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.