#! /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