( *
* LANGUAGE : ANS Forth
* PROJECT : Forth Environments
* DESCRIPTION : Find your way out of a maze.
* CATEGORY : Game, text based.
* AUTHOR : (c) 1983 by A. Clapman - Design and original Spectrum programming
* AUTHOR : (c) 1996 by H. Bezemer - Structured design and 4tH programming
* AUTHOR : 1997 mhx: restored to a Forth program.
* LAST CHANGE : April 11, 1997, Marcel Hendrix
* ARCHIVED : https://benhoyt.com/writings/adventur.frt.txt
* )
NEEDS -miscutil
NEEDS -terminal
REVISION -adventur "─── Adventure Game Version 1.01 ───"
PRIVATES
: ECHO[ BEGIN 0. refill
WHILE 2drop 0 <word>
2dup s" ]ECHO" compare 0<>
WHILE POSTPONE sliteral POSTPONE type POSTPONE cr
REPEATED
2drop ;P IMMEDIATE
: ABOUT
ECHO[
Extract from a time-traveller's diary discovered in the pyramid of
Ikhotep, pharaoh 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.
Careful: use "HELMET TAKE" not "TAKE HELMET"
Type "ADVENTURE" (without the quotes) to start.
]ECHO
;
BASE @ DECIMAL
: .string ( 'string -- ) @ .$ ;P
: d" ( "str" -- c-addr )
&" <word>
DUP 1+ allocate ?allocate
pack ;P
6 =: #flags PRIVATE \ Number of special cases
14 =: #mapped PRIVATE \ numbered locations on the map
0 =: stays PRIVATE \ cannot be moved
1 =: moves PRIVATE \ can be moved
CREATE objects PRIVATE #mapped cells ALLOT
CREATE flags PRIVATE #flags chars ALLOT
CREATE map PRIVATE #mapped cells ALLOT
CREATE default PRIVATE 3 , 4 , 2 , 16 , 13 , 12 , 11 , 10 ,
15 , 14 , 5 , 0 , 7 , 0 ,
0 VALUE north PRIVATE
0 VALUE south PRIVATE
0 VALUE west PRIVATE
0 VALUE east PRIVATE
0 VALUE level PRIVATE \ room where you are
0 VALUE object PRIVATE \ subject mentioned by player
: initmap \ fills the map with values
default map #mapped cells move
flags #flags 0 fill ;p
: CANNOT CR ." YOU CAN'T, IDIOT!!" ;p
: DEAD CR ." YOU'RE DEAD!!" quit ;p
: DUNNO CR ." I don't know what you mean." ;p
: NOTHERE CR ." It isn't here!!" ;p
: NOCARRY CR ." You aren't carrying it, stupid!!" ;p
\ It would be nice to have a graphical editor / compiler for this..
CREATE locations PRIVATE \ map locations to directions
d" a road leading west and east. Two things are pointing to the west." , 0 , 0 , -1 , 2 ,
d" a bend in the road." , 0 , 5 , 1 , 0 ,
d" a small dark shack." , 0 , 0 , 0 , 5 ,
d" a small dark shack." , 0 , 0 , 5 , 15 ,
d" a road leading north and south. There are shacks either side." , 2 , 6 , 3 , 4 ,
d" a road leading north. There is a pyramid south." , 5 , 7 , 0 , 0 ,
d" the entrance hall of the pyramid. There is a road north." , 6 , 12 , 8 , 9 ,
d" the embalming room." , 0 , 0 , 10 , 7 ,
d" the recreation room. An exit to the garden is east." , 0 , 13 , 7 , 16 ,
d" the room of ANKH." , 0 , 0 , 0 , 8 ,
d" a small triangular room." , 0 , 0 , 0 , 12 ,
d" a long oblong room" , 7 , 14 , 11 , 0 ,
d" the funeral parlour" , 9 , 0 , 0 , 0 ,
d" the treasure room. It has been looted. There is a smashed door north." , 12 , 0 , 0 , 0 ,
d" a small circular cave." , 0 , 0 , 4 , 0 ,
d" a small garden." , 0 , 0 , 9 , 0 ,
: room ( -- addr ) \ get address of room
level 1- 5 cells * locations + ;p
: set-possibilities ( 'room -- ) \ fill n-s-w-e variables
cell+
@+ TO north
@+ TO south
@+ TO west
@ TO east ;p
\ A remarkably murky definition, but it's the cornerstone of this game :-(
: except ( v flag# room# -- f ) \ make flag of exception
level = >r
chars flags + c@ =
r> and ;p
: north? north IF ." North" Tab emit THEN ;p
: south? 0 2 12 except IF 0 TO south THEN south IF ." South" Tab emit THEN ;p
: west? 0 3 8 except IF 0 TO west THEN west IF ." West" Tab emit THEN ;p
: east? 0 0 4 except IF 0 TO east THEN east IF ." East" Tab emit THEN ;p
: 'object ( n -- addr ) objects []cell @ ;P
: showcontents ( n -- ) \ prints the appropriate strings
cr Tab emit
dup 'object 2 cells + .string bl emit
'object cell+ .string ;p
: contents \ shows the contents of a room
0 #mapped 0
do
map i cell[] @
level =
IF 1+ i showcontents THEN
loop
0= IF cr Tab emit ." None" THEN
0 3 8 except IF cr ." There is a small slot on the west wall." THEN
2 0 4 except IF cr ." The dragon doesn't like you so he kills you." DEAD THEN
0 0 4 except IF cr ." The dragon blocks a hole in the EAST wall." 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." THEN
0 1 16 except IF cr ." There is something glistening at the top of the tree." THEN
1 1 16 except IF cr ." The tree is lying on the ground" THEN
1 2 12 except level 14 = or IF cr ." The door is smashed down" THEN ;p
: map? ( n -- f )
map []cell @ -1 <> ;p
: lastroom?
level -1 <> IF exit THEN
CR ." LASER BOLTS FLASH OUT FROM THE KILLO-ZAP GUNS FIXED TO THE ROAD!" CR
7 map?
8 map?
and IF CR ." FRIZZLE!!" DEAD THEN
8 map? IF CR ." THE LEFT RAY IS REFLECTED BY THE MIRROR. THE RIGHT ONE ISN'T!!" DEAD THEN
7 map? IF CR ." THE RIGHT RAY IS REFLECTED BY THE REFLECTOR. THE LEFT ONE ISN'T!!" DEAD THEN
CR ." BOTH THE RAYS ARE REFLECTED BY THE MIRROR AND THE REFLECTOR!!"
CR ." YOU HAVE MANAGED TO ESCAPE ALIVE!!" CR
quit ;p
: .room
lastroom?
CR ." You are at " room .string \ show location
room set-possibilities
CR ." Directions you may proceed in:"
CR Tab emit north? south? west? east? CR
CR ." Things of interest here:" contents ;P
: do-go ( val -- )
dup 0= IF drop CANNOT exit THEN TO level ;p
: do-take \ take an object
object map []cell @ -1 = IF cr ." YOU ARE ALREADY CARRYING IT!!" exit THEN
object 0<> 0 map? and IF cr ." YOU HAVEN'T GOT ANYTHING TO CARRY IT IN!!" exit THEN
object map []cell @ level <> IF NOTHERE exit THEN
object 'object @ stays = IF CANNOT exit THEN
object 0= IF -1 map ! cr ." YOU STRAP IT ON YOUR WRIST." exit THEN
-1 object map []cell !
cr ." IT ZOOMS SAFELY INTO YOUR WATCH!" ;p
: do-drop \ drop object
object map? IF NOCARRY THEN
level map object cell[] !
object 12 = IF flags 4 chars + c0! THEN ;p
: do-saw \ saw tree
object 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 cr ." The saw won't work without electricity!!" exit THEN
flags 4 chars + c@ 0= IF cr ." The tree falls on your unprotected head. Crunch." DEAD THEN
1 flags 1 chars + c!
cr ." The tree falls down on your safety helmet."
cr ." An axe falls out of the top of the tree."
level map 13 cell[] ! ;p
: do-smash \ smash door
object 5 <> IF CANNOT exit THEN
13 map? flags 2 chars + c@ 1 = or IF CANNOT exit THEN
level 12 <> IF NOTHERE exit THEN
cr ." Chop chop smash smash.. The door has been smashed down."
1 flags 2 chars + c! ;p
: do-wear \ wear helmet
object 12 <> IF CANNOT exit THEN
12 map? IF NOCARRY exit THEN
1 flags 4 chars + c! ;p
: do-connect \ connect generator
object 6 <> object 2 <> and IF CANNOT exit THEN
map? IF NOCARRY exit THEN
6 map? 2 map? or IF CANNOT exit THEN
1 flags 5 chars + c! ;p
: do-push \ push wall
object 9 <> IF CANNOT exit THEN
object map? IF NOCARRY exit THEN
level 8 <> IF cr ." I can't see anywhere to insert it!!" exit THEN
map object cell[] OFF
cr ." The wall suddenly shakes and glides one side leaving a doorway west!!"
1 flags 3 chars + c! ;p
: do-file \ file knife
object 10 <> IF CANNOT exit THEN
map? IF NOCARRY exit THEN
4 map? IF cr ." You haven't got anything to sharpen it on!!" exit THEN
cr ." The knife turns extra sharp!!"
0 map 10 cell[] !
-1 map 11 cell[] ! ;p
: do-kill \ kill dragon
object 1 <> 11 map? or IF CANNOT exit THEN
level 4 <> IF NOTHERE exit THEN
flags c@ 1 = IF cr ." The poor thing is already dead ..." exit THEN
1 flags c!
cr ." Squelch. The dagger sinks to the hilt in the dragon."
cr ." It's dead. Poor thing." ;p
: do-list \ shows the inventory
cr ." You are carrying:"
0 #mapped 0
do
map i cell[] @
-1 = IF cell+ i showcontents THEN
loop
0= IF cr Tab emit ." Nothing" THEN ;p
: OBJECT: ( attr1 name attr2 # -- )
CREATE DUP , objects []cell HERE SWAP ! , , ,
DOES> @ TO object ;P
WORDLIST CONSTANT <adventure> PRIVATE \ Here's where the user commands go.
<adventure> SET-CURRENT
: go ;
: move ;
: run ;
: walk ;
: stop quit ;
: help .help ;
: north north do-go ; : n north do-go ;
: south south do-go ; : s south do-go ;
: west west do-go ; : w west do-go ;
: east east do-go ; : e east do-go ;
: get do-take ; : take do-take ; : steal do-take ;
: drop do-drop ; : throw do-drop ; : leave do-drop ;
: saw do-saw ; : cut do-saw ; : fell do-saw ;
: chop do-smash ; : smash do-smash ; : axe do-smash ;
: wear do-wear ;
: connect do-connect ;
: insert do-push ; : push do-push ;
: sharpen do-file ; : file do-file ;
: kill do-kill ; : stab do-kill ; : knife do-kill ;
: invent do-list ; : objects do-list ; : inventory do-list ; : list do-list ;
\ attribute1 object attr2 # name
d" wrist" d" watch" moves 0 OBJECT: watch
d" magenta, firebreathing" d" dragon" stays 1 OBJECT: dragon
d" mobile electricity" d" generator" moves 2 OBJECT: generator
d" Canadian Redwood" d" tree" stays 3 OBJECT: tree
d" granite" d" slab" moves 4 OBJECT: slab
d" thick wooden" d" door" stays 5 OBJECT: door
d" electric" d" saw" moves 6 OBJECT: saw
d" purple" d" mirror" moves 7 OBJECT: mirror
d" green" d" reflector" moves 8 OBJECT: reflector
d" 10 pence" d" coin" moves 9 OBJECT: coin
d" butter" d" knife" moves 10 OBJECT: knife
d" razor sharp" d" dagger" moves 11 OBJECT: dagger
d" safety" d" helmet" moves 12 OBJECT: helmet
d" sharp" d" axe" moves 13 OBJECT: axe
FORTH DEFINITIONS
: EVAL-REST
BEGIN >in @ #tib @ <
WHILE bl word count <adventure> SEARCH-WORDLIST
0<> IF execute ELSE #tib @ >in ! DUNNO THEN
REPEAT ;P
: ADVENTURE
PAGE initmap 2 TO level
BEGIN
-1 TO object
cr ." COMMAND> " query
eval-rest
.room
AGAIN ;
CR BASE !
.ABOUT -adventur
DEPRIVE
( * End of File * )