+TheBF Posted September 15, 2023 Author Share Posted September 15, 2023 After a break and some food I have to recant my evil ways. DO LOOP makes the whole thing so simple. HEX 8800 CONSTANT VDPRD \ vdp ram read data 8802 CONSTANT VDPSTS \ vdp status 8C00 CONSTANT VDPWD \ vdp ram write data 8C02 CONSTANT VDPWA \ vdp ram read/write address \ VDP set-address sub-routines CODE 0LIMI 0 LIMI, NEXT, ENDCODE : RMODE ( vdpaddr -- ) DUP 0LIMI VDPWA C! >< VDPWA C! ; : WMODE ( vdpaddr -- ) 4000 OR RMODE ; : VC@+ ( Vdpaddr -- c) VDPRD C@ ; \ read & inc. address : VC!+ ( c --) VDPWD C! ; \ write & inc. address : VC@ ( VDP-adr -- char ) RMODE VDPRD C@ ; : VC! ( c vaddr --) WMODE VC!+ ; \ set address and write \ VDP integer fetch & store : V@ ( VDPadr -- n) VC@ VC@+ FUSE ; : V! ( n vaddr --) >R SPLIT R> VC! VC!+ ; : VWRITE ( addr Vaddr cnt -- ) SWAP WMODE 0 DO COUNT VC!+ LOOP DROP ; : VFILL ( Vaddr cnt char --) ROT WMODE SWAP 0 DO DUP VC!+ LOOP DROP ; : VREAD ( Vaddr Ram cnt --) ROT RMODE BOUNDS DO VC@+ I C! LOOP DROP ; 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 16, 2023 Author Share Posted September 16, 2023 Well as these things seem to go, I had trouble getting my DO LOOP code to work after it "recompiled" as in... it didn't work. That didn't seem obvious to fix so I moved ahead with getting text on the screen. This brought me back to the VDP and video screen control. I decided to simplify and roll the two together. I changed the name VC!+ to EMIT+ because that's what it does. and I remembered a magic word called DUP>R This improves the speed of loops with a counter on the return stack. Here is the STD-OUT.FTH file. It is pretty reasonable in terms of size for what it does. TYPE is adequately fast but VFILL would be a good candidate to recode in Forth Assembler of course. Spoiler \ Standard Forth output words COMPILER HEX TARGET 8800 CONSTANT VDPRD \ vdp ram read data \ 8802 CONSTANT VDPSTS \ vdp status 8C00 CONSTANT VDPWD \ vdp ram write data 8C02 CONSTANT VDPWA \ vdp ram read/write address \ VDP set-address sub-routines CODE 0LIMI 0 LIMI, NEXT, ENDCODE : RMODE ( vdpaddr -- ) DUP 0LIMI VDPWA C! >< VDPWA C! ; : WMODE ( vdpaddr -- ) 4000 OR RMODE ; : EMIT+ ( c --) VDPWD C! ; \ write & inc. address : VFILL ( vaddr len c -- ) ROT WMODE SWAP >R BEGIN DUP EMIT+ R> 1- DUP>R -UNTIL R> 2DROP ; VARIABLE C/L COMPILER 20 C/L T! TARGET VARIABLE COL VARIABLE ROW VARIABLE CURSOR VARIABLE C/SCR COMPILER 3C0 C/SCR T! TARGET 20 CONSTANT BL : CLIP ( n lo hi -- n) ROT MIN MAX ; : >VPOS ( col row -- vaddr) C/L @ * + ; : CURSOR ( -- Vaddr) COL @ ROW @ >VPOS 0 C/SCR @ CLIP ; : COL+! ( n -- ) COL @ + DUP C/SCR @ > IF DROP COL OFF EXIT THEN COL ! ; : ROW+! ( n -- ) ROW @ + 0 23 CLIP ROW ! ; : EMIT ( c --) CURSOR WMODE EMIT+ 1 COL+! ; : CR ( -- ) 1 ROW+! COL OFF ; : SPACE ( -- ) BL EMIT ; : TYPE ( addr len -- ) CURSOR WMODE >R BEGIN COUNT EMIT+ 1 COL+! R> 1- DUP>R -UNTIL R> 2DROP ; : AT-XY ( col row -- ) ROW ! COL ! CURSOR WMODE ; : PAGE 0 C/SCR @ 20 VFILL 0 0 AT-XY ; So with that working I figured out how to make S" work in a cross-compiled definition. That required more spells and elixirs than I bargained for but now I know how to do it. I tested it in this "hello world" program which is back to looking like alphabet soup. I will migrate S" et al back into the compiler I think, but I will need a DEFER word to handle (S") The program compiles to 770 bytes because of the extra features in the STD-OUT file which also required a lot of primitives to be "imported" But on the plus side the actual MAIN program is normal Forth code It looks like I need to make IMPORT: smarter so it only loads primitives that are not already loaded. Then I can put import statements in the library files and forget about them. Spoiler \ TESTPROG2.FTH Demo IMPORT: CODE loops and AUTOSTART Sep 2023 Fox HEX 2000 ORG \ this must be set before compiling any code INCLUDE DSK7.ITC-FORTH \ preamble for indirect threaded Forth \ extend the cross-compiler 1st COMPILER ALSO META DEFINITIONS ( this holds the "immediate" words and support ) HOST: TALIGN ( -- ) THERE ALIGNED H ! ;HOST HOST: S, ( c-addr u -- ) THERE OVER 1+ TALLOT PLACE TALIGN ;HOST \ steal needed kernel primitives COMPILER WARNINGS OFF IMPORT: DUP 2DUP SWAP DROP 2DROP OVER >< ROT IMPORT: >R R> DUP>R IMPORT: 1- 1+ 0= * + > IMPORT: C@ C! COUNT @ ! IMPORT: OR FUSE SPLIT IMPORT: ON OFF MIN MAX ALIGNED COMPILER WARNINGS ON HEX INCLUDE DSK7.STD-OUT COMPILER DECIMAL TARGET : (S") ( -- c-addr u) R> COUNT 2DUP + ALIGNED >R ; \ run-time for S" COMPILER ALSO META DEFINITIONS HOST: S" [CHAR] " PARSE TCOMPILE (S") S, ;HOST IMMEDIATE TARGET : MAIN ( -- ) 768 C/SCR ! PAGE S" HELLO WORLD" TYPE BEGIN AGAIN ; COMPILER AUTOSTART MAIN SAVE DSK7.HELLOWORLD 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 16, 2023 Share Posted September 16, 2023 1 hour ago, TheBF said: TYPE is adequately fast but VFILL would be a good candidate to recode in Forth Assembler of course. You, of course, are welcome to whatever you can use from the VFILL ASL in fbForth101_LowLevelSupport.a99. ...lee 2 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 17, 2023 Author Share Posted September 17, 2023 I have finally decided that the simplest way to run this "meta" compiler as they are called in Forth circles, is to IMPORT all the common Forth code primitives. That way you don't have to do it manually and I don't have to make a program scanner that searches for them in a first pass. The thing is that without the dictionary headers all these words take about 1K bytes. That's a pretty small run time block. The current screen output file uses another ?400 bytes. IMPORT: DUP DROP SWAP OVER ROT -ROT NIP IMPORT: C! C@ COUNT @ ! +! C+! 2! 2@ IMPORT: SP@ SP! RP@ RP! IMPORT: DUP>R >R R> R@ 2>R 2R> IMPORT: ?DUP >< 2DROP 2DUP 2SWAP PICK IMPORT: AND OR XOR IMPORT: 1+ 1- 2+ 2- 2* 4* 8* 2/ IMPORT: 1+! 1-! IMPORT: + - D+ IMPORT: RSHIFT LSHIFT INVERT ABS NEGATE ALIGNED IMPORT: UM* * UM/MOD M/MOD IMPORT: = OVER= 0< U< > < IMPORT: MIN MAX SPLIT FUSE IMPORT: MOVE FILL SKIP SCAN IMPORT: ON OFF IMPORT: BOUNDS /STRING So I rolled everything up into the ITC-FORTH preamble file. Then you just need to include your I/O file. At the moment there is just STD-OUT. And optionally you can import some of the other primitives in the system. I used ?TERMINAL in the demo below. With a different file to define the dictionary headers, I should be able to rebuild the Camel99 kernel on a TI-99! That might be a first? A language rebuilding itself on the 99. hello world looks like this. I think it's turning into a useable thing. \ HELLO.FTH for the recompiler. Demo Sep 16 2023 Fox HEX 2000 ORG \ this must be set before compiling any code INCLUDE DSK7.ITC-FORTH \ preamble for indirect threaded Forth INCLUDE DSK7.STD-OUT IMPORT: ?TERMINAL COMPILER DECIMAL TARGET : MAIN ( -- ) 768 C/SCR ! \ init this variable PAGE S" HELLO WORLD" TYPE BEGIN ?TERMINAL UNTIL BYE ; \ tell the compiler what to do with this COMPILER AUTOSTART MAIN SAVE DSK7.HELLOWORLD HOST \ return to HOST Forth \ you could automatically exit to TI-99 Main page ( BYE ) 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 17, 2023 Author Share Posted September 17, 2023 After I failed to get DO/LOOP working I thought I would take a run a something simpler. Chuck's FOR NEXT loop running on the return stack. That helped me uncovered what was wrong. (the order that you load things is critical when you have words with the same name in these @$@!# cross-compilers) Anyway.. Here is the total code to make a FOR/NEXT loop in ANS Forth. HEX CODE (NEXT) *RP DEC, \ decrement loop ON RSTACK or R15 OC IF, \ test carry flag *IP IP ADD, \ jump back: add offset value to interpreter pointer NEXT, ENDIF, RP INCT, \ remove counter from Rstack IP INCT, \ move past (LOOP)'s in-line parameter NEXT, ENDCODE : FOR ( n -- ) POSTPONE >R HERE ; IMMEDIATE : NEXT ( -- ) POSTPONE (NEXT) HERE - , ; IMMEDIATE And here is what it takes to implement the ANS compliant DO/LOOP I am now understanding why Chuck was not a big fan and why he abandoned DO/LOOP in his later years. TARGET CODE <?DO> ( limit ndx -- ) *SP TOS CMP, 1 $ JNE, TOS POP, TOS POP, IP RPOP, NEXT, +CODE <DO> ( limit indx -- ) 1 $: R0 8000 LI, *SP+ R0 SUB, R0 TOS ADD, R0 RPUSH, TOS RPUSH, TOS POP, NEXT, ENDCODE CODE <+LOOP> TOS *RP ADD, TOS POP, 2 $ JMP, +CODE <LOOP> *RP INC, 2 $: 1 $ JNO, IP INCT, 3 $ JMP, 1 $: *IP IP ADD, NEXT, +CODE UNLOOP 3 $: RP 4 AI, NEXT, ENDCODE CODE I ( -- n) TOS PUSH, *RP TOS MOV, 2 (RP) TOS SUB, NEXT, ENDCODE CODE J ( -- n) TOS PUSH, 4 (RP) TOS MOV, \ outer loop index is on the rstack 6 (RP) TOS SUB, \ index = loopindex - fudge NEXT, ENDCODE VARIABLE LP VARIABLE L0 COMPILER 4 CELLS TALLOT TARGET : >L ( x -- ) ( L: -- x ) 2 LP +! LP @ ! ; \ LP stack grows up : L> ( -- x ) ( L: x -- ) LP @ @ -2 LP +! ; : RAKE ( -- ) ( L: 0 a1 a2 .. aN -- ) BEGIN L> ?DUP WHILE POSTPONE THEN REPEAT ; COMPILER ALSO META DEFINITIONS : DO ( n n -- adr) TCOMPILE <DO> 0 >L POSTPONE BEGIN ; IMMEDIATE : ?DO ( n n -- adr) TCOMPILE <?DO> 0 >L POSTPONE BEGIN ; IMMEDIATE : LEAVE ( -- ) TCOMPILE UNLOOP TCOMPILE BRANCH AHEAD >L ; IMMEDIATE \ complete a DO loop : LOOP ( -- ) TCOMPILE <LOOP> <BACK RAKE ; IMMEDIATE : +LOOP ( -- ) TCOMPILE <+LOOP> <BACK RAKE ; IMMEDIATE PREVIOUS DEFINITIONS Edit: copy paste error. I had the hi-level words twice in the file. 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 20, 2023 Author Share Posted September 20, 2023 I went down the rabbit hole of trying to refine that crude VDP screen driver for the metacompiler. You can ( and I did) waste a lot of time playing with variations on this thing and the conclusion... wait for it... is that CODE is much faster that Forth. But is was fun to see how far could push Forth. The spoiler has the "mostly Forth version. There are only two code words: One to disable interrupts VC!+ which made a big difference. It writes a byte to last VDP address set & auto increments the VDP address You can see that VFILL speed is way slower than ALC but it looks similar to GPL speed. VFILL is only 16 bytes in Forth versus 28 bytes in ALC. The extra code is in RMODE and WMODE and they are re-useable in other words. TYPE is acceptable speed when implemented this way. If I put the FOR NEXT loop counter in a register it would speed up about 10..12% from my testing of FOR NEXT. So there it is. Stuff you already knew but now you have a video for it. Spoiler \ STD-OUT1A.FTH output words in Forth + minimal code Sept 17 2023 COMPILER HEX TARGET 8800 CONSTANT VDPRD \ vdp ram read data \ 8802 CONSTANT VDPSTS \ vdp status 8C00 CONSTANT VDPWD \ vdp ram write data 8C02 CONSTANT VDPWA \ vdp ram read/write address \ VDP set-address sub-routines CODE 0LIMI 0 LIMI, NEXT, ENDCODE : RMODE ( vdpaddr -- ) DUP 0LIMI VDPWA C! >< VDPWA C! ; : WMODE ( vdpaddr -- ) 4000 OR RMODE ; VARIABLE C/L COMPILER 20 C/L T! TARGET VARIABLE COL VARIABLE ROW VARIABLE CURSOR VARIABLE C/SCR COMPILER 3C0 C/SCR T! TARGET 20 CONSTANT BL \ : EMIT+ ( c --) VDPWD C! ; \ write & inc. address CODE VC!+ ( c --) TOS SWPB, TOS VDPWD @@ MOVB, TOS POP, NEXT, ENDCODE : VFILL ( vaddr len c -- ) ROT WMODE SWAP FOR DUP VC!+ NEXT DROP ; : >VPOS ( col row -- vaddr) C/L @ * + ; : CURSOR ( -- Vaddr) COL @ ROW @ >VPOS ; : AT-XY ( col row -- ) ROW ! COL ! CURSOR WMODE ; : PAGE ( -- ) 0 C/SCR @ BL VFILL 0 0 AT-XY ; : ?WRAP ( -- ) COL @ C/SCR @ 1- > IF 0 0 AT-XY THEN ; : ROW+! ( n -- ) ROW @ + 23 > IF ROW OFF EXIT THEN ROW ! ; : EMIT+ ( c -- ) VC!+ COL 1+! ?WRAP ; : EMIT ( c --) CURSOR WMODE EMIT+ ; : CR ( -- ) 1 ROW+! COL OFF ; : SPACE ( -- ) BL EMIT ; : TYPE ( addr len -- ) 1- CURSOR WMODE FOR COUNT EMIT+ NEXT DROP ; COMPILER ALSO META DEFINITIONS HOST: ." [CHAR] " PARSE TCOMPILE (S") TS, TCOMPILE TYPE ;HOST IMMEDIATE I am beginning to get this meta compiler organized and it is better than my DOS one. I have actually learned something after all these years fighting with this stuff. Here is the test program that runs is the video. It's "normal" Forth with a few magic words to keep the compiler happy. With the CORE Forth primitives imported from Camel99 Forth, and the output library above it compiles to 1596 bytes. It could be smaller if I wanted to remove all the primitives that are not used. \ VFILLTEST.FTH using FOR NEXT loop FOR VFILL and TYPE HEX 2000 ORG \ this must be set before compiling any code INCLUDE DSK7.ITC-FORTH \ preamble for indirect threaded Forth INCLUDE DSK7.STD-OUT1A1 \ uses for/next VFILL IMPORT: ?TERMINAL COMPILER DECIMAL TARGET : VFILLTEST 95 FOR 0 C/SCR @ R@ 33 + VFILL NEXT ; : DELAY ( n -- ) FOR R@ DROP NEXT ; TARGET : MAIN ( -- ) 768 C/SCR ! VFILLTEST 5 12 AT-XY ." VFILL in Forth " 5 13 AT-XY ." FOR DUP VC!+ NEXT " 5000 DELAY 0 0 AT-XY BEGIN ." Hello metacompiling world! " ?TERMINAL UNTIL BYE ; COMPILER AUTOSTART MAIN SAVE DSK7.VFILLTEST3 HOST VFILL test mostly Forth.mp4 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted October 9, 2023 Author Share Posted October 9, 2023 (edited) And now the answer to the question I am sure you all have been asking yourselves for years. How does the calling overhead in Forth compare to the calling overhead in Assembly Language? I had read that on some old machines Chuck's method of calling a sub-routine was faster than the native instructions for that purpose on the CPU. (It might have been 1802 processor that exhibited this behaviour) ? My work on the ASMForth system gave me a simple way to compare these things since the source for the nesting benchmark can be compiled with only minor changes. (ASMForth is an "Assembler" that uses Forth syntax conventions.) Spoiler HOST INCLUDE DSK1.ELAPSE ASMFORTH \ these are not "Forth" words. They are "ASMForth" sub-routines : BOTTOM ; : 1st BOTTOM BOTTOM ; : 2nd 1st 1st ; : 3rd 2nd 2nd ; : 4th 3rd 3rd ; : 5th 4th 4th ; : 6th 5th 5th ; : 7th 6th 6th ; : 8th 7th 7th ; : 9th 8th 8th ; : 10th 9th 9th ; : 11th 10th 10th ; : 12th 11th 11th ; : 13th 12th 12th ; : 14th 13th 13th ; : 15th 14th 14th ; : 16th 15th 15th ; : 17th 16th 16th ; : 18th 17th 17th ; : 19th 18th 18th ; : 20th 19th 19th ; \ This CODE word can be called from the "HOST" Forth system CODE RUN 20th ;CODE HOST : 1MILLION CR ." 1 million nest/unnest operations" RUN ; CR .( start demo like this: ) CR .( ELAPSE 1MILLION ) \ recompile with tailcall optimization operator ( -; ) ASMFORTH : BOTTOM ; \ can't optimze this one because there is no function in it. : 1ST BOTTOM BOTTOM -; : 2ND 1ST 1ST -; : 3RD 2ND 2ND -; : 4TH 3RD 3RD -; : 5TH 4TH 4TH -; : 6TH 5TH 5TH -; : 7TH 6TH 6TH -; : 8TH 7TH 7TH -; : 9TH 8TH 8TH -; : 10TH 9TH 9TH -; : 11TH 10TH 10TH -; : 12TH 11TH 11TH -; : 13TH 12TH 12TH -; : 14TH 13TH 13TH -; : 15TH 14TH 14TH -; : 16TH 15TH 15TH -; : 17TH 16TH 16TH -; : 18TH 17TH 17TH -; : 19TH 18TH 18TH -; : 20TH 19TH 19TH -; CODE RUN 20TH ;CODE HOST : 1MILLIONTC CR ." Optimized 1M nest/unnest operations" RUN ; Something to remember is that the normal BL instruction is fast but code called with BL by itself cannot BL to another sub-routine without manual intervention by the programmer saving the linkage register R11. To build "nestable" sub-routines that can call each other many layers deep requires that we add a stack to the system and automate saving R11. My solution was to put the saving instructions at the beginning of every sub-routine and the restore instruction at the end. The allows the program to use BL normally but inside every sub-routine you can BL to another sub-routine with no concerns. Here is the "entry" code in front of every sub-routine R11 RPUSH, And RPUSH, is a "pseudo-instruction" that actually does two instructions. (RP is an alias for R7 in ASMFORTH) RP DECT, \ move the return stack pointer to give us a new cell R11 *RP MOV, \ save R11 in this new cell on the return stack At the end of the every sub-routine we have these two pseudo-instructions. R11 RPOP, RT, These go into the code as: *RP+ R11 MOV, *R11 B, So here is the answer to the burning question: This method of Assembly Language calling is faster than Forth indirect or direct threading. I put TurboForth in the list because people are more familiar with it. We can see that even resorting to direct threading does not match the speed of BL with a return stack. TI-99 Nesting Benchmark TurboForth 1.21 Nesting 1Mil 2:29 (for reference) Camel99 Forth ITC Nesting 1Mil 2:31 Camel99 Forth DTC Nesting 1Mil 2:17 ASMForth II Nesting 1Mil 1:29 - with tail call optimizing 0:54 Now we know. BUT no free lunch was found! Each call uses 4 bytes in your program but a Forth call is only 2 bytes. ASMForth is here for the curious. ASMFORTH/demo at main · bfox9900/ASMFORTH · GitHub Edited October 9, 2023 by TheBF typo 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted October 14, 2023 Author Share Posted October 14, 2023 I took a break from compilers to play with @Vorticon 's tank combat framework. I didn't write games with my TI-99 40 years ago and after I switched to Forth I just wanted to learn about how Forth did what it did. So 40 years later I have a few ideas that might be useful to someone who wants to write a game with a character that moves in different directions. I think it is worth noting that I did not have to resort to fancy data structure creating words. Forth's simple memory control let's us put things into memory the way we need them to be very much like we do in Assembly Language. Here are the relevant pieces of the tank game that move the tanks around. 1. An simple way to make characters that are in different character sets. \ Enumerate Tank chars in different color sets DECIMAL : TANKCHAR: DUP CONSTANT 8 + ; 136 \ 1st tank character TANKCHAR: TANK0 TANKCHAR: TANK1 TANKCHAR: TANK2 TANKCHAR: TANK3 TANKCHAR: TANK4 TANKCHAR: TANK5 TANKCHAR: TANK6 TANKCHAR: TANK7 TANKCHAR: TANK8 TANKCHAR: TANK9 TANKCHAR: TANK10 TANKCHAR: TANK11 TANKCHAR: TANK12 TANKCHAR: TANK13 TANKCHAR: TANK14 TANKCHAR: TANK15 DROP 2. Put the tank characters in a counted string. Notice the 1st byte is the number of characters. \ put all tank chars in a counted string for searching with SCAN CREATE TANKCHARS ( -- Caddr) 16 C, TANK0 C, TANK1 C, TANK2 C, TANK3 C, TANK4 C, TANK5 C, TANK6 C, TANK7 C, TANK8 C, TANK9 C, TANK10 C, TANK11 C, TANK12 C, TANK13 C, TANK14 C, TANK15 C, 2a) Now we can identify an enemy tank like this: \ SCAN is a fast word to find a character in a string : SCANFOR ( Caddr -- n) COUNT ROT SCAN NIP ; \ now we can test an enemy char with SCAN : ENEMY? ( char -- 0|n ) TANKCHARS SCANFOR ; 3. Make some variables that define a tank. I used "USER" variables because each tank has it's own workspace and stacks for multi-tasking. This means inside of a task these variables only affect the little tank that you are controlling. \ -------------------------------------- \ user variables are local for each tank task HEX 30 USER KILLS \ 44 USER HEADING \ compass heading is the direction control \ 46 USER TPAD \ defined in Kernel 48 USER Y 4A USER X 4C USER DY \ dx and dy can be accessed as a 2variable 4E USER DX 50 USER PANZER \ tank character 52 USER SPEED 54 USER MEMORY \ pointer to circular buffer of headings for BETA chars 56 USER MAILBOX \ one mailbox per task 58 USER BRAIN \ holds the address of a word that changes tank behaviour 4. make a tank char pattern for all 8 compass headings. \ tank patterns for 8 compass headings HEX CREATE NORTH$ 1010 , 547C , 7C7C , 7C44 , CREATE NE$ 0012 , 3478 , FE3C , 1810 , CREATE EAST$ 0000 , FC78 , 7F78 , FC00 , CREATE SE$ 1018 , 3CFE , 7834 , 1200 , CREATE SOUTH$ 447C , 7C7C , 7C54 , 1010 , CREATE SW$ 0818 , 3C7F , 1E2C , 4800 , CREATE WEST$ 0000 , 3F1E , FE1E , 3F00 , CREATE NW$ 0090 , 583C , FE78 , 3010 , 5. Put the patterns in an array that can be retrieved with one "heading" number \ Put tank patterns in an array to access them numerically DECIMAL CREATE TANKS ( -- addr) NORTH$ , NE$ , EAST$ , SE$ , SOUTH$ , SW$ , WEST$ , NW$ , \ compass headings in clockwise order for reference \ 0 CONSTANT NORTH \ 1 CONSTANT NE \ 2 CONSTANT EAST \ 3 CONSTANT SE \ 4 CONSTANT SOUTH` \ 5 CONSTANT SW \ 6 CONSTANT WEST \ 7 CONSTANT NW \ select a pattern with a heading : ]TANK ( heading -- Pattern-addr) CELLS TANKS + @ ; 6. Make a way to write the correct tank pattern into the VDP pattern table for a given heading. The user variable PANZER is the tanks's unique character. (I was running out of ways to say the word "tank" so I used German) : TANK-SHAPE ( heading -- ) \ set pattern based on HEADING variable \ RAM address VDP address bytes ]TANK PANZER @ ]PDT 8 VWRITE ; 7. Make an array of "vectors" for all 8 compass headings. These are added to the x,y location to move the tank in the direction it is travelling. Notice it uses 2@ to fetch both numbers at once. \ double constant array of vectors, rotating clockwise like headings CREATE VECTORS ( -- addr) \ Y X \ --- --- -1 , 0 , \ north -1 , 1 , \ NE 0 , 1 , \ east 1 , 1 , \ SE 1 , 0 , \ south 1 , -1 , \ SW 0 , -1 , \ west -1 , -1 , \ NW \ return the correct vectors for a given heading : ]VECTOR ( heading -- dx dy) 2 CELLS * VECTORS + 2@ ; 8. put this all together to control the direction of a tank. I put some protection of this word with ?HEADING but once everything is working well it could be removed. DECIMAL : ?HEADING ( n -- n ) DUP 8 0 WITHIN ABORT" Illegal heading" ; : DIRECTION ( heading -- ) ?HEADING DUP HEADING ! \ remember the new heading DUP ]VECTOR DXDY! \ set tank's vectors for this heading TANK-SHAPE \ set the graphic for this heading ; 9. Changing direction is just this easy because the headings are all in clockwise order. \ words to change the current heading : REVERSE ( heading -- heading') 4 - 07 AND ; : -90DEG ( heading -- -90 ) 2- 07 AND ; : +90DEG ( heading -- +90 ) 2+ 07 AND ; : LEFT ( heading -- -45 ) 1- 07 AND ; : RIGHT ( heading -- -45 ) 1+ 07 AND ; : RND-HEADING 8 RND DIRECTION ; : GO-LEFT HEADING @ LEFT DIRECTION ; : GO-RIGHT HEADING @ RIGHT DIRECTION ; : GO-BACKWARDS HEADING @ REVERSE DIRECTION ; I am pretty content with this now. 5 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted October 17, 2023 Author Share Posted October 17, 2023 Here is a binary program that runs a different version of @Vorticon 's Combat. There are two different types of hunter tanks with 14 other "prey" vehicles. The prey are either GRAY "Alpha" creatures that just wander in a random direction until the hit something then pick another direction -or- they are the BLUE "rabbits". Rabbits are alpha creatures but they have extra "thoughts" : RABBIT-THOUGHTS 7 %CHANCE IF GO-LEFT THEN 7 %CHANCE IF GO-RIGHT THEN 1 %CHANCE IF TURN-AROUND THEN 2 %CHANCE IF FREEZE THEN 5 %CHANCE IF 50 RND 5 + SPEED ! THEN ; The black hunter tank can go a bit faster than the GRAY tanks but it is no smarter. The GREEN gunner picks a place and sits there waiting. Occasionally it will move to a new location. Neither shooting tank has any smarts. If a target is directly in front of the gun it will shoot it. Sometimes it can't detect a target because of multi-tasking moving the target before the hunter gets a chance to detect it. I was surprised by how successful the gunner strategy is. (Except when the black tank finds him and kills him right at the beginning) The binary files are an E/A 5 program called ALPHAHUNT After all 16 tanks have spawned into existence, you can press FCTN 4 to break the program. Type COLD to reboot the thing and you get a new random simulation. (There is a bug in the explosion code that can cause it to make sound after it should stop occasionally. Probably need to look into better Multi-tasking for shared resources OR put it on the ISR sound player) The source for Camel99 Forth might interest some folks. Spoiler \ COMBAT.FTH \ Based on CCOMBAT HOST PROGRAM \ Version 02.14.23 \ by @VORTICON on Atariage.com \ Heavily modified for Camel99 Forth 2023 Brian Fox \ NEEDS DUMP FROM DSK1.TOOLS NEEDS BYTE FROM DSK1.DATABYTE NEEDS RND FROM DSK1.RANDOM NEEDS COLOR FROM DSK1.GRAFIX NEEDS U.R FROM DSK1.UDOTR \ right justified numbers NEEDS HZ FROM DSK1.SOUND NEEDS TASK: FROM DSK1.MTASK99 NEEDS MALLOC FROM DSK1.MALLOC NEEDS MARKER FROM DSK1.MARKER NEEDS VALUE FROM DSK1.VALUES MARKER /ALPHA HEX : NEW-HEAP 2000 H ! H @ 2000 0 FILL ; \ reset & erase heap \ create a task in heap, fork it, assign Execution token : SPAWN ( xt -- pid) USIZE MALLOC DUP>R FORK R@ ASSIGN R> ; \ spawn n NULL tasks and compile the PIDs sequentially in memory : TASKS ( n -- ) 0 DO ['] PAUSE SPAWN , LOOP ; 0 VALUE TASK-TBL \ array of process IDs : ]PID ( n -- PID ) CELLS TASK-TBL + @ ; \ Enumerate Tank chars in different color sets DECIMAL : TANKCHAR: DUP CONSTANT 8 + ; 136 \ 1st tank character TANKCHAR: TANK0 TANKCHAR: TANK1 TANKCHAR: TANK2 TANKCHAR: TANK3 TANKCHAR: TANK4 TANKCHAR: TANK5 TANKCHAR: TANK6 TANKCHAR: TANK7 TANKCHAR: TANK8 TANKCHAR: TANK9 TANKCHAR: TANK10 TANKCHAR: TANK11 TANKCHAR: TANK12 TANKCHAR: TANK13 TANKCHAR: TANK14 TANKCHAR: TANK15 DROP \ put all tank chars in a counted string for searching with SCAN CREATE TANKCHARS ( -- Caddr) 16 C, TANK0 C, TANK1 C, TANK2 C, TANK3 C, TANK4 C, TANK5 C, TANK6 C, TANK7 C, TANK8 C, TANK9 C, TANK10 C, TANK11 C, TANK12 C, TANK13 C, TANK14 C, TANK15 C, \ compute process number (index) from a tank's ASCII character : 8/ 3 RSHIFT ; : >TASK# ( ascii -- n) 8/ [ TANK0 SET# ] LITERAL - ; \ Get PID from the tank character argument \ This allows us to send messages to a tank when we detect it \ in the battlefield : PID ( tank -- PID ) >TASK# ]PID ; \ Named characters make it easier to remember the shapes DECIMAL 128 CONSTANT BKG ( background character) BKG CONSTANT --- ( alias for bkg character ) 130 CONSTANT SQR 131 CONSTANT BULLET 132 CONSTANT BOX 001 CONSTANT DOT ( sprite radar scanner ) \ Enumerate colors for Graphics programs : ENUM ( 0 <text> -- n) DUP CONSTANT 1+ ; \ Color names from TI-Logo are more descriptive 1 ENUM TRANS \ 1 ENUM BLACK ENUM GREEN ENUM LIME ENUM BLUE ENUM SKY ENUM RED ENUM CYAN \ 8 ENUM RUST ENUM ORANGE ENUM YELLOW ENUM LEMON ENUM OLIVE ENUM PURPLE ENUM GRAY ENUM WHITE \ 16 DROP \ -------------------------------------- \ user variables are local for each tank task HEX 30 USER KILLS \ 44 USER HEADING \ compass heading is the direction control \ 46 USER TPAD \ defined in Kernel 48 USER Y 4A USER X 4C USER DY \ dx and dy can be accessed as a 2variable 4E USER DX 50 USER PANZER \ tank character 52 USER SPEED 54 USER MEMORY \ pointer to circular buffer of headings for BETA chars 56 USER MAILBOX \ one mailbox per task 58 USER BRAIN 60 USER SPRITE# \ sprite # of the radar dot \ -------------------------------------- \ words to access the tank data : XY@ ( -- x y) Y 2@ ; : XY! ( x y --) Y 2! ; : POSITION ( -- Vaddr) XY@ >VPOS ; : DXDY! ( x y --) DY 2! ; : DXDY@ ( -- X Y) DY 2@ ; \ random number functions : RNDX ( -- x) 23 RND ; : RNDY ( -- y) 33 RND ; : RANDOM ( -- 0..7) 8 RND ; : RNDV ( -- -1|0|1 ) 3 RND 1- ; \ random vector \ battlefield layout CREATE ScreenData BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,--- BYTE ---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,---,---,---,---,--- BYTE ---,---,---,---,---,SQR,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,SQR,SQR,---,---,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,SQR,---,---,SQR BYTE SQR,---,---,---,SQR,---,---,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,---,---,---,SQR BYTE SQR,---,---,---,SQR,---,---,SQR,SQR,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,SQR,SQR,---,---,SQR,---,---,---,SQR BYTE SQR,---,---,---,SQR,---,---,SQR,SQR,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,SQR,SQR,---,---,SQR,---,---,---,SQR BYTE SQR,---,---,---,SQR,---,---,SQR,SQR,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,SQR,SQR,---,---,SQR,---,---,---,SQR BYTE SQR,---,---,---,SQR,---,---,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,---,---,---,SQR BYTE SQR,---,---,SQR,SQR,---,---,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,---,---,SQR,SQR,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,---,---,---,---,--- BYTE ---,---,---,---,---,SQR,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,--- BYTE ---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,SQR,SQR,SQR,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,SQR,SQR,SQR,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,--- BYTE ---,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,---,---,---,---,---,---,---,---,---,---,---,---,---,---,SQR BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR BYTE SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR,SQR BYTE BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL BYTE BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL ,BL : .BATTLEFIELD ( -- ) ScreenData VPG @ C/SCR @ VWRITE ; \ Score display DECIMAL : .KILLS ( pid -- ) KILLS LOCAL @ 4 U.R ; : .SCORE 2 23 AT-XY ." Hunter:" 0 ]PID .KILLS 4 SPACES ." Gunner:" 1 ]PID .KILLS ; \ ------------------------------------------- \ tank patterns for 8 compass headings HEX CREATE NORTH$ 1010 , 547C , 7C7C , 7C44 , CREATE NE$ 0012 , 3478 , FE3C , 1810 , CREATE EAST$ 0000 , FC78 , 7F78 , FC00 , CREATE SE$ 1018 , 3CFE , 7834 , 1200 , CREATE SOUTH$ 447C , 7C7C , 7C54 , 1010 , CREATE SW$ 0818 , 3C7F , 1E2C , 4800 , CREATE WEST$ 0000 , 3F1E , FE1E , 3F00 , CREATE NW$ 0090 , 583C , FE78 , 3010 , \ Put tank patterns in an array to access them numerically DECIMAL CREATE TANKS ( -- addr) NORTH$ , NE$ , EAST$ , SE$ , SOUTH$ , SW$ , WEST$ , NW$ , \ compass headings in clockwise order for reference \ 0 CONSTANT NORTH \ 1 CONSTANT NE \ 2 CONSTANT EAST \ 3 CONSTANT SE \ 4 CONSTANT SOUTH` \ 5 CONSTANT SW \ 6 CONSTANT WEST \ 7 CONSTANT NW \ select a pattern with a heading : ]TANK ( heading -- Pattern-addr) CELLS TANKS + @ ; : TANK-SHAPE ( heading -- ) \ set pattern based on HEADING variable \ RAM address VDP address bytes ]TANK PANZER @ ]PDT 8 VWRITE ; \ double constant array of vectors, rotating clockwise like headings CREATE VECTORS ( -- addr) \ Y X \ --- --- -1 , 0 , \ north -1 , 1 , \ NE 0 , 1 , \ east 1 , 1 , \ SE 1 , 0 , \ south 1 , -1 , \ SW 0 , -1 , \ west -1 , -1 , \ NW \ return the correct vectors for a given heading : ]VECTOR ( heading -- dx dy) 2 CELLS * VECTORS + 2@ ; : ?HEADING ( n -- n ) DUP 8 0 WITHIN ABORT" Illegal heading" ; DECIMAL : DIRECTION ( heading -- ) ?HEADING DUP HEADING ! \ remember the new heading DUP ]VECTOR DXDY! \ set tank's vectors for this heading TANK-SHAPE \ set the graphic for this heading ; \ words to change the current heading : REVERSE ( heading -- heading') 4 - 07 AND ; : -90DEG ( heading -- -90 ) 2- 07 AND ; : +90DEG ( heading -- +90 ) 2+ 07 AND ; : LEFT ( heading -- -45 ) 1- 07 AND ; : RIGHT ( heading -- -45 ) 1+ 07 AND ; \ EXPLOSION...................... HEX CREATE SHRAPNEL \ :-) 0000 , 125C , 1E2C , 0000 , 0042 , 1498 , 0250 , 1400 , 1084 , 2200 , 1280 , 2400 , 2002 , 8001 , 0000 , 8104 , 0000 , 0000 , 0000 , 0000 , DECIMAL : EXPLODE ( char -- ) 4 NOISE GEN4 0 DB 25 MS 6 NOISE 10 MS ]PDT 5 0 DO PAUSE I 8* SHRAPNEL + OVER 8 VWRITE 40 MS GEN4 I 4* DB LOOP GEN4 -28 DB 60 MS GEN4 MUTE DROP SILENT ; \ add coordinates to a vector : VECT+ ( x y dx dy -- x' y') >R ROT + SWAP R> + ; : PUT-CHAR ( c -- ) PAUSE POSITION VC! ; : ERASE-TANK ( -- ) BKG PUT-CHAR ; : .TANK ( --) PANZER @ PUT-CHAR ; : XY.TANK ( x y --) XY! .TANK ; \ managing tank location in x,y or VDP address form : NEXT-XY ( x y -- x' y') DXDY@ VECT+ ; : FWD ( -- x y) XY@ NEXT-XY ; : RANGE ( x y -- x y) 0 DO NEXT-XY LOOP ; : 3AHEAD ( x y -- x y) NEXT-XY NEXT-XY ; : VDP>XY ( Vaddr -- X Y) C/L@ /MOD ; : NEXT-ADDR ( Vaddr -- Vaddr') VDP>XY FWD >VPOS ; : ADVANCE ( -- ) ERASE-TANK FWD XY.TANK SPEED @ MS ; : DECAY1 ( n -- ) -10 DB DUP MS -18 DB DUP MS -22 DB DUP MS -26 DB MS MUTE ; : BOINK 440 HZ 6 DECAY1 ; : BONK 120 HZ 6 DECAY1 ; \ SCAN is a fast word to find a character : SCANFOR ( Caddr -- n) COUNT ROT SCAN NIP ; \ now we can test an enemy char with SCAN : ENEMY? ( char -- 0|n ) TANKCHARS SCANFOR ; : RND-HEADING 8 RND DIRECTION ; : GO-LEFT HEADING @ LEFT DIRECTION ; : GO-RIGHT HEADING @ RIGHT DIRECTION ; : TURN-AROUND HEADING @ REVERSE DIRECTION ; : THINK BRAIN PERFORM ; : CLEAR-AHEAD? ( -- ?) XY@ NEXT-XY GCHAR BKG = ; DECIMAL : ALPHA-MIND \ common logic for simple creatures RND-HEADING 15 12 XY.TANK BEGIN BEGIN CLEAR-AHEAD? WHILE ADVANCE THINK \ this can RUN anything REPEAT GEN2 BONK RND-HEADING AGAIN ; : ALPHA-TANK ( --) 100 SPEED ! PANZER @ SET# GRAY RED COLOR ['] PAUSE BRAIN ! ALPHA-MIND ; DECIMAL : %CHANCE ( n -- ?) 100 RND > ; : FREEZE ( -- ) 2500 RND 500 + MS ; : RABBIT-THOUGHTS 7 %CHANCE IF GO-LEFT THEN 7 %CHANCE IF GO-RIGHT THEN 1 %CHANCE IF TURN-AROUND THEN 2 %CHANCE IF FREEZE THEN 5 %CHANCE IF 50 RND 5 + SPEED ! THEN ; : RABBIT-TANK ( --) 100 SPEED ! PANZER @ SET# BLUE RED COLOR 15 12 XY.TANK ['] RABBIT-THOUGHTS BRAIN ! ALPHA-MIND ; : DESTROY ( char -- ) DUP PID SLEEP \ put the task to sleep to stop it EXPLODE \ blow up the enemy char BKG FWD >VPOS VC! \ erase from battlefield ; : ALPHA-HUNTER ( --) 95 SPEED ! GEN2 ( set the sound generator for this task ) 15 12 XY! RND-HEADING PANZER @ SET# BLACK RED COLOR BEGIN PAUSE XY@ NEXT-XY GCHAR DUP ENEMY? IF DESTROY KILLS 1+! .SCORE ELSE DUP BKG = IF DROP ADVANCE ELSE \ default actions BOINK GEN2 MUTE RND-HEADING DROP THEN THEN GEN2 MUTE AGAIN ; : FIND-A-WALL ( -- ) BEGIN CLEAR-AHEAD? WHILE ADVANCE REPEAT ; : GO-AND-HIDE ( -- ) RND-HEADING FIND-A-WALL TURN-AROUND ; : GUNNER ( -- ) \ finds a hiding place and shoots what comes past 100 SPEED ! GEN2 PANZER @ SET# GREEN RED COLOR 15 12 XY.TANK GO-AND-HIDE BEGIN PAUSE XY@ NEXT-XY GCHAR DUP ENEMY? IF DESTROY KILLS 1+! .SCORE ELSE DROP THEN \ every so often move to a new location 10000 RND 4 < IF GO-AND-HIDE THEN AGAIN ; : TANK-BUILDER ( xt tank# --) DUP DUP PID PANZER LOCAL ! PID ASSIGN ; \ assign the configured tank programs to tasks : CREATE-TANKS ['] ALPHA-HUNTER TANK0 TANK-BUILDER ['] GUNNER TANK1 TANK-BUILDER ['] ALPHA-TANK TANK2 TANK-BUILDER ['] ALPHA-TANK TANK3 TANK-BUILDER ['] ALPHA-TANK TANK4 TANK-BUILDER ['] ALPHA-TANK TANK5 TANK-BUILDER ['] ALPHA-TANK TANK6 TANK-BUILDER ['] ALPHA-TANK TANK7 TANK-BUILDER ['] ALPHA-TANK TANK8 TANK-BUILDER ['] RABBIT-TANK TANK9 TANK-BUILDER ['] RABBIT-TANK TANK10 TANK-BUILDER ['] RABBIT-TANK TANK11 TANK-BUILDER ['] ALPHA-TANK TANK12 TANK-BUILDER ['] ALPHA-TANK TANK13 TANK-BUILDER ['] ALPHA-TANK TANK14 TANK-BUILDER ['] ALPHA-TANK TANK15 TANK-BUILDER ; : DRAW-SCREEN CLEAR RANDOMIZE S" 0000000000000000" BKG CALLCHAR S" FFFFFFFFFFFFFFFF" SQR CALLCHAR S" 0000001818000000" BULLET CALLCHAR S" FFFFC3C3C3C3FFFF" BOX CALLCHAR S" 0000001000000000" DOT CALLCHAR BKG SET# YELLOW RED COLOR PURPLE SCREEN .BATTLEFIELD .SCORE CREATE-TANKS ; HEX 83D6 CONSTANT ALWAYS \ :-) screen time-out timer DECIMAL : RESTARTS ( n -- ) 1+ 1 DO I ]PID RESTART 1000 MS LOOP ; : RUN INIT-MULTI HERE \ task table will use memory at HERE NEW-HEAP 16 TASKS TO TASK-TBL \ Spawn 16 tasks. Assign HERE to task table DRAW-SCREEN MULTI TANK0 PID RESTART \ start the hunter first 2000 MS \ wait 2 seconds 14 RESTARTS \ the gunner and the "prey" \ console task just updates the score and waits for break key BEGIN ALWAYS ON .SCORE PAUSE ?TERMINAL UNTIL SINGLE SILENT PAGE ; : STARTER WARM GRAPHICS RUN ABORT ; LOCK INCLUDE DSK1.SAVESYS ' STARTER SAVESYS DSK3.ALPHAHUNT ALPHAHUNT ALPHAHUNU 3 Quote Link to comment Share on other sites More sharing options...
+Vorticon Posted October 18, 2023 Share Posted October 18, 2023 That AI book was the basis for my hunter and prey simulation where each of the latter had a certain genetic composition which got passed on based on survival. I suppose you could make the same for the tanks, allowing them to evolve after each battle, with the hope that they will eventually settle on a stable genetic configuration which optimizes survival. Lots of cool options to explore here 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted October 18, 2023 Author Share Posted October 18, 2023 I didn't know about your work on this. Cool. Yes I now have a framework and language that makes it pretty simple to create new entities. There is a vector called the brain that can run any code needed inside the alpha loop and of course you could also just re-write the code loop for a creature. And there is a memory pointer that can be used to remember locations and actions. Lots of potential. I will take a look at your program for some ideas. 4 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted October 18, 2023 Author Share Posted October 18, 2023 Something I realized is that the world is not limited to the screen size. There is about 9K of VDP ram available for the simulation world to exist in, with my Forth environment. The screen could be a window into that world that you could slide up and down to view what's happening. Might go there as well. 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 6, 2023 Author Share Posted November 6, 2023 (edited) Over in the FbForth thread I put up a quick and dirty example of a queue for 16 bit data cells. I dug into some old work I had done in 1990s for MaxForth where I broke Chuck's rule and tried to make a "general solution" for the byte-queue. I was able to make my old work better because I have a learned a few things hanging around here over the last few years. I am amazed though by how much more complicated it is to do it this way rather than the code over at FbForth. So I suppose if you needed 100 queues the general solution is ok. But most of the time we would never need a huge number of queues. ( Circular byte queue for general purpose stuff 21MAR94 FOX ) \ originally written for MaxForth 68hc11 1993 \ re-write for Camel99 Forth 2023 INCLUDE DSK1.TOOLS HEX : BYTE-Q: ( n -- <text>) CREATE DUP DUP 1- AND ABORT" size not power of 2" 0 , ( write pointer "HEAD" ) 0 , ( read pointer "TAIL" ) 0 , ( counter) DUP 1- , ( mask value to provide wrap around ) ALLOT ( data ) ALIGN ; \ fast field creator HEX : FIELD: ( n - <TEXT>) CREATE , ;CODE A118 , \ *W TOS ADD, NEXT, ENDCODE \ field selectors for the Queue data structure DECIMAL : ->HEAD ( q -- adr ) ; IMMEDIATE ( NOP for clarity) 2 FIELD: ->TAIL 4 FIELD: ->CNT 6 FIELD: ->MASK 8 FIELD: ->DATA : HEAD@+ ( q -- n) DUP>R ->HEAD @ DUP 1+ R@ ->MASK @ AND R> ->HEAD ! ; : TAIL@+ ( q -- n) DUP>R ->TAIL @ DUP 1+ R@ ->MASK @ AND R> ->TAIL ! ; : QBYTES ( q -- n) ->CNT @ ; : QC@ ( q -- c) DUP>R QBYTES 0= ABORT" Q empty" R@ TAIL@+ R@ ->DATA + C@ R> ->CNT 1-! ; : QFULL? ( q -- ?) DUP ->CNT @ SWAP ->MASK @ > ; : QC! ( c q -- ) DUP>R QFULL? ABORT" Q full" R@ HEAD@+ R@ ->DATA + ( calculate: [head+data]= Qaddr ) C! ( store the C at adr ) R> ->CNT 1+! ( bump the count field) ; : QRESET ( q -- ) DUP ->HEAD OFF DUP ->TAIL OFF ->CNT OFF ; Here is how they are used. ( Example Queue Code: ) DECIMAL ( CREATE a 1K byte queue data structure ) 256 BYTE-Q: X 128 BYTE-Q: Y : .QSTATS ( q -- ) CR ." Size of Q = " DUP ->MASK @ 1+ . ." bytes" CR ." Head pointer = " DUP ->HEAD @ . CR ." Tail pointer = " DUP ->TAIL @ . CR ." Bytes used = " QBYTES . ; ( put the charset into a Queue ) : QLOAD ( queue --) 127 BL 1+ DO I OVER QC! LOOP DROP ; : QTYPE ( queue -- ) BEGIN DUP QBYTES 0> WHILE DUP QC@ EMIT REPEAT DROP ; \ usage: X QLOAD X QLOAD X QTYPE Y QLOAD Y QTYPE Edited November 6, 2023 by TheBF Updated code 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 7, 2023 Author Share Posted November 7, 2023 When I added the FIELD: word to the queue today it seemed familiar. I remembered that something similar called +FIELD it is part of the Forth 2012 proposal for data structure creation. So for TI-99 rather than using DOES> we use ;CODE and one instruction to create the offsets into data structures like this: : +FIELD \ n <"name"> -- ; Exec: addr -- 'addr CREATE OVER , + \ DOES> @ + ; \ Forth Version ;CODE \ ~3X faster version HEX A118 , \ *W TOS ADD, NEXT, ENDCODE For FbForth or Turbo Forth you replace TOS with *SP in the Assembler code. The complete file is below Spoiler \ forth 2012 structures \ A.15 The optional Facility word set DECIMAL : BEGIN-STRUCTURE ( -- addr 0 ) CREATE HERE 0 0 , \ mark stack, lay dummy DOES> @ \ -- rec-len ; : END-STRUCTURE ( addr n --) SWAP ! ; \ set len : +FIELD \ n <"name"> -- ; Exec: addr -- 'addr CREATE OVER , + \ DOES> @ + ; \ Forth Version ;CODE \ ~3X faster version HEX A118 , \ *W TOS ADD, NEXT, ENDCODE DECIMAL \ using +field, make Forth 2012 field creators : FIELD: ( n1 "name" -- n2 ; addr1 -- addr2 ) ALIGNED 1 CELLS +FIELD ; : CFIELD: ( n1 "name" -- n2 ; addr1 -- addr2 ) 1 CHARS +FIELD ; : 2FIELD: ( d1 "name" -- d2 ; addr1 -- addr2 ) ALIGNED 2 CELLS +FIELD ; \ additional field types for Camel99 Forth : CELLS: ( n -- ) CELLS +FIELD ; : CHARS: ( n -- ) ALIGNED +FIELD ; 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 23, 2023 Author Share Posted November 23, 2023 @dhe got me thinking about using SAMS memory. I wondered how much overhead there would be to byte address every byte in a 64K segment of SAMS memory. I added the complication of keeping two windows in RAM so that you could access and copy strings from different areas in the segment without a temp buffer. Anyway it is ton of code. This is based on some earlier work that I did and I was able to remove a few instructions and there is also a shortcut code if the SAMS page we need is already in RAM. It's a clever hack but I don't think I can base an editor on byte addressing SAMS memory without feeling A LOT OF pain in the speed arena. I will have to write up a CMOVE in Forth to get a feel for it. For reference looping through 64K bytes with a DO LOOP takes 29 seconds. Here is the code in case anyone can see a faster way. I am using @Lee Stewart 's code to replace UM/MOD to compute a page# and offset. \ SAMS memmory access as BLOCK from Forth. Source code Brian Fox NEEDS DUMP FROM DSK1.TOOLS NEEDS MOV, FROM DSK1.ASM9900 NEEDS ELAPSE FROM DSK1.ELAPSE NEEDS SAMSINI FROM DSK1.SAMSINI HERE \ ========================================== \ >REAL is the SAMS manager. Converts a 64K address to a real address in RAM HEX VARIABLE USE VARIABLE SEG 1 SEG ! CREATE WINDOWS 2000 , 3000 , \ windows in Low CPU RAM CREATE PAGES 0 , 0 , \ SAMS page in the buffer 4000 CONSTANT SAMS \ base address of the SAMS card registers CODE >REAL ( virtual -- real) \ this code does TOS 4096 /MOD. ~25% faster than using DIV TOS PUSH, SEG @@ TOS MOV, \ segment# to TOS TOS 4 SLA, \ segment * 64 *SP R5 MOV, \ virtual address to R5 R5 R0 MOV, \ dup in R0 R0 0C SRL, \ r0 = address/2048 R0 TOS ADD, \ page# = QUOTIENT + SEGMENT R5 0FFF ANDI, \ virtual address masked to 12 bits = remainder R5 *SP MOV, \ remainder to 2nd item on stack \ Quick search if page# is already in 1st buffer TOS PAGES @@ CMP, EQ IF, WINDOWS @@ TOS MOV, \ set 1st window *SP+ TOS ADD, \ add the offset NEXT, \ Return to Forth ENDIF, \ search if page# is in 2nd buffer TOS PAGES CELL+ @@ CMP, EQ IF, WINDOWS CELL+ @@ TOS MOV, \ set 2nd window, *SP+ TOS ADD, NEXT, ENDIF, \ ********************************************* \ page# not in memory: Select another window W 0001 LI, USE @@ W XOR, \ toggle the active window W USE @@ MOV, \ put it back in USE W 1 SLA, \ W 2* is our index into PAGES & WINDOWS TOS PAGES (W) MOV, \ store the page# WINDOWS (W) R1 MOV, \ get the window to use ->R1 \ map new page into a RAM window R1 0B SRL, \ divide by 2048 = index into SAMS registers R12 1E00 LI, \ cru address of SAMS 0 SBO, \ SAMS card on TOS SWPB, \ swap bytes on bank value TOS SAMS R1 () MOV, \ load page# into SAMS card register 0 SBZ, \ SAMS card off WINDOWS (W) TOS MOV, \ return buffer on TOS *SP+ TOS ADD, NEXT, ENDCODE : !L ( n virtual -- ) >REAL ! ; : C!L ( c virtual -- ) >REAL C! ; DECIMAL : TEST 65535 0 DO [CHAR] % I C!L LOOP ; \ Forth version using SEG @ 4096 UM/MOD 45 secs \ >REAL 29.4 secs 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 23, 2023 Author Share Posted November 23, 2023 While writing the previous post I realized I could remove the shortcuts and PAGES array and just read the SAMS registers to see what's already in memory. This is smaller but it took 5 seconds longer. Now I wonder if I can do the shortcuts by reading the SAMS register earlier CODE >REAL ( virtual -- real) \ this code does TOS 4096 /MOD. ~25% faster than using DIV TOS PUSH, SEG @@ TOS MOV, \ segment# to TOS TOS 4 SLA, \ segment * 64 *SP R5 MOV, \ virtual address to R5 R5 R0 MOV, \ dup in R0 R0 0C SRL, \ r0 = address/2048 R0 TOS ADD, \ page# = QUOTIENT + SEGMENT R5 0FFF ANDI, \ virtual address masked to 12 bits = remainder R5 *SP MOV, \ remainder to 2nd item on stack \ page# not in memory: Select another window W 0001 LI, USE @@ W XOR, \ toggle the active window W USE @@ MOV, \ put it back in USE W 1 SLA, \ W 2* is our index into PAGES & WINDOWS \ TOS PAGES (W) MOV, \ store the page# WINDOWS (W) R1 MOV, \ get the window to use ->R1 R1 0B SRL, \ divide by 2048 = index into SAMS registers \ map new page into a RAM window R12 1E00 LI, \ cru address of SAMS 0 SBO, \ SAMS card on SAMS R1 () TOS CMP, \ compare register value to new page# in TOS NE IF, TOS SWPB, \ swap bytes on bank value TOS SAMS R1 () MOV, \ load page# into SAMS card register ENDIF, 0 SBZ, \ SAMS card off WINDOWS (W) TOS MOV, \ return buffer on TOS *SP+ TOS ADD, \ add offset from data stack NEXT, ENDCODE 3 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 23, 2023 Author Share Posted November 23, 2023 (edited) OK so I have got it up to a bit more than 2X faster than my original Forth version. I made use of BL sub-routines and re-wrote each memory operation fetch and store for SAMS as CODE words. Spoiler \ SAMS memmory access as BLOCK from Forth. Source code Brian Fox NEEDS DUMP FROM DSK1.TOOLS NEEDS MOV, FROM DSK1.ASM9900 NEEDS ELAPSE FROM DSK1.ELAPSE NEEDS SAMSINI FROM DSK1.SAMSINI HERE \ ========================================== \ _real is the entire SAMS manager HEX VARIABLE USE VARIABLE SEG 1 SEG ! CREATE WINDOWS 2000 , 3000 , \ windows in Low CPU RAM CREATE PAGES 0 , 0 , \ SAMS page in the each window 4000 CONSTANT SAMS \ base address of registers in SAMS card : (R1) R1 () ; \ syntax sugar \ 9900 sub-routine. NOT a Forth word. CREATE _real ( virtual -- real_addr) \ perform TOS 4096 /MOD to compute offset,page# TOS R5 MOV, R5 R0 MOV, \ dup in R0 SEG @@ TOS MOV, \ segment# to TOS TOS 4 SLA, \ segment# * 64 R0 0C SRL, \ divide by 4096 R0 TOS ADD, \ page# = R0 + segment# R5 0FFF ANDI, \ offset= virtual masked to 12 bits \ search if page# is already in 1st buffer TOS PAGES @@ CMP, EQ IF, TOS WINDOWS @ LI, \ set 1st window. ~2x FASTER using LI R5 TOS ADD, \ add the offset RT, \ get out ENDIF, \ search if page# is in 2nd buffer TOS PAGES CELL+ @@ CMP, EQ IF, TOS WINDOWS CELL+ @ LI, \ set 2nd window, R5 TOS ADD, \ add the offset RT, ENDIF, \ page# not in memory: Select another window W 0001 LI, USE @@ W XOR, W USE @@ MOV, W 1 SLA, \ W 2* is new index into PAGES & WINDOWS TOS PAGES (W) MOV, \ remember this new page# WINDOWS (W) R1 MOV, \ get the window to use into R1 \ map new page into a RAM window R1 0B SRL, \ divide window by 2048 = index into SAMS registers R12 1E00 LI, \ cru address of SAMS 0 SBO, \ SAMS card on TOS SWPB, \ swap bytes on page# argument TOS SAMS (R1) MOV, \ load page# into SAMS card register 0 SBZ, \ SAMS card off WINDOWS (W) TOS MOV, \ get window into TOS R5 TOS ADD, \ add the offset RT, \ ------------------------------------------------------------ CODE >REAL ( virtual -- offset page#) _real @@ BL, NEXT, ENDCODE \ Fetch and store in virtual memory. (Long addresses) CODE !L ( n virtual -- ) _real @@ BL, *SP+ *TOS MOV, TOS POP, NEXT, ENDCODE CODE C!L ( c virtual -- ) _real @@ BL, 1 (SP) *TOS MOVB, SP INCT, TOS POP, NEXT, ENDCODE CODE @L ( virtural -- n) _real @@ BL, *TOS TOS MOV, NEXT, ENDCODE CODE C@L ( virtual -- c) _real @@ BL, *TOS TOS MOVB, TOS 8 SRL, NEXT, ENDCODE DECIMAL \ write to low RAM (normal) : TESTC! 65535 0 DO [CHAR] * [ WINDOWS @ ] LITERAL C! LOOP ; \ 13.2 : TESTC!L \ write to all 64K bytes 65535 0 DO [CHAR] % I C!L LOOP ; \ 21.6 secs \ write to a one virtual address 64K times : TESTINPAGE 65535 0 DO [CHAR] & 30000 C!L LOOP ; \ 21 SECs : TESTFETCH 65535 0 DO I C@L DROP LOOP ; \ 25 secs : MOVEL ( addr1 addr2 u --) \ 16 bit move BOUNDS DO DUP @L I !L CELL+ 2 +LOOP DROP ; : FILLL ( addr len char -- ) -ROT BOUNDS DO DUP I C!L LOOP DROP ; 64K byte writes to SAMS take 21.6 seconds. 64K byte writes to regular RAM takes 13.11 seconds I whipped up MOVEL and FILLL as Forth words and they are not bad. Nowhere near as fast as the CODE equivalents. Since I have a native sub-routine I may be able to wrap _real into Assembler loops. Edited November 23, 2023 by TheBF fixed comment 4 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted November 24, 2023 Share Posted November 24, 2023 22 hours ago, TheBF said: While writing the previous post I realized I could remove the shortcuts and PAGES array and just read the SAMS registers to see what's already in memory. This is smaller but it took 5 seconds longer. Now I wonder if I can do the shortcuts by reading the SAMS register earlier. Perhaps you already know this, but you must remember that the registers only contain the 4-KiB “page” numbers mapped and not the 1-MiB “bank” numbers mapped. Of course, if you are only dealing with a 1 MiB SAMS space, it doesn’t matter. However, if you test on Classic99, SAMS is 32 MiB by default. You can make it 0 by setting “sams_enabled=0” in classic99.ini, but there is currently no in-between. ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 24, 2023 Author Share Posted November 24, 2023 13 minutes ago, Lee Stewart said: Perhaps you already know this, but you must remember that the registers only contain the 4-KiB “page” numbers mapped and not the 1-MiB “bank” numbers mapped. Of course, if you are only dealing with a 1 MiB SAMS space, it doesn’t matter. However, if you test on Classic99, SAMS is 32 MiB by default. You can make it 0 by setting “sams_enabled=0” in classic99.ini, but there is currently no in-between. ...lee Thank you. You corrected some of my code a few years back. Since I have a 1Mb card I have not given much thought to anything bigger to honest. But I will test this stuff on the bigger range on Classic99. Something that has occurred to me is that the Forth 32 bit number format could work directly to access SAMS memory as 32bit address. Now that you have put the bug in my head I will report back with something that reads farther into SAMS. 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 24, 2023 Author Share Posted November 24, 2023 (edited) Turns out the code change was almost nothing because I put the SEGment variable contents into R4, the TOS cache register. So I just removed that line of code and the required argument is on the top of the stack already if you put a double address on the data stack. Spoiler \ SAMS access from 32bit addresses from Forth. Brian Fox Nov 23 2023 NEEDS DUMP FROM DSK1.TOOLS NEEDS MOV, FROM DSK1.ASM9900 NEEDS ELAPSE FROM DSK1.ELAPSE NEEDS SAMSINI FROM DSK1.SAMSINI HERE \ ========================================== \ BLOCK is the entire SAMS manager HEX VARIABLE USE VARIABLE SEG 1 SEG ! CREATE WINDOWS 2000 , 3000 , \ windows in Low CPU RAM CREATE PAGES 0 , 0 , \ SAMS page in the each window 4000 CONSTANT SAMS \ base address of registers in SAMS card : (R1) R1 () ; \ syntax sugar \ 9900 sub-routine. NOT a Forth word. \ _real32 takes a double (32bit) address on the stack CREATE _real32 ( d -- real_addr) \ perform TOS 4096 /MOD to compute offset,page# R5 POP, \ R5 holds the low bits, R4 ie TOS hold high bits R5 R0 MOV, \ dup low bits R0 TOS 4 SLA, \ segment# * 16 R0 0C SRL, \ divide by 4096 R0 TOS ADD, \ page# = R0 + segment# R5 0FFF ANDI, \ offset= virtual masked to 12 bits \ search if page# is already in 1st buffer TOS PAGES @@ CMP, EQ IF, TOS WINDOWS @ LI, \ set 1st window. ~2x FASTER using LI R5 TOS ADD, \ add the offset RT, \ get out ENDIF, \ search if page# is in 2nd buffer TOS PAGES CELL+ @@ CMP, EQ IF, TOS WINDOWS CELL+ @ LI, \ set 2nd window, R5 TOS ADD, \ add the offset RT, ENDIF, \ page# not in memory: Select another window W 0001 LI, USE @@ W XOR, W USE @@ MOV, W 1 SLA, \ W 2* is new index into PAGES & WINDOWS TOS PAGES (W) MOV, \ remember this new page# WINDOWS (W) R1 MOV, \ get the window to use into R1 \ map new page into a RAM window R1 0B SRL, \ divide window by 2048 = index into SAMS registers R12 1E00 LI, \ cru address of SAMS 0 SBO, \ SAMS card on TOS SWPB, \ swap bytes on page# argument TOS SAMS (R1) MOV, \ load page# into SAMS card register 0 SBZ, \ SAMS card off WINDOWS (W) TOS MOV, \ get window into TOS R5 TOS ADD, \ add the offset RT, \ ------------------------------------------------------------ CODE >REAL ( virtual -- real) _real32 @@ BL, NEXT, ENDCODE So I added 32bit fetch and store to complete the word set. Now this works like my old HsForth for MsDOS, by the late James Kalihan of Ohio. I can reach out into the 32M range on Classic99 and fetch and store 32bit integers. Bytes work as expected but for ints and doubles you must align the address to the data size. If not you run the risk of writing across a page boundary and parts you your number will not store correctly. \ Fetch and store "LONG" in virtual memory require a double integer address CODE !L ( n d -- ) _real32 @@ BL, *SP+ *TOS MOV, TOS POP, NEXT, ENDCODE CODE 2!L ( d d -- ) _real32 @@ BL, *SP+ *TOS MOV, *SP+ 2 (TOS) MOV, TOS POP, NEXT, ENDCODE CODE C!L ( c d -- ) _real32 @@ BL, 1 (SP) *TOS MOVB, SP INCT, TOS POP, NEXT, ENDCODE CODE @L ( d -- n) _real32 @@ BL, *TOS TOS MOV, NEXT, ENDCODE CODE 2@L ( d -- d) _real32 @@ BL, 2 (TOS) PUSH, *TOS TOS MOV, NEXT, ENDCODE CODE C@L ( d -- c) _real32 @@ BL, *TOS TOS MOVB, TOS 8 SRL, NEXT, ENDCODE I have to use a prefix that I wrote (D#) for doubles because Camel Forth doesn't handle doubles in the kernel. But the screen image shows the system storing and fetching a 32bit integer, at address >1FF0000 (33,388,896) Edited November 24, 2023 by TheBF fixed comment 2 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted November 24, 2023 Share Posted November 24, 2023 Shouldn’t the comment on this line in _real32 TOS 4 SLA, \ segment# * 64 read TOS 4 SLA, \ segment# * 16 ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 24, 2023 Author Share Posted November 24, 2023 7 hours ago, Lee Stewart said: Shouldn’t the comment on this line in _real32 TOS 4 SLA, \ segment# * 64 read TOS 4 SLA, \ segment# * 16 ...lee Yes it should. I will fix it. Thanks. 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted December 27, 2023 Author Share Posted December 27, 2023 I found another place where Forth is discussed on Discord. Someone mentioned tail call optimization so I showed how I did it with a word I called GOTO ( *IP IP MOV,) Another poster asked "Couldn't you use BRANCH?'" After a second I realized I just had to convert the absolute address that GOTO uses, into an offset that Camel Forth BRANCH uses. And when I tried it it made the optimization ~5% faster because BRANCH in Camel99 lives in scratch-pad RAM. \ tail call optimizing semicolon for Camel99 Forth Nov 27 2022 Brian Fox DECIMAL : CELL- 2- ; : PREVXT ( -- XT) HERE CELL- @ ; \ fetch the XT of previous compiled word \ -; does not end with EXIT because it is branching directly to another \ list of tokens. That other list will end in EXIT or NEXT. : -; ( -- ) \ programmer controlled PREVXT >BODY \ get previous XT, compute PFA -2 ALLOT \ erase the previous XT POSTPONE BRANCH HERE - , \ compile BRANCH to the PFA POSTPONE [ \ turn off compiler REVEAL ?CSP ; IMMEDIATE : COLON? ( xt -- ?) @ [ ' DOCOL @ ] LITERAL = ; VARIABLE TAILCALL \ control tail call optimizizing with this variable \ TAILCALL ON turns optimizer on : ; ( -- ) TAILCALL @ IF PREVXT COLON? IF POSTPONE -; ELSE POSTPONE ; THEN ELSE POSTPONE ; THEN ; IMMEDIATE 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted January 3 Author Share Posted January 3 Happy New Year Everybody I was looking at some old code I built for HsForth based on the "Let's Build a Compiler" by Jack Crenshaw Let's Build a Compiler! (penguin.cz) It builds a tiny Pascal compiler and one day I may get enough energy to port it to TI-99. I wondered about putting the keyword table and the symbol table in VDP RAM. You can cram a lot of text into memory using counted strings as a poor-mans linked list. Somebody might want something like this for another purpose and it should port over to the other Forth systems with a few word replacements. If you hit a wall just ask. VC! -> VSBW VC@ -> VSBR VWRITE -> VMBW POSTPONE -> COMPILE I have a little VDP manager library that I include to begin \ VARIABLE VP ( moved to kernel in V2.55 ) HEX 1000 VP ! \ "VDP pointer" start of free VDP RAM : VHERE ( -- addr) VP @ ; \ FETCH the value in VDP pointer : VALLOT ( n -- ) VP +! ; \ add n to the value in VDP pointer : VC, ( n -- ) VHERE VC! 1 VALLOT ; : V, ( n -- ) VHERE V! 2 VALLOT ; : VCOUNT ( vdp$adr -- vdpadr len ) DUP 1+ SWAP VC@ ; : VCREATE ( <text> -- ) VHERE CONSTANT ; \ address when <text> invoked \ : VPLACE ( $addr len Vaddr -- ) \ like PLACE for VDP RAM. In KERNEL 2.6 \ 2DUP VC! 1+ SWAP VWRITE ; Spoiler has the implementation: Edit: I added protection to ADD$ so it doesn't go past the allocated size of the array. Spoiler \ compact string tables in VDP RAM Jan 2024 Brian Fox \ NEEDS DUMP FROM DSK1.LOWTOOLS NEEDS VCOUNT FROM DSK1.VDPMEM \ "place" string caddr/u in VDP memory as byte-counted string : VS, ( caddr u -- ) VHERE OVER 1+ VALLOT VPLACE ; \ compile a string into VDP memory : ," [CHAR] " PARSE VS, ; : NEXT$ ( $addr -- $addr') VCOUNT + ; : NTH$ ( $list n -- $addr) 0 ?DO NEXT$ LOOP ; \ GOTO the nth string \ syntactic sugar. Get length of a string : VLEN ( $addr -- ) POSTPONE VC@ ; IMMEDIATE \ compile null string (0) to start list : VDP{ ( -- VDPaddr) VHERE 0 VC, ; \ compile 0 to end array : }VDP ( Vaddr -- Vaddr size ) 0 VC, \ end with a null string VHERE OVER - ; \ compute the size in bytes \ tables are recorded as a 2CONSTANT : 2CONSTANT CREATE , , DOES> 2@ ; DECIMAL \ Neil Baud's COMPARE modified to compare RAM string to VDP string \ 0 means adr1 = adr2 \ -1 means adr1 < adr2 \ 1 means adr1 > adr2 : VCOMPARE ( addr u1 Vaddr u2 -- -1|0|1 ) ROT 2DUP - >R ( a1 a2 n2 n1) ( R: n2-n1) MIN ( a1 a2 n3) BOUNDS ( loop index I becomes the VDP address) DO ( a1) COUNT I VC@ - ( a1 diff) DUP IF NIP 0< 1 OR ( -1|1) UNLOOP R> DROP EXIT THEN ( a1 diff) DROP ( a1) LOOP DROP ( ) R> DUP IF 0> 1 OR THEN \ 2's complement arithmetic ; \ LOOKUP Returns index into the table or zero : LOOKUP ( addr len table size -- ndx ) DROP NEXT$ -ROT PAD PLACE 1 SWAP BEGIN DUP VLEN WHILE ( string<>0) DUP VCOUNT PAD COUNT 2SWAP VCOMPARE WHILE ( Vcompare<>0) NEXT$ SWAP 1+ SWAP REPEAT THEN ( -- ndx Vaddr ) VLEN 0> \ if string length=0 we hit the end ( ndx ?) AND \ and ndx with flag ; \ create a table of strings that you can add to easily : TABLE: ( n -- ) CREATE VHERE \ VDP address of the table SWAP DUP , VALLOT \ record size, allocate VDP space , 0 VC, \ compile null string in the table DOES> 2@ ( -- Vaddr size) ; : SEEKFREE ( vdp[] size-- Vaddr) BOUNDS ( -- last 1st ) NEXT$ \ skip the first null BEGIN 2DUP > WHILE ( last > 1st) DUP VLEN WHILE NEXT$ REPEAT THEN NIP ; : ADD$ ( addr len vdp[] size -- ) 2DUP + >R \ Rpush end of array SEEKFREE ( -- addr len Vaddr) 2DUP + R> > ABORT" Can't ADD$" DUP>R VPLACE R> VALLOT ; : NEW ( Vaddr size -- ) 0 VFILL ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ And here is what it looks like when you use it. \ >> TEST CODE << \ reset the VDP memory pointer to your chosen first address HEX 1000 VP ! \ create a finite size list of string constants VDP{ ," IF" ," ELSE" ," ENDIF" ," WHILE" ," ENDWHILE" ," DO" ," ENDDO" ," LOOP" ," ENDLOOP" ," REPEAT" ," UNTIL" ," FOR" ," TO" ," ENDFOR" ," BREAK" ," READ" ," WRITE" ," VAR" ," END" ," PROCEDURE" ," PROGRAM" }VDP 2CONSTANT KEYWORDS S" REPEAT" KEYWORDS LOOKUP . S" absent" KEYWORDS LOOKUP . 1024 TABLE: SYMBOLS SYMBOLS NEW S" symbol1" SYMBOLS ADD$ S" symbol2" SYMBOLS ADD$ S" symbol3" SYMBOLS ADD$ S" symbol4" SYMBOLS ADD$ S" symbol5" SYMBOLS ADD$ S" symbol6" SYMBOLS ADD$ S" symbol7" SYMBOLS ADD$ S" symbol8" SYMBOLS ADD$ S" symbol9" SYMBOLS ADD$ S" symbol10" SYMBOLS ADD$ S" symbol11" SYMBOLS ADD$ S" symbol12" SYMBOLS ADD$ S" symbol13" SYMBOLS ADD$ S" symbol14" SYMBOLS ADD$ \ test code to view the tables : VTYPE ( Vaddr len --) BOUNDS ?DO I VC@ EMIT LOOP ; : VPRINT ( V$ -- ) VCOUNT CR VTYPE ; : .TABLE ( table size -- ) BOUNDS NEXT$ BEGIN 2DUP > WHILE DUP VLEN WHILE DUP VPRINT NEXT$ REPEAT THEN 2DROP ; 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted January 3 Author Share Posted January 3 In the VDP packed string arrays in the previous post, I changed ADD$ to give it protection from writing past your allocated TABLE size. Much better. : ADD$ ( addr len vdp[] size -- ) 2DUP + >R \ Rpush end of array SEEKFREE ( -- addr len Vaddr) 2DUP + R> > ABORT" Can't ADD$" DUP>R VPLACE R> VALLOT ; 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.