(HP71B) Speed experience with Video (EMU71 and Video80 screen)

[floppy]

Another graphic program: SNAKE in forth (last update 13 Dec 2023; tested on EMU71; speed improvement)

2023 12 28 bug: will be corrected the next weeks.. in case the new apple location appear on the body area of the snake, it will disappear from the screen. Rarely happening. However > 0.26%

Upload:
FTHUTILA and C
TIME (ASM)
H71B1
SNAKE

keys:
w or W up
a or A left
s or S down
d or D right

start in the forth prompt with..
D-D ( redirect to the screen )
SSNAKE

H71B1

Code:

( under CC BY SA CreativeCommons floppy @ )
( https://www.hpmuseum.org/forum/ )
VARIABLE CELLV
HERE 0 , HERE SWAP - CELLV !
2 STRING RES2CHR
RES2CHR 27 CHR$ S<& 69 CHR$ S<& 2DROP
-1 CONSTANT TRUE
0 CONSTANT FALSE
: >= < 0= ;
: 0<> 0= 0= ;
: .R >R S->D R> D.R ;
: D0= OR 0= ;
: D= D- D0= ;
: 2, , , ;
: 2! SWAP OVER ! 5+ ! ;
: 2@ DUP 5+ @ SWAP @ ; 
: 2CONSTANT CREATE , , DOES> 2@ ;
: 2VARIABLE CREATE 0 , 0 , DOES> ;
: 2NIP 2SWAP 2DROP ;
: AT-XY 27 EMIT 37 EMIT SWAP EMIT EMIT ;
: AT-XY<BF 2SWAP 27 CHR$ S<& 37 CHR$ S<& 4 ROLL CHR$ S<& ROT
CHR$ S<& ;
: BLANK 20 FILL ;
: CELLS 5 * ;
: CELL+ 5+ ;
: CELL- 5- ;
: CHAR+ 2+ ;
: CHAR- 2- ;
: CHAR BL WORD CHAR+ C@ ;
: NIP SWAP DROP ;
: N>$ S->D STR$ ;
: ON TRUE SWAP ! ;
: OFF FALSE SWAP ! ;
: PAGE 27 EMIT 69 EMIT ;
: WITHIN OVER - >R - R> U< ;
: VALUE CREATE , DOES> @ ;
: CHARS 2* ;
: COMPARE S= 0<> ;
: CLEARSTR DROP DUP 1 CHARS - 0 SWAP C! 0 ;
: MS 0 DO LOOP ;
: PERFORM @ EXECUTE ;
: -ROT ROT ROT ;
: PMOD DUP -ROT MOD DUP 0< IF + ELSE NIP THEN ;
: STRDUMP OVER 0 DO DUP I SWAP MOD 0= IF CR ELSE THEN -ROT C@+ .
ROT " " TYPE LOOP 2DROP DROP ;

SNAKE

Code:

( original from https://github.com/robertpfeiffer/forthsnake/.. )
( ..blob/master/snake.forth )
( updates under CC BY SA CreativeCommons floppy @ )
( https://www.hpmuseum.org/forum/ )
76 STRING LINEBUF
128 STRING SIDEBUF
52 STRING SL1
" +--------------------------------------------------+" SL1 S!
: STRV CREATE DUP 1 - 5 * 1 + DUP C, C, 43 C, 2 - 0 DO 27 C, 66
C, 27 C, 68 C, 124 C, LOOP 27 C, 66 C, 27 C, 68 C, 43 C, DOES>
1 CHARS + DUP 1 CHARS + SWAP C@ ;
15 STRING SNAKEBUF
21 STRING LENGTHBUF
5 STRING APPLEBUF
: MYRAND OVER - TIME 1000.0 F/ FP 100000.0 F* FTOI SWAP PMOD + ;
: SNAKE-SIZE 200 ;
: XDIM 51 ;
: YDIM 21 ;
YDIM 1 + STRV SV1
CREATE SNAKE SNAKE-SIZE CELLS 2 * NALLOT
CREATE APPLE 2 CELLS NALLOT
CREATE APPLE_OLD 2 CELLS NALLOT
VARIABLE HEAD
VARIABLE LENGTH
VARIABLE DIRECTION
: SEGMENT HEAD @ + SNAKE-SIZE PMOD CELLS 2 * SNAKE + ;
: POS+ ROT + -ROT + SWAP ;
: POINT= 2@ ROT 2@ ROT = -ROT = AND ;
: HEAD* 0 SEGMENT ;
: MOVE-HEAD! HEAD @ 1 - SNAKE-SIZE PMOD HEAD ! ;
: GROW! 1 LENGTH +! ;
: EAT-APPLE! APPLE 2@ APPLE_OLD 2! 1 XDIM MYRAND 1 YDIM MYRAND
APPLE 2! GROW! ;
: STEP! HEAD* 2@ MOVE-HEAD! POS+ HEAD* 2! ;
: LEFT -1 0 ; 
: RIGHT 1 0 ;
: DOWN 0 1 ;
: UP 0 -1 ;
: WALL? HEAD* 2@ 1 YDIM WITHIN SWAP 1 XDIM WITHIN AND NOT ;
: CROSSING? FALSE LENGTH @ 1 2DUP = IF 2DROP ELSE DO I SEGMENT
HEAD* POINT= OR LOOP THEN ;
: APPLE? HEAD* APPLE POINT= ;
: DEAD? WALL? CROSSING? OR ;
: DRAW-FRAME LINEBUF CLEARSTR 0 0 AT-XY<BF SL1 S<& OUTPUT
LINEBUF CLEARSTR 0 YDIM AT-XY<BF SL1 S<& OUTPUT SIDEBUF CLEARSTR
0 0 AT-XY<BF SV1 S<& OUTPUT SIDEBUF CLEARSTR XDIM 0 AT-XY<BF SV1
S<& OUTPUT ;
: DRAW-SNAKE SNAKEBUF CLEARSTR LENGTH @ 0 2DUP = IF 2DROP ELSE
DO I SEGMENT 2@ AT-XY<BF 35 CHR$ S<& LOOP THEN OUTPUT ;
: UPDATE-SNAKE SNAKEBUF CLEARSTR 0 SEGMENT 2@ AT-XY<BF " #" S<&
OUTPUT SNAKEBUF CLEARSTR LENGTH @ SEGMENT 2@ AT-XY<BF 32 CHR$
S<& OUTPUT ;
: DRAW-APPLE APPLEBUF CLEARSTR APPLE 2@ AT-XY<BF " Q" S<& OUTPUT
;
: UPDATE-APPLE APPLEBUF CLEARSTR APPLE_OLD 2@ AT-XY<BF " #"
S<& OUTPUT DRAW-APPLE ;
: DRAW-LENGTH LENGTHBUF CLEARSTR 0 22 AT-XY<BF " SNAKE LENGTH: "
S<& LENGTH @ N>$ S<& OUTPUT ;
: UPDATE-LENGTH LENGTHBUF CLEARSTR 14 22 AT-XY<BF LENGTH @ N>$
S<& OUTPUT ;
: NEWGAME! RES2CHR OUTPUT 0 HEAD ! XDIM 2 / YDIM 2 / SNAKE 2! 3
3 APPLE 2! 3 LENGTH ! ['] UP DIRECTION ! LEFT STEP! LEFT STEP!
LEFT STEP! LEFT STEP! DRAW-FRAME DRAW-SNAKE DRAW-APPLE
DRAW-LENGTH ;
: GAMELOOP BEGIN DUP MS ?TERMINAL IF KEY DUP 97 = IF ['] LEFT
ELSE DUP 65 = IF ['] LEFT ELSE DUP 119 = IF ['] UP ELSE DUP 87 =
IF ['] UP ELSE DUP 100 = IF ['] RIGHT ELSE DUP 68 = IF ['] RIGHT
ELSE DUP 115 = IF ['] DOWN ELSE DUP 83 = IF ['] DOWN ELSE 
DIRECTION @ THEN THEN THEN THEN THEN THEN THEN THEN DIRECTION !
DROP THEN DIRECTION PERFORM STEP! APPLE? IF EAT-APPLE!
UPDATE-APPLE UPDATE-LENGTH ELSE UPDATE-SNAKE THEN DEAD? UNTIL
DROP ." *** GAME OVER ***" CR ;
: SSNAKE DELAY00  0 PRIMARY !  RES2CHR OUTPUT CR CR 
." Snake in Forth" CR CR 3000 MS NEWGAME! 200 GAMELOOP ;