Willsy Posted February 6, 2022 Share Posted February 6, 2022 (edited) Nick Morgan has a great github where he teaches some first principles of Forth. The page is particularly impressive because there is a Forth interpreter built in to the web page: You can execute Forth code right on the web page. Very impressive. The page includes a nice little Snake game example. I was particularly struck by the clarity of the code. It took about 10 minutes to convert the code to run in TurboForth, which I think is testament to the clarity of the code - it's very easy to understand. Posted for comments, and hopefully will inspire others to give Forth a try on the TI. There are three great Forth systems available for yout TI: TurboForth, fbForth, and CAMEL99. This particular version is written for TurboForth, but could easily be changed to run on the other systems. I took the code and made a couple of changes. I added a score feature, and a play again feature. Enjoy. Here's the code: \ Attribution: Originally written by Nick Morgan. \ source: https://skilldrick.github.io/easyforth/#snake \ Adapted for TurboForth: Mark Wills, 4 Feb 2022. variable snake-x-head 100 cells allot variable snake-y-head 100 cells allot variable apple-x variable apple-y variable score variable delay 0 constant left 1 constant up 2 constant right 3 constant down 24 constant height variable direction variable length variable last-key : snake-x ( offset -- address ) cells snake-x-head + ; : snake-y ( offset -- address ) cells snake-y-head + ; : draw-white ( x y -- ) xmax * + bl swap v! ; : draw-black ( x y -- ) xmax * + ascii # swap v! ; : draw-O ( x y -- ) xmax * + ascii o swap v! ; : draw-walls ( -- ) 0 0 ascii # xmax hchar 23 0 ascii # xmax hchar 0 0 ascii # 23 vchar 0 xmax 1- ascii # 23 vchar ; : init-snake 4 length ! length @ 1 + 0 do 12 i - i snake-x ! 12 i snake-y ! loop right direction ! ; : show-score ( -- ) score @ n>s dup xmax swap - 0 gotoxy type ; : set-apple-pos ( x y -- ) apple-y ! apple-x ! ; : init-apple ( -- ) 4 4 set-apple-pos ; : initialize page draw-walls init-snake init-apple 0 score ! show-score 1500 delay ! ; : move-up -1 snake-y-head +! ; : move-left -1 snake-x-head +! ; : move-down 1 snake-y-head +! ; : move-right 1 snake-x-head +! ; : move-snake-head ( -- ) direction @ left over = if move-left else up over = if move-up else right over = if move-right else down over = if move-down then then then then drop ; : move-snake-tail ( -- ) 0 length @ do i snake-x @ i 1+ snake-x ! i snake-y @ i 1+ snake-y ! -1 +loop ; : is-horizontal ( -- ) direction @ dup left = swap right = or ; : is-vertical ( -- ) direction @ dup up = swap down = or ; : turn-up ( -- ) is-horizontal if up direction ! then ; : turn-left ( -- ) is-vertical if left direction ! then ; : turn-down ( -- ) is-horizontal if down direction ! then ; : turn-right ( -- ) is-vertical if right direction ! then ; : change-dir ( key -- ) ascii s over = if turn-left else ascii e over = if turn-up else ascii d over = if turn-right else ascii x over = if turn-down then then then then drop ; : check-input ( -- ) key? 32 or change-dir ; : random-position ( -- n ) xmax 2- rnd ; : move-apple ( -- ) apple-x @ apple-y @ draw-white random-position 1+ ( x) random-position 22 mod 1+ ( y) set-apple-pos ; : grow-snake ( -- ) length @ 1+ 100 min length ! ; : check-apple ( -- ) snake-x-head @ apple-x @ = snake-y-head @ apple-y @ = and if move-apple grow-snake 1 score +! show-score delay @ 20 - 100 max delay ! then ; : check-collision ( -- flag ) snake-x-head @ snake-y-head @ xmax * + v@ ascii # = ; : draw-snake ( -- ) length @ 0 do i snake-x @ i snake-y @ draw-black loop length @ snake-x @ length @ snake-y @ draw-white ; : draw-apple ( -- ) apple-x @ apple-y @ draw-O ; : wait ( n -- ) delay @ 0 do loop ; : centered ( c-addr u y ) >r xmax 1 >> over 1 >> - r> gotoxy type ; : game-over ( -- flag ) s" OOPS! That's gotta hurt!" 11 centered s" Game over! Play again? (Y/N)" 12 centered key 32 or ascii n = ; : game-loop ( -- ) begin draw-snake draw-apple check-input move-snake-tail move-snake-head check-apple wait check-collision until ; : start ( -- ) begin initialize game-loop game-over until cr ; That's it. That's all it takes to make a simple game. Enjoy! Edited February 7, 2022 by Willsy code tweaks (thanks Lee Stewart) 10 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted February 6, 2022 Share Posted February 6, 2022 5 hours ago, Willsy said: Nick Morgan has a great github where he teaches some first principles of Forth. The page is particularly impressive because there is a Forth interpreter built in to the web page: You can execute Forth code right on the web page. Very impressive. The page includes a nice little Snake game example. I was particularly struck by the clarity of the code. It took about 10 minutes to convert the code to run in TurboForth, which I think is testament to the clarity of the code - it's very easy to understand. Posted for comments, and hopefully will inspire others to give Forth a try on the TI. There are three great Forth systems available for yout TI: TurboForth, fbForth, and CAMEL99. This particular version is written for TurboForth, but could easily be changed to run on the other systems. I took the code and made a couple of changes. I added a score feature, and a play again feature. Not sure why game-over does not throw a “stack underflow” error: key ascii n = over ascii N = or ; <<---should cause stack underflow key dup ascii n = swap ascii N = or ; <<---will do what you intend Here are some minimal changes I would make [it is always easier to pick apart someone else’s code than one’s own ]: : change-dir ( key -- ) 32 or \ <<---force key to lower case ascii s over = if turn-left else ascii e over = if turn-up else ascii d over = if turn-right else ascii x over = if turn-down then then then then drop ; : game-over ( -- flag ) s" OOPS! That's gotta hurt!" 11 centered s" Game over! Play again? (Y/N)" 12 centered key 32 or \ <<---force key to lower case ascii n = ; \ <<---just check for 'n' ...lee 4 Quote Link to comment Share on other sites More sharing options...
GDMike Posted February 6, 2022 Share Posted February 6, 2022 Kept getting that stack underflow on my attempts at coding Forth yesterday, and tracked each word down by "\" commenting the definition one by one while reloading until I found the culprit. It's pretty easy to find unknown areas that throw errors. But then you have to fix the error. Lol 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted February 6, 2022 Share Posted February 6, 2022 In my obsessive way I took this game and used it to learn how to make my system work better. I never wrote games so it gave me a good skeleton and poked holes in my system. It is also politically incorrect since my snake likes to eat mice not apples. oops! Anyway here is the source code after 6 interations and blowing up my underlying code. I must confess that it does get a bit addictive trying to go at "Viper" speed. It doesn't have a remembered scoring system so it's still not a finished product. I attached an executable program for the E/A cartridge option 5. Spoiler \ snake a simple game in Forth ported to CAMEL99 Forth \ DERIVED FROM: https://skilldrick.github.io/easyforth/#snake \ revised to use CAMEL99/TI-99 features CR .( \\\\\\ Version 6 \\\\\\\\ ) \ \\ snake sounds and mouse squeak \\\\\ INCLUDE DSK1.RANDOM INCLUDE DSK1.GRAFIX INCLUDE DSK1.CASE INCLUDE DSK1.ARRAYS INCLUDE DSK1.UDOTR INCLUDE DSK1.MARKER CR .( compiling Snake...) \ ======================================= \ We use direct control of the sound chip \ rather than sound lists and a player. HEX \ noise control words : NOISE ( n -- ) E0 OR SND! ; \ n selects the noise type \ noise envelope control : NOISE-DB ( db --) F MIN F0 OR SND! ; : NOISE-OFF ( -- ) F NOISE-DB ; DECIMAL : NOISE-UP ( speed -- ) 2 15 DO I NOISE-DB DUP MS -1 +LOOP DROP ; : NOISE-DOWN ( speed -- ) 15 2 DO I NOISE-DB DUP MS LOOP DROP NOISE-OFF ; \ channel 1 sound control words DECIMAL : f(clk) ( -- d) 46324 1 ; \ this is 111,860 as 32 bit int. \ >FCODE re-arranges freq. value nibbles (4bits) for the TMS9919 HEX : >FCODE ( 0abc -- 0cab) \ ASM would make this much faster DUP 0F AND SWAP ( -- 000c 0abc) 4 RSHIFT ( -- 000c 00ab) SWAP >< ( SWPB) ( -- 00ab 0c00) + ; : HZ>CODE ( freq -- fcode ) f(clk) ROT UM/MOD NIP >FCODE 8000 OR ; \ *TRICKY STUFF* \ Calculating the 9919 freq. code takes too long BUT we can convert frequency \ to 9919 chip code at compile time then compile as 16 bit literal number \ using this text MACRO : [HZ] ( freq -- fcode ) S" HZ>CODE ] LITERAL" EVALUATE ; \ sound channel #1 control words : FREQ! ( fcode -- ) SPLIT SND! SND! ; : ]HZ ( freq -- ) [HZ] POSTPONE FREQ! ; \ pre-compiled fcode version : HZ ( freq -- ) HZ>CODE SPLIT SND! SND! ; \ runtime calculation version : DB ( n -- ) 90 OR SND! ; : MUTE ( -- ) 9F SND! ; DECIMAL 500 CONSTANT MAXLENGTH \ x/y coordinate storage for the snake MAXLENGTH 2+ ARRAY ]SNAKE-X MAXLENGTH 2+ ARRAY ]SNAKE-Y : SNAKE-X-HEAD ( -- addr) [ 0 ]SNAKE-X ] LITERAL ; : SNAKE-Y-HEAD ( -- addr) [ 0 ]SNAKE-Y ] LITERAL ; .( .) VARIABLE SPEED VARIABLE PREY-X VARIABLE PREY-Y VARIABLE DIRECTION VARIABLE LENGTH \ characters used DECIMAL 136 CONSTANT SHEAD \ use different color set 42 CONSTANT SNAKE 128 CONSTANT PREY 30 CONSTANT BRICK BL CONSTANT WHITE \ Direction #s 0 CONSTANT LEFT 1 CONSTANT UP 2 CONSTANT RIGHT 3 CONSTANT DOWN HEX CREATE HEADLEFT 0C16 , 37FF , FF37 , 160C , CREATE HEADUP 1818 , 3C7E , 99FF , 7E3C , CREATE HEADRIGHT 3068 , ECFF , FFEC , 6830 , CREATE HEADDOWN 3C7E , FF99 , 7E3C , 1818 , \ array of head patterns CREATE HEADS ( n -- addr ) HEADLEFT , HEADUP , HEADRIGHT , HEADDOWN , \ set head pattern n to snake's head : ]HEADPATTERN ( n -- addr) CELLS HEADS + @ SHEAD CHARDEF ; : FACE ( direction# -- ) DUP ]HEADPATTERN DIRECTION ! ; \ shape data for PREY, brick, mouse and snake chars HEX CREATE CLAY 007E , 6A56 , 6A56 , 7E00 , CREATE VIPER 3C5E , EBF7 , EBDD , 7E3C , CREATE MOUSE 0004 , 3E7B , 7FFC , 8270 , CREATE MOUSE2 0008 , 3F7B , 7EFC , 8270 , \ mouse looking up CREATE JUMPMS 84BE , FB7F , 3C42 , 0000 , DECIMAL \ get random x or y position within playable area : RANDOM-X ( -- n ) C/L@ 2- RND 1+ ; : RANDOM-Y ( -- n ) L/SCR 2- RND 1+ ; \ text macros make drawing faster. : DRAW-WHITE ( x y -- ) S" >VPOS BL SWAP VC! " EVALUATE ; IMMEDIATE : DRAW-SNAKE ( X Y -- ) S" >VPOS SNAKE SWAP VC! " EVALUATE ; IMMEDIATE : DRAW-HEAD ( x y -- ) S" >VPOS SHEAD SWAP VC! " EVALUATE ; IMMEDIATE : DRAW-PREY ( -- ) PREY PREY-X @ PREY-Y @ >VPOS VC! ; .( .) : DRAW-WALLS 0 0 BRICK 31 HCHAR 0 1 BRICK 22 VCHAR 31 0 BRICK 24 VCHAR 0 23 BRICK 31 HCHAR ; : DRAW-SNAKE SNAKE-X-HEAD @ SNAKE-Y-HEAD @ DRAW-HEAD LENGTH @ 1 DO I ]SNAKE-X @ I ]SNAKE-Y @ DRAW-SNAKE LOOP LENGTH @ DUP ]SNAKE-X @ SWAP ]SNAKE-Y @ DRAW-WHITE ; : INITIALIZE-SNAKE 6 DUP LENGTH ! 1+ 0 DO 12 I - I ]SNAKE-X ! 12 I ]SNAKE-Y ! LOOP RIGHT FACE ; : PLACE-PREY ( y x -- ) PREY-X ! PREY-Y ! ; : MOVE-SNAKE-HEAD ( n -- ) DIRECTION @ CASE LEFT OF -1 SNAKE-X-HEAD +! ENDOF UP OF -1 SNAKE-Y-HEAD +! ENDOF RIGHT OF 1 SNAKE-X-HEAD +! ENDOF DOWN OF 1 SNAKE-Y-HEAD +! ENDOF ENDCASE ; \ move each segment of the snake forward by one DECIMAL \ : MOVE-SNAKE-TAIL \ 0 LENGTH @ \ DO \ I ]SNAKE-X DUP @ SWAP CELL+ ! \ I ]SNAKE-Y DUP @ SWAP CELL+ ! \ -1 +LOOP ; : MOVE-SNAKE-TAIL \ src addr dest addr size \ --------- --------- ------------- SNAKE-X-HEAD DUP CELL+ LENGTH @ CELLS CMOVE> SNAKE-Y-HEAD DUP CELL+ LENGTH @ CELLS CMOVE> ; : MOVE-SNAKE ( -- ) MOUSE2 PREY CHARDEF 4 NOISE 8 NOISE-DB \ soft white noise MOVE-SNAKE-TAIL 10 NOISE-DB \ ramp down noise MOVE-SNAKE-HEAD 12 NOISE-DB \ ramp down noise MOUSE PREY CHARDEF NOISE-OFF ; .( .) DECIMAL : HORIZONTAL? ( -- ?) DIRECTION @ DUP LEFT = SWAP RIGHT = OR ; : VERTICAL? ( -- ?) DIRECTION @ DUP UP = SWAP DOWN = OR ; : TURN-UP HORIZONTAL? IF UP FACE THEN ; : TURN-LEFT VERTICAL? IF LEFT FACE THEN ; : TURN-DOWN HORIZONTAL? IF DOWN FACE THEN ; : TURN-RIGHT VERTICAL? IF RIGHT FACE THEN ; ( EXIT THEN gets out of the case statement faster than ENDOF) : CHANGE-DIRECTION ( key -- ) CASE [CHAR] S OF TURN-LEFT EXIT THEN \ ENDOF [CHAR] E OF TURN-UP EXIT THEN \ ENDOF [CHAR] D OF TURN-RIGHT EXIT THEN \ ENDOF [CHAR] X OF TURN-DOWN EXIT THEN \ ENDOF ENDCASE ; DECIMAL : SWOOSH ( -- ) NOISE-OFF 5 NOISE 8 NOISE-UP 20 NOISE-DOWN ; : NEW-PREY SWOOSH PREY-X @ PREY-Y @ DRAW-WHITE RANDOM-Y RANDOM-X PLACE-PREY DRAW-PREY ; : GROW-SNAKE ( -- ) 1 LENGTH +! ; : DEAD-SNAKE ( -- ) NOISE-OFF SNAKE SET# DUP 11 1 COLOR 250 MS 2 1 COLOR SHEAD SET# 2 1 COLOR ; : HAPPY-SNAKE ( -- ) [ SNAKE SET# ] LITERAL 17 3 DO DUP I 1 COLOR I 100 * HZ 0 DB 40 MS LOOP MUTE ( -- 5) 13 1 COLOR ; .( .) DECIMAL : DECAY ( n -- ) 16 0 DO I DB DUP MS LOOP DROP ; : SQUEAK ( -- ) NOISE-OFF [ 3800 ]HZ 0 DB 45 MS \ pre-computed freq. is faster 6 DB 25 MS [ 3500 ]HZ 75 MS 8 DB 25 MS [ 1300 ]HZ 11 DB 25 MS [ 800 ]HZ MUTE ; DECIMAL : SCARED-PREY ( -- ) JUMPMS PREY CHARDEF SQUEAK [ PREY SET# ] LITERAL DUP 9 1 COLOR 2 1 COLOR MOUSE PREY CHARDEF ; : FASTER ( -- ) SPEED @ 5 - 1 MAX SPEED ! ; : CHECK-PREY ( -- ) SNAKE-X-HEAD @ PREY-X @ = SNAKE-Y-HEAD @ PREY-Y @ = AND IF SCARED-PREY HAPPY-SNAKE GROW-SNAKE FASTER NEW-PREY THEN ; : COLLISION? ( -- ? ) SNAKE-X-HEAD @ SNAKE-Y-HEAD @ >VPOS VC@ DUP BRICK = SWAP SNAKE = OR ; \ utility words for menus : WAIT-KEY BEGIN KEY? UNTIL ; : AT" POSTPONE AT-XY POSTPONE ." ; IMMEDIATE : INITIALIZE PAGE 4 SCREEN MOUSE PREY CHARDEF PREY SET# 2 1 COLOR CLAY BRICK CHARDEF BRICK SET# 9 1 COLOR VIPER SNAKE CHARDEF SNAKE SET# 13 1 COLOR SHEAD SET# 7 1 COLOR DRAW-WALLS INITIALIZE-SNAKE RANDOM-Y RANDOM-X PLACE-PREY ; .( .) HEX : PLAY ( -- ) BEGIN SPEED @ MS DRAW-SNAKE DRAW-PREY 83C8 OFF \ set continuous key reading KEY? CHANGE-DIRECTION MOVE-SNAKE CHECK-PREY COLLISION? UNTIL 0C SCREEN HONK 0B 5 AT" GAME OVER" HONK DEAD-SNAKE ; DECIMAL : ENDGAME 5 14 AT" You sure? (Y/N)" KEY [CHAR] Y = IF PAGE ABORT ELSE 5 14 >VPOS 26 BL VFILL THEN ; : SETLEVEL ( n --) SPEED ! ; : BREAK; POSTPONE EXIT POSTPONE THEN ; IMMEDIATE DECIMAL : MENU PAGE 5 5 AT" Select Start Level" 5 8 AT" 1 - SNAIL" 5 9 AT" 2 - WORM" 5 10 AT" 3 - SNAKE 5 11 AT" 4 - VIPER" 5 12 AT" 5 - Quit 3 23 AT" (It goes faster as you win)" BEGIN 5 13 AT-XY KEY CASE [CHAR] 1 OF 150 SETLEVEL BREAK; [CHAR] 2 OF 110 SETLEVEL BREAK; [CHAR] 3 OF 75 SETLEVEL BREAK; [CHAR] 4 OF 50 SETLEVEL BREAK; [CHAR] 5 OF ENDGAME ENDOF HONK ENDCASE AGAIN ; DECIMAL : TITLE ( -- ) GRAPHICS 5 5 AT" THE SNAKE" 5 7 AT" Use the E,S,D,X keys" 5 8 AT" to move the snake 5 9 AT" and catch the mouse." 5 12 AT" The more he eats, 5 13 AT" the faster he goes!" 5 20 AT" Press any key to begin..." WAIT-KEY ; .( .) : RUN ( -- ) TITLE BEGIN MENU INITIALIZE PLAY 500 MS KEY? DROP ( wait for key release) 2 13 AT" Your snake was " LENGTH @ . ." Ft. long" 2 15 AT" Press ENTER to play again" KEY 13 <> UNTIL NOISE-OFF 8 20 AT" SSSSSee you later!" 1500 MS GRAPHICS ; : COLD WARM RUN BYE ; LOCK INCLUDE DSK1.SAVESYS ' COLD SAVESYS DSK3.SNAKE6 SNAKE6.zip 3 3 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.