1. snake.fth

\ a study of github.com/robertpfeiffer/forthsnake, although essentially the same
include random.fs     \ the only line depending on GFORTH
: not ( b -- b ) 0= ; \ changed since the def. in the original means INVERT
: myrand ( fr to -- r ) swap dup >r - 1+ random r> + ; \ random at [fr,to]

200 constant snake-size
 50 constant xdim
 20 constant ydim

create snake snake-size cells 2* allot does> swap snake-size mod cells 2* + ;
2variable apple
variable head
variable length
variable direction

: segment ( seg -- adr ) head @ + snake ;
: pos+    ( x1 y1 x2 y2 -- x y ) rot + -rot + swap ;
: point=  ( ptadr1 ptadr2 -- f ) 2@ rot 2@ rot = -rot = and ;

: head*   ( -- adr ) 0 segment ;
: move-head!  ( -- ) head @ 1- snake-size mod head ! ;
: grow!       ( -- ) 1 length +! ;

: eat-apple!  ( -- ) 1 xdim myrand 1 ydim myrand apple 2! grow! ;
: step! ( dx dy -- ) head* 2@ move-head! pos+ head* 2! ;

: left  ( -- dx dy ) -1  0 ;
: right ( -- dx dy )  1  0 ;
: down  ( -- dx dy )  0  1 ;
: up    ( -- dx dy )  0 -1 ;

: wall?     ( -- f ) head* 2@ 1 ydim within swap 1 xdim within and not ;
: crossing? ( -- f ) false length @ 1 do i segment head* point= or loop ;
: apple?    ( -- f ) head* apple point= ;
: dead?     ( -- f ) wall? crossing? or ;

: draw-frame ( -- )  0 0 at-xy
                     xdim 0 do ." +" loop
                     ydim 0 do xdim i at-xy ." +" cr ." +" loop
                     xdim 0 do ." +" loop cr ;
: draw-snake ( -- )  length @ 0 do i segment 2@ at-xy ." #" loop ;
: draw-apple ( -- )  apple 2@ at-xy ." Q" ;

: render     ( -- )  page draw-snake draw-apple draw-frame  cr length @ . ;

: newgame! ( -- )
  0 head !  xdim 2/ ydim 2/ HEAD* 2!  3 3 apple 2!  3 length !
  ['] up direction !  left step! left step! left step! left step! ;

: gameloop ( time -- )
    begin
        render dup ms
        key? if
            key dup [char] h = if ['] left  else
                dup [char] k = if ['] up    else
                dup [char] l = if ['] right else
                dup [char] j = if ['] down  else
                direction @
                then then then then
            nip direction !
        then
        direction perform step!
        apple? if eat-apple! then
    dead? until drop
    ." *** GAME OVER ***" ;

newgame!

." Snake in Forth"
3000 ms
200 gameloop

2. snake-orig.fs

\ the code from github.com/robertpfeiffer/forthsnake
\ (in rev2, I will re-write it for clarity)
: not ( b -- b ) true xor ;
: myrand ( a b -- r ) over - utime + swap mod + ;

: snake-size 200 ;
: xdim 50 ;
: ydim 20 ;

create snake snake-size cells 2 * allot
create apple 2 cells allot
variable head
variable length
variable direction

: segment ( seg -- adr ) head @ + snake-size mod cells 2 * snake + ;
: pos+ ( x1 y1 x2 y2 -- x y ) rot + -rot + swap ;
: point= 2@ rot 2@ rot = -rot = and ;

: head* ( -- x y ) 0 segment ;
: move-head! ( -- ) head @ 1 - snake-size mod head ! ;
: grow! ( -- ) 1 length +! ;

: eat-apple! ( -- )  1 xdim myrand 1 ydim myrand apple 2! grow! ;
: step! ( xdiff ydiff -- ) head* 2@ move-head! pos+ head* 2! ;

: left  -1  0 ;
: right  1  0 ;
: down   0  1 ;
: up     0 -1 ;

: wall? ( -- bool ) head* 2@ 1 ydim within swap 1 xdim within and not ;
: crossing? ( -- bool ) false length @ 1 ?do i segment head* point= or loop ;
: apple? ( -- bool ) head* apple point= ;
: dead? wall? crossing? or ;

: draw-frame ( -- ) 0 0 at-xy xdim 0 ?do ." +" loop
 ydim 0 ?do xdim i at-xy ." +" cr ." +" loop xdim 0 ?do ." +" loop cr ;
: draw-snake ( -- ) length @ 0 ?do i segment 2@ at-xy ." #" loop ;
: draw-apple ( -- ) apple 2@ at-xy ." Q" ;

: render page draw-snake draw-apple draw-frame cr length @ . ;

: newgame!
  0 head ! xdim 2 / ydim 2 / snake 2! 3 3 apple 2! 3 length !
  ['] up direction ! left step! left step! left step! left step! ;

: gameloop ( time -- )
begin render dup ms
key? if key
   dup 97 = if ['] left else
   dup 119 = if ['] up else
   dup 100 = if ['] right else
   dup 115 = if ['] down else direction @
   then then then then
  direction ! drop then
direction perform step!
apple? if eat-apple! then
dead? until drop ." *** GAME OVER ***" ;

newgame!

." Snake in Forth"
3000 ms
200 gameloop

sushi3.fth

\ derived joke app
anew --sushi--
: srcfile s" sushi3.fth" ;
' srcfile set-srcfile

: (TBF) abort ;

: 2-  2 - ;
: under-swap ( a b c -- b a c ) >r swap r> ;
: pos+ ( x1 y1 x2 y2 -- x1+x2 y1+y2 ) under-swap + >r + r> ;
: pos= ( x1 y1 x2 y2 -- f           ) under-swap = >r = r> and ;
: .hbar   [char] - emit ;
: .vbar   [char] | emit ;
: .corner [char] + emit ;

40 constant xdim
11 constant ydim
16 constant buf-size
variable 'head
2variable 'dir
variable 'corner-count

create ringbuf buf-size cells 2* allot does> swap buf-size mod cells 2* + ;
: seg   ( seg#  -- segadr )  'head @ + ringbuf ;
: 0seg  (       -- segadr )  0 seg ;
: head@ (       -- x y    )  0seg 2@ ;
: head! ( x y   --        )  0seg 2! ;
: dir@  (       -- dx dy  )  'dir 2@ ;
: dir!  ( dx dy --        )  'dir 2! ;
: move-head!  'head @ 1- buf-size mod 'head ! ;
: step!       head@ dir@ pos+ move-head! head! ;
: turn-left!  dir@ swap negate dir! ;

: corner? ( x y -- f )
	2dup 1       1       pos= if true else
	2dup 1       ydim 1- pos= if true else
	2dup xdim 1- 1       pos= if true else
	2dup xdim 1- ydim 1- pos= if true else
	false
	then then then then
	nip nip ;

: draw-frame { x0 xn y0 yn -- }
	x0 y0 at-xy xn x0 do .hbar loop
	yn y0 do x0 i at-xy .vbar xn i at-xy .vbar loop
	x0 yn at-xy xn x0 do .hbar loop
	xn yn  x0 yn  xn y0  x0 y0  4 0 do at-xy .corner loop ;
: draw-iframe  2 xdim 2- 2 ydim 2- draw-frame ;
: draw-eframe  0 xdim    0 ydim    draw-frame ;

: .sushi-char ( u -- ) s" sushi " drop + c@ emit ;
: draw-sushi  6 0 do i seg 2@ at-xy i .sushi-char loop ;

: corner-count++  1 'corner-count +! ;
: cycle-count ( -- u ) 'corner-count @ 1- 4 / ;
: draw-lap     0 ydim 1+ at-xy ." Lap: " cycle-count 1+ . ;

3 value max-count
: sushi-init 0 'head ! -1 0 dir! 7 1 head! 5 0 do step! loop 0 'corner-count ! ;
: sushi-loop
	page draw-iframe draw-eframe 
	begin
		draw-sushi draw-lap 50 ms
		step! 
		head@ corner? if turn-left! corner-count++ then
	cycle-count max-dount >= until ;
: sushi  sushi-init sushi-loop ;
: n-sushi ( cnt -- ) to max-count sushi ;

\ sushi