+TheBF Posted August 11, 2018 Author Share Posted August 11, 2018 When you learn about other architectures, and what a context switch really means, you gotta love BLWP. It's a nice instruction for sure, but there are other ways to skin the cat too. The classic Forth virtual machine uses only three registers to record context. Data stack pointer Return stack pointer Instruction Pointer So that is the same number of registers you need to save the context of the 9900. Here is a context switcher for the same Forth system but without resorting to using RTWP. \ Conventional Forth context switcher CODE: PAUSE ( -- ) SP RPUSH, \ 28 IP RPUSH, \ 28 RP 4 (UP) MOV, \ 22 save my return stack pointer in RSAVE user-var BEGIN, 2 (UP) UP MOV, \ 22 load the next task's UP into CPU UP (context switch) *UP R0 MOV, \ 18 test the tflag for zero NE UNTIL, \ 10 loop until it's not zero 4 (UP) RP MOV, \ 22 restore local Return stack pointer so I can retrieve IP and SP IP RPOP, \ 22 load this task's IP SP RPOP, \ 22 load this task's SP NEXT, \ = 194 * .333 = 64.6uS context switch END-CODE Just counting cycles it is just over 3 times slower, but to be fair it's all software, the RPUSH macros are 2 instructions and the RPOP macro is a Register indirect,auto-inc instruction. If the 9900 had hardware support for stacks it would be much faster. This two stack architecture has also been cast in silicon and FPGAs and it goes pretty fast! I actually envision a machine with both features: two hardware driven stacks and a WP register that can point to fast RAM. I need to get up to speed on FPGAs... Quote Link to comment Share on other sites More sharing options...
+TheBF Posted August 12, 2018 Author Share Posted August 12, 2018 (edited) Integrating BLWP into Forth Can we make BLWP sub-routines that create their own vectors and call themselves? Previously I experimented with using BLWP in the Forth environment here: http://atariage.com/forums/topic/273872-camel99-forth-information-goes-here/?p=4087033 I took up my own idea, in that thread, of perhaps using BLWP with a byte queue structure so that the input/output pointers would be managed in registers rather than memory addresses. (ie: Forth variables) This worked ok but doing it seemed to create a lot of noise code which looked complicated to me. Just like in Assembler, to make a BLWP callable sub-routine we must: Define the workspace memory Define the code that will run Create the vector in memory with the workspace address and the code address Now Forth is a programmable Compiler. I felt there must be a way to "automate" that noise code away by extending the compiler to do the grunt work. I envisioned being able to do this: MYWKSP SUB: MYSUB1 <INSTRUCTION> <INSTRUCTION> <INSTRUCTION> ETC... RTWP, ENDSUB The workspace is passed to the sub-routine as a parameter. Then SUB: creates a new word in Forth at compile time. (when the program is loading) We follow that new word with assembly language and end with RTWP. ENDSUB is just a housekeeping routine that checks if we left any garbage on the forth stack with our assembly language and halts if we did. We gave it a nice name so that the code looks better. This is common in Forth where you are making a language as you write the program. This is pretty simple to do. In Forth it looks like this: : SUB: ( wksp -- ) CREATE \ make a new word in Dictionary !CSP \ record current stack position (for error checking) ( wksp) , HERE CELL+ , \ compile a 9900 vector into memory : ENDSUB ( -- ) ?CSP ; \ HALT if stack position has changed Forth ASM coders HERE is the equivalent of $ in ALC. CELL+ adds 2 to a number. So HERE CELL+ is equivalent to $+2. The comma compiles both numbers into Forth memory creating a BLWP vector. HERE CELL+ as the 2nd address in the vector means the code must begin in the next memory location. Once we have the SUB: directive defined, we can define a sub-routine and it makes it's own vector. Cool! Since we added a BLWP command to CAMEL99 Forth, we would run it like this: MYSUB1 BLWP But there's more! This can be hard to grok but here goes... Forth's compiler can also specify some extra code that will run when you invoke a word. This is equivalent to creating an Object with only one method. This is Forth's super-power as a low level language. What if we created the vector (which is data, ie an object) And specified that the code that runs on that data (ie the method) is "BLWP" Whoa!! That would mean that the vector would call itself! Forth can specify the "method" code to be in Forth or Assembly language. So for efficiency let's use Assembly language. : SUB: ( wksp -- ) CREATE \ make a new word in Dictionary !CSP \ record current stack position ( wksp) , HERE CELL+ , \ compile a vector (2 cells) ;CODE *W BLWP, \ code that runs when word is invoked NEXT, \ return to Forth ENDCODE Explanation of the ";code" section All words created with SUB: will run BLWP *W and return to Forth Forth's "working register" is called W ( alias for R5) When a Forth word is executed, R5 contains the address of the DATA which in this case is the address of the vector that SUB: created So with this we can safely make Assembly language sub-routines that call themselves from Forth. I like this! The spoiler has the code for testing this idea. I did not complete code to read the Queue yet but It's coming soon. \ byte queue using BLWP to manage pointers \ Concept here is to replace variables that manage circular pointers \ with registers in a workspace. The requires less code because registers \ do not need to loaded if the workspace is initialized first. \ It also runs faster because the data is always in registers. \ Interface to Forth is through R0 of the QREGS workspace. \ The base address of QREGS workspace is used just like a forth variable \ since it is just an address like a Forth variable. \ Use C! to write a byte into QREGS(R0) puts the byte in the correct side of the register. \ Use @ to fetch the value from QREGS(R0) to get the error flag. INCLUDE DSK1.TOOLS.F INCLUDE DSK1.ASM9900.F \ DATA ======================= HEX 100 CONSTANT QSIZE \ size be must power of 2 QSIZE 1- CONSTANT QMASK \ used for wrap pointer wrap around \ data is allocated in Lo memory with MALLOC QSIZE MALLOC CONSTANT Q \ points to Q's data 20 MALLOC CONSTANT QREGS \ points to a workspace for Q operations \ ============================ \ Compiler Directive to create a BLWP subroutine ... \ ... THAT CALLS ITSELF! : SUB: ( wksp -- ) \ At COMPILE TIME: \ - Create a label in the dictionary \ - compile a BLWP vector ( 2 addresses) \ - pull the workspace from Forth stack and compile it \ - The code starts at next cell after current address \ - Compute that address and compile into the vector CREATE \ make a new word in Dictionary !CSP \ record current stack position \ compile wksp compile code address \ ------------ -------------------- ( wksp) , HERE CELL+ , \ At RUNTIME: ( when Forth executes the "word" we create) \ - Forth's "working register is called W ( R5) \ - When a Forth word is executed, R5 contains the address \ of the "body" of the word \ - all words created with SUB: run BLWP *W ;CODE *W BLWP, \ code that runs when word is invoked NEXT, \ return to Forth ENDCODE : ENDSUB ( -- ) ?CSP ; \ check stack positio for junk left on it. QREGS SUB: INIT-QREGS \ code that initializes wksp \ R0 is character input buffer R1 CLR, \ flag for no error R2 SETO, \ flag for error R8 Q LI, \ R8 holds the Q data buffer address R9 CLR, \ R9 is the input pointer R10 CLR, \ R10 is the output pointer RTWP, ENDSUB \ Forth word to erase Q data and QREGS and call INIT-REGS : INIT-Q QREGS 20 0 FILL Q QSIZE 0 FILL INIT-QREGS ; \ ===================================== \ code to enqueue a byte in 'Q' QREGS SUB: ENQ ( c -- ? ) R9 INC, \ inc input pointer R9 QMASK ANDI, \ binary wrap around R9 R10 CMP, \ did we hit the deQ pointer? NE IF, R0 Q R9 () MOVB, \ move char in R0 to Q(R9) R0 CLR, \ reset R0, it's the return value ELSE, R0 SETO, \ return true as error flag ENDIF, RTWP, ENDSUB \ Forth word to call the code. : ENQ ( c -- ) QREGS C! \ put c in R0 of QREGS workspace ENQ \ call ENQ and return flag ; : TEST ( -- ) \ fill the Q with ascii chars INIT-Q BEGIN [CHAR] ~ [CHAR] ! \ for all ASCII chars DO I ENQ QREGS @ ABORT" Q over-run" LOOP ?BREAK AGAIN ; Edited August 12, 2018 by TheBF 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted August 12, 2018 Author Share Posted August 12, 2018 (edited) Further development on using BLWP. I believe it is more correct to refer to these routines called by BLWP as SUB-PROGRAMS. So I have changed the names to PROG: ;PROG. The interesting challenge is exchanging data from the Forth stack to the sub-program's workspace. There are many ways to do it by I chose to use the [TOS] macro to reference R4 in Forth's workspace. The other obvious way is to simply put the data directly in the SUB-PROGRAM'S workspace. They are just like a Forth variable after all. I am still not convinced that BLWP is the absolute fastest way to do this from inside Forth, but with the PROG: directive it is very convenient to create the structure needed to do use it. And registers make nicer code. The spoiler has a re-worked version of the previous code with a Hi-level API for the Forth programmer to read,write and query the Queue and a test program that exercises the code. *EDIT* Code cleanup, comment improvements INCLUDE DSK1.TOOLS.F INCLUDE DSK1.ASM9900.F \ DATA ======================= HEX 100 CONSTANT QSIZE \ size be must power of 2 QSIZE 1- CONSTANT QMASK \ used for wrap pointer wrap around \ data is allocated in Lo memory with MALLOC QSIZE MALLOC CONSTANT Q \ points to Q's data 20 MALLOC CONSTANT QREGS \ points to a workspace for Q operations \ ============================ \ Compiler Directive to create a BLWP sub-program \ ... THAT CALLS ITSELF! : PROG: ( wksp -- ) CREATE ( wksp) , HERE CELL+ , !CSP ;CODE *W BLWP, NEXT, ENDCODE : ;PROG ( -- ) ?CSP ; \ check stack position for junk left on it : [TOS] 8 R13 () ; \ macro for Forth's TOS register \ ============================ \ create sub-programs QREGS PROG: INIT-QREGS \ code that initializes wksp \ R0 is character input buffer R8 Q LI, \ R8 holds the Q data buffer address R9 CLR, \ R9 is the input pointer R10 CLR, \ R10 is the output pointer RTWP, ;PROG \ code to enqueue a byte in 'Q' QREGS PROG: ENQ ( c -- ? ) \ put byte in Q, return error code R9 INC, \ inc input pointer R9 QMASK ANDI, \ binary wrap around R9 R10 CMP, \ did we hit the out pointer? NE IF, [TOS] SWPB, \ fix byte order [TOS] Q R9 () MOVB, \ move char in TOS to Q(R9) [TOS] CLR, \ reset TOS, it's the return value ELSE, [TOS] SETO, \ return true as error flag ENDIF, RTWP, \ return to Forth ;PROG \ DEQ requires we put a zero on the Forth stack. \ This makes room on the Forth stack for the return data QREGS PROG: DEQ ( 0 -- c) \ returned char can be any byte value. [0..255] R9 R10 CMP, NE IF, R10 INC, \ bump out pointer R10 QMASK ANDI, \ wrap pointer Q R10 () [TOS] MOVB, \ take char from Q->Forth tos [TOS] SWPB, \ fix the byte order ELSE, [TOS] SETO, \ no data, return -1 ENDIF, RTWP, ;PROG \ qdata? requires we put a zero on the Forth stack. \ This makes room on the Forth stack for the return flag QREGS PROG: QSTAT ( 0 -- ?) \ true means data waiting R9 R10 CMP, NE IF, [TOS] SETO, ENDIF, RTWP, ;PROG \ Hi-level Forth API to the sub-programs : QDATA? ( -- ?) 0 QSTAT ; : QC! ( c -- ) ENQ ABORT" Q full" ; : QC@ ( -- c |-1) 0 DEQ DUP TRUE = ABORT" Q empty" ; : Q$! ( addr len -- ) BOUNDS DO I C@ QC! LOOP ; : QEMIT ( -- ) BEGIN QDATA? WHILE QC@ EMIT REPEAT ; : INIT-Q QREGS 20 0 FILL Q QSIZE 0 FILL INIT-QREGS ; : TEST ( -- ) INIT-Q PAGE ." Testing character Queue" BEGIN CR CR ." Loading 5 strings into Q..." S" String #1. " Q$! S" String #2. " Q$! S" String #3. " Q$! S" String #4. " Q$! S" String #5. " Q$! CR CR ." Reading ALL strings..." CR QEMIT CR ?BREAK AGAIN ; Edited August 14, 2018 by TheBF 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted August 14, 2018 Author Share Posted August 14, 2018 Does this look like Forth? CREATE FRUIT { " Apples" " Oranges" } ok FRUIT {LEN} . 2 ok CREATE NAMES { " Bob" "Carol" "Ted" "Alice" } I revisited an old post on Rosetta Code and updated it. The problem task was to count the number of elements in an array that contain two strings. One of the fun things about playing with Forth is inventing the way you want your program to look by making it yourself. I saw how this was done in Factor and imitated it somewhat which makes very nice to use. http://www.rosettacode.org/wiki/Array_length#Forth I need to add more functions to this concept. The spoiler shows what I have so far. \ string array meta language : STRING, ( caddr len -- ) \ Allocate space & compile string into memory HERE OVER CHAR+ ALLOT PLACE ; : " ( -- ) [CHAR] " PARSE STRING, ; \ Parse input to " and compile to memory \ Array delimiter words : { ALIGN 0 C, ; \ Compile 0 byte start/end of array : } ALIGN 0 C, ; \ String array words : {NEXT} ( str -- next_str) \ Iterate to next string COUNT + ; : {NTH} ( n array_addr -- str) \ Returns address of the Nth item in the array SWAP 0 DO {NEXT} LOOP ; : {LEN} ( array_addr -- ) \ count strings in the array 0 >R \ Counter on Rstack {NEXT} BEGIN DUP C@ \ Fetch length byte WHILE \ While true R> 1+ >R \ Inc. counter {NEXT} REPEAT DROP R> ; \ return counter to data stack : {.} ( $ -- ) COUNT TYPE ; : '"' [CHAR] " EMIT ; : {""} ( $ -- ) '"' SPACE {.} '"' SPACE ; : }PRINT ( n array -- ) SWAP {NTH} {.} ; : {LIST} ( array_addr -- ) \ count strings in the array CR ." { " {NEXT} BEGIN DUP C@ \ Fetch length byte WHILE \ While true DUP {""} {NEXT} REPEAT DROP ." }" ; CREATE OZ { " LIONS" " and" " TIGERS" " and" " BEARS" " OH MY!" } 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted August 16, 2018 Author Share Posted August 16, 2018 (edited) Adding CALLCHAR to Camel99 Forth I had avoided making character patterns the way TI BASIC does it because I felt that converting the 16 digit text string to binary was needless when I could simple convert 4 separate integers. When I took a run at making a word to do it, a long time ago, it always turned into something too complicated so I abandoned it. I was playing with a little string tool called CHOP and I realized it could be part of the solution. CHOP takes a string and cuts it at the place you specify returning the two pieces on the data stack. Because the remainder string is on top you can CHOP a string over and over. So 1st I took the pattern string like: S" AAAABBBBCCCCDDDD" and did 4 CHOP 4 CHOP 4 CHOP which gives 4 strings on the data stack: S" AAAABBBBCCCCDDDD" 4 CHOP 4 CHOP 4 CHOP TYPE DDDD ( <-- TOP of stack) TYPE CCCC TYPE BBBB TYPE AAAA CHOP is very fast because it does not copy strings into memory. It starts with the address and length of the string and simply calculates a new address and new length for whatever you CHOP. This is 10X faster than copying sub-strings into memory. So with CHOP I could get 4 hex strings, convert them to integers and write them to VDP memory. Then I realized that ANS Forth has a 32 bit string->integer convertor word! So this means I could cut the big string into just 2 parts and convert each part into 32 bit numbers which is 2X faster. So this version of CALLCHAR is not too slow however it is still many times slower than using CHARDEF, which takes binary data in CPU ram and "blits" all 8 bytes into VDP RAM at once. However if you are setting character patterns while your program is loading (at compile time) then it very convenient and does not affect runtime at all. But if you do this: : ASQUARE S" FFFFFFFFFFFFFFFF" 93 CALLCHAR ; … and use ASQUARE repeatedly in your program know that it will be a little slow because the conversion is being done every time ASQUARE runs. The current version is writing to VDP memory at runtime, but now that the conversion is pretty efficient, the next step would be to compile the binary data into CPU RAM and feed that to CHARDEF when needed. Hmm... I think it's time to re-look at the word PATTERN: FYI: This effort is all about trying to bridge the gap for the BASIC programmer looking to try Forth. \ CALLCHAR for CAMEL99 Forth BJF Aug 2018 \ Usage: \ DECIMAL \ S" FFFF0000FFFF0000" 92 CALLCHAR INCLUDE DSK1.TOOLS.F INCLUDE DSK1.GRAFIX.F : CHOP ( addr len n -- addr len addr len ) >R \ Rpush n 2DUP DROP R@ \ dup $, do left$ 2SWAP \ put original $ on top R> /STRING ; \ cut remainder string : >UINT32 ( addr len -- d ) \ hex string->unsigned 32 bit integer BASE @ >R HEX 0 0 2SWAP >NUMBER ABORT" bad int" DROP R> BASE ! ; : CALLCHAR ( addr len char-- addr ) ]PDT >R \ rpush pat. desc. table address 8 CHOP \ chop string in half >UINT32 R@ 4 + V! \ convert 8 digits and write to VDP R@ 6 + V! >UINT32 R@ V! \ convert 8 digits and write to VDP R> 2+ V! ; Edited August 16, 2018 by TheBF Quote Link to comment Share on other sites More sharing options...
+TheBF Posted August 17, 2018 Author Share Posted August 17, 2018 (edited) So armed with these 2 new words CHOP and >UINT32 I decided to do this the Forth way. I extended the compiler and made a word that creates new words. This is very much like an object constructor to use modern lingo. The new word creator is call SHAPE: When you create a new Shape you give it a character pattern and SHAPE: remembers that pattern in its own little memory space. SHAPE: also lets you name that pattern and records the new word name in the Forth Dictionary. It looks like this: S" FFFFFFFFFFFFFFFF" SHAPE: ASQUARE OK. So that's pretty straightforward except that ASQUARE is not just a dumb little structure with some data in it. No! ASQUARE knows how to write it's pattern into the VDP RAM memory where the pattern descriptions are kept. Yes! ASQUARE can do stuff. In fact if you give ASQUARE an ascii number it knows how to find the VDP pattern location for that ASCII character AND it will write the pattern that you gave it earlier directly into the pattern table. So you can say this: CHAR A ASQUARE CHAR Q ASQUARE 150 ASQUARE 158 ASQUARE And all four characters will now look like square blocks. Here is the code for SHAPE: : CHOP ( addr len n -- addr len addr' len' ) >R \ Rpush n 2DUP DROP R@ \ dup $, do left$ ** see footnote: 2SWAP \ put original $ on top R> /STRING ; \ cut remainder string : >UINT32 ( addr len -- d ) \ hex string->unsigned 32 bit integer BASE @ >R HEX 0 0 2SWAP >NUMBER ABORT" bad int" DROP R> BASE ! ; : SHAPE: ( addr len -- addr) \ S" FFFFFFFFFFFFFFFF" SHAPE: ASQUARE \ COMPILE TIME behavioue CREATE \ create a name in dictionary 8 CHOP 2SWAP \ chop the stack string into 2 strings >UINT32 , , \ convert & compile 1st 2 integers >UINT32 , , \ convert & compile 2nd 2 integers \ RUNTIME behavior DOES> ( char DataAddr -- ) \ CHAR X ASQUARE changes X to a square SWAP ]PDT 8 VWRITE ; \ compute PDT address of char \ write 8 bytes to VDP ** Doing a LEFT$ operation on a stack string is so easy it's hard to believe. Given a stack string (address length) combination on the data stack, all you do is DROP length and put your new length in it's place. So simple and very fast. Edited August 17, 2018 by TheBF 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted August 27, 2018 Author Share Posted August 27, 2018 Struggling with Eliza Many many years ago I found a version of *Eliza the classic Lisp chatbot program, written in a dialect of BASIC. Naturally I spent a bunch of time converting it to TI-BASIC. Truth be told it was the funniest before I had it debugged because the responses were totally unpredictable. One of the things that was difficult about doing Eliza in line-numbered BASIC was that making changes to the keywords and responses was very manual. I always thought there had to be a way to make it easier in Forth but never got around to it. It's a pretty big program coming in at 664 lines. I added some Forth words to create lists of strings and a few operations for those lists. This really helped to make editing simpler. Example: CREATE KEYWORDS \ original Eliza keywords { " COMPUTER" " NAME" " SORRY" " I REMEMBER" " DO YOU REMEMBER" " I DREAMT" " DREAM ABOUT" " DREAM" " MY MOTHER" " MY FATHER" " I WANT" " I AM GLAD" " I AM SAD" " ARE LIKE" " IS LIKE" " ALIKE" " I WAS" " WAS I" " I AM" " AM I" " AM" " ARE YOU" " YOU ARE" " BECAUSE" " WERE YOU" " I FEEL" " I FELT" " WHY DON'T YOU" " YES" " NO" " SOMEONE" " EVERYONE" " ALWAYS" " WHAT" " PERHAPS" " ARE" " BYE" " CONSOLE" } Here is the reply compiler. It takes the list and gives it a name in the Forth dictionary. It also creates 2 internal variables that record the length of the list (how many strings) and another that keeps track of which one you last printed, automatically incrementing that counter each time. Here is a sample reply list: '{ " What would it mean if you got~" " Why do you want~" " Suppose you soon got~" " What if you never got~" } REPLY: IWANT I kind of like the final program : ELIZA ( -- ) TEXT WHT/BLK COLLAPSE ( reset string stack) S" Eliza" BIG.TYPE CR GREETING BEGIN LISTEN ANALYZE REPLY AGAIN ; The spoiler has the program and there is video of a quick interaction on GitHub : https://github.com/bfox9900/CAMEL99-V2/blob/master/Video/ELIZA1.mp4 \ ELIZA in CAMEL99 Forth \ This implementation uses the Forth dictionary as a big case statement \ Eliza's KEYWORD phrases are converted to Forth words by removing the spaces \ and punctuation. \ Example: \ "I CAN'T" becomes ICANT. ICANT is a FORTH word so all we need is a word \ in the dictionary called ICANT to make something happen. \ INCLUDE DSK1.TOOLS.F \ for debugging \ ======[ punctuation characters ]====== DECIMAL CHAR ~ CONSTANT '~' \ strings that end with '~' reflect the users input CHAR , CONSTANT ',' CHAR . CONSTANT '.' \ working memory for string processing CREATE INPUT$ 81 ALLOT \ holds the "clean" reply from the patient \ === string stack in HEAP ==== VARIABLE SSP \ the string stack pointer 255 CONSTANT MXLEN \ 255 bytes is longest string MXLEN 1+ CONSTANT SSW \ width of string stack items SSW 10 * MALLOC CONSTANT $STAK \ ten strings deep (2.5 Kbytes!) : NEW: ( -- ) SSW SSP +! ; \ bump string stack pointer by 256 : COLLAPSE ( -- ) SSP OFF ; \ reset string stack pointer to zero : TOP$ ( -- $) SSP @ $STAK + ; \ string stack in dictionary \ string stack helpers ==== : SPUSH ( addr len -- top$ ) NEW: TOP$ DUP >R PLACE R> ; : ?SSP ( -- ) SSP @ 0= ABORT" Empty $ stack" ; : DROP$ ( -- ) ?SSP MXLEN NEGATE SSP +! ; : $= ( $1 $2 -- ?) S= 0= ; : POS$ ( $1 $2 -- n ) \ return "position" $1 in $2 DUP -ROT DUP -ROT ( -- $2 $2 $1 $2) COUNT BOUNDS DO I OVER COUNT $= IF NIP I SWAP LEAVE THEN LOOP DROP - ABS ; \ special case that checks for trailing space after matched word : MATCH$ ( $1 $2 -- n ) \ return "position" $1 in $2 DUP -ROT DUP -ROT ( -- $2 $2 $1 $2) COUNT BOUNDS DO I OVER COUNT \ ( -- addr caddr len ) DUP I + C@ BL = >R \ check for space, rpush result $= R> AND \ if match AND a trailing space IF NIP I SWAP LEAVE THEN LOOP DROP - ABS ; \ \ ---[ utility words ]--- \ : LEN ( $ -- length) C@ ; : LASTCHAR ( $ -- c) DUP LEN + C@ ; \ get last char in a string : BETWEEN ( n min max -- ?) 1+ WITHIN ; \ is n between or equal-to min/max : FORALLCHARS ( $ -- end start) COUNT BOUNDS ; \ for DO LOOP on strings : >= ( n n -- ? ) 1- > ; : <= ( n n -- ? ) 1+ < ; : $. ( $ --) COUNT TYPE ; \ text color definitions HEX : WHT/BLK ( -- ) F1 7 VWTR ; DECIMAL \ ---[ string support ]--- : MEMBER? ( addr len char -- ? ) SCAN NIP ; \ is char in stack string addr,len : APPEND-CHAR ( char $ -- ) DUP >R \ copy string address COUNT DUP 1+ \ addr,len, len+1 R> C! \ store new length + C! ; \ put char at end of string \ --------[ STRIP$ ]-------- \ passed to STRIP$. 1st char is blank. Rest is punctutation : "NOISE" ( -- addr len) S" ,.?!'@#$[]%^&*()_+-{}:<>" ; : STRIP$ ( $ addr len -- $) \ Use: C" TEST 1 2 3" "BL" STRIP$ ROT NEW: TOP$ OFF \ set TOP$ to empty FORALLCHARS DO 2DUP I C@ MEMBER? 0= IF I C@ TOP$ APPEND-CHAR \ build new string THEN LOOP 2DROP TOP$ ; \ \ ---[ case testers ]--- \ : LOWER? ( char -- ?) [CHAR] a [CHAR] z BETWEEN ; : UPPER? ( char -- ?) [CHAR] A [CHAR] Z BETWEEN ; \ \ ---[ Forth stack string words ]--- \ : -TRAILING ( adr len -- adr len') \ remove trailing blanks (spaces) BEGIN 2DUP + 1- C@ BL = WHILE 1- REPEAT ; : TRIM ( addr len -- addr' len') BL SKIP -TRAILING ; : +CHAR ( addr len char -- addr len') >R \ save the char 2DUP + \ calc end address+1 R> SWAP C! \ store character 1+ ; \ inc length \ \ ---[ case covertors ]--- \ HEX : UPPER ( c -- c ) DUP LOWER? IF 05F AND THEN ; : LOWER ( c -- c ) DUP UPPER? IF 020 OR THEN ; : TOUPPER ( addr len -- addr len ) \ convert STACK$ to uppercase in place 2DUP BOUNDS DO I C@ UPPER I C! LOOP ; : TOLOWER ( addr len -- addr len ) \ convert STACK$ to uppercase 2DUP BOUNDS DO I C@ LOWER I C! LOOP ; : LOWER.TYPE ( adr len -- ) \ cleaning leading space, print in lower case BOUNDS ?DO I C@ LOWER EMIT LOOP ; \ ---[ list words ]--- \ CREATE {NIL} 0 , \ nil list : { ( -- ) ALIGN !CSP ; \ record stack pos. : } ( -- ) ALIGN {NIL} @ , ?CSP ; \ ends list, check stack : '{ ( -- addr) HERE { ; \ start a new list, address on stack : " ( -- ) \ compile a linked-list string HERE 0 , \ make space for link [CHAR] " WORD DUP C@ 1+ ALLOT ALIGN HERE SWAP 2- ! DROP ; \ fill in the link \ : CAR ( list -- next) @ ; \ : CDR ( list -- addr) CELL+ ; : {NEXT} ( list -- list' ) @ ; \ get next string in a list : {$} ( link -- $) CELL+ ; : {NTH} ( list n -- $addr ) \ the nth string in a list 0 ?DO {NEXT} LOOP ; : {PRINT} ( link -- ) {$} COUNT CR TYPE ; : {LEN} ( list -- n ) \ count the no. of items in a list 0 >R BEGIN {NEXT} DUP R> 1+ >R 0= UNTIL DROP R> 1- ; : {PRINT} ( list -- ) \ for viewing a list when debugging CR 0 >R BEGIN DUP @ WHILE DUP {$} COUNT DUP 4 + C/L@ > IF CR THEN TYPE ." , " {NEXT} R> 1+ >R REPEAT DROP R> CR . ." items" ; VARIABLE MFLAG \ simpler that stack juggling :-) VARIABLE POSITION \ ALSO record the position keyword in $ : {MEMBER} ( $ {list} -- -1 | ndx ) \ is ANY member of {list} in $ MFLAG ON \ -1 flag means not found SWAP COUNT NEW: TOP$ PLACE \ $ goes on string stack 0 >R \ counter on rstack BEGIN DUP @ \ CAR the list WHILE DUP {$} TOP$ MATCH$ DUP POSITION ! IF R@ MFLAG ! DROP {NIL} \ drop {list}, replace with {nil} ELSE {NEXT} R> 1+ >R \ inc the counter THEN \ to end the loop REPEAT DROP$ \ clean string stack DROP \ clean data stack R> DROP MFLAG @ ; \ return the mflag value \ ---[ Traditional Eliza Banner Printer ]=== HEX : ]PDT ( char# -- 'pdt[n] ) 8* 800 + ; \ character bit-map table VARIABLE LETTER : BIG.TYPE ( addr len -- ) 8 0 DO CR ( str len) 2DUP BOUNDS ?DO I C@ DUP LETTER ! ]PDT J + VC@ \ PDT char, byte# J from VDP RAM 2 7 DO \ from bit# 7 to 2 DUP 1 I LSHIFT AND \ mask out each bit IF LETTER @ EMIT \ if true emit a character ELSE SPACE \ else print space THEN -1 +LOOP DROP LOOP ( str len) LOOP 2DROP ; \ =========================[ ELIZA BEGINS ] ======================== \ --- REFLECTIONS --- CREATE PHRASES { " I AM" \ 0 " I HAVE" \ 1 " I'VE" \ 2 " I'M" \ 3 " I WILL" \ 4 " I'D" \ 5 " I'LL" \ 6 " MINE" \ 7 " ARE" \ 8 " WERE" \ 9 " ME" \ 11 " YOUR" \ 12 " IS" \ 13 " MY" " I" " YOU" } CREATE CONJUGATIONS \ trailing space needed for correct printing { " YOU ARE " \ 0 " YOU'VE " \ 1 " YOU'VE " \ 2 " YOU'RE " \ 4 " YOU'LL " \ 5 " YOU WOULD " \ 6 " YOU WILL " \ 7 " YOURS " \ 8 " AM " \ 9 " WAS " \ 9 " YOU " \ 11 " MY " \ 12 " BEING " \ 13 " YOUR " " YOU " " I " } CONJUGATIONS {LEN} CONSTANT #CONJUGATES : ]PHRASE ( n -- $) PHRASES SWAP {NTH} {$} ; : ]CONJUGATE ( n -- $) CONJUGATIONS SWAP {NTH} {$} ; \ ---[ KEYWORDS ]--- \ DECIMAL CREATE KEYWORDS \ original Eliza keywords { " COMPUTER" " NAME" " SORRY" " I REMEMBER" " DO YOU REMEMBER" " I DREAMT" " DREAM ABOUT" " DREAM" " MY MOTHER" " MY FATHER" " I WANT" " I AM GLAD" " I AM SAD" " ARE LIKE" " IS LIKE" " ALIKE" " I WAS" " WAS I" " I AM" " AM I" " AM" " ARE YOU" " YOU ARE" " BECAUSE" " WERE YOU" " I FEEL" " I FELT" " WHY DON'T YOU" " YES" " NO" " SOMEONE" " EVERYONE" " ALWAYS" " WHAT" " PERHAPS" " ARE" " BYE" " CONSOLE" } : ]KEYWORD ( ndx -- $) \ keyword indexed array with protection DUP 0< IF DROP {NIL} ( return empty string) ELSE KEYWORDS SWAP {NTH} {$} THEN ; \ convert keyword# into a FORTH word by removing spaces and NOISE. \ Output is a stack string for EVALUATE to use : >ACTION ( n -- addr len ) DUP 0< ABORT" >ACTION ndx err" ]KEYWORD "NOISE" STRIP$ COUNT ; \ ============================================== \ --- REPLIES SUPPORT CODE --- : REPLY: ( list -- ) DUP {LEN} \ count the strings in the list 1- \ 1 less is the last string in the list 0 \ 0 is the first string to use ROT \ put the list address on top CREATE \ create a Forth name for the list , \ compile list addres , \ compile the string to use as reply , ; \ compile the list length \ given a reply address these words compute the offset of the fields : ->USE# ( replyaddr -- fld_addr) CELL+ ; : ->CNT# ( replyaddr -- fld_addr) 2 CELLS + ; : ->LIST ( replyaddr -- fld_addr) {NEXT} ; : ->1ST$ ( replyaddr -- $ ) {NEXT} {$} ; \ returns 1st string in list : REPLY$ ( replyaddr -- $ ) DUP ->USE# @ SWAP ->LIST SWAP {NTH} {$} ; : LASTREPLY? ( replyaddr -- ) ->USE# 2@ = ; \ compare CNT# & USE#. : REPLY++ ( replyaddr -- ) \ circular increment USE# DUP LASTREPLY? IF ->USE# OFF ELSE 1 SWAP ->USE# +! THEN ; : {REPLY} ( keyword# -- {list}) >ACTION EVALUATE ->LIST ; VARIABLE ROGERIAN \ set if Rogerian answer is needed : PRINT.REPLY ( $ -- $ ) \ prints everthing up to the '~' char ROGERIAN OFF CR CR FORALLCHARS DO I C@ DUP '~' = IF DROP ROGERIAN ON LEAVE THEN EMIT LOOP SPACE ; \ dot reply prints the reply to "USE" and advances the '->USE#' or resets it to 1 : .REPLY ( reply_addr -- ) DUP REPLY$ PRINT.REPLY REPLY++ ; \ ============================= \ === REPLY LISTS === \ '{ " Are you frightened by machines?" " Are you talking about me in particular?" " What do you think computers have to do with your problem?" " Don't you think computers can help people?" " What is it about machines that worries you?" } REPLY: COMPUTER '{ " Names don't interest me." " I don't care about names. Go on." } REPLY: NAME '{ " Please don't apologize." " Apologies are not necessary." " What feelings do you get when you apologize?" } REPLY: SORRY '{ " Do you often think of~" " Does thinking of this bring anything else to mind~" " What else do you remember?" " Why do you recall this right now?" " What in the present situation reminds you of~" " What is the connection between me and~" } REPLY: IREMEMBER '{ " Did you think I would forget~" " Why do you think I should recall~" \ now " What about~" " You mentioned!" \ this should bring back word from Remember " Do you really think its likely that~" " Do you wish that~" " What do you think about~" " Really-- if!" } REPLY: DOYOUREMEMBER '{ " Really--~" " Have you ever fantasized about this while you were awake?" " Have you dreamt about this before?" } REPLY: IDREAMT '{ " In reality, how do you feel about~" } REPLY: DREAMABOUT '{ " What does this dream suggest to you?" " Do you dream often?" " What persons appear in your dreams?" " Don't you believe that dream has to do with your problem?" } REPLY: DREAM '{ " Who else in your family~" " Tell me more about your family" } REPLY: MYMOTHER '{ " Your father~" " Does he influence you strongly?" " What else comes to mind when you think of your father?" } REPLY: MYFATHER '{ " What would it mean if you got~" " Why do you want~" " Suppose you soon got~" " What if you never got~" } REPLY: IWANT '{ " How have I helped you to be~" " What makes you happy just now?" " Can you explain why you are suddenly~" } REPLY: IAMGLAD '{ " I am sorry to hear you are depressed" " I'm sure its not pleasant to be saD" } REPLY: IAMSAD \ (((?* ?x) are like (?* ?y)) NEED TO ADD THIS CAPABILITY '{ " What resemblance do you see between them?" } REPLY: ARELIKE \ (((?* ?x) is like (?* ?y)) NEED TO ADD THIS CAPABILITY '{ " In what way is it that the two are alike?" " What resemblance do you see?" " Could there really be some connection?" " How?" } REPLY: ISLIKE '{ " In what way?" " What simililarities do you see?" " How?" } REPLY: ALIKE '{ " Were you really?" " Perhaps I already knew you were~" " Why are you telling you were~" } REPLY: IWAS '{ " What if you were~" " Do you think you were~" " What would it mean if you were~" } REPLY: WASI '{ " In what way are you~" " Do you want to be~" } REPLY: IAM '{ " Do you believe you are~" " Would you want to be~" " You wish I would tell you you are~" " What would it mean if you were~" } REPLY: AMI '{ " Why do you say 'AM?'" " I don't understand that." } REPLY: AM '{ " Why are you interested in whether or not i am~" " Would you prefer if i were not~" " Perhaps in your fantasies i am~" } REPLY: AREYOU '{ " What makes you think i am~" } REPLY: YOUARE '{ " Is that the real reason?" " Do any other reasons come to mind?" " Does that reason explain anything else?" } REPLY: BECAUSE '{ " Perhaps I was~" " What do you think?" " What if I had been~" } REPLY: WEREYOU '{ " Maybe NOW you could~" " What if you could~" } REPLY: ICANT '{ " How often do you feel~" " Do you enjoy feeling~" } REPLY: IFEEL '{ " What other feelings do you have?" } REPLY: IFELT \ (((?* ?x) I (?* ?y) you (?* ?z)) COOL ONE! Need to do this \ (Perhaps in your fantasy we ?y each other)) '{ " Why don't you~" } REPLY: WHYDONTYOU '{ " You seem quite positive." " Are you sure?" " I understand." } REPLY: YES '{ " Are you saying 'NO' just to be negative?" " You are being a bit negative." " Why not?" } REPLY: NO '{ " Can you be more specific?" } REPLY: SOMEONE '{ " Surely not everyone" " Can you think of anyone in particular?" " Who for example?" " Are youe thinking of a special person" } REPLY: EVERYONE '{ " Can you think of a specific example" " When?" " What incident are you thinking of?" " Really-- always?" } REPLY: ALWAYS '{ " Why do you ask?" " Does that question interest you?" " What is it you really want to know?" " What do you think?" " What else comes to mind when you ask that?" } REPLY: WHAT '{ " You do not seem quite certain" } REPLY: PERHAPS '{ " Did you think they might not be~" " Possibly they are~" } REPLY: ARE : END_SESSION TEXT QUIT ; \ can change this to BYE : BYE CR ." OK. Thanks for chatting." CR ." Bye bye!" 700 MS 1500 MS END_SESSION ; '{ " What does that suggest to you?" " I see." " I'm not sure I understand you fully." " Can we get back to the topic of your mental health?" " Can you expand on that a bit?" " That is quite interesting. Tell me more. " " Are you being honest?" } REPLY: TAPDANCE : CONSOLE CR CR ." Exiting program..." CR ." CAMEL99 FORTH" CR QUIT ; \ ------------------[ replies end ]----------------- \ /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ : GREETING ( -- ) CR ." ===================================" CR CR ." Hi! My name is Eliza." CR ." Can I help you?" ; : $ACCEPT ( $addr -- ) DUP 1+ 80 ACCEPT SWAP C! ; : READLINE ( $ -- addr len ) \ **returns a stack string ** CR BEEP ." >" $ACCEPT ; : LISTEN ( -- $ ) BEGIN PAD DUP READLINE LEN 0> UNTIL PAD COUNT TRIM TOUPPER BL +CHAR INPUT$ PLACE INPUT$ ; \ "cut tail" of INPUT$ \ return everything after the keyword phrase as stack string : /TAIL ( keyword input$ -- adr len) \ "cut tail" 2DUP POS$ >R \ -- key input SWAP LEN \ -- input length R> + \ -- input offset SWAP COUNT ROT /STRING ; : 3RD ( a b c -- a b c a ) 2 PICK ; : SPLIT ( addr len char -- str1 len1 str2 len2) >R 2DUP R> SCAN 2SWAP 3RD - ; : /WORD ( addr len char -- 1word len remainder len) SPLIT 1+ ( add one to include the trailing space) 2SWAP 1 /STRING ; : CONJUGATE$ ( $ -- $ | $') \ check for PHRASES membership DUP PHRASES {MEMBER} DUP 0< \ ( -- $ ndx ?) IF \ not a member DROP \ drop ndx, keep original $ ELSE NIP \ remove original $, keep ndx ]CONJUGATE \ replaced with conjugate THEN ; : /CONJUGATE ( addr len -- ) TRIM BEGIN DUP 0> ( len>0 ?) WHILE BL /WORD 2SWAP SPUSH \ cut each word->string stack CONJUGATE$ COUNT LOWER.TYPE COLLAPSE ( string stack) REPEAT 2DROP ; DECIMAL \ keywords are found by {MEMBER} which scans $ for any MEMBER of the list : ANALYZE ( $ -- 0 | ndx) KEYWORDS {MEMBER} ; : REPLY ( n -- ) \ n= keyword index DUP -1 = IF ( no matching keyword) DROP TAPDANCE .REPLY ELSE ( keywords found) DUP >ACTION EVALUATE .REPLY ROGERIAN @ IF ( n) ]KEYWORD INPUT$ /TAIL /CONJUGATE ELSE DROP THEN THEN ; DECIMAL : ELIZA ( -- ) TEXT WHT/BLK COLLAPSE ( reset string stack) S" Eliza" BIG.TYPE CR GREETING BEGIN LISTEN ANALYZE REPLY AGAIN ; * https://en.wikipedia.org/wiki/ELIZA 5 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted August 31, 2018 Author Share Posted August 31, 2018 My objective with CAMEL99 Forth was to create some "training wheels" for someone who is a TI-BASIC programmer but wanted to try Forth. I am not sure that it is as painless as I wanted it to be. :-) I suppose the only way to be truly painless would be to write a BASIC language in Forth. Here is an example I used from the TI-BASIC User Reference Guide that is in the CAMEL99 Document. 100 REM Random Color Dots 110 RANDOMIZE 120 CALL CLEAR 130 FOR C=2 TO 16 140 CALL COLOR(C,C,C) 150 NEXT C 160 N=INT(24*RND+1) ( N is the note value) 170 Y=110*(2^(1/12))^N ( this calculates a musical note frequency) 180 CHAR=INT(120*RND)*40 190 ROW=INT(23*RND)+1 200 COL=INT(31*RND)+1 210 CALL SOUND(-500,Y,2) 220 CALL HCHAR(ROW,COL,CHAR) 230 GOTO 160 And here is how it looks in CAMEL99 Forth with "training wheels included" \ Random Color Dots INCLUDE DSK1.RANDOM.F INCLUDE DSK1.SOUND.F INCLUDE DSK1.CHARSET.F INCLUDE DSK1.GRAFIX.F DECIMAL : SET-COLORS ( -- ) 19 4 DO I I I COLOR LOOP ; \ lines 130,140,150 \ rather than use variables we make words with the same names \ that calculate the numbers we need and leave them on the stack : Y ( -- n ) 1001 RND 110 + ; \ does not calc. musical notes. : CHR ( -- n ) 79 RND 32 + ; : ROW ( -- n ) 23 RND ; : COL ( -- n ) 31 RND ; \ create a SOUND word from primitives HZ DB MS MUTE : SOUND ( dur freq att --) DB HZ MS MUTE ; : RUN ( -- ) RANDOMIZE CLEAR SET-COLORS BEGIN GEN1 125 Y -2 SOUND \ Use Generator #1. Controls speed also COL ROW CHR 1 HCHAR ?TERMINAL \ check for the break key UNTIL 8 SCREEN \ restore things like BASIC does 4 19 2 1 COLORS \ change char sets 4..19 CHARSET ; Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 1, 2018 Author Share Posted September 1, 2018 V 2.0.22 : Multi-task Friendly VDP I/O and Numeric Conversion I am really liking 9900 indexed addressing these days. I have re-written the ASM I/O primitives in the CAMEL99 Kernel so they use USER variables rather that absolute variable addresses. USER variables are a table of variables created for each task (including the root task). These variables are referenced based on base address of the task. In CAMEL99 we have expanded the concept of the 9900 Workspace so that after the registers there is a table of USER variables. The USER VARIABLES are reference by putting the workspace address into a register with the STWP instruction and using indexed addressing to get their address. This added very little complexity to the system and it now means that each task can reference its own cursor positions and print numbers without messing up another task because there is separate copy of all the needed variables for each task and the system I/O routines automagically select the correct variable addresses. Update Notes: Sept 1, 2018 V2.0.22- V2.0.22 now can print text and numbers to VDP screen from any task- Changes to Video i/o primitives so they are multi-tasking friendly. ASM code now uses USER variable indexed addressing so that variables VROW VCOL C/L and OUT are unique for every task.- HOLD reverted back to Forth version for multi-tasking- Added TPAD USER VARIABLE which holds the offset of PAD from HERE. By setting TPAD to bigger number for other tasks, each task gets a PAD and HOLD buffer in unallocated dictionary memory. The spoiler shows the current USER variable list in CAMEL99 Forth. Many are commented out in the kernel to save dictionary space in the Kernel. \ USER 0..1F are CPU workspace registers \ 0 USER: 'R0 \ 2 USER: 'R1 \ 4 USER: 'R2 \ 6 USER: 'R3 \ 8 USER: 'R4 \ A USER: 'R5 \ C USER: 'R6 \ E USER: 'R7 \ 10 USER: 'R8 \ 12 USER: 'R9 \ 14 USER: 'R10 \ 16 USER: 'R11 \ 18 USER: 'R12 \ 1A USER: 'R13 \ 1C USER: 'R14 \ 1E USER: 'R15 \ ( *not all USER vars are named to save KERNEL space* ) 20 USER: TFLAG \ TASK flag awake/asleep status 22 USER: JOB \ Forth word that runs in a task 24 USER: DP \ dictionary pointer 26 USER: HP \ hold pointer, for text->number convertion 28 USER: CSP 2A USER: BASE 2C USER: >IN \ 2E USER: 'EMIT \ vector for char. output routine \ 30 USER: 'CR \ vector for carriage return \ 32 USER: 'KEY \ vector for wait-for-key \ 34 USER: 'KEY? \ vector for key pressed test \ 36 USER: 'TYPE \ vector for block output \ 38 USER: 'PAGE \ vector for screen clear 3A USER: LP \ LEAVE stack pointer. 3C USER: SOURCE-ID \ 0 for console, -1 for EVALUATE, 1 for include 3E USER: 'SOURCE \ WATCH OUT! This is 2variable, occupies 3E and 40 \ 40 USER: ------- \ used by 'SOURCE \ 42 USER: CURRENT \ 44 USER: CONTEXT \ 46 USER: LH \ local TASK HEAP pointer if needed 48 USER: OUT \ counts chars since last CR (newline) 4A USER: VROW \ current VDP column (in fast RAM) 4C USER: VCOL \ current VDP row (in fast RAM) 4E USER: C/L \ Chars per line (32 or 40 depending on VDP mode) 50 USER: C/SCR \ chars per screen >300 or 3C0 52 USER: 'INTERPRET \ Vector for the interpreter \ 54 USER: --- 1+ DSRSIZ \ O/S use *PROTECTED IN ROOT TASK, Free for other tasks \ 56 USER: --- DSRNAM \ O/S use *PROTECTED IN ROOT TASK, Free for other tasks \ 58 USER: --- \ O/S use *PROTECTED IN ROOT TASK, Free for other tasks 5A USER: TPAD \ offset used so each task has a separate PAD \ 5C USER: \ Free user variable \ 5E USER: \ Free user variable \ 60 USER: \ Free user variable \ 62 USER: \ Free user variable \ 64 USER: \ Free user variable \ 66 USER: \ Free user variable \ 68 USER: \ Free user variable \ 6A USER: \ Free user variable \ 6C USER: \ Free user variable \ 6E USER: \ Free user variable 2 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 1, 2018 Share Posted September 1, 2018 My objective with CAMEL99 Forth was to create some "training wheels" for someone who is a TI-BASIC programmer but wanted to try Forth. I am not sure that it is as painless as I wanted it to be. :-) I suppose the only way to be truly painless would be to write a BASIC language in Forth. Here is an example I used from the TI-BASIC User Reference Guide that is in the CAMEL99 Document. 100 REM Random Color Dots 110 RANDOMIZE 120 CALL CLEAR 130 FOR C=2 TO 16 140 CALL COLOR(C,C,C) 150 NEXT C 160 N=INT(24*RND+1) ( N is the note value) 170 Y=110*(2^(1/12))^N ( this calculates a musical note frequency) 180 CHAR=INT(120*RND)*40 190 ROW=INT(23*RND)+1 200 COL=INT(31*RND)+1 210 CALL SOUND(-500,Y,2) 220 CALL HCHAR(ROW,COL,CHAR) 230 GOTO 160 And here is how it looks in CAMEL99 Forth with "training wheels included" \ Random Color Dots INCLUDE DSK1.RANDOM.F INCLUDE DSK1.SOUND.F INCLUDE DSK1.CHARSET.F INCLUDE DSK1.GRAFIX.F DECIMAL : SET-COLORS ( -- ) 19 4 DO I I I COLOR LOOP ; \ lines 130,140,150 \ rather than use variables we make words with the same names \ that calculate the numbers we need and leave them on the stack : Y ( -- n ) 1001 RND 110 + ; \ does not calc. musical notes. : CHR ( -- n ) 79 RND 32 + ; : ROW ( -- n ) 23 RND ; : COL ( -- n ) 31 RND ; \ create a SOUND word from primitives HZ DB MS MUTE : SOUND ( dur freq att --) DB HZ MS MUTE ; : RUN ( -- ) RANDOMIZE CLEAR SET-COLORS BEGIN GEN1 125 Y -2 SOUND \ Use Generator #1. Controls speed also COL ROW CHR 1 HCHAR ?TERMINAL \ check for the break key UNTIL 8 SCREEN \ restore things like BASIC does 4 19 2 1 COLORS \ change char sets 4..19 CHARSET ; Line 180 of the TI Basic program should end with “+40”, not “*40” (see the TI User’s Reference Guide). Adding 40 gives a range of 40 – 159, which makes sense because the highest character code for TI Basic is 159. Also, should not the numbers consumed by RND in CHR, ROW and COL each be one higher to give maximum values of 111, 23 and 31, respectively? On another note, attempting to convert this little program to run in fbForth 2.0 revealed a bug in my SOUND word that I must fix before I release Build 11. I need to tell @Willsy that he has the same problem in TurboForth because I copied his code! [Edit: The code looks to be correct, but something was not working properly. I will post more in proper thread. between my ears!] ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 2, 2018 Author Share Posted September 2, 2018 Line 180 of the TI Basic program should end with “+40”, not “*40” (see the TI User’s Reference Guide). Adding 40 gives a range of 40 – 159, which makes sense because the highest character code for TI Basic is 159. Also, should not the numbers consumed by RND in CHR, ROW and COL each be one higher to give maximum values of 111, 23 and 31, respectively? On another note, attempting to convert this little program to run in fbForth 2.0 revealed a bug in my SOUND word that I must fix before I release Build 11. I need to tell @Willsy that he has the same problem in TurboForth because I copied his code! ...lee Ah right on line 180. Thanks. Yes you are correct on the CHR,ROW AND COL values. I should add a 1+. And for once I accidentally found a bug for you. B Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 2, 2018 Share Posted September 2, 2018 Ah right on line 180. Thanks. Yes you are correct on the CHR,ROW AND COL values. I should add a 1+. Won’t that cause the ranges to start at 1 when they should(?) start at 0 for ROW and COL? And for once I accidentally found a bug for you. I think the bug was between my ears! I will post an fbForth version shortly. ...lee Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 2, 2018 Share Posted September 2, 2018 Here is an fbForth version of “Random Color Dots” (see post #158): \ "Random Color Dots"--conversion of TI Basic example from TI-99/4A \ _User's Reference Guide_, p. 259 through Camel99 Forth to fbForth 2.0 DECIMAL : SET-COLORS ( -- ) \ lines 130,140,150 19 4 DO I I I COLOR LOOP ; \ Rather than use variables, we make words with the same names \ that calculate the numbers we need and leave them on the stack. : Y ( -- n ) \ lines 160,170 [floating point (FP) calculations] >F 111860.8 \ K: FP sound chip frequency constant >F 1.059463094359 \ FP tone-step base = 2^(1/12) 24 RND S->F \ N: FP tone-step base exponent for 24 half \ tones from 110 Hz to 415 Hz ^ \ (2^(1/12))^N in FP >F 110 F* \ F: FP frequency of new note F/ \ K/F: FP frequency code for SOUND chip F->S ; \ K/F converted to integer for SOUND-chip input : CHR ( -- n ) 80 RND 32 + ; \ line 180 [range: 32-111] : ROW ( -- n ) 24 RND ; \ line 190 [range: 0-23] : COL ( -- n ) 32 RND ; \ line 200 [range: 0-31] : BASIC-MODE ( -- ) 5911 ( 1717h) DCT 4 + ! \ store black/cyan in default color table GRAPHICS ; \ set GRAPHICS mode as in TI BASIC : WAIT ( ms -- ) \ approx. ms of time to wait 0 DO 10 0 DO LOOP LOOP ; : RUN ( -- ) BASIC-MODE RANDOMIZE CLS SET-COLORS BEGIN Y 0 0 SOUND \ use Generator #1--also controls pitch 100 WAIT \ wait ~100 ms COL ROW 1 CHR HCHAR ?TERMINAL \ check for the break key UNTIL 0 15 0 SOUND \ mute Generator #1 BASIC-MODE ; \ restore things like BASIC does ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 2, 2018 Author Share Posted September 2, 2018 Won’t that cause the ranges to start at 1 when they should(?) start at 0 for ROW and COL? I think the bug was between my ears! I will post an fbForth version shortly. ...lee Yes, and it appears that I have to look at my PRNG. It seems to not work well with even numbers. I like it because it did not repeat for 64K numbers, but it has other issues. It never ends... B Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 2, 2018 Author Share Posted September 2, 2018 Here is an fbForth version of “Random Color Dots” (see post #158): \ "Random Color Dots"--conversion of TI Basic example from TI-99/4A \ _User's Reference Guide_, p. 259 through Camel99 Forth to fbForth 2.0 DECIMAL : SET-COLORS ( -- ) \ lines 130,140,150 19 4 DO I I I COLOR LOOP ; \ Rather than use variables, we make words with the same names \ that calculate the numbers we need and leave them on the stack. : Y ( -- n ) \ lines 160,170 [floating point (FP) calculations] >F 111860.8 \ K: FP sound chip frequency constant >F 1.059463094359 \ FP tone-step base = 2^(1/12) 24 RND S->F \ N: FP tone-step base exponent for 24 half \ tones from 110 Hz to 415 Hz ^ \ (2^(1/12))^N in FP >F 110 F* \ F: FP frequency of new note F/ \ K/F: FP frequency code for SOUND chip F->S ; \ K/F converted to integer for SOUND-chip input : CHR ( -- n ) 80 RND 32 + ; \ line 180 [range: 32-111] : ROW ( -- n ) 24 RND ; \ line 190 [range: 0-23] : COL ( -- n ) 32 RND ; \ line 200 [range: 0-31] : BASIC-MODE ( -- ) 5911 ( 1717h) DCT 4 + ! \ store black/cyan in default color table GRAPHICS ; \ set GRAPHICS mode as in TI BASIC : WAIT ( ms -- ) \ approx. ms of time to wait 0 DO 10 0 DO LOOP LOOP ; : RUN ( -- ) BASIC-MODE RANDOMIZE CLS SET-COLORS BEGIN Y 0 0 SOUND \ use Generator #1--also controls pitch 100 WAIT \ wait ~100 ms COL ROW 1 CHR HCHAR ?TERMINAL \ check for the break key UNTIL 0 15 0 SOUND \ mute Generator #1 BASIC-MODE ; \ restore things like BASIC does ...lee Ooooo I am jealous of those floating point routines. Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 3, 2018 Author Share Posted September 3, 2018 (edited) Yes, and it appears that I have to look at my PRNG. It seems to not work well with even numbers. I like it because it did not repeat for 64K numbers, but it has other issues. It never ends... B Ok I surrender... for now. I have put the TI Forth PRNG in RANDOM.F as machine code. All the methods I see online use 32 bit integers which I can do but it I want to do better analysis. My 16 BIT version of the GForth PRNG didn't repeat for 64K numbers but it was not nearly random enough. So the old TI Forth algorithm will be part of CAMEL99 until further notice. HEX 83C0 CONSTANT SEED \ TI incrementing number in main menu CODE RNDW ( -- n) 0646 , C584 , \ TOS PUSH, C0E0 , SEED , \ SEED @@ R3 MOV, 0202 , 6FE5 , \ R2 6FE5 LI, 38C2 , \ R2 R3 MPY, 0224 , 7AB9 , \ TOS 7AB9 AI, 0B54 , \ TOS 5 SRC, C804 , SEED , \ TOS SEED @@ MOV, NEXT, ENDCODE \ 24 bytes : RANDOMIZE ( n -- ) SEED ! ; : RND ( n -- n') RNDW ABS SWAP MOD ; Edited September 3, 2018 by TheBF 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 4, 2018 Author Share Posted September 4, 2018 It's Alive. Well at least the console and monitor. 2 Quote Link to comment Share on other sites More sharing options...
RickyDean Posted September 4, 2018 Share Posted September 4, 2018 (edited) It's Alive. Well at least the console and monitor. oooh, I like the original 10in monitor in the back. i used to have both types the older bigger one and this one. Edited September 4, 2018 by RickyDean Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 5, 2018 Share Posted September 5, 2018 Ok I surrender... for now. I have put the TI Forth PRNG in RANDOM.F as machine code. All the methods I see online use 32 bit integers which I can do but it I want to do better analysis. My 16 BIT version of the GForth PRNG didn't repeat for 64K numbers but it was not nearly random enough. So the old TI Forth algorithm will be part of CAMEL99 until further notice. HEX 83C0 CONSTANT SEED \ TI incrementing number in main menu CODE RNDW ( -- n) 0646 , C584 , \ TOS PUSH, C0E0 , SEED , \ SEED @@ R3 MOV, 0202 , 6FE5 , \ R2 6FE5 LI, 38C2 , \ R2 R3 MPY, 0224 , 7AB9 , \ TOS 7AB9 AI, 0B54 , \ TOS 5 SRC, C804 , SEED , \ TOS SEED @@ MOV, NEXT, ENDCODE \ 24 bytes : RANDOMIZE ( n -- ) SEED ! ; : RND ( n -- n') RNDW ABS SWAP MOD ; Just to be clear: Rather than the address of the seed, SEED in TI Forth is a word that stores the number on the stack at the seed address, >83C0. Once off of the TI-99/4A title screen, >83C0 is static unless changed programmatically. I am not sure I understand RANDOMIZE here. In TI Forth, it neither takes nor leaves anything from/on the stack. Instead, it races the ISR for the VDP interrupt in a loop that counts how many iterations it takes to catch the interrupt. That number becomes the new seed. For fbForth, I converted the high-level Forth of TI Forth: : RANDOMIZE ( --- ) 8802 C@ DROP \ clear VDP interrupt 0 \ initialize race counter BEGIN \ begin race for VDP interrupt 1+ \ increment counter 8802 C@ 80 AND \ test for VDP interrupt UNTIL SEED ; \ store count at >83C0 to ALC: * Body of RANDOMIZE--- RNDMZ DATA $+2 MOVB @>8802,R0 get VDP status byte CLR R0 discard it CLR R1 clear counter S1016A INC R1 increment counter MOVB @>8802,R0 get VDP status byte ANDI R0,>8000 VDP interrupt? JEQ S1016A no, increment counter MOV R1,@>83C0 yes, store new seed B *NEXT return to Forth inner interpreter [Aside: I just noticed that I wasted an instruction in the ALC. The ANDI instruction clears the low byte of R0, which obviates the necessity for clearing R0 ahead of the loop. ] As always, if any of my code interests you, you have carte blanche on its use. ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 5, 2018 Author Share Posted September 5, 2018 As usual I took a "slightly" different approach from what was. I looked at >83C0 in the debugger and saw that it spins in the MAIN menu until I enter the E/A menus. That gives me a pretty random number to "seed" the PRNG when you start CAMEL99 Forth so for things like games it seemed ideal. In the event that you want to start with a specific SEED value, say for a specific sequence, I used RANDOMIZE to let you set the "SEED". The word RANDOMIZE is arguably not the best choice. I can readily change it to SEED, since most of the system is a library file. Thanks for showing me the RANDOMIZE code. Isn't it strange how we see these things in our code after we present them to someone. Our focus must change somehow. I might try a different approach. There are two addresses madly incrementing all the time. >8379 and the screen time out. It would be simple to grab a byte from each and fuse them together, What do you think of that idea? HEX : RANDOMIZE ( -- ) 8379 C@ 83D7 C@ FUSE SEED ; ( FUSE is in CAMEL99 Kernel for "fusing" 2 bytes together) Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 5, 2018 Share Posted September 5, 2018 I might try a different approach. There are two addresses madly incrementing all the time. >8379 and the screen time out. It would be simple to grab a byte from each and fuse them together, What do you think of that idea? HEX : RANDOMIZE ( -- ) 8379 C@ 83D7 C@ FUSE SEED ; ( FUSE is in CAMEL99 Kernel for "fusing" 2 bytes together) Not too bad. I have thought of doing something with those counters, as well. >8379 is the VDP interrupt timer and ticks once every 1/60 second. In fact, all that TI Basic’s RANDOMIZE does is to grab that byte and jam it into the low byte of >83C0, viz., >83C1. There are a couple of potential problems with the screen timeout timer, however: The console keyboard service routine (KSR) resets it to 0 at every keystroke. The console KSR or ISR (I forget which) increments it by 2, so it is always an even number. You can change it to an odd number after each keystroke to prevent the screen timing out, but then it will always be odd until the next keystroke. ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 5, 2018 Author Share Posted September 5, 2018 (edited) I revisited the GForth PRNG and the problem I was having seems to be due to the magic number they call generator. I used 1/2 of the original 32 bit number and It was very bad. I used the TI magic number and it works quite well now and still has a repeat frequency of 64K. The other thing that I believe is good is not using MOD to get the reduced values from RND although that is hearsay to me. I don't know the math to prove it. \ GForth Random number method, modified for CAMEL Forth BJF Sept 5 2018 HEX 83C0 CONSTANT 'SEED 6FE5 CONSTANT GENERATOR : RNDW ( -- N ) GENERATOR 'SEED @ UM* DROP 1+ DUP 'SEED ! ; : RND ( N -- 0..N-1 ) RNDW UM* NIP ; 1235 'SEED ! I wrote a test that puts letters on the screen in random places until every hole is not blank. I uses an ALC version of SCAN so it goes reasonably fast. The TI version seems to take longer to get that last hole filled. 7062 vs 5169 for GForth version with the >1235 SEED Gotta go to bed now. CREATE SBUFF C/SCR @ ALLOT : SCAN-FOR-BLANKS ( -- ?) 0 SBUFF C/SCR @ VREAD \ read VDP into buffer SBUFF C/SCR @ BL SCAN NIP ; \ scan buffer for blanks VARIABLE ITERATIONS VARIABLE DUPLICATES : WAIT-KEY BEGIN KEY? UNTIL ; : UNTILFULL ( -- ) PAGE DUPLICATES OFF ITERATIONS OFF BEGIN C/SCR @ RND DUP VC@ DUP BL = IF DROP [CHAR] A SWAP VC! ELSE 1+ SWAP VC! 1 DUPLICATES +! THEN 1 ITERATIONS +! SCAN-FOR-BLANKS 0= UNTIL BEEP WAIT-KEY PAGE ." Random Screen Fill" CR CR ITERATIONS @ U. ." iterations" ( 7062 ) CR DUPLICATES @ U. ." duplicates" ( 6102 ) ; Edited September 5, 2018 by TheBF Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 5, 2018 Author Share Posted September 5, 2018 (edited) DUH! My previous GForth PRNG did not use a prime number. I believe that is why it is working better now with 28649 ( 6FE5) Now it does not repeat for 65535 numbers. In the screen fill test it took 6148 iterations to fill every position in TEXT mode with HEX 1235 as the seed value. \ GForth Random number method, modified for CAMEL Forth BJF Sept 5 2018 HEX 83C0 CONSTANT RND# \ TI incrementing number in main menu DECIMAL 28649 ( 6FE5) CONSTANT PRIME# ( PRIME number) : SEED ( n -- ) RND# ! ; : RNDW ( -- n ) PRIME# RND# @ UM* DROP 1+ DUP SEED ; : RND ( n -- 0..n-1 ) RNDW UM* NIP ; HEX : RANDOMIZE ( -- ) 8379 C@ 83D7 C@ FUSE SEED ; 1235 SEED ( COMMENT OUT IF YOU WANT RND# FROM MAIN MENU) Edited September 5, 2018 by TheBF 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 5, 2018 Share Posted September 5, 2018 DUH! My previous GForth PRNG did not use a prime number. I believe that is why it is working better now with 28649 ( 6FE5) 28649 (>6FE9) is, indeed, prime, but >6FE5 (28645) is not. It is the latter that TI used. The number (>7AB9) TI used to add to the product of >6FE5 and the value at >83C0 is not prime either. They do not have any primes in common, however. I always thought the bit pattern of the two numbers might be important, but I am not sure. It is kind of interesting that the second number is π to 5 places with 1 added to the last place—as though to insure the lowest bit is 1. In fact the lowest bit of both numbers is 1. ...lee Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 5, 2018 Share Posted September 5, 2018 Here is a much faster version of your PRNG-testing program that avoids copying the screen from VRAM to CRAM every iteration: \ Random Screen Fill that avoids using SCAN and whole-screen copying. VARIABLE BLANK_CNT VARIABLE ITERATIONS VARIABLE DUPLICATES : WAIT-KEY BEGIN KEY? UNTIL ; : UNTILFULL ( -- ) PAGE C/SCR @ BLANK_CNT ! \ initialize to screenfull of blanks DUPLICATES OFF ITERATIONS OFF BEGIN C/SCR @ RND DUP VC@ DUP BL = IF DROP [CHAR] A SWAP VC! -1 BLANK_CNT +! \ decrement blank count ELSE 1+ SWAP VC! 1 DUPLICATES +! THEN 1 ITERATIONS +! BLANK_CNT @ 0= \ did we hit all the blanks? UNTIL BEEP WAIT-KEY PAGE ." Random Screen Fill" CR CR ITERATIONS @ U. ." iterations" CR DUPLICATES @ U. ." duplicates" ; and here it is converted to fbForth: \ Random Screen Fill converted from CAMEL99 to fbForth 2.0--- \ ...avoids using SCAN and whole-screen copying 0 VARIABLE BLANK_CNT 0 VARIABLE ITERATIONS 0 VARIABLE DUPLICATES : WAIT-KEY BEGIN ?KEY UNTIL ; : UNTILFULL ( -- ) PAGE SCRN_END @ BLANK_CNT ! \ initialize to screenfull of blanks 0 DUPLICATES ! 0 ITERATIONS ! BEGIN SCRN_END @ RND DUP VSBR DUP BL = IF DROP ASCII A SWAP VSBW -1 BLANK_CNT +! \ decrement blank count ELSE 1+ SWAP VSBW 1 DUPLICATES +! THEN 1 ITERATIONS +! BLANK_CNT @ 0= \ did we hit all the blanks? UNTIL BEEP WAIT-KEY PAGE ." Random Screen Fill" CR CR ITERATIONS @ U. ." iterations" CR DUPLICATES @ U. ." duplicates" ; ...lee 1 Quote Link to comment Share on other sites More sharing options...
Like us on Facebook
Follow us on Twitter
AtariAge on Instagram
Watch us on YouTube
Chat on Discord
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.