\ (c) 1983 by A. Clapman - Design and original Spectrum BASIC programming
\ (c) 1996,7 by H. Bezemer - Structured design and 4tH programming

\ Extract from a time-travellers diary discovered in the pyramid of
\ Ikhotep, pharoah of the ninth dynasty, on the planet Sirius B,
\ in the dog star system.

\ "I have been attempting to discover the secret of the pyramid for some
\ months now. It is the only way I will be able to escape this barren
\ planet. After my time-machine was destroyed by the warrior tribe I
\ found my way to this dusty monument after consulting a man they regard
\ as a wizard. He is in fact a fellow traveller in time and space exiled
\ by the Time Lords to this lost planet. He has decided to stay and
\ persue his black arts amoung the warrior folk. But he has told me of
\ a time gate which will lead me back to the main time lanes and freedom.
\ He said the gate was hidden within the pyramid. I have uncovered some
\ clues but not enough to lead me to the final solution. I can only keep
\ trying. But I feel that, for me at least, time is running out."

\ The diary was found next to a small pile of oddly shaped bones deep
\ within the heart of the pyramid.

\ Can you find your way out of the pyramid and off the barren planet?
\ You will find several rooms within the pyramid and several objects
\ within those rooms which must be collected to solve the riddle of the
\ ancient monument. The program uses the standard two word entry system
\ and adjectives should not be entered. To move simply type in the
\ direction you want to go, for example 'N' or 'north'. Other useful
\ words are TAKE, GET, THROW, DROP, INVENTORY.

true  constant 4TH

4TH [IF]
false constant FORTH

true  constant HARDTAB
false constant SOFTTAB

: length$ count ;                      \ 4tH compatible count
#pad constant #temp$                   \ size of temp. string
[THEN]

FORTH [IF]
include 4th.frt cls                    \ load interface

true  constant HARDTAB
false constant SOFTTAB

: length$ count swap 1- swap ;         \ Forth compatible count
80 constant #temp$                     \ size of temp. string
[THEN]

HARDTAB [IF]
: tab 9 emit ;                         \ print a TAB
[THEN]

SOFTTAB [IF]
: tab 4 spaces ;                       \ alternative tab
[THEN]

#temp$ string temp$                    \ temporary space for string

0 constant todo                        \ is still alive
1 constant done                        \ is already dead
2 constant seen                        \ dragon has seen you

1 string ?dragon                       \ is dragon alive
1 string ?tree                         \ is tree uncut
1 string ?door                         \ is the door intact
1 string ?wall                         \ is the wall closed
1 string ?helmet                       \ is the helmet off
1 string ?power                        \ is the power off

 0 constant moving                     \ code action groups
 1 constant GOnorth
 2 constant GOsouth
 3 constant GOwest
 4 constant GOeast
 5 constant taking
 6 constant dropping
 7 constant sawing
 8 constant smashing
 9 constant wearing
10 constant connect
11 constant pushing
12 constant filing
13 constant killing
14 constant listing

-1   constant NULL                     \ NULL pointer

create actions                         \ map vocabulary to actions
  " go"        , moving ,
  " move"      , moving ,
  " run"       , moving ,
  " walk"      , moving ,
  " north"     , GOnorth ,
  " n"         , GOnorth ,
  " south"     , GOsouth ,
  " s"         , GOsouth ,
  " west"      , GOwest ,
  " w"         , GOwest ,
  " east"      , GOeast ,
  " e"         , GOeast ,
  " get"       , taking ,
  " take"      , taking ,
  " steal"     , taking ,
  " drop"      , dropping ,
  " throw"     , dropping ,
  " leave"     , dropping ,
  " saw"       , sawing ,
  " cut"       , sawing ,
  " fell"      , sawing ,
  " chop"      , smashing ,
  " smash"     , smashing ,
  " axe"       , smashing ,
  " wear"      , wearing ,
  " connect"   , connect ,
  " insert"    , pushing ,
  " push"      , pushing ,
  " sharpen"   , filing ,
  " file"      , filing ,
  " kill"      , killing ,
  " stab"      , killing ,
  " knife"     , killing ,
  " invent"    , listing ,
  " objects"   , listing ,
  " inventory" , listing ,
  " list"      , listing ,
  NULL ,

14 constant #objects                   \ number of objects

 0 constant watch                      \ code objects
 1 constant dragon
 2 constant generator
 3 constant tree
 4 constant slab
 5 constant door
 6 constant saw
 7 constant mirror
 8 constant reflector
 9 constant coin
10 constant knife
11 constant dagger
12 constant helmet
13 constant axe

create objects                         \ map vocabulary to objects
  " watch"     , watch ,
  " dragon"    , dragon ,
  " generator" , generator ,
  " tree"      , tree ,
  " slab"      , slab ,
  " door"      , door ,
  " saw"       , saw ,
  " mirror"    , mirror ,
  " reflector" , reflector ,
  " coin"      , coin ,
  " knife"     , knife ,
  " dagger"    , dagger ,
  " helmet"    , helmet ,
  " axe"       , axe ,
  NULL ,

0  constant stays                      \ cannot be moved
1  constant moves                      \ can be moved

create attributes                      \ map attributes to objects
  " wrist"                  , moves ,
  " magenta, firebreathing" , stays ,
  " mobile electricity"     , moves ,
  " Canadian Redwood"       , stays ,
  " granite"                , moves ,
  " thick wooden"           , stays ,
  " electric"               , moves ,
  " purple"                 , moves ,
  " green"                  , moves ,
  " 10 pence"               , moves ,
  " butter"                 , moves ,
  " razor sharp"            , moves ,
  " safety"                 , moves ,
  " sharp"                  , moves ,

-1 constant _Person_                   \ locations
-1 constant _Exit_
 0 constant _NoWhere_
 1 constant _RoadWE_
 2 constant _RoadBend_
 3 constant _ShackW_
 4 constant _ShackE_
 5 constant _RoadNS_
 6 constant _RoadN_
 7 constant _Pyramid_
 8 constant _Embalm_
 9 constant _Recreation_
10 constant _ANKH_
11 constant _Triangular_
12 constant _Oblong_
13 constant _Funeral_
14 constant _Treasure_
15 constant _Cave_
16 constant _Garden_

create locations                       \ map locations to directions
  " a road leading west and east. Two things are pointing to the west." ,
  _NoWhere_ , _NoWhere_ , _Exit_ , _RoadBend_ ,
  " a bend in the road." ,
  _NoWhere_ , _RoadNS_ , _RoadWE_ , _NoWhere_ ,
  " a small dark shack." ,
  _NoWhere_ , _NoWhere_ , _NoWhere_ , _RoadNS_ ,
  " a small dark shack." ,
  _NoWhere_ , _NoWhere_ , _RoadNS_ , _Cave_ ,
  " a road leading north and south. There are shacks either side." ,
  _RoadBend_ , _RoadN_ , _ShackW_ , _ShackE_ ,
  " a road leading north. There is a pyramid south." ,
  _RoadNS_ , _Pyramid_ , _NoWhere_ , _NoWhere_ ,
  " the entrance hall of the pyramid. There is a road north." ,
  _RoadN_ , _Oblong_ , _Embalm_ , _Recreation_ ,
  " the embalming room." ,
  _NoWhere_ , _NoWhere_ , _ANKH_ , _Pyramid_ ,
  " the recreation room. An exit to the garden is east." ,
  _NoWhere_ , _Funeral_ , _Pyramid_ , _Garden_ ,
  " the room of ANKH." ,
  _NoWhere_ , _NoWhere_ , _NoWhere_ , _Embalm_ ,
  " a small triangular room." ,
  _NoWhere_ , _NoWhere_ , _NoWhere_ , _Oblong_ ,
  " a long oblong room" ,
  _Pyramid_ , _Treasure_ , _Triangular_ , _NoWhere_ ,
  " the funeral parlour" ,
  _Recreation_ , _NoWhere_ , _NoWhere_ , _NoWhere_ ,
  " the treasure room. It has been looted. There is a smashed door north." ,
  _Oblong_ , _NoWhere_ , _NoWhere_ , _NoWhere_ ,
  " a small circular cave." ,
  _NoWhere_ , _NoWhere_ , _ShackE_ , _NoWhere_ ,
  " a small garden." ,
  _NoWhere_ , _NoWhere_ , _Recreation_ , _NoWhere_ ,

#objects array map                     \ map of objects

create default
   _ShackW_ ,                          \ watch in west shack
   _ShackE_ ,                          \ dragon in east shack
   _RoadBend_ ,                        \ generator in bend of the road
   _Garden_ ,                          \ tree in the garden
   _Funeral_ ,                         \ slab in funeral parlor
   _Oblong_ ,                          \ door in oblong room
   _Triangular_ ,                      \ saw in triangular room
   _ANKH_ ,                            \ mirror in room of ANKH
   _Cave_ ,                            \ reflector in cave
   _Treasure_ ,                        \ coin in treasure room
   _RoadNS_ ,                          \ knife on north/south road
   _NoWhere_ ,                         \ dagger is nowhere
   _Pyramid_ ,                         \ helmet in pyramid
   _NoWhere_ ,                         \ axe is nowhere

: initmap                              \ fills the map with values
  #objects 0
  do
    default i th @'
    map i th !
  loop

  todo ?dragon c!                      \ reset flags
  todo ?tree   c!
  todo ?door   c!
  todo ?wall   c!
  todo ?helmet c!
  todo ?power  c!
;

: print$ count type ;                  \ print a string

: CANNOT                               \ default warning
  ." YOU CAN'T, IDIOT!!" CR CR
  r> drop
;

: DEAD                                 \ exit game
  ." YOU'RE DEAD!!" CR CR
  quit
;

: IDUNNO                               \ I don't know!
  ." I don't know what a " print$ ."  is." CR CR
;

: OUTSIDE                              \ not here!
  ." It isn't here!!" CR CR
  r> drop
;

: MISSING
  ." You aren't carrying it, stupid!!" CR CR
  r> drop
;

true constant ?ignore                  \ ignore case
                                       \ this routine compares two strings
: match                                ( a1 a2 -- f )
  length$ 1+                           ( a1 a2 n )
  dup 0                                ( a1 a2 n n 0 )
  do                                   ( a1 a2 f )
    drop                               ( a1 a2 )
    over i + c@                        ( a1 a2 c1)
    over i + c@                        ( a1 a2 c1 c2)
    xor ?ignore                        ( a1 a2 n f)
    if                                 ( a1 a2 n)
      32 not and                       ( a1 a2 f)
    then                               ( a1 a2 f)
    dup                                ( a1 a2 f f)
    if                                 ( a1 a2 f)
      leave
    then                               ( a1 a2 f)
  loop
  >r drop drop r>                      ( f )
;
                                       \ this routine finds the matching token
: find                                 ( a -- xt f | a -f )
  begin
    over over                          ( a1 tk a1 tk)
    @' dup NULL <>                     ( a1 tk a1 s f )
    if                                 ( a1 tk a1 s )
      temp$ copy                       ( a1 tk a1 a2 )
      match dup                        ( a1 tk f2 f1 )
    else
      drop drop true false             ( a1 tk f2 f1 )
    then
  while                                ( a1 tk f2 )
    drop                               ( a1 tk )
    cell+ cell+                        ( a1 tk )
  repeat                               ( a1 tk f )

  if                                   ( a1 tk )
    drop false                         ( a1 f )
  else
    swap drop                          ( tk )
    cell+ @' true                      ( xt f )
  then
;
                                       \ this routine interprets a string
: decode                               ( tk -- )
  bl word length$ 0=                   ( tk a f )
  if swap drop false exit              ( a -f )
  else swap find                       ( xt f | a -f )
  then
;

variable north
variable south
variable west
variable east

_RoadBend_ value where                 \ room where you are

: direction        ( a var -- a+1 )    \ fill direction variable
  swap cell+ dup @' rot !
;

: room             ( -- xt )           \ get address of room
  where 1- 5 cells * locations +
;

: display          ( a -- )            \ display a string
  @' temp$ copy print$
;

: except           ( val flag where )  \ make flag of exception
  where =                              ( val flag f )
  rot rot                              ( f val flag )
  c@ =                                 ( f f )
  and                                  ( f )
;

: correct                              \ correct directions
  except
  if false swap ! else drop then
;

: north?                               \ going north ?
  north @ if ." North" tab then
;

: south?                               \ going south ?
  south todo ?door _Oblong_ correct
  south @ if ." South" tab then
;

: west?                                \ going west ?
  west todo ?wall _Embalm_ correct
  west @ if ." West" tab then
;

: east?                                \ going east ?
  east todo ?dragon _ShackE_ correct
  east @ if ." East" tab then
;

: showcontents                         \ prints the appropriate strings
  tab
  2* dup attributes swap th display
  bl emit
  objects swap th display
  cr
;

: contents                             \ shows the contents of a room
  0 #objects 0
  do
    map i th @
    where =
    if 1+ i showcontents then
  loop
  0= if tab ." None" cr then
                                       \ all exceptions
  todo ?wall _Embalm_ except
  if cr ." There is a small slot on the west wall." cr then
  seen ?dragon _ShackE_ except
  if cr ." The dragon doesn't like you so he kills you." cr DEAD then
  todo ?dragon _ShackE_ except
  if cr ." The dragon blocks a hole in the EAST wall." cr seen ?dragon c! then

  where _ShackE_ <>
  ?dragon c@ seen =
  and

  if todo ?dragon c! then

  done ?dragon _ShackE_ except
  if cr ." The dragon is dead." cr then
  todo ?tree _Garden_ except
  if cr ." There is something glistening at the top of the tree." cr then
  done ?tree _Garden_ except
  if cr ." The tree is lying on the ground" cr then
  done ?door _Oblong_ except
  if cr ." The door is smashed down" cr then
;

: missing?             ( n -- f )
  map swap th @ _Person_ <>
;

: lastroom?

  where _Exit_ =

  if
    ." LASER BOLTS FLASH OUT FROM THE KILLO-ZAP GUNS FIXED TO THE ROAD!" CR

    mirror missing? reflector missing? and
    if
      ." FRIZZLE!!" CR
      DEAD
    then

    reflector missing?
    if
      ." THE LEFT RAY IS REFLECTED BY THE MIRROR. THE RIGHT ONE ISN'T!!" CR
      DEAD
    then

    mirror missing?
    if
      ." THE RIGHT RAY IS REFLECTED BY THE REFLECTOR. THE LEFT ONE ISN'T!!" CR
      DEAD
    then

    ." BOTH THE RAYS ARE REFLECTED BY THE MIRROR AND THE REFLECTOR!!" CR
    ." YOU HAVE MANAGED TO ESCAPE ALIVE!!" CR CR
    quit
  then
;

: showroom
  lastroom?
  ." You are at "
  room dup display cr                  \ show location
  north direction
  south direction
  west  direction
  east  direction
  drop
  ." Directions you may proceed in:" cr tab
  north? south? west? east? CR CR
  ." Things of interest here:" cr
  contents
;

0 constant do-move                     \ dummy executable

: do-go                                ( var -- )
  @ dup 0=                             ( n f )
  if                                   ( n )
    drop CANNOT                        ( -- )
  else                                 ( n )
    to where                           ( -- )
  then
;

: go-north                             \ go north
  north do-go
;

: go-south                             \ go south
  south do-go
;

: go-west                              \ go west
  west do-go
;

: go-east                              \ go east
  east do-go
;

: do-take                              \ take an object
  objects decode
  if                                   \ do we already have it?
    dup map swap th @ _Person_ =
    if drop ." YOU ARE ALREADY CARRYING IT!!" CR CR exit then
                                       \ do we have a watch?
    dup watch <> watch missing? and
    if drop ." YOU HAVEN'T GOT ANYTHING TO CARRY IT IN!!" CR CR exit then
                                       \ is it here?
    dup map swap th @ where <>
    if drop OUTSIDE then
                                       \ can we move it?
    dup 2* 1+ attributes swap th @' stays =
    if drop CANNOT then

    dup 0=
    if                                 \ put the watch on
      ." YOU STRAP IT ON YOUR WRIST."
    else                               \ zoom it in your watch
      ." IT ZOOMS SAFELY INTO YOUR WATCH!"
    then

    cr cr                              \ now you carry it
    map swap th _Person_ swap !
  else
    IDUNNO
  then
;

: do-drop                              \ drop object
  objects decode
  if
    dup missing?                       \ do we have it?
    if drop MISSING then
                                       \ drop it in the room
    dup where map rot th !
                                       \ put your helmet off
    helmet =
    if todo ?helmet c! then
  else
    IDUNNO
  then
;

: do-saw                               \ saw tree
  objects decode
  if
    tree <>                            \ saw a tree?
    ?tree c@ 0<>                       \ is tree cut?
    generator missing?                 \ do we have a generator?
    saw missing?                       \ do we have a saw?
    or or or

    if CANNOT then

    where _Garden_ <>                  \ are we in the garden?
    if OUTSIDE then

    ?power c@ 0=                       \ do we have power?
    if ." The saw won't work without electricity!!" cr cr exit then

    ?helmet c@ 0=                      \ are we wearing a helmet?
    if ." The  tree falls on your unprotected head. Crunch." cr cr DEAD then

    done ?tree c!                      \ now cut the tree
    ." The tree falls down on your safety helmet." cr
    ." An axe falls out of the top of the tree." cr cr
    where map axe th !                 \ and show the axe

  else
    IDUNNO
  then
;

: do-smash                             \ smash door
  objects decode
  if
    door <>                            \ do we smash a door?
    axe missing?                       \ do we have an axe?
    ?door c@ 0<>                       \ is the door smashed?
    or or

    if CANNOT then

    where _Oblong_ <>                  \ are we in the oblong room?
    if OUTSIDE then

    ." Chop chop smash smash.. The door has been smashed down." cr cr
    done ?door c!                      \ now smash the door
  else
    IDUNNO
  then
;

: do-wear                              \ wear helmet
  objects decode
  if                                   \ do we want to wear a helmet?
    helmet <> if CANNOT then

    helmet missing?                    \ do we have a helmet?
    if MISSING then

    done ?helmet c!                    \ now put on the helmet
  else
   IDUNNO
  then
;

: do-connect                           \ connect generator
  objects decode
  if
    dup dup                            \ do we connect a generator
    saw <> swap generator <> and       \ or a saw?
    if drop CANNOT then

    missing?                           \ do we have it?
    if MISSING then

    saw missing? generator missing? or \ do we miss anything?
    if CANNOT then

    done ?power c!                     \ ok, power is on!
  else
    IDUNNO
  then
;

: do-push                              \ push wall
  objects decode
  if
    dup
    coin <>                            \ do we insert a coin?
    if drop CANNOT then

    dup missing?                       \ do we have it?
    if drop MISSING then

    where _Embalm_ <>                  \ are we in the embalming room?
    if
      drop ." I can't see anywhere to insert it!!"
    else
      map swap th _NoWhere_ swap !     \ coin disappears in slot
      ." The wall suddenly shakes and glides one side leaving a doorway west!!"
      done ?wall c!                      \ the wall is open!
    then

    cr cr
  else
    IDUNNO
  then
;

: do-file                              \ file knife
  objects decode
  if
    dup knife <>                       \ do we want to file a knife?
    if drop CANNOT then

    missing?                           \ do we have a knife?
    if MISSING then

    slab missing?                      \ do we have a slab?
    if
      ." You haven't got anything to sharpen it on!!"
    else
      ." The knife turns extra sharp!!"
      _NoWhere_ map knife  th !        \ knife turns into
      _Person_  map dagger th !        \ a dagger!
    then

    cr cr
  else
    IDUNNO
  then
;

: do-kill                              \ kill dragon
  objects decode
  if
    dragon <>                          \ do we want to kill a dragon?
    dagger missing?                    \ is the dagger missing?
    or

    if CANNOT then

    where _ShackE_ <>                  \ are we in the east shack?
    if OUTSIDE then

    ?dragon c@ done =                  \ is the dragon alive?
    if
      ." The poor thing is already dead."
    else
      done ?dragon c!                  \ now he is!
      ." Squelch. The dagger sinks to the hilt in the dragon." cr
      ." It's dead. Poor thing."
    then

    cr cr
  else
    IDUNNO
  then
;

: do-list                              \ shows the inventory
  ." You are carrying:" cr
  0 #objects 0
  do
    map i th @
    _Person_ =
    if cell+ i showcontents then
  loop
  0= if tab ." Nothing" cr then
  cr
;

create do-it                           \ jumptable to words
  ' do-move    ,
  ' go-north   ,
  ' go-south   ,
  ' go-west    ,
  ' go-east    ,
  ' do-take    ,
  ' do-drop    ,
  ' do-saw     ,
  ' do-smash   ,
  ' do-wear    ,
  ' do-connect ,
  ' do-push    ,
  ' do-file    ,
  ' do-kill    ,
  ' do-list    ,

: action                              \ decode & execute action
  begin
    true                              ( f )
    actions decode                    ( f xt f )
    if                                ( f xt )
      dup moving =                    ( f xt f )
      if                              ( f xt )
        drop drop false               ( -f )
      else                            ( f xt )
        do-it swap th @' execute      ( f )
      then
    else                              ( f a )
      ." I don't know how to " print$ [char] . emit CR CR
    then                              ( f )
  until
;

: command                              \ input a command
  CR ." COMMAND " query CR
  action
;

: venture                              \ main program
  initmap
  begin
    showroom
    command
  again
;

venture
