Robot game in FORTH

robots.forth

anew =============================robots=============================

\ refactored the following a bit
\ https://gist.github.com/nfunato/39490e1e5d41a9a2d8b0f614a46feeea#file-02a_robots-fs

\ -------------------------------------------------------------------
\ General utils

: not ( v -- f )  0= ;
: 3dup ( a b c -- a b c a b c )  dup 2over rot ;
: clear-input  begin key? while key drop repeat ;

\ NOTE: the followings can be replaced by 'include random.fs', execpt randomize.
variable seed
$10450405 Constant generator            \ 272958459
: rnd  ( -- n )  seed @ generator um* drop 1+ dup seed ! ;
: random ( n -- 0..n-1 )  rnd um* nip ;
: randomize  utime drop seed ! ;

\ -------------------------------------------------------------------
\ Constants

  64 constant SCR_WIDTH
  16 constant SCR_HEIGHT

1024 constant POS#              \ 1024=64x16
 544 constant SCR_CENTER_POS    \ 64*8 + 32

10 constant MONSTER#

-8191 constant BYE_THROW \ users' throwval must be less than -4095

\ -------------------------------------------------------------------
\ Screen manaagement

\ Gforth's MOD uses FM/MOD(Floored-Mod), so we don't need to redefine MOD.
\ (cf. section 3.2.2.1 of https://forth-standard.org/standard/usage)
\ : mod  ( n1 n2 -- n3 )     \ this MOD certainly uses fm/mod, not sm/rem
\    >r s>d r> fm/mod drop ;

: =>pos ( x y -- pos )
    \ NOTE: overhang from the screen is handled by MODs in the definition.
    SCR_HEIGHT mod  SCR_WIDTH *  >r
    SCR_WIDTH mod  r> + ;

: =>coord ( pos -- x y )
    s>d SCR_WIDTH fm/mod ;

: coord+ ( x1 y1 x2 y2 -- x1+x2 y1+y2 )
    rot + >r + r> ;

: pos+coord ( pos xofs yofs -- pos' )
    \ see comment at =>pos
    rot =>coord coord+ =>pos ;

: distance ( pos1 pos2 -- manhattan-distance )
    >r =>coord r> =>coord rot - abs >r - abs r> + ;

: at-coord ( x y -- )  1 1 coord+ at-xy ;
: at-pos ( pos -- )  =>coord at-coord ;
: at-bottom  0  SCR_HEIGHT 2 +  at-xy ;

\ -------------------------------------------------------------------
\ Position management (human)

\ ?-offset ( -- dx dy )
: q-offset -1 -1 ;  : w-offset  0 -1 ;  : e-offset  1 -1 ;
: a-offset -1  0 ;  : s-offset  0  0 ;  : d-offset  1  0 ;
: z-offset -1  1 ;  : x-offset  0  1 ;  : c-offset  1  1 ;

: offset-fn ( ch -- ofsFn )
    case
        [char] q of ['] q-offset endof
        [char] w of ['] w-offset endof
        [char] e of ['] e-offset endof
        [char] a of ['] a-offset endof
        [char] d of ['] d-offset endof
        [char] z of ['] z-offset endof
        [char] x of ['] x-offset endof
        [char] c of ['] c-offset endof
        ['] s-offset swap
    endcase ;

: my-new-pos ( pos -- pos' )
    clear-input
    at-bottom ." qwe/asd/zxc to move, (t)eleport, (l)eave: "
    key dup [char] l = if 2drop BYE_THROW throw  else
        dup [char] t = if 2drop POS# random      else
        ( pos ch ) offset-fn execute pos+coord
        then then ;

variable 'my-pos
: init-my-pos  SCR_CENTER_POS 'my-pos ! ;
: update-my-pos  'my-pos @  my-new-pos  'my-pos ! ;

\ -------------------------------------------------------------------
\ Position management (monsters)

create monsters  MONSTER# cells allot  does> swap cells + ;

: randomize-monster ( omit-pos -- mpos )
    begin POS# random 2dup <> until nip ;

: init-monsters-pos ( omit-pos -- )
    MONSTER# 0 do  dup randomize-monster  i monsters !  loop
    drop ;

: captured? ( -- f )
    'my-pos @  false
    MONSTER# 0 do  over i monsters @ = if true or leave then  loop
    nip ;

: monster-stuck? ( mpos -- f )
    0
    MONSTER# 0 do  over i monsters @ = if 1+ then  loop 1 >
    nip ;

: all-monsters-stuck? ( -- f )
    true
    MONSTER# 0 do  i monsters @ monster-stuck? not if false and leave then  loop ;

\ select min-distance adjacent
: monster-new-pos ( mpos -- mpos' )
    'my-pos @
    locals| my-pos mpos |
    \ see comment at pos+coord
    2 -1 do 2 -1 do mpos j i pos+coord  dup my-pos distance loop loop
    8 0 do ( pos1 dist1 pos2 dist2 ) 3dup nip > if 2swap then  2drop loop
    drop ;

: update-monster-pos { 'm }
    'm @  monster-stuck? not if 'm @  monster-new-pos  'm ! then ;

: update-monsters-pos
    MONSTER# 0 do i monsters update-monster-pos loop ;

\ -------------------------------------------------------------------
\ Display

: .+  [char] + emit ;  : .-  [char] - emit ;  : .|  [char] | emit ;
: .@  [char] @ emit ;  : .A  [char] A emit ;  : .#  [char] # emit ;

: .me
    'my-pos @ at-pos .@ ;

: .monster ( pos -- )
    dup at-pos monster-stuck? if .# else .A then ;

: .monsters
    MONSTER# 0 do i monsters @ .monster loop ;

: .frame-1 { x0 y0 xn yn -- }
    x0 y0 at-xy xn x0 do .- loop
    yn y0 1+ do x0 i at-xy .| xn i at-xy .| loop
    x0 yn at-xy xn x0 do .- loop
    xn yn x0 yn xn y0 x0 y0 4 0 do at-xy .+ loop ;

: .frame
    0 0 SCR_WIDTH 1+ SCR_HEIGHT 1+ .frame-1 ;

: .screen
    page .frame .me .monsters at-bottom ;

\ -------------------------------------------------------------------
\ Robots

1 constant PLAYER_WIN
2 constant PLAYER_LOSE
3 constant PLAYER_LOSE2     \ PLAYER_WIN | PLAYER_LOSE

: robots-loop ( -- result )
    0 begin
        .screen
        captured?           if PLAYER_LOSE or then
        all-monsters-stuck? if PLAYER_WIN  or then
    dup 0= while
        update-my-pos
        update-monsters-pos
        \ assert( depth 1 = ) assert( dup 0= )
    repeat ;

: robots
    randomize
    init-my-pos
    'my-pos @ init-monsters-pos
    ['] robots-loop catch ( minusThrowVal | resultVal 0 )
    at-bottom
    ?dup if
        case
            BYE_THROW of cr ." BYE" endof
            dup throw
        endcase
    else
        case
            PLAYER_WIN   of ." PLAYER WIN!"  endof
            PLAYER_LOSE  of ." PLAYER LOSE!" endof
            PLAYER_LOSE2 of ." PLAYER LOSE!" endof
            abort" robots"
        endcase
    then ;

cr .( Please type 'robots' to play the robots game.)
cr .( If you want to provide a turnkey system, uncomment the last line.)
cr
\ ROBOTS