From 58d01a2f1054fe5a920037de70350c5c8d3a9886 Mon Sep 17 00:00:00 2001 From: elioat Date: Sat, 1 Jul 2023 08:51:53 -0400 Subject: * --- forth/adventur.forth | 345 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 345 insertions(+) create mode 100644 forth/adventur.forth (limited to 'forth/adventur.forth') diff --git a/forth/adventur.forth b/forth/adventur.forth new file mode 100644 index 0000000..df58463 --- /dev/null +++ b/forth/adventur.forth @@ -0,0 +1,345 @@ +( * + * 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 + 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 ) + &" + 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 PRIVATE \ Here's where the user commands go. + + 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 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 * ) -- cgit 1.4.1-2-gfad0