\ (c) 1983 by A. Clapman - Design and original Spectrum programming
\ (c) 1996 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. 
) 

: print$  count type ;
: tab     9 emit ;

80 constant #temp$			\ size of temp. string (Forth)

true constant ?ignore			\ ignore case
-1   constant NULL			\ NULL pointer
 6   constant #flags			\ No. flags

CREATE flags #flags chars ALLOT		\ flags
CREATE temp$ #temp$ chars ALLOT		\ temporary space for string

CREATE map 14 cells allot

 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

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

 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
  c" watch"     , watch ,
  c" dragon"    , dragon ,
  c" generator" , generator ,
  c" tree"      , tree ,
  c" slab"      , slab ,
  c" door"      , door ,
  c" saw"       , saw ,
  c" mirror"    , mirror ,
  c" reflector" , reflector ,
  c" coin"      , coin ,
  c" knife"     , knife ,
  c" dagger"    , dagger ,
  c" helmet"    , helmet ,
  c" axe"       , axe ,
  NULL ,

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

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

create locations                       \ map locations to directions
  c" a road leading west and east. Two things are pointing to the west." ,
  0 , 0 , -1 , 2 ,
  c" a bend in the road." ,
  0 , 5 , 1 , 0 ,
  c" a small dark shack." ,
  0 , 0 , 0 , 5 ,
  c" a small dark shack." ,
  0 , 0 , 5 , 15 ,
  c" a road leading north and south. There are shacks either side." ,
  2 , 6 , 3 , 4 ,
  c" a road leading north. There is a pyramid south." ,
  5 , 7 , 0 , 0 ,
  c" the entrance hall of the pyramid. There is a road north." ,
  6 , 12 , 8 , 9 ,
  c" the embalming room." ,
  0 , 0 , 10 , 7 ,
  c" the recreation room. An exit to the garden is east." ,
  0 , 13 , 7 , 16 ,
  c" the room of ANKH." ,
  0 , 0 , 0 , 8 ,
  c" a small triangular room." ,
  0 , 0 , 0 , 12 ,
  c" a long oblong room" ,
  7 , 14 , 11 , 0 ,
  c" the funeral parlour" ,
  9 , 0 , 0 , 0 ,
  c" the treasure room. It has been looted. There is a smashed door north." ,
  12 , 0 , 0 , 0 ,
  c" a small circular cave." ,
  0 , 0 , 4 , 0 ,
  c" a small garden." ,
  0 , 0 , 9 , 0 ,

create default 3 , 4 , 2 , 16 , 13 , 12 , 11 , 10 , 15 , 14 , 5 , 0 , 7 , 0 ,

: initmap                              \ fills the map with values
  14 0
  do
    default i th @'
    map i th !
  loop
  flags #flags 0 fill
;
                                       \ this routine compares two chars
: CANNOT                               \ default warning
  ." YOU CAN'T, IDIOT!!" cr cr
;

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

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

: NOTHERE                              \ not here!
  ." It isn't here!!" cr cr
;

: NOCARRY
  ." You aren't carrying it, stupid!!" cr cr
;
                                       \ this routine compares two chars
: c=                                   ( a1 a2 -- f )
  c@ swap c@                           ( c2 c1 )
  xor                                  ( n )
  ?ignore                              ( n f )
  if
    32 not and                         ( f )
  then                                 ( f )
;
                                       \ 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 over                          ( a1 a2 a1 a2 )
    i + swap                           ( a1 a2 a2+n a1 )
    i +                                ( a1 a2 a2+n a1+n)
    c=                                 ( 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

variable level                         \ room where you are

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

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

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

: except           ( v fo l )          \ make flag of exception
  level @ =                            ( v fo f )
  rot rot                              ( f v fo )
  flags                                ( f v fo fl )
  swap chars +                         ( f v a )
  c@ =                                 ( f f )
  and                                  ( f )
;

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

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

: south?                               \ going south ?
  south 0 2 12 correct
  south @ if ." South" tab then
;

: west?                                \ going west ?
  west 0 3 8 correct
  west @ if ." West" tab then
;

: east?                                \ going east ?
  east 0 0 4 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 14 0
  do
    map i th @
    level @ =
    if 1+ i showcontents then
  loop
  0= if tab ." None" cr then
                                       \ all exceptions
  0 3 8 except
  if cr ." There is a small slot on the west wall." cr then
  2 0 4 except
  if cr ." The dragon doesn't like you so he kills you." cr DEAD then
  0 0 4 except
  if cr ." The dragon blocks a hole in the EAST wall." cr 2 flags c! then

  level @ 4 <>
  flags c@ 2 =
  and

  if 0 flags c! then

  1 0 4 except
  if cr ." The dragon is dead." cr then
  0 1 16 except
  if cr ." There is something glistening at the top of the tree." cr then
  1 1 16 except
  if cr ." The tree is lying on the ground" cr then
  1 2 12 except level @ 14 = or
  if cr ." The door is smashed down" cr then
;

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

: ?lastroom

  level @ -1 <>
  if exit then

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

  7 ?map 8 ?map and
  if
    ." FRIZZLE!!" CR
    DEAD
  then

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

  7 ?map
  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
;

: 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 )
    level !                            ( -- )
  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
    dup map swap th @ -1 =
    if drop ." YOU ARE ALREADY CARRYING IT!!" CR exit then

    dup 0 <> 0 ?map and
    if drop ." YOU HAVEN'T GOT ANYTHING TO CARRY IT IN!!" CR exit then

    dup map swap th @ level @ <>
    if drop NOTHERE exit then

    dup 2* 1+ attributes swap th @' stays =
    if drop CANNOT exit then

    dup 0=
    if map swap th -1 swap ! ." YOU STRAP IT ON YOUR WRIST." CR exit then

    map swap th -1 swap !
    ." IT ZOOMS SAFELY INTO YOUR WATCH!" CR
  else
    IDUNNO
  then
;

: do-drop                              \ drop object
  objects decode
  if
    dup ?map
    if drop NOCARRY then

    dup level @ map rot th !

    12 =
    if 0 flags 4 chars + c! then
  else
    IDUNNO
  then
;

: do-saw                               \ saw tree
  objects decode
  if
    3 <> flags 1 chars + c@ 1 = or
    if CANNOT exit then

    2 ?map 6 ?map or
    if CANNOT exit then

    level @ 16 <>
    if NOTHERE exit then

    flags 5 chars + c@ 0=
    if ." The saw won't work without electricity!!" cr exit then

    flags 4 chars + c@ 0=
    if ." The  tree falls on your unprotected head. Crunch." cr DEAD then

    1 flags 1 chars + c!
    ." The tree falls down on your safety helmet." cr
    ." An axe falls out of the top of the tree." cr
    level @ map 13 th !

  else
    IDUNNO
  then
;

: do-smash                             \ smash door
  objects decode
  if
    5 <>
    if CANNOT exit then

    13 ?map flags 2 chars + c@ 1 = or
    if CANNOT exit then

    level @ 12 <>
    if NOTHERE exit then

    ." Chop chop smash smash.. The door has been smashed down." cr
    1 flags 2 chars + c!
  else
    IDUNNO
  then
;

: do-wear                              \ wear helmet
  objects decode
  if
    12 <> if CANNOT exit then

    12 ?map
    if NOCARRY exit then

    1 flags 4 chars + c!
  else
   IDUNNO
  then
;

: do-connect                           \ connect generator
  objects decode
  if
    dup dup
    6 <> swap 2 <> and
    if drop CANNOT exit then

    ?map
    if NOCARRY exit then

    6 ?map 2 ?map or
    if CANNOT exit then

    1 flags 5 chars + c!
  else
    IDUNNO
  then
;

: do-push                              \ push wall
  objects decode
  if
    dup
    9 <>
    if drop CANNOT exit then

    dup ?map
    if drop NOCARRY exit then

    level @ 8 <>
    if drop ." I can't see anywhere to insert it!!" cr exit then

    map swap th 0 swap !
    ." The wall suddenly shakes and glides one side leaving a doorway west!!"
    cr 1 flags 3 chars + c!
  else
    IDUNNO
  then
;

: do-file                              \ file knife
  objects decode
  if
    dup 10 <>
    if drop CANNOT exit then

    ?map
    if NOCARRY exit then

    4 ?map
    if ." You haven't got anything to sharpen it on!!" cr exit then

    ." The knife turns extra sharp!!" cr
     0 map 10 th !
    -1 map 11 th !
  else
    IDUNNO
  then
;

: do-kill                              \ kill dragon
  objects decode
  if
    1 <> 11 ?map or
    if CANNOT exit then

    level @ 4 <>
    if NOTHERE exit then

    flags c@ 1 =
    if ." The poor thing is already dead." cr exit then

    1 flags c!
    ." Squelch. The dagger sinks to the hilt in the dragon." cr
    ." It's dead. Poor thing." cr
  else
    IDUNNO
  then
;

: do-list                              \ shows the inventory
  ." You are carrying:" cr
  0 14 0
  do
    map i th @
    -1 =
    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
  2 level !
  begin
    showroom
    command
  again
;

venture
