From 54624392e45175f9a2e7af6af3085a9d36239e9d Mon Sep 17 00:00:00 2001
From: wrmr
Date: Sun, 7 Jan 2024 15:57:45 -0500
Subject: initial commit

---
 adv.f | 779 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 779 insertions(+)
 create mode 100755 adv.f

(limited to 'adv.f')

diff --git a/adv.f b/adv.f
new file mode 100755
index 0000000..e8dc6fe
--- /dev/null
+++ b/adv.f
@@ -0,0 +1,779 @@
+#! /usr/bin/env gforth
+
+\ adventure game (very WIP)
+\ 24 Dec 2023
+
+\ no content yet
+
+\ i plan to try and keep development of this on
+\ tilde.town, so i have a reason to come back other
+\ than website stuff.
+
+\ to do:
+
+\ - add exits and movement
+
+\ - implement basic actions for movement, examination, object manipulation
+
+\ - start fleshing out game world with stuff to do
+
+\ - assemble a... plot? a plotline? a story? gotta have some end goal to
+\   work towards, even if it's just something like "find all thirteen
+\   ancient artifacts and put them in the museum case! :3"
+
+\ - polish, polish, polish.  ANSI colors, custom display words to allow
+\   for screen effects or whatver
+
+\ - tell people about it?
+
+( State )
+
+variable playing?
+
+: init  playing? on ;
+: fini ;
+
+( Utils )
+
+: ],  ] postpone literal ;
+
+( ANSI escape sequences )
+
+char 1 constant red
+char 2 constant green
+char 3 constant yellow
+char 4 constant blue
+char 5 constant magenta
+char 6 constant cyan
+char 7 constant white
+char 9 constant default
+: fg!   .\" \x1b[3" emit ." m" ;
+: bg!   .\" \x1b[4" emit ." m" ;
+: norm  .\" \x1b[0m" ;
+: bold  .\" \x1b[1m" ;
+: ;bold  .\" \x1b[22m" ;
+
+( Display output )
+
+\ carriage returns will cause the next character to
+\ be uppercased automatically! very convenient, i
+\ think, given how new lines generally comprise new
+\ sentences
+
+variable cap  variable capslock  variable col
+: emwait ;
+: crwait ;
+: cr  cr  crwait  col off ;
+: lower?  dup [char] a >= swap [char] z <= and ;
+: ?>upper  dup lower? if -33 and then ;
+variable (pbl)
+: emit  dup bl = >r  1 col +!  dup bl <> (pbl) @ and
+  col @ 64 >= and  r> (pbl) !  if cr then
+  cap @ if ?>upper  cap @ capslock @ and cap !  then  emit  emwait ;
+: type  bounds ?do i c@ emit loop ;
+: ."    postpone s" postpone type ; immediate
+: cr    cr  cap on ;
+: space  bl emit ;
+
+\ FIXME: scan for parenthesized bits of code, such that
+\ .{ You poke [dob .the].} gets ultimately compiled as
+\ S" You poke " TYPE DOB .THE S" ." TYPE
+char [ constant lesc
+char ] constant resc
+: /scan  >r  over swap  r> scan  drop over - ;
+\ feels inefficient -- probably a better way
+: {...}  begin 2dup lesc scan nip while
+  2dup lesc /scan  tuck  postpone sliteral  postpone type
+  1+ /string  2dup resc /scan tuck  evaluate
+  1+ /string repeat dup 0>
+  if    postpone sliteral  postpone type
+  else  2drop  then ;
+: .{    postpone cr
+  begin  [char] } parse  {...}
+  tib >in @ 1- + c@ [char] } = ?dup 0=
+  if postpone space refill 0= then until ; immediate
+
+( String hashing )
+
+: digit?  dup [char] 0 >=  swap [char] 9 <=  and ;
+
+\ collides deliberately, for entertainment purposes.
+\ to calculate max number of letters stored in a single
+\ 64-bit cell, we need to solve for x in 26^x = 2^64.
+\ which is log26(2^64), which is log(2^64)/log(26), which
+\ is a little over thirteen and a half characters.
+
+\ i could be wrong about all of that btw <3
+
+\ considering this is a stupid litle text adventure game,
+\ and something like "construction" is only twelve letters
+\ long, and really it doesn't matter if things get truncated
+\ anyway, i think we're safe.
+
+\ another way fit for 16-bit systems would be to have a
+\ limited vocabulary of words that appear in object names
+\ etc., like the old Infocom games did.  writing a vocabulary
+\ by hand would be boring.  i guess i could make a global
+\ flag called FLESHVOCAB? or sth, and have it so when set
+\ the vocabulary-searching word would add a new vocabulary
+\ entry on failure instead of just returning zero.
+
+\ i'm not gonna do that today!  it would be more portable,
+\ and mister moore says portability's the devil's business.
+\ maybe next time i do something for DOS?  that'd be cool.
+\ forth feels a good fit for text adventure making on small
+\ systems -- 'specially since string parsing words can be
+\ user-defined so it'd be really easy to introduce a custom
+\ text encoding/compression scheme...
+
+\ that sounds so cool, now i think of it...
+
+\ a project for another time!
+
+\ XOR'ing a letter with 32 will toggle upper and lowercase
+: >5bit  dup digit? if [char] 0 - else -33 and [char] A - then  1+ ;
+: hash ( a u -- n )  0 -rot  bounds do  26 *  i c@ >5bit +  loop ;
+: hash"  [char] " parse hash  state @ if postpone literal then ; immediate
+
+( String -> word hashes )
+
+create wdbuf 256 allot
+
+\ hehehe, blch
+
+: blch?  bl <= ;
+: andch?  dup [char] , =  swap [char] & =  or ;
+: thenc?  dup [char] ; =  swap [char] . = or ;
+: punct?  dup andch?  swap thenc?  or  ;
+: wdch?  dup blch?  swap punct?  or 0= ;
+
+: more?  ( a u xt -- )  >r over c@ r> execute  over 0> and ;
+: /bl  begin  ['] blch? more?  while 1 /string repeat ;
+: >word  wdbuf count + c!  wdbuf c@ 1+ wdbuf c! ;
+
+: punctw ( a u -- a u )   over c@
+  dup andch? if drop s" and"  exit then
+  dup thenc? if drop s" then" exit then
+  drop s" unknown" ;
+
+\ side effects taste nice!
+
+: /word  ( a u -- a' u' )  /bl  0 wdbuf c!
+  ['] punct? more? 
+  if  punctw wdbuf place  1 /string  exit then
+  begin ['] wdch? more? while
+  over c@ >word  1 /string  repeat ;
+
+( Chain words )
+
+\ basically words which can be modified later to have
+\ new bits of code running before or after older versions,
+\ stored as a linked list of execution tokens. this makes
+\ it easy to, for instance, define the body of a word and
+\ then narrow it down with special cases and sanity checks
+\ later on down the line. or, in our case here, to define
+\ actions simply, and only afterwards specify "can't do
+\ that, stupid!" under different conditions.
+
+variable ;xt  variable chcont?  variable curch
+: ;  postpone ;  ;xt @ if ;xt @ execute ;xt off then ; immediate
+: ch>head ; : ch>tail cell+ ; : ch>next ; : ch>xt cell+ ;
+: instead  chcont? off ;
+: (chain)  chcont? @ >r  chcont? on  ch>head @
+  begin    dup 0<>  chcont? @  and
+  while    dup >r  ch>xt @ execute  r> ch>next @
+  repeat   drop r> chcont? ! ;
+: ;chain  here curch @ 2dup ch>head ! ch>tail !  0 , , ;
+: (:chain)  create  here curch !  0 , 0 , does> (chain) ;
+: :chain  (:chain)  ['] ;chain ;xt !  :noname ;
+: ch<  ch>tail @      ch>next !  ch>tail ! ;
+: >ch  ch>head @ swap ch>next !  ch>head ! ;
+: ;ere  here  0 , swap ,  swap 2dup >ch ;
+: ;aft  here  0 , swap ,  swap 2dup ch< ;
+: :ere  ' >body  ['] ;ere ;xt !  :noname ;
+: :aft  ' >body  ['] ;aft ;xt !  :noname ;
+
+: ?deny{  postpone if postpone .{ postpone instead
+  postpone exit postpone then ; immediate
+: ?or{  postpone 0= postpone ?deny{ ; immediate
+
+( Actions )
+
+\ action buffers are null-terminated, like c strings
+\ for ease of iteration etc
+
+-1 constant argwd
+create lastact 0 ,
+: act>prev ;
+: act>proc cell+ ;
+: act>buf [ 2 cells ], + ;
+
+\ i think this is a term real people use?
+: glob?  1 =  swap c@ [char] * =  and ;
+
+: actwd  2dup glob? if 2drop argwd else hash then ;
+: s>act, ( a u -- )
+  begin   /word  wdbuf c@ 0>
+  while   wdbuf count actwd ,
+  repeat  0 ,  2drop ;
+
+\ i love parsing words
+
+: act:  ( xt -- )  >r
+  begin   [char] / parse  dup 0>
+  while   here  lastact @ ,  lastact !  r@ ,  s>act,
+  repeat  2drop r> drop ;
+
+( Structures )
+
+\ state-smart fields to yield ... efficiency, maybe?
+\ in this non-realtime text adventure, throttled by the
+\ speed of SSH connections, not the FORTH program?
+\ at the cost of filling SEE with magic numbers?
+\ that part's kinda funny, so i'm keeping it.
+
+\ opaque byte offsets, fuck yeah
+
+\ in a native code forth you could have FIELD directly
+\ compile an inline addition instruction, even w/o a
+\ peephole optimizer to that kinda thing automatically
+\ -- just poke opcodes right into fuckin memory, hell
+\ yeah.
+
+\ this is for gforth, though, which is lame and boring
+\ and traditional and Good Enough
+
+: :recd  create  here 0 ,  0  does> @ ;
+: field  create immediate  over , +  does> @
+  state @ if postpone literal postpone + else + then ;
+: enum   dup constant 1+ ;
+: recd;  swap ! ;
+
+( Exits )
+
+:recd exits
+	enum north
+	enum northeast
+	enum east
+	enum southeast
+	enum south
+	enum southwest
+	enum west
+	enum northwest
+	enum up
+	enum down
+recd;
+
+create oppotbl  south , southwest , west , northwest ,
+north , northeast , east , southeast , down , up ,
+: opposite cells oppotbl + @ ;
+
+( Game objects )
+
+:recd gob
+       cell field >last
+       cell field >flags
+       cell field >rel
+       cell field >env
+       cell field >inv \ latest child object
+       cell field >pob \ previous sibling
+       cell field >nob \ next sibling
+exits cells field >exits
+          0 field >name
+recd;
+: >keys  >name count + ; \ name hash, null-terminated, count-preceded
+: >desc  >keys count 1+ cells + ;
+: >exit  cells + >exits ;
+
+: zallot  here over 0 fill  allot ;
+
+variable desc#
+variable curob
+
+\ gob zallot!  gob zallot!
+\ sounds like a magic spell
+
+: id:  create  here  gob zallot  curob @ over >last !  curob ! ;
+: desc,  dup desc# +!  0 do count c, loop  drop ;
+: ?desc, dup 0> if desc, else 2drop then ;
+: keys,  curob @ >name count  here >r 0 c,
+  begin  /word  wdbuf c@ 0>
+  while  wdbuf count hash ,  r@ c@ 1+ r@ c!
+  repeat 2drop r> drop  0 , ;
+: name:  $0A parse  tuck here place  1+ allot  keys, ;
+: syn:   $0A parse  -1 cells allot
+  begin /word wdbuf c@ 0> while  wdbuf count hash ,
+  curob @ >keys  dup c@ 1+ swap c!  repeat  0 ,  2drop ;
+: nl     s"  " ;
+: desc:  desc# off  here  0 ,
+  begin  source >in @ /string /bl
+	 ?desc, nl desc, refill 0=  #tib @ 0= or
+  until  desc# @ swap ! ;
+: $@     dup cell+ swap @ ;
+
+: excise ( obj -- )
+  dup  dup >env @ >inv @  = if  dup >nob @  over >env @ >inv !  then
+  dup >pob @ ?dup if  over >nob @  swap >nob !  then
+  dup >nob @ ?dup if  over >pob @  swap >pob !  then
+  dup >pob off  dup >nob off  >env off ;
+
+: inv+ ( c to -- )
+  over >nob  over >inv @  swap !
+  dup >inv @ if 2dup >inv @ >pob ! then
+  >inv ! ;
+
+: env!   dup >env @ if dup excise then
+         2dup swap inv+  >env ! ;
+
+variable player
+variable intang
+: you     player @ ;
+
+( Flags )
+
+create flag# 1 ,
+: !flag!  create , does> @  curob @ >flags  tuck @ or  swap ! ;
+: !flag?  create , does> @ swap >flags @ and 0<> ;
+: flag  flag# @  dup !flag!  dup !flag?  2* flag# ! ;
+
+flag	room	room?
+flag	item	item?
+flag	contr	contr?
+flag	suprt	suprt?
+flag	scen	scen?
+
+( Gender and grammar )
+
+\ yaay, my favorite...
+
+flag	an	an?
+flag	the	the?
+flag	proper	proper?
+flag	plur	plur?
+flag	ucnt	ucnt?
+flag	masc	masc?
+flag	fem	fem?
+flag	neut	neut?
+
+: you?  you = ;
+
+: .you  drop bold ." you" ;bold ;
+: .name  >name count  bold type ;bold ;
+
+: when  postpone dup  ' compile,  postpone if
+  $0A parse evaluate  postpone exit  postpone then ; immediate
+
+: .the
+  when you?	.name
+  when proper?	.name
+  		." the " .name ;
+
+: .a
+  when you?	.you
+  when the?	.the
+  when proper?	.name
+  when ucnt?	.name
+  when plur?	." some " .name
+  when an?	." an " .name
+  		." a " .name ;
+
+: .nom
+  when you?	drop ." you"
+  when masc?	drop ." he"
+  when fem?	drop ." she"
+  when neut?	drop ." they"
+  when plur?	drop ." they"
+  		drop ." it" ;
+
+: .acc
+  when you?	drop ." you"
+  when masc?	drop ." him"
+  when fem?	drop ." her"
+  when neut?	drop ." them"
+  when plur?	drop ." them"
+  		drop ." it" ;
+
+: .gen
+  when you?	drop ." your"
+  when masc?	drop ." his"
+  when fem?	drop ." her"
+  when neut?	drop ." their"
+  when plur?	drop ." their"
+  		drop ." its" ;
+
+: .gens
+  when you?	drop ." yours"
+  when masc?	drop ." his"
+  when fem?	drop ." hers"
+  when neut?	drop ." theirs"
+  when plur?	drop ." theirs"
+  		drop ." its" ;
+
+: .ref
+  when you?	drop ." yourself"
+  when masc?	drop ." himself"
+  when fem?	drop ." herself"
+  when neut?	drop ." themself"
+  when plur?	drop ." themselves"
+  		drop ." itself" ;
+
+: .that
+  when you?	drop ." yourself"
+  when masc?	drop ." him"
+  when fem?	drop ." her"
+  when neut?	drop ." them"
+  when plur?	drop ." those"
+  		drop ." that" ;
+
+: are?   dup plur?  over neut? or  swap you? or  ;
+: .is  are? if ." are" else ." is" then ;
+: (s)  are? 0= if ." s" then ;
+
+( Relations )
+
+1 constant in
+2 constant atop
+3 constant under
+4 constant heldby
+: now    ( ob rel env -- )    rot tuck env! >rel ! ;
+: is?    ( ob rel env -- ? )  rot tuck >env @ =   -rot >rel @ =   and ;
+: isn't? ( ob rel env -- ? )  rot tuck >env @ <>  -rot >rel @ <>  or ;
+: first ( rel env -- )  curob @ -rot now ;
+: .rel case
+  in of ." inside" endof
+  atop of ." on top of" endof
+  under of ." underneath" endof
+  heldby of ." held by" endof
+  ." child of"
+  endcase ;
+
+( Object definition shortcuts )
+
+variable lastroom
+: room  room  curob @ lastroom ! ;
+: item  item  in lastroom @ first ;
+: scen  scen  in lastroom @ first ;
+
+( Object debug info display )
+
+8 constant o#max
+create o# 0 ,
+: o.cr  cr  o# @ 2* spaces ;
+
+: o.type  bounds do i c@ $0A = if o.cr else i c@ emit then loop ;
+: o.f  flag# @  begin dup 0> while
+  2dup and if dup ." $" u. then  2/ repeat  2drop ;
+: .o  o# @ o#max > if drop exit then
+  base @ >r hex
+  o.cr  dup >pob @ u. ." <- " dup u. ." -> " dup >nob @ u.
+  o.cr  dup >name count type  ."  ( " dup >flags @ o.f ." ) "
+	dup >rel @ .rel  space  dup >env @ u.
+	dup >env @ ?dup if ." (" >name count type ." )" then
+  o.cr  dup >desc $@ o.type
+  >inv @  begin  ?dup while
+    1 o# +!  dup recurse  -1 o# +!  >nob @  repeat
+  r> base ! ;
+: .o  cr .o cr ;
+: .e  you >env @ ?dup if .o then ;
+
+( Object resolution )
+
+: self-word?
+  dup hash" me" =
+  over hash" self" = or
+  swap hash" myself" = or ;
+
+: called-word? ( hash obj -- )
+  \ over self-word? over you = and if 2drop true exit then
+  false -rot
+  >keys count cells bounds do
+  i @ over = if nip true swap leave then
+  cell +loop  drop ;
+
+: called? ( ha u obj -- )
+  >r true -rot r>
+  -rot  cells bounds do
+  i @ over called-word? 0=
+  if nip false swap leave then
+  cell +loop  drop ;
+
+: inv{  postpone >inv postpone @ postpone begin postpone ?dup
+        postpone while postpone >r ; immediate
+: inv;  postpone r@ postpone r> postpone xor postpone >r ; immediate
+: }inv  postpone r@ postpone if postpone r> postpone >nob
+        postpone @ postpone then postpone repeat ; immediate
+: child  postpone r@ ; immediate
+
+8 constant maxro#  variable ro#  2variable ron ( resob name )
+: (resob)
+  dup  ron 2@  rot called? if exit then
+  ro# @ maxro# >= if drop exit then
+  ro# @  dup >r  1+ ro# !
+  0 swap  inv{
+    child recurse ?dup if nip then
+  }inv  r> ro# ! ;
+: resob  ro# off  ron 2!  you >env @ (resob) ;
+: rob  parse-word hash pad !  pad 1 resob ;
+
+( Action matching )
+
+16 constant #args
+16 constant #argb
+
+variable arg#
+variable argb#
+create argb  #argb cells allot
+create args  #args cells allot
+: argz  args #args cells 0 fill ;
+
+( Most of these words act on a pair of pointers to word hashes,
+  TOS the pattern to check against. )
+
+\ this took me so long to get working, and the main bug
+\ was in the loop condition the whole time, not any of
+\ the code i was looking at.
+
+variable inarg?
+: advance  cell+ swap cell+ swap ;
+variable argend
+: arg   arg# @ cells args + ;
+: arg?  argb# @ 0> ;
+
+\ EOMATCH gets reset for each action we search, so the highest
+\ priority error to occur during FINDACT is used for error msgs
+variable matcherr
+variable eomatch
+: eomatch:  create , does> @ eomatch ! ;
+
+1  dup eomatch: succ
+1+ dup constant #nomatch
+1+ dup constant #notfound
+1+ dup constant #noarg
+drop
+#notfound eomatch: notfound
+#nomatch eomatch: nomatch
+#noarg eomatch: noarg
+
+: badmatch  cr matcherr @ case
+  #noarg of ." Regarding what?" endof
+  #nomatch of ." I didn't understand that." endof
+  #notfound of ." I don't know what that is." endof
+  endcase ;
+
+: :arg  dup @ argend !  inarg? on  argb# off ;
+: article?
+  dup  hash" the" =     over hash" an"   = or
+  over hash" a"   = or  swap hash" some" = or ;
+: >arg
+  dup article? if drop exit then
+  argb# @ #argb 1- >= if drop exit then
+  argb# @ cells argb + !  1 argb# +! ;
+: ;arg  argb argb# @ resob
+  ?dup if  arg ! 1 arg# +!
+  else notfound then inarg? off ;
+
+: argend?  dup  argend @ =  swap 0=  or ;
+: ?;arg  arg? if ;arg else noarg then ;
+: >arg+  over @ >arg  swap cell+ swap ;
+: inarg  over @ argend? if ?;arg else >arg+ then ;
+: same?  over @ over @ = ;
+: atend?  dup @ 0= ;
+: grammar
+  eomatch @ if exit then
+  dup @ argwd =
+  if    cell+ :arg
+  else  same?
+        if    atend? if succ else advance then
+        else  nomatch then
+  then ;
+: match? ( b1 b2 -- ? )
+  eomatch off  arg# off  inarg? off  argz
+  begin   inarg? @ if inarg else grammar then
+          eomatch @  arg# @ #args >=  or
+  until  2drop  eomatch @  dup matcherr @ >
+  if dup matcherr ! then  1 = ;
+
+: findact  matcherr off
+  lastact
+  begin   @ dup
+  while   2dup act>buf match?
+  if      nip exit then
+  repeat  nip ;
+
+( Command execution )
+
+64 constant #cmd
+variable cmd#
+create cmdbuf  #cmd cells allot
+: >cmd  cmd# @ cells cmdbuf + !  1 cmd# +! ;
+: cmd>buf cmd# off
+  begin   /word  wdbuf c@ 0>
+	  cmd# @ #cmd 1- < and  ( leave room for final 0 )
+  while   wdbuf count hash >cmd
+  repeat  0 >cmd  2drop ;
+
+\ confusion stolen from t2tmud.org:9999
+: perform  act>proc @ execute ;
+
+: nostk  depth 0 ?do drop loop ;
+: .exc  bold red fg! ." EXCEPTION #" . norm ;
+: .ok   bold green fg! ."   ok" norm ;
+: cmd4  cr  ['] evaluate catch  ?dup if .exc nostk else .ok then ;
+
+: cmd  over c@ [char] ; = over 0> and
+  if 1 /string cmd4 exit then
+  cmd>buf  cmdbuf findact
+  ?dup if perform else badmatch then ;
+
+( Verb procedures )
+
+: dob  args @ ;
+: iob  args cell+ @ ;
+
+: .inv
+  inv{  child .a  child >nob @
+  if  child >nob @ >nob @
+      if ." , " else ." , and " then
+  then }inv ;
+
+\ Universal verbs
+
+:noname you >inv @
+  if cr ." You hold " you .inv ." ."
+  else cr ." You are empty-handed." then ;
+act: inventory / inv / i
+
+:noname cr ." Goodbye." cr playing? off ;
+act: quit
+
+\ Chain verbs (modifiable)
+\ these end in underscores because it looks like a text cursor
+
+: grammar  ' act: ;
+
+
+: in-desc?  dup you <>  swap scen? 0=  and ;
+: #others  0  over inv{ child in-desc? if 1+ then }inv ;
+: has-others?  #others 0> ;
+
+:chain look_
+  you >env @
+  capslock on  cr bold dup .name norm cr  capslock off
+  cr dup >desc $@ type
+  has-others? if cr cyan fg! then
+  inv{  child in-desc?
+  if    .{ [child .a] [child .is] here.}
+  then }inv  norm ;
+
+:chain exam_  cr dob >desc $@ type
+  dob >inv @ if cyan fg! cr
+  .{ [dob .the] hold[dob (s)] [dob .inv].}
+  norm then ;
+
+:chain take_  dob heldby you now
+  .{ You pick up [dob .the].} ;
+
+:chain drop_  dob you >rel @ you >env @ now
+  .{ You drop [dob .the].} ;
+
+:chain put_in_  dob in iob now
+  .{ You put [dob .the] in [iob .the].} ;
+:chain put_on_  dob in iob now
+  .{ You put [dob .the] on [iob .the].} ;
+
+grammar look_	look / l
+grammar exam_	look * / l * / examine * / x * / look at * / l at *
+grammar take_	get * / take * / pick up * / pick * up
+grammar drop_	drop * / put * down / put down *
+grammar put_in_ put * in */put * into */put * inside */put * inside of */put * within *
+grammar put_on_	put * on * / put * onto */put * atop */put * on top of *
+
+: held  heldby you is? ;
+
+:ere drop_  dob held ?or{ You'd need to pick [dob .nom] up first.} ;
+:ere take_  dob item? ?or{ You can't take [dob .the].} ;
+:ere take_  dob held if instead
+  cr .{ You're already holding [dob .that].} then ;
+:ere take_  dob you = ?deny{ You've always been self-possessed.} ;
+
+variable putrel
+create relatbl  ' contr? , ' suprt? ,
+: relacc?  iob  putrel @ 1- cells relatbl + @ execute ;
+  
+: ?put-rel putrel !
+  dob held ?or{ You're not holding [dob .that].} 
+  dob iob = ?deny{ [putrel @ .rel] [dob .ref]?} 
+  dob you = iob you = or ?deny{ Yourself?}
+  relacc? ?or{ You can't put anything [putrel @ .rel] [dob .that]!} ;
+
+:ere put_in_ in   ?put-rel ;
+:ere put_on_ atop ?put-rel ;
+
+: ?go-to  ?dup
+  if    you in rot now  look_
+  else  .{ You can't go that way.}
+  then ;
+: exit:  >r  :chain  s" you >env @ >exits" evaluate
+  r> cells postpone literal  s" + @ ?go-to" evaluate
+  postpone ; ;
+
+north		exit: n_
+northeast	exit: ne_
+east		exit: e_
+southeast	exit: se_
+south		exit: s_
+southwest	exit: sw_
+west		exit: w_
+northwest	exit: nw_
+up		exit: u_
+down		exit: d_
+grammar d_	d / down / go d / go down
+grammar n_	n / north / go n / go north
+grammar ne_	ne / northeast / go ne / go northeast
+grammar e_	e / east / go e / go east
+grammar se_	se / southeast / go se / go southeast
+grammar s_	s / south / go s / go south
+grammar sw_	sw / southwest / go sw / go southwest
+grammar w_	w / west / go w / go west
+grammar nw_	nw / northwest / go nw / go northwest
+grammar u_	u / up / go u / go up
+grammar d_	d / down / go d / go down
+
+: ->  ' execute  swap cells  curob @ >exits +  ! ;
+: <-  curob @  swap cells ' execute >exits +  ! ;
+: <->  >r  curob @ ' execute  2dup
+  >exits r@ opposite cells + !
+  swap >exits r> cells + ! ;
+
+: :diob  curob @ postpone literal  postpone <>
+  postpone if postpone exit postpone then postpone instead ;
+\ doesn't work in VFX Forth?
+: :iob  :ere postpone iob :diob ;
+: :dob  :ere postpone dob :diob ;
+
+\ Grammar
+
+( User interface )
+
+256 constant #inbuf
+create inbuf #inbuf allot
+: prompt  ." > " ;
+: input  green fg!  cr bold prompt ;bold
+  inbuf #inbuf accept  inbuf swap  norm ;
+: intro  page look_ cr ;
+: play  init intro  begin playing? @ while  input cmd cr repeat  fini ;
+
+( Game world )
+
+: room:  id: room ;
+: item:  id: item ;
+: scen:  id: scen ;
+: you:   id: in lastroom @ first  curob @ player ! ;
+: to:    >r lastroom @  room:  curob @
+  2dup r@ opposite >exit !  swap r> >exit ! ;
+
+include gam.f
+
+( Play )
+
+play bye
-- 
cgit 1.4.1-2-gfad0