Original Source
commit
c446b240a9
|
@ -0,0 +1,793 @@
|
||||||
|
|
||||||
|
; "SUBTITLE COAL MINE"
|
||||||
|
|
||||||
|
<DEFINE BOOM-ROOM ("AUX" (DUMMY? <>) (WIN ,WINNER) O (AOBJS <AOBJS .WIN>))
|
||||||
|
#DECL ((DUMMY?) <OR ATOM FALSE> (WIN) ADV (O) OBJECT)
|
||||||
|
<COND (<OR <VERB? "GO-IN">
|
||||||
|
<AND <VERB? "ON" "TRNON" "LIGHT" "BURN">
|
||||||
|
<SET DUMMY? T>>>
|
||||||
|
<COND (<OR <AND <MEMQ <SET O <SFIND-OBJ "CANDL">> .AOBJS>
|
||||||
|
<TRNN .O ,ONBIT>>
|
||||||
|
<AND <MEMQ <SET O <SFIND-OBJ "TORCH">> .AOBJS>
|
||||||
|
<TRNN .O ,ONBIT>>
|
||||||
|
<AND <MEMQ <SET O <SFIND-OBJ "MATCH">> .AOBJS>
|
||||||
|
<TRNN .O ,ONBIT>>>
|
||||||
|
<UNWIND
|
||||||
|
<PROG ()
|
||||||
|
<COND (.DUMMY?
|
||||||
|
<TELL
|
||||||
|
"I didn't realize that adventurers are stupid enough to light a
|
||||||
|
" ,LONG-TELL1 <ODESC2 .O> " in a room which reeks of coal gas.
|
||||||
|
Fortunately, there is justice in the world.">)
|
||||||
|
(<TELL
|
||||||
|
"Oh dear. It appears that the smell coming from this room was coal
|
||||||
|
gas. I would have thought twice about carrying a " ,LONG-TELL1
|
||||||
|
<ODESC2 .O> "in here.">)>
|
||||||
|
<FWEEP 7>
|
||||||
|
<JIGS-UP " BOOOOOOOOOOOM ">>
|
||||||
|
<JIGS-UP " BOOOOOOOOOOOM ">>)>)>>
|
||||||
|
|
||||||
|
<DEFINE BATS-ROOM ()
|
||||||
|
<COND (<AND <VERB? "GO-IN">
|
||||||
|
<NOT <MEMQ <SFIND-OBJ "GARLI"> <AOBJS ,WINNER>>>>
|
||||||
|
<FLY-ME>)
|
||||||
|
(<VERB? "LOOK">
|
||||||
|
<TELL
|
||||||
|
"You are in a small room which has only one door, to the east.">
|
||||||
|
<AND <MEMQ <SFIND-OBJ "GARLI"> <AOBJS ,WINNER>>
|
||||||
|
<TELL
|
||||||
|
"In the corner of the room on the ceiling is a large vampire bat who
|
||||||
|
is obviously deranged and holding his nose.">>)>>
|
||||||
|
|
||||||
|
<DEFINE FLY-ME ("AUX" (BAT-DROPS ,BAT-DROPS))
|
||||||
|
#DECL ((BAT-DROPS) <VECTOR [REST STRING]>)
|
||||||
|
<UNWIND
|
||||||
|
<PROG ()
|
||||||
|
<FWEEP 4 1>
|
||||||
|
<TELL
|
||||||
|
"A deranged giant vampire bat (a reject from WUMPUS) swoops down
|
||||||
|
from his belfry and lifts you away....">
|
||||||
|
<GOTO <FIND-ROOM <PICK-ONE .BAT-DROPS>>>>
|
||||||
|
<GOTO <FIND-ROOM <PICK-ONE .BAT-DROPS>>>>
|
||||||
|
<PUT ,PRSVEC 2 <>>
|
||||||
|
<ROOM-INFO>
|
||||||
|
T>
|
||||||
|
|
||||||
|
<DEFINE FWEEP (NUM "OPTIONAL" (SLP 0))
|
||||||
|
#DECL ((NUM SLP) FIX)
|
||||||
|
<REPEAT ((N .NUM))
|
||||||
|
#DECL ((N) FIX)
|
||||||
|
<AND <0? <SET N <- .N 1>>> <RETURN>>
|
||||||
|
<IMAGE 7>
|
||||||
|
<OR <0? .SLP> <SLEEP .SLP>>>
|
||||||
|
<TTY-INIT <>>>
|
||||||
|
|
||||||
|
<GDECL (BAT-DROPS) <VECTOR [REST STRING]>>
|
||||||
|
|
||||||
|
<SETG CAGE-TOP!-FLAG T>
|
||||||
|
|
||||||
|
<DEFINE DUMBWAITER ("AUX" (TB <SFIND-OBJ "TBASK">)
|
||||||
|
(TOP <SFIND-ROOM "TSHAF">) (BOT <SFIND-ROOM "BSHAF">)
|
||||||
|
(FB <SFIND-OBJ "FBASK">) (CT ,CAGE-TOP!-FLAG)
|
||||||
|
(DUMMY ,DUMMY) (LIT? <LIT? ,HERE>))
|
||||||
|
#DECL ((FB TB) OBJECT (TOP BOT) ROOM (LIT? CT) <OR ATOM FALSE>
|
||||||
|
(DUMMY) <VECTOR [REST STRING]>)
|
||||||
|
<COND (<VERB? "RAISE">
|
||||||
|
<COND (.CT
|
||||||
|
<TELL <PICK-ONE ,DUMMY>>)
|
||||||
|
(<REMOVE-OBJECT .TB>
|
||||||
|
<REMOVE-OBJECT .FB>
|
||||||
|
<INSERT-OBJECT .TB .TOP>
|
||||||
|
<INSERT-OBJECT .FB .BOT>
|
||||||
|
<TELL "The basket is raised to the top of the shaft.">
|
||||||
|
<SETG CAGE-TOP!-FLAG T>)>)
|
||||||
|
(<VERB? "LOWER">
|
||||||
|
<COND (<NOT .CT>
|
||||||
|
<TELL <PICK-ONE .DUMMY>>)
|
||||||
|
(<REMOVE-OBJECT .TB>
|
||||||
|
<REMOVE-OBJECT .FB>
|
||||||
|
<INSERT-OBJECT .TB .BOT>
|
||||||
|
<INSERT-OBJECT .FB .TOP>
|
||||||
|
<TELL "The basket is lowered to the bottom of the shaft.">
|
||||||
|
<SETG CAGE-TOP!-FLAG <>>
|
||||||
|
<COND (<AND .LIT? <NOT <LIT? ,HERE>>>
|
||||||
|
<TELL "It is now pitch black.">)>
|
||||||
|
T)>)
|
||||||
|
(<OR <==? <PRSO> .FB>
|
||||||
|
<==? <PRSI> .FB>>
|
||||||
|
<TELL "The basket is at the other end of the chain.">)
|
||||||
|
(<VERB? "TAKE">
|
||||||
|
<TELL "The cage is securely fastened to the iron chain.">)>>
|
||||||
|
|
||||||
|
<DEFINE MACHINE-ROOM ()
|
||||||
|
<COND (<VERB? "LOOK">
|
||||||
|
<TELL ,MACHINE-DESC
|
||||||
|
,LONG-TELL1
|
||||||
|
<COND (<TRNN <SFIND-OBJ "MACHI"> ,OPENBIT>
|
||||||
|
"open.")
|
||||||
|
("closed.")>>)>>
|
||||||
|
|
||||||
|
<DEFINE MACHINE-FUNCTION ("AUX" (DUMMY ,DUMMY) (MACH <SFIND-OBJ "MACHI">))
|
||||||
|
#DECL ((MACH) OBJECT (DUMMY) <VECTOR [REST STRING]>)
|
||||||
|
<COND
|
||||||
|
(<==? ,HERE <SFIND-ROOM "MACHI">>
|
||||||
|
<COND
|
||||||
|
(<VERB? "OPEN">
|
||||||
|
<COND (<TRNN .MACH ,OPENBIT>
|
||||||
|
<TELL <PICK-ONE .DUMMY>>)
|
||||||
|
(<TELL "The lid opens.">
|
||||||
|
<TRO .MACH ,OPENBIT>)>)
|
||||||
|
(<VERB? "CLOSE">
|
||||||
|
<COND (<TRNN .MACH ,OPENBIT>
|
||||||
|
<TELL "The lid closes.">
|
||||||
|
<TRZ .MACH ,OPENBIT>
|
||||||
|
T)
|
||||||
|
(<TELL <PICK-ONE .DUMMY>>)>)>)>>
|
||||||
|
|
||||||
|
<DEFINE MSWITCH-FUNCTION ("AUX" (C <SFIND-OBJ "COAL">) D (MACH <SFIND-OBJ "MACHI">)
|
||||||
|
(SCREW <SFIND-OBJ "SCREW">))
|
||||||
|
#DECL ((MACH SCREW C D) OBJECT)
|
||||||
|
<COND (<VERB? "TURN">
|
||||||
|
<COND (<==? <PRSI> .SCREW>
|
||||||
|
<COND (<TRNN .MACH ,OPENBIT>
|
||||||
|
<TELL
|
||||||
|
"The machine doesn't seem to want to do anything.">)
|
||||||
|
(<TELL
|
||||||
|
"The machine comes to life (figuratively) with a dazzling display of
|
||||||
|
colored lights and bizarre noises. After a few moments, the
|
||||||
|
excitement abates." ,LONG-TELL1>
|
||||||
|
<COND (<==? <OCAN .C> .MACH>
|
||||||
|
<REMOVE-OBJECT .C>
|
||||||
|
<PUT .MACH
|
||||||
|
,OCONTENTS
|
||||||
|
(<SET D <SFIND-OBJ "DIAMO">>
|
||||||
|
!<OCONTENTS .MACH>)>
|
||||||
|
<PUT .D ,OCAN .MACH>)
|
||||||
|
(<NOT <EMPTY? <OCONTENTS .MACH>>>
|
||||||
|
<PUT .MACH ,OCONTENTS (<SFIND-OBJ "GUNK">)>)
|
||||||
|
(T)>)>)
|
||||||
|
(<TELL "It seems that a " 1 <ODESC2 <PRSI>> " won't do.">)>)>>
|
||||||
|
|
||||||
|
<DEFINE GUNK-FUNCTION ("AUX" (G <SFIND-OBJ "GUNK">) (M <OCAN .G>))
|
||||||
|
#DECL ((G) OBJECT (M) <OR OBJECT FALSE>)
|
||||||
|
<COND (.M
|
||||||
|
<PUT .M ,OCONTENTS <SPLICE-OUT .G <OCONTENTS .M>>>
|
||||||
|
<PUT .G ,OCAN <>>
|
||||||
|
<TELL
|
||||||
|
"The slag turns out to be rather insubstantial, and crumbles into dust
|
||||||
|
at your touch. It must not have been very valuable.">)>>
|
||||||
|
|
||||||
|
<SETG SCORE-MAX <+ ,SCORE-MAX <SETG LIGHT-SHAFT 10>>>
|
||||||
|
|
||||||
|
<DEFINE NO-OBJS ()
|
||||||
|
<COND (<EMPTY? <AOBJS ,WINNER>>
|
||||||
|
<SETG EMPTY-HANDED!-FLAG T>)
|
||||||
|
(ELSE <SETG EMPTY-HANDED!-FLAG <>>)>
|
||||||
|
<COND (<AND <==? ,HERE <SFIND-ROOM "BSHAF">>
|
||||||
|
<LIT? ,HERE>>
|
||||||
|
<SCORE-UPD ,LIGHT-SHAFT>
|
||||||
|
<SETG LIGHT-SHAFT 0>)>>
|
||||||
|
|
||||||
|
<GDECL (LIGHT-SHAFT) FIX>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
;"SUBTITLE OLD MAN RIVER, THAT OLD MAN RIVER..."
|
||||||
|
|
||||||
|
<DEFINE CLIFF-FUNCTION ()
|
||||||
|
<COND (<MEMQ <SFIND-OBJ "RBOAT"> <AOBJS ,WINNER>>
|
||||||
|
<SETG DEFLATE!-FLAG <>>)
|
||||||
|
(<SETG DEFLATE!-FLAG T>)>>
|
||||||
|
|
||||||
|
<DEFINE STICK-FUNCTION ("AUX" (HERE ,HERE))
|
||||||
|
#DECL ((HERE) ROOM)
|
||||||
|
<COND (<VERB? "WAVE">
|
||||||
|
<COND (<OR <==? .HERE <SFIND-ROOM "FALLS">>
|
||||||
|
<==? .HERE <SFIND-ROOM "POG">>>
|
||||||
|
<COND (<NOT ,RAINBOW!-FLAG>
|
||||||
|
<TRO <SFIND-OBJ "POT"> ,OVISON>
|
||||||
|
<TELL
|
||||||
|
"Suddenly, the rainbow appears to become solid and, I venture,
|
||||||
|
walkable (I think the giveaway was the stairs and bannister).">
|
||||||
|
<SETG RAINBOW!-FLAG T>)
|
||||||
|
(<TELL
|
||||||
|
"The rainbow seems to have become somewhat run-of-the-mill.">
|
||||||
|
<SETG RAINBOW!-FLAG <>>)>)
|
||||||
|
(<==? .HERE <SFIND-ROOM "RAINB">>
|
||||||
|
<SETG RAINBOW!-FLAG <>>
|
||||||
|
<JIGS-UP
|
||||||
|
"The structural integrity of the rainbow seems to have left it,
|
||||||
|
leaving you about 450 feet in the air, supported by water vapor.">)
|
||||||
|
(<TELL "Very good.">)>)>>
|
||||||
|
|
||||||
|
<DEFINE FALLS-ROOM ()
|
||||||
|
<COND (<VERB? "LOOK">
|
||||||
|
<TELL
|
||||||
|
"You are at the top of Aragain Falls, an enormous waterfall with a
|
||||||
|
drop of about 450 feet. The only path here is on the north end." ,LONG-TELL1>
|
||||||
|
<COND (,RAINBOW!-FLAG
|
||||||
|
<TELL
|
||||||
|
"A solid rainbow spans the falls.">)
|
||||||
|
(<TELL
|
||||||
|
"A beautiful rainbow can be seen over the falls and to the east.">)>)>>
|
||||||
|
|
||||||
|
<DEFINE BARREL ("OPTIONAL" (ARG <>))
|
||||||
|
#DECL ((ARG) <OR FALSE ATOM>)
|
||||||
|
<AND <==? .ARG READ-IN>
|
||||||
|
<COND (<VERB? "WALK"> <TELL "You cannot move the barrel.">)
|
||||||
|
(<VERB? "LOOK">
|
||||||
|
<TELL
|
||||||
|
"You are inside a barrel. Congratulations. Etched into the side of the
|
||||||
|
barrel is the word 'Geronimo!'. From your position, you cannot see
|
||||||
|
the falls.">)
|
||||||
|
(<VERB? "TAKE"> <PICK-ONE ,YUKS>)
|
||||||
|
(<VERB? "BURN">
|
||||||
|
<TELL "The barrel is damp and cannot be burned.">)>>>
|
||||||
|
|
||||||
|
<DEFINE DBOAT-FUNCTION ("AUX" (HERE ,HERE) (DBOAT <SFIND-OBJ "DBOAT">))
|
||||||
|
#DECL ((DBOAT) OBJECT (HERE) ROOM)
|
||||||
|
<COND (<VERB? "INFLA">
|
||||||
|
<TELL
|
||||||
|
"This boat will not inflate since some moron put a hole in it.">)
|
||||||
|
(<VERB? "PLUG">
|
||||||
|
<COND (<==? <PRSI> <SFIND-OBJ "PUTTY">>
|
||||||
|
<TELL
|
||||||
|
"Well done. The boat is repaired.">
|
||||||
|
<COND (<NOT <OROOM .DBOAT>>
|
||||||
|
<DROP-OBJECT .DBOAT>
|
||||||
|
<TAKE-OBJECT <SFIND-OBJ "IBOAT">>)
|
||||||
|
(<REMOVE-OBJECT <SFIND-OBJ "DBOAT">>
|
||||||
|
<INSERT-OBJECT <SFIND-OBJ "IBOAT"> .HERE>)>)
|
||||||
|
(<WITH-TELL <PRSI>>)>)>>
|
||||||
|
|
||||||
|
<DEFINE RBOAT-FUNCTION ("OPTIONAL" (ARG <>)
|
||||||
|
"AUX" (RBOAT <SFIND-OBJ "RBOAT">)
|
||||||
|
(IBOAT <SFIND-OBJ "IBOAT">) (HERE ,HERE))
|
||||||
|
#DECL ((ARG) <OR FALSE ATOM> (IBOAT RBOAT) OBJECT (HERE) ROOM)
|
||||||
|
<COND (.ARG <>)
|
||||||
|
(<VERB? "BOARD">
|
||||||
|
<COND (<MEMQ <SFIND-OBJ "STICK"> <AOBJS ,WINNER>>
|
||||||
|
<TELL
|
||||||
|
"There is a hissing sound and the boat deflates.">
|
||||||
|
<REMOVE-OBJECT .RBOAT>
|
||||||
|
<INSERT-OBJECT <SFIND-OBJ "DBOAT"> .HERE>
|
||||||
|
T)>)
|
||||||
|
(<VERB? "INFLA">
|
||||||
|
<TELL "Inflating it further would probably burst it.">)
|
||||||
|
(<VERB? "DEFLA">
|
||||||
|
<COND (<==? <AVEHICLE ,WINNER> .RBOAT>
|
||||||
|
<TELL
|
||||||
|
"You can't deflate the boat while you're in it.">)
|
||||||
|
(<NOT <MEMQ .RBOAT <ROBJS .HERE>>>
|
||||||
|
<TELL
|
||||||
|
"The boat must be on the ground to be deflated.">)
|
||||||
|
(<TELL
|
||||||
|
"The boat deflates.">
|
||||||
|
<SETG DEFLATE!-FLAG T>
|
||||||
|
<REMOVE-OBJECT .RBOAT>
|
||||||
|
<INSERT-OBJECT .IBOAT .HERE>)>)>>
|
||||||
|
|
||||||
|
<DEFINE BREATHE ()
|
||||||
|
<PERFORM INFLATER <FIND-VERB "INFLA"> <PRSO> <SFIND-OBJ "LUNGS">>>
|
||||||
|
|
||||||
|
<DEFINE IBOAT-FUNCTION ("AUX" (IBOAT <SFIND-OBJ "IBOAT">) (RBOAT <SFIND-OBJ "RBOAT">)
|
||||||
|
(HERE ,HERE))
|
||||||
|
#DECL ((IBOAT RBOAT) OBJECT (HERE) ROOM)
|
||||||
|
<COND (<VERB? "INFLA">
|
||||||
|
<COND (<NOT <MEMQ .IBOAT <ROBJS .HERE>>>
|
||||||
|
<TELL
|
||||||
|
"The boat must be on the ground to be inflated.">)
|
||||||
|
(<==? <PRSI> <SFIND-OBJ "PUMP">>
|
||||||
|
<TELL
|
||||||
|
"The boat inflates and appears seaworthy.">
|
||||||
|
<SETG DEFLATE!-FLAG <>>
|
||||||
|
<REMOVE-OBJECT .IBOAT>
|
||||||
|
<INSERT-OBJECT .RBOAT .HERE>)
|
||||||
|
(<==? <PRSI> <SFIND-OBJ "LUNGS">>
|
||||||
|
<TELL
|
||||||
|
"You don't have enough lung power to inflate it.">)
|
||||||
|
(<TELL
|
||||||
|
"With a " 1 <ODESC2 <PRSI>> "? Surely you jest!">)>)>>
|
||||||
|
|
||||||
|
<DEFINE OVER-FALLS ()
|
||||||
|
<COND (<VERB? "LOOK"> T)
|
||||||
|
(<JIGS-UP ,OVER-FALLS-STR1>)>>
|
||||||
|
|
||||||
|
<SETG BUOY-FLAG!-FLAG T>
|
||||||
|
|
||||||
|
<DEFINE SHAKER ("AUX" (HERE ,HERE))
|
||||||
|
#DECL ((HERE) ROOM)
|
||||||
|
<COND (<OBJECT-ACTION>)
|
||||||
|
(<TRNN <PRSO> ,VILLAIN>
|
||||||
|
<TELL "This seems to have no effect.">)
|
||||||
|
(<NOT <TRNN <PRSO> ,TAKEBIT>>
|
||||||
|
<TELL "You can't take it; thus, you can't shake it!">)
|
||||||
|
(<AND <NOT <TRNN <PRSO> ,OPENBIT>>
|
||||||
|
<NOT <EMPTY? <OCONTENTS <PRSO>>>>
|
||||||
|
<TELL
|
||||||
|
"It sounds like there is something inside the " 1 <ODESC2 <PRSO>> ".">>)
|
||||||
|
(<AND <TRNN <PRSO> ,OPENBIT>
|
||||||
|
<NOT <EMPTY? <OCONTENTS <PRSO>>>>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) OBJECT)
|
||||||
|
<PUT .X ,OCAN <>>
|
||||||
|
<INSERT-OBJECT .X .HERE>>
|
||||||
|
<OCONTENTS <PRSO>>>
|
||||||
|
<PUT <PRSO> ,OCONTENTS ()>
|
||||||
|
<TELL
|
||||||
|
"All of the objects spill onto the floor.">)>>
|
||||||
|
|
||||||
|
<DEFINE RIVR4-ROOM ()
|
||||||
|
<AND <MEMQ <SFIND-OBJ "BUOY"> <AOBJS ,WINNER>>
|
||||||
|
,BUOY-FLAG!-FLAG
|
||||||
|
<TELL
|
||||||
|
"Something seems funny about the feel of the buoy.">
|
||||||
|
<SETG BUOY-FLAG!-FLAG <>>>>
|
||||||
|
|
||||||
|
<SETG BEACH-DIG!-FLAG 0>
|
||||||
|
|
||||||
|
<SETG GUANO-DIG!-FLAG 0>
|
||||||
|
|
||||||
|
<GDECL (BEACH-DIG!-FLAG GUANO-DIG!-FLAG) FIX>
|
||||||
|
|
||||||
|
<DEFINE DIGGER ()
|
||||||
|
<COND (<==? <PRSI> <SFIND-OBJ "SHOVE">>
|
||||||
|
<OBJECT-ACTION>)
|
||||||
|
(<TRNN <PRSI> ,TOOLBIT>
|
||||||
|
<TELL
|
||||||
|
"Digging with the " 1 <ODESC2 <PRSI>> " is slow and tedious.">)
|
||||||
|
(<TELL
|
||||||
|
"Digging with a " 1 <ODESC2 <PRSI>> " is silly.">)>>
|
||||||
|
|
||||||
|
<DEFINE GROUND-FUNCTION ()
|
||||||
|
<COND (<==? ,HERE <SFIND-ROOM "BEACH">>
|
||||||
|
<SAND-FUNCTION>)
|
||||||
|
(<VERB? "DIG">
|
||||||
|
<TELL "The ground is too hard for digging here.">)>>
|
||||||
|
|
||||||
|
<DEFINE SAND-FUNCTION ("AUX" (S <SFIND-OBJ "STATU">) (HERE ,HERE) CNT)
|
||||||
|
#DECL ((S) OBJECT (HERE) ROOM (CNT) FIX)
|
||||||
|
<COND (<VERB? "DIG">
|
||||||
|
<SETG BEACH-DIG!-FLAG <SET CNT <+ 1 ,BEACH-DIG!-FLAG>>>
|
||||||
|
<COND (<G? .CNT 4>
|
||||||
|
<SETG BEACH-DIG!-FLAG 0>
|
||||||
|
<AND <MEMQ .S <ROBJS .HERE>>
|
||||||
|
<TRZ .S ,OVISON>>
|
||||||
|
<JIGS-UP "The hole collapses, smothering you.">)
|
||||||
|
(<==? .CNT 4>
|
||||||
|
<COND (<NOT <TRNN .S ,OVISON>>
|
||||||
|
<TELL "You can see a small statue here in the sand.">
|
||||||
|
<TRO .S ,OVISON>)>)
|
||||||
|
(<L? .CNT 0>)
|
||||||
|
(<TELL <NTH ,BDIGS .CNT>>)>)>>
|
||||||
|
|
||||||
|
<DEFINE GUANO-FUNCTION ("AUX" (HERE ,HERE) CNT)
|
||||||
|
#DECL ((HERE) ROOM (CNT) FIX)
|
||||||
|
<COND (<VERB? "DIG">
|
||||||
|
<SETG GUANO-DIG!-FLAG <SET CNT <+ 1 ,GUANO-DIG!-FLAG>>>
|
||||||
|
<COND (<G? .CNT 3>
|
||||||
|
<TELL "This is getting you nowhere.">)
|
||||||
|
(<TELL <NTH ,CDIGS .CNT>>)>)>>
|
||||||
|
|
||||||
|
<GDECL (BDIGS CDIGS) <VECTOR [REST STRING]>>
|
||||||
|
|
||||||
|
<DEFINE GERONIMO ()
|
||||||
|
<COND (<==? <AVEHICLE ,WINNER> <SFIND-OBJ "BARRE">>
|
||||||
|
<JIGS-UP ,OVER-FALLS-STR>)
|
||||||
|
(<TELL
|
||||||
|
"Wasn't he an Indian?">)>>
|
||||||
|
|
||||||
|
<GDECL (SWIMYUKS) <VECTOR [REST STRING]>>
|
||||||
|
|
||||||
|
<DEFINE SWIMMER ("AUX" (SWIMYUKS ,SWIMYUKS))
|
||||||
|
#DECL ((SWIMYUKS) <VECTOR [REST STRING]>)
|
||||||
|
<COND (<RTRNN ,HERE ,RFILLBIT>
|
||||||
|
<TELL
|
||||||
|
"Swimming is not allowed in this dungeon.">)
|
||||||
|
(<TELL <PICK-ONE .SWIMYUKS>>)>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
;"SUBTITLE LURKING GRUES"
|
||||||
|
|
||||||
|
<DEFINE GRUE-FUNCTION ()
|
||||||
|
<COND (<VERB? "EXAMI">
|
||||||
|
<TELL ,GRUE-DESC1 ,LONG-TELL1>)
|
||||||
|
(<VERB? "FIND">
|
||||||
|
<TELL ,GRUE-DESC2 ,LONG-TELL1>)>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
;"THE VOLCANO"
|
||||||
|
|
||||||
|
<SETG BTIE!-FLAG <>>
|
||||||
|
<GDECL (BTIE!-FLAG) <OR FALSE OBJECT>>
|
||||||
|
|
||||||
|
<SETG BINF!-FLAG <>>
|
||||||
|
|
||||||
|
<DEFINE BALLOON BALLACT ("OPTIONAL" (ARG <>)
|
||||||
|
"AUX" (BALL <SFIND-OBJ "BALLO">) (CONT <SFIND-OBJ "RECEP">)
|
||||||
|
M (BINF ,BINF!-FLAG) R)
|
||||||
|
#DECL ((ARG) <OR ATOM FALSE> (BALL CONT) OBJECT
|
||||||
|
(BINF) <OR FALSE OBJECT> (M) <OR FALSE VECTOR>
|
||||||
|
(BALLACT) ACTIVATION (R) <OR NEXIT CEXIT DOOR ROOM>)
|
||||||
|
<COND (<==? .ARG READ-OUT>
|
||||||
|
<COND (<VERB? "LOOK">
|
||||||
|
<COND (.BINF
|
||||||
|
<TELL
|
||||||
|
"The cloth bag is inflated and there is a "
|
||||||
|
1
|
||||||
|
<ODESC2 .BINF>
|
||||||
|
" burning in the receptacle.">)
|
||||||
|
(<TELL "The cloth bag is draped over the the basket.">)>
|
||||||
|
<COND (,BTIE!-FLAG
|
||||||
|
<TELL "The balloon is tied to the hook.">)>)>
|
||||||
|
<RETURN <> .BALLACT>)>
|
||||||
|
<COND (<==? .ARG READ-IN>
|
||||||
|
<COND (<VERB? "WALK">
|
||||||
|
<COND (<SET M
|
||||||
|
<MEMQ <2 ,PRSVEC> <REXITS ,HERE>>>
|
||||||
|
<COND (,BTIE!-FLAG
|
||||||
|
<TELL "You are tied to the ledge.">
|
||||||
|
<RETURN T .BALLACT>)
|
||||||
|
(ELSE
|
||||||
|
<AND <TYPE? <SET R <2 .M>> ROOM>
|
||||||
|
<NOT <RTRNN .R ,RMUNGBIT>>
|
||||||
|
<SETG BLOC .R>>
|
||||||
|
<CLOCK-INT ,BINT 3>
|
||||||
|
<RETURN <> .BALLACT>)>)
|
||||||
|
(<TELL
|
||||||
|
"I'm afraid you can't control the balloon in this way.">
|
||||||
|
<RETURN T .BALLACT>)>)
|
||||||
|
(<AND <VERB? "TAKE">
|
||||||
|
<==? ,BINF!-FLAG <PRSO>>>
|
||||||
|
<TELL "You don't really want to hold a burning "
|
||||||
|
1
|
||||||
|
<ODESC2 <PRSO>>
|
||||||
|
".">
|
||||||
|
<RETURN T .BALLACT>)
|
||||||
|
(<AND <VERB? "PUT">
|
||||||
|
<==? <PRSI> .CONT>
|
||||||
|
<NOT <EMPTY? <OCONTENTS .CONT>>>>
|
||||||
|
<TELL "The receptacle is already occupied.">
|
||||||
|
<RETURN T .BALLACT>)
|
||||||
|
(<RETURN <> .BALLACT>)>)>
|
||||||
|
<COND (<VERB? "C-INT">
|
||||||
|
<COND (<OR <AND <TRNN .CONT ,OPENBIT> ,BINF!-FLAG>
|
||||||
|
<MEMBER "LEDG" <STRINGP <RID ,HERE>>>>
|
||||||
|
<RISE-AND-SHINE .BALL>)
|
||||||
|
(<DECLINE-AND-FALL .BALL>)>)>>
|
||||||
|
|
||||||
|
<SETG BLAB!-FLAG <>>
|
||||||
|
|
||||||
|
<GDECL (BURNUP-INT BINT) CEVENT>
|
||||||
|
|
||||||
|
<DEFINE RISE-AND-SHINE (BALL
|
||||||
|
"AUX" (S <TOP ,SCRSTR>) M
|
||||||
|
(IN? <==? <AVEHICLE ,WINNER> .BALL>) (BL ,BLOC))
|
||||||
|
#DECL ((BALL) OBJECT (BL) ROOM (M) <OR FALSE STRING> (S) STRING
|
||||||
|
(IN?) <OR ATOM FALSE>)
|
||||||
|
<CLOCK-INT ,BINT 3>
|
||||||
|
<COND (<SET M <MEMBER "VAIR" <STRINGP <RID .BL>>>>
|
||||||
|
<COND (<=? <REST .M 4> "4">
|
||||||
|
<CLOCK-DISABLE ,BURNUP-INT>
|
||||||
|
<CLOCK-DISABLE ,BINT>
|
||||||
|
<REMOVE-OBJECT .BALL>
|
||||||
|
<INSERT-OBJECT <SFIND-OBJ "DBALL"> <SFIND-ROOM "VLBOT">>
|
||||||
|
<COND (.IN?
|
||||||
|
<JIGS-UP
|
||||||
|
|
||||||
|
"Your balloon has hit the rim of the volcano, ripping the cloth and
|
||||||
|
causing you a 500 foot drop. Did you get your flight insurance?">)
|
||||||
|
(<==? ,HERE <SFIND-ROOM "VLBOT">>
|
||||||
|
<TELL
|
||||||
|
"You watch the balloon explode after hitting the rim; its tattered
|
||||||
|
remains land on the ground by your feet.">)
|
||||||
|
(<TELL
|
||||||
|
"You hear a boom and notice that the balloon is falling to the ground.">)>
|
||||||
|
<SETG BLOC <SFIND-ROOM "VLBOT">>)
|
||||||
|
(<SUBSTRUC <STRINGP <RID .BL>> 0 4 .S>
|
||||||
|
<PUT .S 5 <CHTYPE <+ <CHTYPE <5 .M> FIX> 1> CHARACTER>>
|
||||||
|
<COND (.IN?
|
||||||
|
<GOTO <SETG BLOC <FIND-ROOM .S>>>
|
||||||
|
<TELL "The balloon ascends.">
|
||||||
|
<ROOM-INFO>)
|
||||||
|
(<PUT-BALLOON .BALL .S "ascends.">)>)>)
|
||||||
|
(<SET M <MEMBER "LEDG" <STRINGP <RID .BL>>>>
|
||||||
|
<SUBSTRUC "VAIR" 0 4 .S>
|
||||||
|
<PUT .S 5 <5 .M>>
|
||||||
|
<COND (.IN?
|
||||||
|
<GOTO <SETG BLOC <FIND-ROOM .S>>>
|
||||||
|
<TELL "The balloon leaves the ledge.">
|
||||||
|
<ROOM-INFO>)
|
||||||
|
(<CLOCK-INT ,VLGIN 10>
|
||||||
|
<PUT-BALLOON .BALL .S "floats away. It seems to be ascending,
|
||||||
|
due to its light load.">)>)
|
||||||
|
(.IN?
|
||||||
|
<GOTO <SETG BLOC <SFIND-ROOM "VAIR1">>>
|
||||||
|
<TELL "The balloon rises slowly from the ground.">
|
||||||
|
<ROOM-INFO>)
|
||||||
|
(<PUT-BALLOON .BALL "VAIR1" "lifts off.">)>>
|
||||||
|
|
||||||
|
<DEFINE BALLOON-BURN ("AUX" BLABE (BALL <SFIND-OBJ "BALLO">))
|
||||||
|
#DECL ((BALL BLABE) OBJECT)
|
||||||
|
<TELL "The "
|
||||||
|
1
|
||||||
|
<ODESC2 <PRSO>>
|
||||||
|
" burns inside the receptacle.">
|
||||||
|
<SETG BURNUP-INT <CLOCK-INT ,BRNIN <* <OSIZE <PRSO>> 20>>>
|
||||||
|
<TRO <PRSO> <+ ,FLAMEBIT ,LIGHTBIT ,ONBIT>>
|
||||||
|
<TRZ <PRSO> <+ ,TAKEBIT ,READBIT>>
|
||||||
|
<COND (,BINF!-FLAG)
|
||||||
|
(<TELL
|
||||||
|
"The cloth bag inflates as it fills with hot air.">
|
||||||
|
<COND (<NOT ,BLAB!-FLAG>
|
||||||
|
<PUT .BALL
|
||||||
|
,OCONTENTS
|
||||||
|
(<SET BLABE <SFIND-OBJ "BLABE">>
|
||||||
|
!<OCONTENTS .BALL>)>
|
||||||
|
<PUT .BLABE ,OCAN .BALL>)>
|
||||||
|
<SETG BLAB!-FLAG T>
|
||||||
|
<SETG BINF!-FLAG <PRSO>>
|
||||||
|
<CLOCK-INT ,BINT 3>)>>
|
||||||
|
|
||||||
|
<DEFINE PUT-BALLOON (BALL THERE STR "AUX" (HERE ,HERE))
|
||||||
|
#DECL ((BALL) OBJECT (HERE) ROOM (THERE STR) STRING)
|
||||||
|
<COND (<OR <MEMBER "LEDG" <STRINGP <RID .HERE>>>
|
||||||
|
<==? .HERE <FIND-ROOM "VLBOT">>>
|
||||||
|
<TELL "You watch as the balloon slowly " 1 .STR>)>
|
||||||
|
<REMOVE-OBJECT .BALL>
|
||||||
|
<INSERT-OBJECT .BALL <SETG BLOC <FIND-ROOM .THERE>>>>
|
||||||
|
|
||||||
|
<GDECL (BLOC) ROOM>
|
||||||
|
|
||||||
|
<DEFINE DECLINE-AND-FALL (BALL "AUX" (S <TOP ,SCRSTR>) M (BL ,BLOC)
|
||||||
|
(IN? <==? <AVEHICLE ,WINNER> .BALL>) FOO)
|
||||||
|
#DECL ((BALL) OBJECT (BL) ROOM (M) <OR FALSE STRING> (S) STRING
|
||||||
|
(IN?) <OR ATOM FALSE> (FOO) CEVENT)
|
||||||
|
<CLOCK-INT ,BINT 3>
|
||||||
|
<COND (<SET M <MEMBER "VAIR" <STRINGP <RID .BL>>>>
|
||||||
|
<COND (<=? <REST .M 4> "1">
|
||||||
|
<COND (.IN?
|
||||||
|
<GOTO <SETG BLOC <SFIND-ROOM "VLBOT">>>
|
||||||
|
<COND (,BINF!-FLAG
|
||||||
|
<TELL "The balloon has landed.">
|
||||||
|
<CLOCK-INT ,BINT 0>
|
||||||
|
<ROOM-INFO>)
|
||||||
|
(T
|
||||||
|
<REMOVE-OBJECT .BALL>
|
||||||
|
<INSERT-OBJECT <SFIND-OBJ "DBALL"> ,BLOC>
|
||||||
|
<PUT ,WINNER ,AVEHICLE <>>
|
||||||
|
<CLOCK-DISABLE <SET FOO <CLOCK-INT ,BINT 0>>>
|
||||||
|
<TELL
|
||||||
|
"You have landed, but the balloon did not survive.">)>)
|
||||||
|
(<PUT-BALLOON .BALL "VLBOT" "lands.">)>)
|
||||||
|
(<SUBSTRUC <STRINGP <RID .BL>> 0 4 .S>
|
||||||
|
<PUT .S 5 <CHTYPE <- <CHTYPE <5 .M> FIX> 1> CHARACTER>>
|
||||||
|
<COND (.IN?
|
||||||
|
<GOTO <SETG BLOC <FIND-ROOM .S>>>
|
||||||
|
<TELL "The balloon descends.">
|
||||||
|
<ROOM-INFO>)
|
||||||
|
(<PUT-BALLOON .BALL .S "descends.">)>)>)>>
|
||||||
|
|
||||||
|
<DEFINE BCONTENTS ()
|
||||||
|
<COND (<VERB? "TAKE">
|
||||||
|
<TELL
|
||||||
|
"The " 0 <ODESC2 <PRSO>> " is an integral part of the basket and cannot
|
||||||
|
be removed.">
|
||||||
|
<COND (<==? <PRSO> <SFIND-OBJ "BROPE">>
|
||||||
|
<TELL " The wire might possibly be tied, though.">)
|
||||||
|
(<TELL "">)>)
|
||||||
|
(<VERB? "FIND" "EXAMI">
|
||||||
|
<TELL
|
||||||
|
"The " 1 <ODESC2 <PRSO>> " is part of the basket. It may be manipulated
|
||||||
|
within the basket but cannot be removed.">)>>
|
||||||
|
|
||||||
|
<DEFINE WIRE-FUNCTION ("AUX" (BINT ,BINT))
|
||||||
|
#DECL ((BINT) CEVENT)
|
||||||
|
<COND (<VERB? "TAKE" "FIND" "EXAMI">
|
||||||
|
<BCONTENTS>)
|
||||||
|
(<VERB? "TIE">
|
||||||
|
<COND (<AND <==? <PRSO> <SFIND-OBJ "BROPE">>
|
||||||
|
<OR <==? <PRSI> <SFIND-OBJ "HOOK1">>
|
||||||
|
<==? <PRSI> <SFIND-OBJ "HOOK2">>>>
|
||||||
|
<SETG BTIE!-FLAG <PRSI>>
|
||||||
|
<ODESC1 <PRSI>
|
||||||
|
"The basket is anchored to a small hook by the braided wire.">
|
||||||
|
<CLOCK-DISABLE .BINT>
|
||||||
|
<TELL "The balloon is fastened to the hook.">)>)
|
||||||
|
(<AND <VERB? "UNTIE">
|
||||||
|
<==? <PRSO> <SFIND-OBJ "BROPE">>>
|
||||||
|
<COND (,BTIE!-FLAG
|
||||||
|
<CLOCK-ENABLE <SET BINT <CLOCK-INT ,BINT 3>>>
|
||||||
|
<ODESC1 ,BTIE!-FLAG ,HOOK-DESC>
|
||||||
|
<SETG BTIE!-FLAG <>>
|
||||||
|
<TELL "The wire falls off of the hook.">)
|
||||||
|
(<TELL "The wire is not tied to anything.">)>)>>
|
||||||
|
|
||||||
|
<DEFINE BURNUP ("AUX" (R <SFIND-OBJ "RECEP">) (OBJ <1 <OCONTENTS .R>>))
|
||||||
|
#DECL ((R OBJ) OBJECT)
|
||||||
|
<COND (<==? ,HERE ,BLOC>
|
||||||
|
<TELL
|
||||||
|
"You notice that the " 1 <ODESC2 .OBJ> " has burned out, and that
|
||||||
|
the cloth bag starts to deflate.">)>
|
||||||
|
<PUT .R ,OCONTENTS <SPLICE-OUT .OBJ <OCONTENTS .R>>>
|
||||||
|
<SETG BINF!-FLAG <>>
|
||||||
|
T>
|
||||||
|
|
||||||
|
<SETG SAFE-FLAG!-FLAG <>>
|
||||||
|
|
||||||
|
<DEFINE SAFE-ROOM ()
|
||||||
|
<COND (<VERB? "LOOK">
|
||||||
|
<TELL
|
||||||
|
"You are in a dusty old room which is virtually featureless, except
|
||||||
|
for an exit on the north side."
|
||||||
|
,LONG-TELL1
|
||||||
|
<COND (<NOT ,SAFE-FLAG!-FLAG>
|
||||||
|
"
|
||||||
|
Imbedded in the far wall, there is a rusty old box. It appears that
|
||||||
|
the box is somewhat damaged, since an oblong hole has been chipped
|
||||||
|
out of the front of it.")
|
||||||
|
("
|
||||||
|
On the far wall is a rusty box, whose door has been blown off.")>>)>>
|
||||||
|
|
||||||
|
<DEFINE SAFE-FUNCTION ()
|
||||||
|
<COND (<VERB? "TAKE">
|
||||||
|
<TELL "The box is imbedded in the wall.">)
|
||||||
|
(<VERB? "OPEN">
|
||||||
|
<COND (,SAFE-FLAG!-FLAG <TELL "The box has no door!">)
|
||||||
|
(<TELL "The box is rusted and will not open.">)>)
|
||||||
|
(<VERB? "CLOSE">
|
||||||
|
<COND (,SAFE-FLAG!-FLAG <TELL "The box has no door!">)
|
||||||
|
(<TELL "The box is not open, chomper!">)>)>>
|
||||||
|
|
||||||
|
<DEFINE BRICK-FUNCTION ()
|
||||||
|
<COND (<VERB? "BURN">
|
||||||
|
<REMOVE-OBJECT <FIND-OBJ "BRICK">>
|
||||||
|
<JIGS-UP ,BRICK-BOOM>)>>
|
||||||
|
|
||||||
|
<DEFINE FUSE-FUNCTION ("AUX" (FUSE <SFIND-OBJ "FUSE">)
|
||||||
|
(BRICK <SFIND-OBJ "BRICK">) BRICK-ROOM OC)
|
||||||
|
#DECL ((FUSE BRICK) OBJECT (BRICK-ROOM) <OR ROOM FALSE>
|
||||||
|
(OC) <OR OBJECT FALSE>)
|
||||||
|
<COND (<VERB? "BURN">
|
||||||
|
<TELL "The wire starts to burn.">
|
||||||
|
<CLOCK-ENABLE <CLOCK-INT ,FUSIN 2>>)
|
||||||
|
(<VERB? "C-INT">
|
||||||
|
<COND (<==? <OCAN .FUSE> .BRICK>
|
||||||
|
<COND (<SET OC <OCAN .BRICK>>
|
||||||
|
<SET BRICK-ROOM <OROOM .OC>>)
|
||||||
|
(<SET BRICK-ROOM <OROOM .BRICK>>)>
|
||||||
|
<OR .BRICK-ROOM <SET BRICK-ROOM ,HERE>>
|
||||||
|
<COND (<==? .BRICK-ROOM ,HERE>
|
||||||
|
<MUNG-ROOM .BRICK-ROOM
|
||||||
|
"The way is blocked by debris from an explosion.">
|
||||||
|
<JIGS-UP ,BRICK-BOOM>)
|
||||||
|
(<==? .BRICK-ROOM <SFIND-ROOM "SAFE">>
|
||||||
|
<CLOCK-INT ,SAFIN 5>
|
||||||
|
<SETG MUNGED-ROOM <OROOM .BRICK>>
|
||||||
|
<TELL "There is an explosion nearby.">
|
||||||
|
<COND (<MEMQ .BRICK <OCONTENTS <SFIND-OBJ "SSLOT">>>
|
||||||
|
<TRZ <SFIND-OBJ "SSLOT"> ,OVISON>
|
||||||
|
<TRO <SFIND-OBJ "SAFE"> ,OPENBIT>
|
||||||
|
<SETG SAFE-FLAG!-FLAG T>)>)
|
||||||
|
(<TELL "There is an explosion nearby.">
|
||||||
|
<CLOCK-INT ,SAFIN 5>
|
||||||
|
<SETG MUNGED-ROOM .BRICK-ROOM>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) OBJECT)
|
||||||
|
<COND (<TRNN .X ,TAKEBIT>
|
||||||
|
<TRZ .X ,OVISON>)>>
|
||||||
|
<ROBJS .BRICK-ROOM>>
|
||||||
|
<COND (<==? .BRICK-ROOM <SFIND-ROOM "LROOM">>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) OBJECT)
|
||||||
|
<PUT .X ,OCAN <>>>
|
||||||
|
<OCONTENTS <SFIND-OBJ "TCASE">>>
|
||||||
|
<PUT <SFIND-OBJ "TCASE"> ,OCONTENTS ()>)>)>
|
||||||
|
<REMOVE-OBJECT .BRICK>)
|
||||||
|
(<OR <NOT <OROOM .FUSE>> <==? ,HERE <OROOM .FUSE>>>
|
||||||
|
<TELL "The wire rapidly burns into nothingness.">)>
|
||||||
|
<REMOVE-OBJECT .FUSE>)>>
|
||||||
|
|
||||||
|
<DEFINE SAFE-MUNG ("AUX" (RM ,MUNGED-ROOM))
|
||||||
|
#DECL ((RM) ROOM)
|
||||||
|
<COND (<==? ,HERE .RM>
|
||||||
|
<JIGS-UP
|
||||||
|
<COND (<RTRNN .RM ,RHOUSEBIT>
|
||||||
|
"The house shakes, and the ceiling of the room you're in collapses,
|
||||||
|
turning you into a pancake.")
|
||||||
|
("The room trembles and 50,000 pounds of rock fall on you, turning you
|
||||||
|
into a pancake.")>>)
|
||||||
|
(<TELL
|
||||||
|
"You may recall that recent explosion. Well, probably as a result of
|
||||||
|
that, you hear an ominous rumbling, as if one of the rooms in the
|
||||||
|
dungeon had collapsed." ,LONG-TELL1>
|
||||||
|
<AND <==? .RM <SFIND-ROOM "SAFE">>
|
||||||
|
<CLOCK-INT ,LEDIN 8>>)>
|
||||||
|
<MUNG-ROOM .RM "The way is blocked by debris from an explosion.">>
|
||||||
|
|
||||||
|
<DEFINE LEDGE-MUNG ("AUX" (RM <SFIND-ROOM "LEDG4">))
|
||||||
|
#DECL ((RM) ROOM)
|
||||||
|
<COND (<==? ,HERE .RM>
|
||||||
|
<COND (<AVEHICLE ,WINNER>
|
||||||
|
<COND (,BTIE!-FLAG
|
||||||
|
<SET RM <SFIND-ROOM "VLBOT">>
|
||||||
|
<SETG BLOC .RM>
|
||||||
|
<REMOVE-OBJECT <SFIND-OBJ "BALLO">>
|
||||||
|
<INSERT-OBJECT <SFIND-OBJ "DBALL"> .RM>
|
||||||
|
<SETG BTIE!-FLAG <>>
|
||||||
|
<SETG BINF!-FLAG <>>
|
||||||
|
<CLOCK-DISABLE ,BINT>
|
||||||
|
<CLOCK-DISABLE ,BRNIN>
|
||||||
|
<JIGS-UP
|
||||||
|
"The ledge collapses, probably as a result of the explosion. A large
|
||||||
|
chunk of it, which is attached to the hook, drags you down to the
|
||||||
|
ground. Fatally.">)
|
||||||
|
(<TELL "The ledge collapses, leaving you with no place to land.">)>)
|
||||||
|
(T
|
||||||
|
<JIGS-UP
|
||||||
|
"The force of the explosion has caused the ledge to collapse
|
||||||
|
belatedly.">)>)
|
||||||
|
(<TELL "The ledge collapses, giving you a narrow escape.">)>
|
||||||
|
<MUNG-ROOM .RM "The ledge has collapsed and cannot be landed on.">>
|
||||||
|
|
||||||
|
<DEFINE LEDGE-FUNCTION ()
|
||||||
|
<COND (<VERB? "LOOK">
|
||||||
|
<TELL
|
||||||
|
"You are on a wide ledge high into the volcano. The rim of the
|
||||||
|
volcano is about 200 feet above and there is a precipitous drop below
|
||||||
|
to the bottom." ,LONG-TELL1
|
||||||
|
<COND (<RTRNN <SFIND-ROOM "SAFE"> ,RMUNGBIT>
|
||||||
|
" The way to the south is blocked by rubble.")
|
||||||
|
(" There is a small door to the south.")>>)>>
|
||||||
|
|
||||||
|
<DEFINE BLAST ()
|
||||||
|
<COND (<==? ,HERE <SFIND-ROOM "SAFE">>)
|
||||||
|
(<TELL "I don't really know how to do that.">)>>
|
||||||
|
|
||||||
|
<DEFINE VOLGNOME ()
|
||||||
|
<COND (<MEMBER "LEDG" <STRINGP <RID ,HERE>>>
|
||||||
|
<TELL ,GNOME-DESC ,LONG-TELL1>
|
||||||
|
<INSERT-OBJECT <SFIND-OBJ "GNOME"> ,HERE>)
|
||||||
|
(<CLOCK-INT ,VLGIN 1>)>>
|
||||||
|
|
||||||
|
<SETG GNOME-DOOR!-FLAG <SETG GNOME-FLAG!-FLAG <>>>
|
||||||
|
|
||||||
|
<DEFINE GNOME-FUNCTION ("AUX" (GNOME <SFIND-OBJ "GNOME">) BRICK)
|
||||||
|
#DECL ((GNOME) OBJECT (BRICK) OBJECT)
|
||||||
|
<COND (<AND <VERB? "GIVE" "THROW">
|
||||||
|
<COND (<N==? <OTVAL <PRSO>> 0>
|
||||||
|
<TELL
|
||||||
|
"Thank you very much for the " ,LONG-TELL1 <ODESC2 <PRSO>> ". I don't believe
|
||||||
|
I've ever seen one as beautiful. 'Follow me', he says, and a door
|
||||||
|
appears on the west end of the ledge. Through the door, you can see
|
||||||
|
a narrow chimney sloping steeply downward. The gnome moves quickly,
|
||||||
|
and he disappears from sight.">
|
||||||
|
<REMOVE-OBJECT <PRSO>>
|
||||||
|
<REMOVE-OBJECT .GNOME>
|
||||||
|
<SETG GNOME-DOOR!-FLAG T>)
|
||||||
|
(<BOMB? <PRSO>>
|
||||||
|
<OR <OROOM <SET BRICK <SFIND-OBJ "BRICK">>>
|
||||||
|
<INSERT-OBJECT .BRICK ,HERE>>
|
||||||
|
<REMOVE-OBJECT .GNOME>
|
||||||
|
<CLOCK-DISABLE ,GNOIN>
|
||||||
|
<CLOCK-DISABLE ,VLGIN>
|
||||||
|
<TELL
|
||||||
|
"'That certainly wasn't what I had in mind', he says, and disappears.">)
|
||||||
|
(<TELL
|
||||||
|
"'That wasn't quite what I had in mind', he says, crunching the
|
||||||
|
" 1 <ODESC2 <PRSO>> " in his rock-hard hands.">
|
||||||
|
<REMOVE-OBJECT <PRSO>>)>>)
|
||||||
|
(<VERB? "C-INT">
|
||||||
|
<COND (<==? ,HERE <OROOM .GNOME>>
|
||||||
|
<TELL
|
||||||
|
"The gnome glances at his watch. 'Oops. I'm late for an
|
||||||
|
appointment!' He disappears, leaving you alone on the ledge." ,LONG-TELL1>)>
|
||||||
|
<REMOVE-OBJECT .GNOME>)
|
||||||
|
(<TELL
|
||||||
|
"The gnome appears increasingly nervous.">
|
||||||
|
<OR ,GNOME-FLAG!-FLAG <CLOCK-INT ,GNOIN 5>>
|
||||||
|
<SETG GNOME-FLAG!-FLAG T>)>>
|
|
@ -0,0 +1,924 @@
|
||||||
|
|
||||||
|
"BIBLE -- print catalog of object, rooms, and verbs"
|
||||||
|
|
||||||
|
<SETG NO-SORT T>
|
||||||
|
|
||||||
|
<DEFINE BIBLE ("OPTIONAL" (F "NUL:") "AUX" (C <OPEN "PRINT" .F>) (O ,OUTCHAN))
|
||||||
|
#DECL ((F) STRING (C) <OR CHANNEL FALSE> (O) CHANNEL)
|
||||||
|
<SETG NO-SORT <>>
|
||||||
|
<AND .C
|
||||||
|
<PROG ((OUTCHAN .C))
|
||||||
|
#DECL ((OUTCHAN) <SPECIAL CHANNEL>)
|
||||||
|
<SETG OUTCHAN .C>
|
||||||
|
<APPLY-RANDOM DO-SCRIPT>
|
||||||
|
<ATLAS>
|
||||||
|
<PRINC <ASCII 12> .C>
|
||||||
|
<CATALOG>
|
||||||
|
<PRINC <ASCII 12> .C>
|
||||||
|
<GET-ACTIONS>
|
||||||
|
<PRINC <ASCII 12> .C>
|
||||||
|
<APPLY-RANDOM DO-UNSCRIPT>
|
||||||
|
<SETG OUTCHAN .O>
|
||||||
|
<CLOSE .C>>>
|
||||||
|
"DONE">
|
||||||
|
|
||||||
|
<DEFINE ATLAS ("TUPLE" RMTUP
|
||||||
|
"AUX" (CNT 0) (RMS '![]) (OUTCHAN .OUTCHAN) (TEST? <>) (SHORT? <>)
|
||||||
|
(PVAL? <>))
|
||||||
|
#DECL ((RMTUP) TUPLE (RMS) <UVECTOR [REST ROOM]> (OUTCHAN) CHANNEL
|
||||||
|
(CNT) FIX (TEST? SHORT?) <OR FALSE ATOM>)
|
||||||
|
<COND (<EMPTY? .RMTUP>)
|
||||||
|
(ELSE
|
||||||
|
<COND (<==? <1 .RMTUP> T>
|
||||||
|
<SET RMTUP <REST .RMTUP>>
|
||||||
|
<SET SHORT? T>
|
||||||
|
<COND (<==? <1 .RMTUP> T>
|
||||||
|
<SET RMTUP <REST .RMTUP>>
|
||||||
|
<SET PVAL? T>)>)>
|
||||||
|
<COND (<AND <NOT <EMPTY? .RMTUP>> <TYPE? <1 .RMTUP> ROOM>>
|
||||||
|
<SET RMS
|
||||||
|
<MAPF
|
||||||
|
,UVECTOR
|
||||||
|
<FUNCTION (N "AUX" R)
|
||||||
|
#DECL ((N) STRING (R) ROOM)
|
||||||
|
<COND (<NOT <EMPTY? <RDESC2 <SET R <FIND-ROOM .N>>>>>
|
||||||
|
<MAPRET .R>)
|
||||||
|
(<PRINC "****** "> <PRINC .N>
|
||||||
|
<PRINC " is NOT a room ******">
|
||||||
|
<CRLF> <MAPRET>)>>
|
||||||
|
.RMTUP>>)
|
||||||
|
(<AND <NOT <EMPTY? .RMTUP>> <TYPE? <1 .RMTUP> FORM ATOM FIX>>
|
||||||
|
<SET TEST? T>)>)>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (R "AUX" X)
|
||||||
|
#DECL ((R) <SPECIAL ROOM> (X) ANY)
|
||||||
|
<COND (<OR <NOT .TEST?>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (TEST)
|
||||||
|
#DECL ((TEST) ANY)
|
||||||
|
<OR <COND (<TYPE? .TEST FIX>
|
||||||
|
<RTRNN .R .TEST>)
|
||||||
|
(<TYPE? .TEST ATOM>
|
||||||
|
<COND (<NOT <GASSIGNED? .TEST>> <>)
|
||||||
|
(<TYPE? ,.TEST FIX>
|
||||||
|
<SET X <NTH .R ,.TEST>>)
|
||||||
|
(<SET X <OGET .R .TEST>>)>)
|
||||||
|
(<EVAL .TEST>)>
|
||||||
|
<MAPLEAVE <>>>>
|
||||||
|
.RMTUP>>
|
||||||
|
<SET CNT <+ .CNT 1>>
|
||||||
|
<COND (.SHORT?
|
||||||
|
<ROOM-NAME .R>
|
||||||
|
<COND (.PVAL? <COLUMN 30> <PRINC "==> "> <SPRINT .X>)>
|
||||||
|
<CRLF>)
|
||||||
|
(ELSE <RINFO .R .RMS>)>)>>
|
||||||
|
<COND (<OR .TEST? ,NO-SORT> <UVECTOR !,ROOMS>)
|
||||||
|
(<OORDER <UVECTOR !,ROOMS> ,RDESC2>)>>
|
||||||
|
.CNT>
|
||||||
|
|
||||||
|
"CATALOG -- print catalog of all objects"
|
||||||
|
|
||||||
|
<DEFINE CATALOG ("TUPLE" OBJTUP
|
||||||
|
"AUX" (CNT 0) OBJS (OUTCHAN .OUTCHAN) (TEST? <>) (SHORT? <>)
|
||||||
|
(PVAL? <>))
|
||||||
|
#DECL ((OBJTUP) TUPLE (OBJS) UVECTOR (OUTCHAN) CHANNEL
|
||||||
|
(CNT) FIX (TEST? SHORT?) <OR ATOM FALSE>)
|
||||||
|
<COND (<EMPTY? .OBJTUP> <SET OBJS <UVECTOR !,OBJECTS>>)
|
||||||
|
(ELSE
|
||||||
|
<COND (<==? <1 .OBJTUP> T>
|
||||||
|
<SET OBJTUP <REST .OBJTUP>>
|
||||||
|
<SET SHORT? T>
|
||||||
|
<COND (<==? <1 .OBJTUP> T>
|
||||||
|
<SET OBJTUP <REST .OBJTUP>>
|
||||||
|
<SET PVAL? T>)>)>
|
||||||
|
<COND (<AND <NOT <EMPTY? .OBJTUP>> <TYPE? <1 .OBJTUP> FORM ATOM FIX>>
|
||||||
|
<SET TEST? T>
|
||||||
|
<SET OBJS <UVECTOR !,OBJECTS>>)
|
||||||
|
(<NOT <EMPTY? .OBJTUP>>
|
||||||
|
<SET OBJS
|
||||||
|
<MAPF
|
||||||
|
,UVECTOR
|
||||||
|
<FUNCTION (N "AUX" O)
|
||||||
|
#DECL ((N) STRING (O) OBJECT)
|
||||||
|
<COND (<NOT <EMPTY? <ODESC2 <SET O <FIND-OBJ .N>>>>>
|
||||||
|
<MAPRET .O>)
|
||||||
|
(ELSE
|
||||||
|
<PRINC "****** ">
|
||||||
|
<PRINC .N>
|
||||||
|
<PRINC " is NOT an object ******">
|
||||||
|
<CRLF>
|
||||||
|
<MAPRET>)>>
|
||||||
|
.OBJTUP>>)
|
||||||
|
(ELSE <SET OBJS <UVECTOR !,OBJECTS>>)>)>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (O "AUX" X)
|
||||||
|
#DECL ((O) <SPECIAL OBJECT> (X) ANY)
|
||||||
|
<COND (<OR <NOT .TEST?>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (TEST)
|
||||||
|
#DECL ((TEST) ANY)
|
||||||
|
<OR <COND (<TYPE? .TEST FIX>
|
||||||
|
<TRNN .O .TEST>)
|
||||||
|
(<TYPE? .TEST ATOM>
|
||||||
|
<COND (<NOT <GASSIGNED? .TEST>> <>)
|
||||||
|
(<TYPE? ,.TEST FIX>
|
||||||
|
<SET X <NTH .O ,.TEST>>)
|
||||||
|
(<SET X <OGET .O .TEST>>)>)
|
||||||
|
(<EVAL .TEST>)>
|
||||||
|
<MAPLEAVE <>>>>
|
||||||
|
.OBJTUP>>
|
||||||
|
<SET CNT <+ .CNT 1>>
|
||||||
|
<COND (.SHORT?
|
||||||
|
<OBJECT-NAME .O>
|
||||||
|
<COND (.PVAL? <COLUMN 30> <PRINC "==> "> <SPRINT .X>)>
|
||||||
|
<CRLF>)
|
||||||
|
(ELSE <OINFO .O>)>)>>
|
||||||
|
<COND (<OR .TEST? ,NO-SORT> .OBJS)
|
||||||
|
(<OORDER .OBJS ,ODESC2>)>>
|
||||||
|
.CNT>
|
||||||
|
|
||||||
|
<DEFINE COLUMN (N "AUX" (OUTCHAN .OUTCHAN) (X <- .N <14 .OUTCHAN>>))
|
||||||
|
#DECL ((N X) FIX (OUTCHAN) CHANNEL)
|
||||||
|
<COND (<L=? .X 0> <PRINC !\ >)
|
||||||
|
(ELSE
|
||||||
|
<PRINTSTRING " "
|
||||||
|
.OUTCHAN
|
||||||
|
.X>)>>
|
||||||
|
|
||||||
|
<DEFINE SPRINT (A "AUX" (OUTCHAN .OUTCHAN) AR AL)
|
||||||
|
#DECL ((A) ANY (OUTCHAN) CHANNEL (AR) <OR STRING FALSE> (AL) FIX)
|
||||||
|
<COND (<TYPE? .A OBJECT> <OBJECT-NAME .A>)
|
||||||
|
(<TYPE? .A ROOM> <ROOM-NAME .A>)
|
||||||
|
(<MONAD? .A> <PRIN1 .A>)
|
||||||
|
(<TYPE? .A STRING>
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<EMPTY? .A>
|
||||||
|
<SET AL 0>
|
||||||
|
<SET A "">
|
||||||
|
<RETURN>)
|
||||||
|
(<MEMQ <1 .A> "
|
||||||
|
\"">
|
||||||
|
<SET A <REST .A>>)
|
||||||
|
(ELSE
|
||||||
|
<COND (<SET AR <MEMQ <ASCII 13> .A>>
|
||||||
|
<SET AL <- <LENGTH .A> <LENGTH .AR>>>)
|
||||||
|
(<SET AL <LENGTH .A>>)>
|
||||||
|
<SET AL <MIN .AL <- <13 .OUTCHAN> <+ 6 <14 .OUTCHAN>>>>>
|
||||||
|
<RETURN>)>>
|
||||||
|
<PRINC !\">
|
||||||
|
<PRINTSTRING .A .OUTCHAN .AL>
|
||||||
|
<PRINC "... \"">)>
|
||||||
|
T>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
<DEFINE RINFO (A "OPTIONAL" (RMS '![])
|
||||||
|
"AUX" R (OUTCHAN .OUTCHAN) (HERO ,PLAYER) (LAMP <FIND-OBJ "LAMP">))
|
||||||
|
#DECL ((A) <OR ROOM STRING> (R) ROOM (RMS) UVECTOR (OUTCHAN) CHANNEL
|
||||||
|
(HERO) ADV (LAMP) OBJECT)
|
||||||
|
<AND <TYPE? .A STRING> <SET A <FIND-ROOM .A>>>
|
||||||
|
<SET R .A>
|
||||||
|
<OR <MEMQ <FIND-OBJ "LAMP"> <AOBJS ,WINNER>> <CONS-OBJ "LAMP">>
|
||||||
|
<TRO .LAMP ,ONBIT>
|
||||||
|
<PROG ()
|
||||||
|
<COND (<==? <RID .R> <PSTRING "!">> <RETURN>)>
|
||||||
|
<COND (<AND <NOT <EMPTY? .RMS>>
|
||||||
|
<NOT <MEMQ .R .RMS>>
|
||||||
|
<NOT <EXIT-TO <REXITS .R> .RMS>>>
|
||||||
|
<RETURN>)>
|
||||||
|
<SETG HERE .R>
|
||||||
|
<PUT .HERO ,AROOM .R>
|
||||||
|
<RTRO .R ,RSEENBIT>
|
||||||
|
<PRINC "
|
||||||
|
====== ">
|
||||||
|
<ROOM-NAME .R T>
|
||||||
|
<PRINC " ======
|
||||||
|
">
|
||||||
|
<CRLF>
|
||||||
|
<BIT-INFO .R>
|
||||||
|
<DIR-INFO .R>
|
||||||
|
<PRINC "`">
|
||||||
|
<COND (<TYPE? ,ROOM-DESC RSUBR RSUBR-ENTRY>
|
||||||
|
<ROOM-DESC>)
|
||||||
|
(<APPLY-RANDOM ,ROOM-DESC>)>
|
||||||
|
<PRINC "'">
|
||||||
|
<CRLF>
|
||||||
|
<COND (<RACTION .R>
|
||||||
|
<PRINC "Special action function: ">
|
||||||
|
<COND (<TYPE? <RACTION .R> NOFFSET>
|
||||||
|
<PRIN1 <GET-ATOM <RACTION .R>>>)
|
||||||
|
(<FUNCTION-PRINT <RACTION .R>>)>
|
||||||
|
<CRLF>)>>>
|
||||||
|
|
||||||
|
<SETG BITTYS
|
||||||
|
[,RLIGHTBIT
|
||||||
|
,RAIRBIT
|
||||||
|
,RWATERBIT
|
||||||
|
,RSACREDBIT
|
||||||
|
,RFILLBIT
|
||||||
|
,RMUNGBIT
|
||||||
|
,RBUCKBIT
|
||||||
|
,RHOUSEBIT
|
||||||
|
,RENDGAME]>
|
||||||
|
|
||||||
|
<SETG DESCS
|
||||||
|
'["Lighted"
|
||||||
|
"Mid-air"
|
||||||
|
"Watery"
|
||||||
|
"Robber-proof"
|
||||||
|
"Water-source"
|
||||||
|
"Destroyed"
|
||||||
|
"Bucket"
|
||||||
|
"part of the House"
|
||||||
|
"part of the End Game"]>
|
||||||
|
|
||||||
|
<GDECL (BITTYS) <VECTOR [REST FIX]> (DESCS) <VECTOR [REST STRING]>>
|
||||||
|
|
||||||
|
"BIT-INFO -- print info about a room's bits"
|
||||||
|
|
||||||
|
<DEFINE BIT-INFO (R "AUX" (BB <>) (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((R) ROOM (BB) <OR ATOM FALSE> (OUTCHAN) CHANNEL)
|
||||||
|
<COND (<NOT <0? <RVAL .R>>>
|
||||||
|
<PRINC "Room is valued at ">
|
||||||
|
<PRINC <RVAL .R>>
|
||||||
|
<SET BB T>)>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (B D)
|
||||||
|
#DECL ((B) FIX (D) STRING)
|
||||||
|
<COND (<RTRNN .R .B>
|
||||||
|
<COND (.BB <PRINC ", ">)
|
||||||
|
(ELSE
|
||||||
|
<PRINC "Room is ">)>
|
||||||
|
<SET BB T>
|
||||||
|
<PRINC .D>)>>
|
||||||
|
,BITTYS
|
||||||
|
,DESCS>
|
||||||
|
<AND .BB <PRINC ".
|
||||||
|
|
||||||
|
">>>
|
||||||
|
|
||||||
|
<COND (<NOT <LOOKUP "COMPILE" <ROOT>>>
|
||||||
|
<SETG DIRS
|
||||||
|
[<CHTYPE <PSTRING "OUT"> DIRECTION>
|
||||||
|
"Out"
|
||||||
|
<CHTYPE <PSTRING "NE"> DIRECTION>
|
||||||
|
"Northeast"
|
||||||
|
<CHTYPE <PSTRING "NW"> DIRECTION>
|
||||||
|
"Northwest"
|
||||||
|
<CHTYPE <PSTRING "SE"> DIRECTION>
|
||||||
|
"Southeast"
|
||||||
|
<CHTYPE <PSTRING "SW"> DIRECTION>
|
||||||
|
"Southwest"
|
||||||
|
<CHTYPE <PSTRING "NORTH"> DIRECTION>
|
||||||
|
"North"
|
||||||
|
<CHTYPE <PSTRING "SOUTH"> DIRECTION>
|
||||||
|
"South"
|
||||||
|
<CHTYPE <PSTRING "EAST"> DIRECTION>
|
||||||
|
"East"
|
||||||
|
<CHTYPE <PSTRING "WEST"> DIRECTION>
|
||||||
|
"West"
|
||||||
|
<CHTYPE <PSTRING "UP"> DIRECTION>
|
||||||
|
"Up"
|
||||||
|
<CHTYPE <PSTRING "DOWN"> DIRECTION>
|
||||||
|
"Down"
|
||||||
|
<CHTYPE <PSTRING "LAUNC"> DIRECTION>
|
||||||
|
"Launch"
|
||||||
|
<CHTYPE <PSTRING "CROSS"> DIRECTION>
|
||||||
|
"Cross"
|
||||||
|
<CHTYPE <PSTRING "CLIMB"> DIRECTION>
|
||||||
|
"Climb"
|
||||||
|
<CHTYPE <PSTRING "EXIT"> DIRECTION>
|
||||||
|
"Exit"
|
||||||
|
<CHTYPE <PSTRING "ENTER"> DIRECTION>
|
||||||
|
"Enter"
|
||||||
|
<CHTYPE <PSTRING "LAND"> DIRECTION>
|
||||||
|
"Land"]>)>
|
||||||
|
|
||||||
|
<GDECL (DIRS) <VECTOR [REST DIRECTION STRING]>>
|
||||||
|
|
||||||
|
<DEFINE EXIT-TO (EXITS RMS)
|
||||||
|
#DECL ((EXITS) EXIT (RMS) <UVECTOR [REST ROOM]>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (E)
|
||||||
|
#DECL ((E) <OR DIRECTION ROOM CEXIT NEXIT DOOR>)
|
||||||
|
<COND (<TYPE? .E DIRECTION>)
|
||||||
|
(<AND <TYPE? .E ROOM> <MEMQ .E .RMS>>
|
||||||
|
<MAPLEAVE T>)
|
||||||
|
(<AND <TYPE? .E CEXIT> <MEMQ <2 .E> .RMS>>
|
||||||
|
<MAPLEAVE T>)
|
||||||
|
(<AND <TYPE? .E DOOR>
|
||||||
|
<OR <MEMQ <DROOM1 .E> .RMS>
|
||||||
|
<MEMQ <DROOM2 .E> .RMS>>>
|
||||||
|
<MAPLEAVE T>)>>
|
||||||
|
.EXITS>>
|
||||||
|
|
||||||
|
<DEFINE DIR-INFO (ROOM "AUX" (L <REXITS .ROOM>) (DL ,DIRS) D R (OUTCHAN .OUTCHAN) X)
|
||||||
|
#DECL ((L) <OR EXIT VECTOR> (DL) VECTOR (OUTCHAN) CHANNEL (D) STRING
|
||||||
|
(ROOM) ROOM (X) <OR FALSE VECTOR> (R) ANY)
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<EMPTY? .L> <CRLF> <RETURN>)
|
||||||
|
(<NOT <TYPE? <1 .L> DIRECTION>>
|
||||||
|
<PRINC " BADLY designed room!">)
|
||||||
|
(<==? <1 .L> <CHTYPE <PSTRING "#!#!#"> DIRECTION>>
|
||||||
|
<PRINC "No exits from this room.">
|
||||||
|
<COND (<LENGTH? .L 2> <CRLF> <CRLF> <RETURN>)
|
||||||
|
(ELSE <PRINC " BADLY designed room!">)>)
|
||||||
|
(<SET X <MEMQ <1 .L> .DL>> <PRINC <2 .X>>)
|
||||||
|
(ELSE <PRINC <1 .L>>)>
|
||||||
|
<COND (<TYPE? <SET R <2 .L>> ROOM>
|
||||||
|
<PRINC " to ">
|
||||||
|
<ROOM-NAME .R>
|
||||||
|
<PRINC !\.>)
|
||||||
|
(<TYPE? .R CEXIT>
|
||||||
|
<PRINC " to ">
|
||||||
|
<ROOM-NAME <2 .R>>
|
||||||
|
<PRINC " (if ">
|
||||||
|
<PRINC <1 .R>>
|
||||||
|
<PRINC ").">)
|
||||||
|
(<TYPE? .R DOOR>
|
||||||
|
<PRINC " to ">
|
||||||
|
<ROOM-NAME <COND (<==? <DROOM1 .R> .ROOM> <DROOM2 .R>)
|
||||||
|
(<==? <DROOM2 .R> .ROOM> <DROOM1 .R>)>>
|
||||||
|
<PRINC " (if ">
|
||||||
|
<OBJECT-NAME <DOBJ .R>>
|
||||||
|
<PRINC " is open).">)
|
||||||
|
(<TYPE? .R NEXIT>
|
||||||
|
<PRINC " is closed: ">
|
||||||
|
<COND (<EMPTY? <SET D <REST .R 0>>>
|
||||||
|
<PRINC "[No reason]">)
|
||||||
|
(<PRINC .D>)>)
|
||||||
|
(ELSE <PRINC "???">)>
|
||||||
|
<CRLF>
|
||||||
|
<SET L <REST .L 2>>>>
|
||||||
|
|
||||||
|
"ROOM-NAME -- print name of a room in less than 40 characters"
|
||||||
|
|
||||||
|
<DEFINE ROOM-NAME (R "OPTIONAL" (BIG <>) "AUX" (D <RDESC2 .R>) (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((R) ROOM (D) STRING (BIG) <OR ATOM FALSE> (OUTCHAN) CHANNEL)
|
||||||
|
<COND (<EMPTY? .D>
|
||||||
|
<PRINC "[NIL Room]">)
|
||||||
|
(ELSE
|
||||||
|
<COND (<OR .BIG <LENGTH? .D 40>> <PRINC .D>)
|
||||||
|
(ELSE <PRINTSTRING .D .OUTCHAN 35> <PRINC "...">)>
|
||||||
|
<PRINC " {">
|
||||||
|
<PRINC <STRINGP <RID .R>>>
|
||||||
|
<PRINC !\}>)>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
<DEFINE OBJECT-NAME (O "OPTIONAL" (A? <>) "AUX" (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((O) OBJECT (A?) <OR ATOM FALSE> (OUTCHAN) CHANNEL)
|
||||||
|
<COND (<EMPTY? <ODESC2 .O>>)
|
||||||
|
(T
|
||||||
|
<AND .A? <PRINC "A ">>
|
||||||
|
<PRINC <ODESC2 .O>>)>
|
||||||
|
<PRINC " {">
|
||||||
|
<PRINC <STRINGP <OID .O>>>
|
||||||
|
<PRINC !\}>>
|
||||||
|
|
||||||
|
"OINFO -- print info for a given object"
|
||||||
|
|
||||||
|
<DEFINE OINFO (SOBJ "OPTIONAL" (REC? <>) "AUX" O BB (OUTCHAN .OUTCHAN) OSYN)
|
||||||
|
#DECL ((SOBJ) <OR STRING OBJECT> (O) OBJECT (OUTCHAN) CHANNEL
|
||||||
|
(OSYN) UVECTOR (BB REC?) <OR ATOM FALSE>)
|
||||||
|
<COND (<TYPE? .SOBJ STRING> <SET O <FIND-OBJ .SOBJ>>)
|
||||||
|
(<SET O .SOBJ>)>
|
||||||
|
<PRINC "
|
||||||
|
====== ">
|
||||||
|
<OBJECT-NAME .O T>
|
||||||
|
<PRINC " ======">
|
||||||
|
<CRLF>
|
||||||
|
<SET OSYN
|
||||||
|
<COND (<NOT <EMPTY? <ONAMES .O>>> <REST <ONAMES .O>>)
|
||||||
|
(ELSE <ONAMES .O>)>>
|
||||||
|
<COND (<NOT <EMPTY? .OSYN>>
|
||||||
|
<CRLF>
|
||||||
|
<PRINC "Synonyms: ">
|
||||||
|
<SET BB <>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (A)
|
||||||
|
#DECL ((A) PSTRING)
|
||||||
|
<COND (.BB <PRINC ", ">)>
|
||||||
|
<SET BB T>
|
||||||
|
<PRINC <STRINGP .A>>>
|
||||||
|
<REST <ONAMES .O>>>
|
||||||
|
<PRINC !\.>
|
||||||
|
<CRLF>)>
|
||||||
|
<COND (<NOT <EMPTY? <OADJS .O>>>
|
||||||
|
<AND <EMPTY? .OSYN> <CRLF>>
|
||||||
|
<PRINC "Adjectives: ">
|
||||||
|
<SET BB <>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (A)
|
||||||
|
#DECL ((A) ADJECTIVE)
|
||||||
|
<COND (.BB <PRINC ", ">)>
|
||||||
|
<SET BB T>
|
||||||
|
<PRINC <STRINGP .A>>>
|
||||||
|
<OADJS .O>>
|
||||||
|
<PRINC !\.>
|
||||||
|
<CRLF>)>
|
||||||
|
<CRLF>
|
||||||
|
<COND (<TRNN .O ,NDESCBIT>
|
||||||
|
<PRINC "[No description]">
|
||||||
|
<CRLF>)
|
||||||
|
(ELSE
|
||||||
|
<COND (<AND <ODESCO .O> <NOT <EMPTY? <ODESCO .O>>>>
|
||||||
|
<PRINC "`">
|
||||||
|
<PRINC <ODESCO .O>>
|
||||||
|
<PRINC "'">
|
||||||
|
<CRLF>)>
|
||||||
|
<COND (<NOT <EMPTY? <ODESC1 .O>>>
|
||||||
|
<PRINC "`">
|
||||||
|
<PRINC <ODESC1 .O>>
|
||||||
|
<PRINC "'">
|
||||||
|
<CRLF>)>)>
|
||||||
|
<CRLF>
|
||||||
|
<COND (<NOT <0? <OGLOBAL .O>>>
|
||||||
|
<PRINC "The ">
|
||||||
|
<OBJECT-NAME .O>
|
||||||
|
<PRINC " is a global object.">
|
||||||
|
<CRLF>)>
|
||||||
|
<REPEAT ((O .O) (FIRST? T))
|
||||||
|
#DECL ((O) OBJECT (FIRST?) <OR ATOM FALSE>)
|
||||||
|
<COND (<OCAN .O>
|
||||||
|
<SET O <OCAN .O>>
|
||||||
|
<COND (<OR <TRNN .O ,VILLAIN> <OACTOR .O>>
|
||||||
|
<COND (.FIRST? <PRINC "Carried by a ">)
|
||||||
|
(ELSE <PRINC ", carried by a ">)>)
|
||||||
|
(.FIRST? <PRINC "In a ">)
|
||||||
|
(ELSE <PRINC ", in a ">)>
|
||||||
|
<OBJECT-NAME .O>
|
||||||
|
<SET FIRST? <>>)
|
||||||
|
(<OROOM .O>
|
||||||
|
<COND (.FIRST? <PRINC "In the ">)
|
||||||
|
(ELSE <PRINC ", in the ">)>
|
||||||
|
<ROOM-NAME <OROOM .O>>
|
||||||
|
<PRINC !\.>
|
||||||
|
<RETURN>)
|
||||||
|
(ELSE
|
||||||
|
<COND (.FIRST? <PRINC "No initial location.">)
|
||||||
|
(ELSE <PRINC ", nowhere.">)>
|
||||||
|
<RETURN>)>>
|
||||||
|
<CRLF>
|
||||||
|
<COND (<OR <NOT <0? <OFVAL .O>>>
|
||||||
|
<NOT <0? <OTVAL .O>>>>
|
||||||
|
<PRINC "Value: ">
|
||||||
|
<COND (<NOT <0? <OFVAL .O>>>
|
||||||
|
<PRINC <OFVAL .O>>
|
||||||
|
<PRINC " if found">
|
||||||
|
<COND (<NOT <0? <OTVAL .O>>>
|
||||||
|
<PRINC ", ">
|
||||||
|
<PRINC <OTVAL .O>>
|
||||||
|
<PRINC " more if in trophy case">)>)
|
||||||
|
(<NOT <0? <OTVAL .O>>>
|
||||||
|
<PRINC <OTVAL .O>>
|
||||||
|
<PRINC " if in trophy case">)>
|
||||||
|
<PRINC ".">
|
||||||
|
<CRLF>)>
|
||||||
|
<COND (<G? <OSIZE .O> 0>
|
||||||
|
<PRINC "Weighs ">
|
||||||
|
<COND (<==? <OSIZE .O> ,BIGFIX> <PRINC "a ton">)
|
||||||
|
(<PRINC <OSIZE .O>>)>
|
||||||
|
<PRINC ".">
|
||||||
|
<CRLF>)>
|
||||||
|
<COND (<TRNN .O ,LIGHTBIT>
|
||||||
|
<PRINC "Can produce light ">
|
||||||
|
<COND (<OLINT .O>
|
||||||
|
<PRINC "for ">
|
||||||
|
<PRINC <1 <2 <OLINT .O>>>>
|
||||||
|
<PRINC " moves.">)
|
||||||
|
(ELSE <PRINC "indefinitely.">)>
|
||||||
|
<CRLF>)>
|
||||||
|
<COND (<G? <OCAPAC .O> 0>
|
||||||
|
<PRINC "Capacity of ">
|
||||||
|
<PRINC <OCAPAC .O>> <PRINC "."> <CRLF>
|
||||||
|
<COND (<NOT <EMPTY? <OCONTENTS .O>>>
|
||||||
|
<SET BB <>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (C)
|
||||||
|
#DECL ((C) OBJECT)
|
||||||
|
<COND (.BB <PRINC ", ">)
|
||||||
|
(ELSE
|
||||||
|
<PRINC "The ">
|
||||||
|
<OBJECT-NAME .O>
|
||||||
|
<PRINC " contains ">)>
|
||||||
|
<SET BB T>
|
||||||
|
<PRINC "a ">
|
||||||
|
<OBJECT-NAME .C>>
|
||||||
|
<OCONTENTS .O>>
|
||||||
|
<PRINC ".">
|
||||||
|
<CRLF>)>)>
|
||||||
|
<COND (<G? <OSTRENGTH .O> 0>
|
||||||
|
<PRINC "Fighting strength of ">
|
||||||
|
<PRINC <OSTRENGTH .O>> <PRINC "."> <CRLF>
|
||||||
|
<COND (<NOT <EMPTY? <OCONTENTS .O>>>
|
||||||
|
<SET BB <>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (C)
|
||||||
|
#DECL ((C) OBJECT)
|
||||||
|
<COND (.BB <PRINC ", ">)
|
||||||
|
(ELSE
|
||||||
|
<PRINC "The ">
|
||||||
|
<OBJECT-NAME .O>
|
||||||
|
<PRINC " is armed with ">)>
|
||||||
|
<SET BB T>
|
||||||
|
<PRINC "a ">
|
||||||
|
<OBJECT-NAME .C>>
|
||||||
|
<OCONTENTS .O>>
|
||||||
|
<PRINC ".">
|
||||||
|
<CRLF>)>)>
|
||||||
|
<COND (<NOT <0? <CHTYPE <OFLAGS .O> FIX>>>
|
||||||
|
<SET BB <>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (B D)
|
||||||
|
#DECL ((B) FIX (D) STRING)
|
||||||
|
<COND (<TRNN .O .B>
|
||||||
|
<COND (.BB <PRINC ", ">)
|
||||||
|
(ELSE
|
||||||
|
<PRINC "The ">
|
||||||
|
<OBJECT-NAME .O>
|
||||||
|
<PRINC " is ">)>
|
||||||
|
<SET BB T>
|
||||||
|
<PRINC .D>)>>
|
||||||
|
,OBITTYS
|
||||||
|
,ODESCS>
|
||||||
|
<PRINC ".">
|
||||||
|
<CRLF>)>
|
||||||
|
<COND (<OACTION .O>
|
||||||
|
<PRINC "Special action function: ">
|
||||||
|
<FUNCTION-PRINT <OACTION .O>>
|
||||||
|
<CRLF>)>
|
||||||
|
<COND (.REC?
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (O) #DECL ((O) OBJECT) <OINFO .O T>>
|
||||||
|
<OCONTENTS .O>>)>
|
||||||
|
"DONE">
|
||||||
|
|
||||||
|
<SETG OBITTYS
|
||||||
|
![,OVISON
|
||||||
|
,READBIT
|
||||||
|
,TAKEBIT
|
||||||
|
,DOORBIT
|
||||||
|
,TRANSBIT
|
||||||
|
,FOODBIT
|
||||||
|
,NDESCBIT
|
||||||
|
,DRINKBIT
|
||||||
|
,CONTBIT
|
||||||
|
,LIGHTBIT
|
||||||
|
,VICBIT
|
||||||
|
,BURNBIT
|
||||||
|
,FLAMEBIT
|
||||||
|
,TOOLBIT
|
||||||
|
,TURNBIT
|
||||||
|
,VEHBIT
|
||||||
|
,FINDMEBIT
|
||||||
|
,SLEEPBIT
|
||||||
|
,SEARCHBIT
|
||||||
|
,SACREDBIT
|
||||||
|
,TIEBIT
|
||||||
|
,CLIMBBIT
|
||||||
|
,ACTORBIT
|
||||||
|
,WEAPONBIT
|
||||||
|
,FIGHTBIT
|
||||||
|
,VILLAIN
|
||||||
|
,STAGGERED
|
||||||
|
,TRYTAKEBIT
|
||||||
|
,NO-CHECK-BIT
|
||||||
|
,OPENBIT
|
||||||
|
,TOUCHBIT
|
||||||
|
,ONBIT!]>
|
||||||
|
|
||||||
|
<SETG ODESCS
|
||||||
|
'["visible"
|
||||||
|
"readable"
|
||||||
|
"takeable"
|
||||||
|
"a door"
|
||||||
|
"transparent"
|
||||||
|
"edible"
|
||||||
|
"indescribable"
|
||||||
|
"drinkable"
|
||||||
|
"a container"
|
||||||
|
"a light"
|
||||||
|
"a victim"
|
||||||
|
"flammable"
|
||||||
|
"burning"
|
||||||
|
"a tool"
|
||||||
|
"turnable"
|
||||||
|
"a vehicle"
|
||||||
|
"reachable from a vehicle"
|
||||||
|
"asleep"
|
||||||
|
"searchable"
|
||||||
|
"sacred"
|
||||||
|
"tieable"
|
||||||
|
"climbable"
|
||||||
|
"an actor"
|
||||||
|
"a weapon"
|
||||||
|
"fighting"
|
||||||
|
"a villain"
|
||||||
|
"staggered"
|
||||||
|
"dangerous to touch"
|
||||||
|
"collective noun"
|
||||||
|
"open"
|
||||||
|
"touched"
|
||||||
|
"turned on"
|
||||||
|
"diggable"
|
||||||
|
"a bunch"]>
|
||||||
|
|
||||||
|
<GDECL (OBITTYS) <UVECTOR [REST FIX]> (ODESCS) <VECTOR [REST STRING]>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
<GDECL (ACTIONS WORDS) OBLIST>
|
||||||
|
|
||||||
|
"GET-ACTIONS -- print action-info for all verbs"
|
||||||
|
|
||||||
|
<DEFINE GET-ACTIONS ("OPTIONAL" (V <>) "AUX" V1)
|
||||||
|
#DECL ((V) <OR FALSE <UVECTOR [REST PSTRING]>>)
|
||||||
|
<OR .V <SET V <ORDER ,ACTIONS-POBL>>>
|
||||||
|
<SET V1 <IVECTOR <* 3 <LENGTH .V>>>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X "AUX" (A <PLOOKUP .X ,ACTIONS-POBL>) M)
|
||||||
|
#DECL ((X) PSTRING (A) ACTION (M) <OR FALSE VECTOR>)
|
||||||
|
<COND (<SET M <MEMQ .A <TOP .V1>>>
|
||||||
|
<PUT <SET M <BACK .M>>
|
||||||
|
1
|
||||||
|
(.X !<1 .M>)>)
|
||||||
|
(<PUT .V1 1 (.X)>
|
||||||
|
<PUT .V1 2 .A>
|
||||||
|
<PUT .V1 3 0>
|
||||||
|
<SET V1 <REST .V1 3>>)>>
|
||||||
|
.V>
|
||||||
|
<MAPR <>
|
||||||
|
<FUNCTION (VV "AUX" (ITM <1 .VV>))
|
||||||
|
#DECL ((VV) VECTOR (ITM) ANY)
|
||||||
|
<COND (<TYPE? .ITM LIST>
|
||||||
|
<PUT .VV 3 <TOPACT .ITM <2 .VV>>>)>>
|
||||||
|
<SET V1 <TOP .V1>>>
|
||||||
|
<SET V1 <MAPF ,VECTOR
|
||||||
|
<FUNCTION (X)
|
||||||
|
<COND (<TYPE? .X LOSE> <MAPSTOP>)
|
||||||
|
(.X)>>
|
||||||
|
.V1>>
|
||||||
|
<SORT <> .V1 3 2>
|
||||||
|
<MAPR <>
|
||||||
|
<FUNCTION (VV "AUX" (ITM <1 .VV>) NM (1ST? T))
|
||||||
|
#DECL ((VV) VECTOR (ITM) ANY (NM) PSTRING
|
||||||
|
(1ST?) <OR FALSE ATOM>)
|
||||||
|
<COND (<TYPE? <SET ITM <1 .VV>> LIST>
|
||||||
|
<CRLF>
|
||||||
|
<PRINC <STRINGP <SET NM <CHTYPE <3 .VV> PSTRING>>>>
|
||||||
|
<PRINC " (">
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) PSTRING)
|
||||||
|
<COND (<N==? .X .NM>
|
||||||
|
<OR .1ST? <PRINC " ">>
|
||||||
|
<SET 1ST? <>>
|
||||||
|
<PRINC <STRINGP .X>>)>>
|
||||||
|
.ITM>
|
||||||
|
<PRINC !\)>
|
||||||
|
<GET-ACTION <2 .VV>>)
|
||||||
|
(<TYPE? .ITM LOSE> <MAPLEAVE T>)>>
|
||||||
|
.V1>
|
||||||
|
<LENGTH .V1>>
|
||||||
|
|
||||||
|
<DEFINE TOPACT (LST ACT "AUX" (ASTR <3 .ACT>))
|
||||||
|
#DECL ((LST) <LIST [REST PSTRING]> (ACT) ACTION (ASTR) STRING)
|
||||||
|
<COND (<EMPTY? .ASTR>
|
||||||
|
<SET ASTR <STRING <STRINGP <1 .LST>>>>)>
|
||||||
|
<COND (<MAPF <>
|
||||||
|
<FUNCTION (PSTR)
|
||||||
|
#DECL ((PSTR) PSTRING)
|
||||||
|
<COND (<COMPS <STRINGP .PSTR> .ASTR>
|
||||||
|
<MAPLEAVE <CHTYPE .PSTR FIX>>)>>
|
||||||
|
.LST>)
|
||||||
|
(<CHTYPE <NTH .LST <LENGTH .LST>> FIX>)>>
|
||||||
|
|
||||||
|
<DEFINE COMPS (STR1 STR2)
|
||||||
|
#DECL ((STR1 STR2) STRING)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (CHR1 CHR2)
|
||||||
|
#DECL ((CHR1 CHR2) CHARACTER)
|
||||||
|
<COND (<AND <G=? <ASCII .CHR2> <ASCII !\a>>
|
||||||
|
<L=? <ASCII .CHR2> <ASCII !\z>>>
|
||||||
|
<SET CHR2 <CHTYPE <- <ASCII .CHR2> 32> CHARACTER>>)>
|
||||||
|
<COND (<==? .CHR1 .CHR2>)
|
||||||
|
(<MAPLEAVE <>>)>>
|
||||||
|
.STR1
|
||||||
|
.STR2>>
|
||||||
|
|
||||||
|
"GET-ACTION -- print info for a single verb"
|
||||||
|
|
||||||
|
<DEFINE GET-ACTION (A "AUX" (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((A) ACTION (OUTCHAN) CHANNEL)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (S)
|
||||||
|
#DECL ((S) SYNTAX)
|
||||||
|
<CRLF>
|
||||||
|
<COND (<STRNN .S ,SDRIVER> <COLUMN 4> <PRINC "* ">)
|
||||||
|
(ELSE <COLUMN 6>)>
|
||||||
|
<PRINC <VSTR .A>>
|
||||||
|
<PARG <SYN1 .S>>
|
||||||
|
<PARG <SYN2 .S>>>
|
||||||
|
<VDECL .A>>
|
||||||
|
<CRLF>>
|
||||||
|
|
||||||
|
"PARG -- print info for one argument of a verb"
|
||||||
|
|
||||||
|
<DEFINE PARG (VARG "AUX" (B <VBIT .VARG>) (W <VWORD .VARG>) (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((VARG) VARG (B W) FIX (OUTCHAN) CHANNEL)
|
||||||
|
<COND (<AND <0? .B> <0? .W>>)
|
||||||
|
(ELSE
|
||||||
|
<COND (<VPREP .VARG>
|
||||||
|
<PRINC !\ >
|
||||||
|
<PLC <STRINGP <VPREP .VARG>>>)>
|
||||||
|
<PRINC " <">
|
||||||
|
<PVBIT .B>
|
||||||
|
<AND <N==? .B <VFWIM .VARG>> <PRINC !\/> <PVBIT <VFWIM .VARG>>>
|
||||||
|
<PVWORD .W>
|
||||||
|
<PRINC !\>>)>>
|
||||||
|
|
||||||
|
"PVBIT -- print info for object spec for a verb argument"
|
||||||
|
|
||||||
|
<DEFINE PVBIT (B "AUX" (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((B) FIX (OUTCHAN) CHANNEL)
|
||||||
|
<COND (<==? .B -1> <PRINC "any">)
|
||||||
|
(<0? .B> <PRINC "?none?">)
|
||||||
|
(ELSE
|
||||||
|
<PBITS .B ,ODESCS>)>>
|
||||||
|
|
||||||
|
"PVWORD -- print verb info for a verb argument"
|
||||||
|
|
||||||
|
<DEFINE PVWORD (W "AUX" (OUTCHAN .OUTCHAN) TC (COM <>))
|
||||||
|
#DECL ((W) FIX (OUTCHAN) CHANNEL (TC) FIX (COM) <OR FALSE ATOM>)
|
||||||
|
<COND (<==? .W 3>)
|
||||||
|
(<0? .W> <PRINC ":none">)
|
||||||
|
(ELSE
|
||||||
|
<PRINC !\:>
|
||||||
|
<SET TC </ <CHTYPE <ANDB .W <+ ,VTBIT ,VCBIT>> FIX> 4>>
|
||||||
|
<SET COM T>
|
||||||
|
<COND (<0? .TC> <SET COM <>>)
|
||||||
|
(<1? .TC> <PRINC "try">)
|
||||||
|
(<==? .TC 2> <PRINC "have">)
|
||||||
|
(<==? .TC 3> <PRINC "take">)>
|
||||||
|
<PBITS .W ,VBDESCS .COM>)>>
|
||||||
|
|
||||||
|
<SETG VBDESCS '["adv" "room" "" "" ""]>
|
||||||
|
|
||||||
|
<GDECL (VBDESCS) <VECTOR [REST STRING]>>
|
||||||
|
|
||||||
|
"PBITS -- print bits that are on in a flagword"
|
||||||
|
|
||||||
|
<DEFINE PBITS (B BNAMES "OPTIONAL" (COM? <>) "AUX" (N 1) (C 1) (OUTCHAN .OUTCHAN) S)
|
||||||
|
#DECL ((B C N) FIX (BNAMES) <VECTOR [REST STRING]> (COM?) <OR ATOM FALSE>
|
||||||
|
(OUTCHAN) CHANNEL (S) STRING)
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<NOT <0? <CHTYPE <ANDB .B .N> FIX>>>
|
||||||
|
<COND (<NOT <EMPTY? <SET S <NTH .BNAMES .C>>>>
|
||||||
|
<AND .COM? <PRINC ",">>
|
||||||
|
<SET COM? T>
|
||||||
|
<PRINC .S>)>)>
|
||||||
|
<COND (<==? .N *200000000000*> <RETURN>)
|
||||||
|
(ELSE <SET N <* .N 2>> <SET C <+ .C 1>>)>>>
|
||||||
|
|
||||||
|
"PLC -- print a string in lower case"
|
||||||
|
|
||||||
|
<DEFINE PLC (STR "AUX" (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((STR) STRING (OUTCHAN) CHANNEL)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (C "AUX" (A <ASCII .C>))
|
||||||
|
#DECL ((C) CHARACTER (A) FIX)
|
||||||
|
<COND (<AND <G=? .A <ASCII !\A>>
|
||||||
|
<L=? .A <ASCII !\Z>>>
|
||||||
|
<SET A <+ .A 32>>)>
|
||||||
|
<PRINC <ASCII .A>>>
|
||||||
|
.STR>
|
||||||
|
.STR>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
"GET-VERBS -- print various verb garbage -- probably doesn't work?"
|
||||||
|
|
||||||
|
<DEFINE GET-VERBS ("OPTIONAL" (TOPL <>) "AUX" (WORDS ,WORDS-POBL) V (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((V) <UVECTOR [REST PSTRING]> (TOPL) <OR ATOM FALSE> (OUTCHAN) CHANNEL)
|
||||||
|
<SET V <ORDER .WORDS>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X "AUX" (A <PLOOKUP .X .WORDS>))
|
||||||
|
#DECL ((X) PSTRING (A) ANY)
|
||||||
|
<COND (<AND <TYPE? .A VERB>
|
||||||
|
<OR <NOT .TOPL> <==? .X <1 .A>>>>
|
||||||
|
<PRINC <STRINGP .X>>
|
||||||
|
<COLUMN 10>
|
||||||
|
<COND (<==? <1 .A> .X> <PRINC "Top Level">)
|
||||||
|
(<PRINC "= "> <PRINC <STRINGP <1 .A>>>)>
|
||||||
|
<CRLF>)>>
|
||||||
|
.V>
|
||||||
|
<LENGTH .V>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
"GET-WORDS -- print various garbage about WORDS"
|
||||||
|
|
||||||
|
<DEFINE GET-WORDS ("AUX" (WORDS ,WORDS-POBL) V (LSTNAME <>) (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((V) UVECTOR (LSTNAME) <OR PSTRING FALSE> (OUTCHAN) CHANNEL)
|
||||||
|
<SET V <ORDER .WORDS>>
|
||||||
|
<MAPR <>
|
||||||
|
<FUNCTION (Y "AUX" Z (X <1 .Y>))
|
||||||
|
#DECL ((X) PSTRING (Y) UVECTOR)
|
||||||
|
<COND
|
||||||
|
(<N==? .X .LSTNAME>
|
||||||
|
<PRINC <STRINGP .X>>
|
||||||
|
<SET LSTNAME .X>
|
||||||
|
<COLUMN 10>
|
||||||
|
<COND (<SET Z <PLOOKUP .X .WORDS>>
|
||||||
|
<COND (<TYPE? .Z VERB>
|
||||||
|
<PRINC "ACTION">
|
||||||
|
<COLUMN 24>
|
||||||
|
<COND (<==? <1 .Z> .X> <PRINC "Top Level">)
|
||||||
|
(<PRINC "= "> <PRINC <STRINGP <1 .Z>>>)>)
|
||||||
|
(<TYPE? .Z BUZZ> <PRINC "BUZZ WORD">)
|
||||||
|
(<PRIN1 <TYPE .Z>>)>)>
|
||||||
|
<CRLF>)>>
|
||||||
|
.V>
|
||||||
|
</ <LENGTH .V> 2>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
"ORDER -- sorter for uvectors of atoms"
|
||||||
|
|
||||||
|
<DEFINE ORDER (O "AUX" (L ()) O1 S S1 S2 V1 V2 SP1 SP2)
|
||||||
|
#DECL ((O) <OR <UVECTOR [REST PSTRING]> POBLIST> (S S1 S2) UVECTOR
|
||||||
|
(SP1 SP2) STRING (V1 V2) PSTRING (O1) <<PRIMTYPE UVECTOR>
|
||||||
|
[REST LIST]>
|
||||||
|
(L) <LIST [REST PSTRING ANY]>)
|
||||||
|
<COND (<TYPE? .O POBLIST>
|
||||||
|
<SET O1 .O>
|
||||||
|
<SET S
|
||||||
|
<MAPF ,UVECTOR
|
||||||
|
<FUNCTION ("AUX" Y)
|
||||||
|
<COND (<EMPTY? .L>
|
||||||
|
<COND (<EMPTY? .O1> <MAPSTOP>)
|
||||||
|
(T
|
||||||
|
<SET L <1 .O1>>
|
||||||
|
<SET O1 <REST .O1>>)>
|
||||||
|
<MAPRET>)
|
||||||
|
(<SET Y <1 .L>>
|
||||||
|
<SET L <REST .L 2>>
|
||||||
|
<MAPRET .Y>)>>>>)
|
||||||
|
(<SET S .O>)>
|
||||||
|
<SET S1 <SET S2 .S>>
|
||||||
|
<COND (<LENGTH? .S 1> .S)
|
||||||
|
(ELSE
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<EMPTY? .S2>
|
||||||
|
<COND (<EMPTY? <SET S1 <REST .S1>>> <RETURN .S>)
|
||||||
|
(<SET S2 <REST .S1>> <AGAIN>)>)>
|
||||||
|
<SET V1 <1 .S1>>
|
||||||
|
<SET V2 <1 .S2>>
|
||||||
|
<COND (<G? <CHTYPE .V1 FIX> <CHTYPE .V2 FIX>>
|
||||||
|
<PUT .S1 1 .V2>
|
||||||
|
<PUT .S2 1 .V1>)>
|
||||||
|
<SET S2 <REST .S2>>>)>>
|
||||||
|
|
||||||
|
"OORDER -- order a list by an offset in each element"
|
||||||
|
|
||||||
|
<DEFINE OORDER (S OFFS "AUX" S1 S2 V1 V2 SP1 SP2)
|
||||||
|
#DECL ((S S1 S2) <UVECTOR [REST <PRIMTYPE VECTOR>]> (V1 V2) <PRIMTYPE VECTOR>
|
||||||
|
(OFFS) FIX (SP1 SP2) STRING)
|
||||||
|
<SET S1 <SET S2 .S>>
|
||||||
|
<COND (<LENGTH? .S 1> .S)
|
||||||
|
(ELSE
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<EMPTY? .S2>
|
||||||
|
<COND (<EMPTY? <SET S1 <REST .S1>>> <RETURN .S>)
|
||||||
|
(<SET S2 <REST .S1>> <AGAIN>)>)>
|
||||||
|
<SET V1 <1 .S1>>
|
||||||
|
<SET V2 <1 .S2>>
|
||||||
|
<SET SP1 <NTH .V1 .OFFS>>
|
||||||
|
<SET SP2 <NTH .V2 .OFFS>>
|
||||||
|
<COND (<ALPH .SP1 .SP2>
|
||||||
|
<PUT .S1 1 .V2>
|
||||||
|
<PUT .S2 1 .V1>)>
|
||||||
|
<SET S2 <REST .S2>>>)>>
|
||||||
|
|
||||||
|
<DEFINE ALPH (S1 S2 "AUX" (L1 <LENGTH .S1>) (L2 <LENGTH .S2>))
|
||||||
|
#DECL ((S1 S2) STRING (L1 L2) FIX)
|
||||||
|
<COND (<AND <0? .L1> <NOT <0? .L2>>> <>)
|
||||||
|
(<AND <0? .L2> <NOT <0? .L1>>> T)
|
||||||
|
(ELSE
|
||||||
|
<MAPR <>
|
||||||
|
<FUNCTION (S1 S2 "AUX" (C1 <ASCII <1 .S1>>) (C2 <ASCII <1 .S2>>)
|
||||||
|
(L1 <LENGTH .S1>) (L2 <LENGTH .S2>))
|
||||||
|
#DECL ((S1 S2) STRING (C1 C2 L1 L2) FIX)
|
||||||
|
<COND (<AND <G=? .C1 <ASCII !\a>> <L=? .C1 <ASCII !\z>>>
|
||||||
|
<SET C1 <- .C1 32>>)>
|
||||||
|
<COND (<AND <G=? .C2 <ASCII !\a>> <L=? .C2 <ASCII !\z>>>
|
||||||
|
<SET C2 <- .C2 32>>)>
|
||||||
|
<COND (<==? .C1 .C2>
|
||||||
|
<COND (<AND <0? .L1> <NOT <0? .L2>>> <MAPLEAVE <>>)
|
||||||
|
(<AND <0? .L2> <NOT <0? .L1>>> <MAPLEAVE T>)>)
|
||||||
|
(<G? .C1 .C2>
|
||||||
|
<MAPLEAVE T>)
|
||||||
|
(<L? .C1 .C2>
|
||||||
|
<MAPLEAVE <>>)>>
|
||||||
|
.S1 .S2>)>>
|
|
@ -0,0 +1,650 @@
|
||||||
|
|
||||||
|
"(c) Copyright 1978, Massachusetts Institute of Technology. All rights reserved."
|
||||||
|
|
||||||
|
<AND <L? ,MUDDLE 100>
|
||||||
|
<NOT <OR <LOOKUP "COMPILE" <ROOT>>
|
||||||
|
<LOOKUP "GROUP-GLUE" <GET INITIAL OBLIST>>>>
|
||||||
|
<USE "LSRTNS">>
|
||||||
|
|
||||||
|
;"newtypes for oblist hack"
|
||||||
|
<NEWTYPE PSTRING WORD>
|
||||||
|
<NEWTYPE POBLIST UVECTOR '<<PRIMTYPE UVECTOR> [REST LIST]>>
|
||||||
|
|
||||||
|
;"applicables"
|
||||||
|
|
||||||
|
<NEWTYPE NOFFSET WORD>
|
||||||
|
|
||||||
|
<PUT RAPPLIC DECL '<OR ATOM FALSE NOFFSET>>
|
||||||
|
|
||||||
|
;"newtypes for parser"
|
||||||
|
|
||||||
|
<NEWTYPE BUZZ WORD>
|
||||||
|
|
||||||
|
<NEWTYPE DIRECTION WORD>
|
||||||
|
|
||||||
|
<NEWTYPE ADJECTIVE WORD>
|
||||||
|
|
||||||
|
<NEWTYPE PREP WORD>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
;"generalized oflags tester"
|
||||||
|
|
||||||
|
<DEFMAC TRNN ('OBJ 'BIT)
|
||||||
|
<FORM N==? <FORM CHTYPE <FORM ANDB .BIT <FORM OFLAGS .OBJ>> FIX> 0>>
|
||||||
|
<DEFMAC RTRNN ('RM 'BIT)
|
||||||
|
<FORM N==? <FORM CHTYPE <FORM ANDB .BIT <FORM RBITS .RM>> FIX> 0>>
|
||||||
|
<DEFMAC GTRNN ('RM 'BIT)
|
||||||
|
<FORM N==? <FORM CHTYPE <FORM ANDB .BIT <FORM RGLOBAL .RM>> FIX> 0>>
|
||||||
|
<DEFMAC RTRZ ('RM BIT)
|
||||||
|
<FORM PUT .RM ,RBITS <FORM CHTYPE <FORM ANDB <FORM RBITS .RM> <XORB .BIT -1>> FIX>>>
|
||||||
|
<DEFMAC TRC ('OBJ 'BIT)
|
||||||
|
<FORM PUT .OBJ ,OFLAGS <FORM CHTYPE <FORM XORB <FORM OFLAGS .OBJ> .BIT> FIX>>>
|
||||||
|
<DEFMAC TRZ ('OBJ BIT)
|
||||||
|
<FORM PUT .OBJ ,OFLAGS <FORM CHTYPE <FORM ANDB <FORM OFLAGS .OBJ> <XORB .BIT -1>> FIX>>>
|
||||||
|
<DEFMAC TRO ('OBJ 'BIT)
|
||||||
|
<FORM PUT .OBJ ,OFLAGS <FORM CHTYPE <FORM ORB <FORM OFLAGS .OBJ> .BIT> FIX>>>
|
||||||
|
<DEFMAC RTRO ('RM 'BIT)
|
||||||
|
<FORM PUT .RM ,RBITS <FORM CHTYPE <FORM ORB <FORM RBITS .RM> .BIT> FIX>>>
|
||||||
|
<DEFMAC RTRC ('RM 'BIT)
|
||||||
|
<FORM PUT .RM ,RBITS <FORM CHTYPE <FORM XORB <FORM RBITS .RM> .BIT> FIX>>>
|
||||||
|
<DEFMAC ATRNN ('ADV 'BIT)
|
||||||
|
<FORM N==? <FORM CHTYPE <FORM ANDB .BIT <FORM AFLAGS .ADV>> FIX> 0>>
|
||||||
|
<DEFMAC ATRZ ('ADV BIT)
|
||||||
|
<FORM PUT .ADV ,AFLAGS <FORM CHTYPE <FORM ANDB <FORM AFLAGS .ADV> <XORB .BIT -1>>
|
||||||
|
FIX>>>
|
||||||
|
<DEFMAC ATRO ('ADV 'BIT)
|
||||||
|
<FORM PUT .ADV ,AFLAGS <FORM CHTYPE <FORM ORB <FORM AFLAGS .ADV> .BIT> FIX>>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
;"room definition"
|
||||||
|
|
||||||
|
<NEWSTRUC ROOM
|
||||||
|
VECTOR
|
||||||
|
RID
|
||||||
|
PSTRING ;"room id"
|
||||||
|
RDESC1
|
||||||
|
STRING ;"long description"
|
||||||
|
RDESC2
|
||||||
|
STRING ;"short description"
|
||||||
|
REXITS
|
||||||
|
EXIT ;"list of exits"
|
||||||
|
ROBJS
|
||||||
|
<LIST [REST OBJECT]> ;"objects in room"
|
||||||
|
RACTION
|
||||||
|
RAPPLIC ;"room-action"
|
||||||
|
RBITS
|
||||||
|
FIX ;"random flags"
|
||||||
|
RPROPS
|
||||||
|
<LIST [REST ATOM ANY]>>
|
||||||
|
|
||||||
|
;"Slots for room"
|
||||||
|
|
||||||
|
<MAKE-SLOT RVAL FIX 0>
|
||||||
|
|
||||||
|
;"value for entering"
|
||||||
|
|
||||||
|
<MAKE-SLOT RGLOBAL FIX ,STAR-BITS>
|
||||||
|
|
||||||
|
;"globals for room"
|
||||||
|
|
||||||
|
<FLAGWORD RSEENBIT ;"visited?"
|
||||||
|
RLIGHTBIT ;"endogenous light source?"
|
||||||
|
RLANDBIT ;"on land"
|
||||||
|
RWATERBIT ;"water room"
|
||||||
|
RAIRBIT ;"mid-air room"
|
||||||
|
RSACREDBIT ;"thief not allowed"
|
||||||
|
RFILLBIT ;"can fill bottle here"
|
||||||
|
RMUNGBIT ;"room has been munged"
|
||||||
|
RBUCKBIT ;"this room is a bucket"
|
||||||
|
RHOUSEBIT ;"This room is part of the house"
|
||||||
|
RENDGAME ;"This room is in the end game"
|
||||||
|
RNWALLBIT ;"This room doesn't have walls">
|
||||||
|
|
||||||
|
;"exit"
|
||||||
|
|
||||||
|
<NEWTYPE EXIT
|
||||||
|
VECTOR
|
||||||
|
'<<PRIMTYPE VECTOR> [REST DIRECTION <OR ROOM CEXIT DOOR NEXIT>]>>
|
||||||
|
|
||||||
|
;"conditional exit"
|
||||||
|
|
||||||
|
<NEWSTRUC CEXIT
|
||||||
|
VECTOR
|
||||||
|
CXFLAG
|
||||||
|
ATOM ;"condition flag"
|
||||||
|
CXROOM
|
||||||
|
ROOM ;"room it protects"
|
||||||
|
CXSTR
|
||||||
|
<OR FALSE STRING> ;"description"
|
||||||
|
CXACTION
|
||||||
|
RAPPLIC ;"exit function">
|
||||||
|
|
||||||
|
<NEWSTRUC DOOR
|
||||||
|
VECTOR
|
||||||
|
DOBJ
|
||||||
|
OBJECT ;"the door"
|
||||||
|
DROOM1
|
||||||
|
ROOM ;"one of the rooms"
|
||||||
|
DROOM2
|
||||||
|
ROOM ;"the other one"
|
||||||
|
DSTR
|
||||||
|
<OR FALSE STRING> ;"what to print if closed"
|
||||||
|
DACTION
|
||||||
|
RAPPLIC ;"what to call to decide">
|
||||||
|
|
||||||
|
<NEWTYPE NEXIT STRING>
|
||||||
|
|
||||||
|
;"unusable exit description"
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
;"PARSER related types"
|
||||||
|
|
||||||
|
<NEWSTRUC ACTION VECTOR VNAME PSTRING ;"atom associated with this action"
|
||||||
|
VDECL VSPEC ;"syntaxes for this verb (any number)"
|
||||||
|
VSTR STRING ;"string to print when talking about this verb">
|
||||||
|
|
||||||
|
;"VSPEC -- uvector of syntaxes for a verb"
|
||||||
|
|
||||||
|
<NEWTYPE VSPEC UVECTOR '<<PRIMTYPE UVECTOR> [REST SYNTAX]>>
|
||||||
|
|
||||||
|
;"SYNTAX -- a legal syntax for a sentence involving this verb"
|
||||||
|
|
||||||
|
<NEWSTRUC SYNTAX VECTOR SYN1 VARG ;"direct object, more or less"
|
||||||
|
SYN2 VARG ;"indirect object, more or less"
|
||||||
|
SFCN VERB ;"function to handle this action"
|
||||||
|
SFLAGS FIX ;"flag bits for this verb">
|
||||||
|
|
||||||
|
;"SFLAGS of a SYNTAX"
|
||||||
|
|
||||||
|
<FLAGWORD SFLIP ;"T -- flip args (for verbs like PICK)"
|
||||||
|
SDRIVER ;"T -- default syntax for gwimming and orphanery">
|
||||||
|
|
||||||
|
;"STRNN -- test a bit in the SFLAGS slot of a SYNTAX"
|
||||||
|
|
||||||
|
<DEFMAC STRNN ('S 'BIT)
|
||||||
|
<FORM N==? <FORM CHTYPE <FORM ANDB .BIT <FORM SFLAGS .S>> FIX> 0>>
|
||||||
|
|
||||||
|
; "VARG -- types and locations of objects acceptable as args to verbs,
|
||||||
|
these go in the SYN1 and SYN2 slots of a SYNTAX."
|
||||||
|
|
||||||
|
<NEWSTRUC VARG VECTOR VBIT FIX
|
||||||
|
;"acceptable object characteristics (default any)"
|
||||||
|
VFWIM FIX ;"spec for fwimming"
|
||||||
|
VPREP <OR PREP FALSE> ;"preposition that must precede(?) object"
|
||||||
|
VWORD FIX ;"locations object may be looked for in">
|
||||||
|
|
||||||
|
;"flagbit definitions for VWORD of a VARG"
|
||||||
|
|
||||||
|
<FLAGWORD VABIT ;"AOBJS -- look in AOBJS"
|
||||||
|
VRBIT ;"ROBJS -- look in ROBJS"
|
||||||
|
VTBIT ;"1 => try to take the object"
|
||||||
|
VCBIT ;"1 => care if can't take object"
|
||||||
|
VFBIT ;"1 => care if can't reach object">
|
||||||
|
|
||||||
|
;"VTRNN -- test a bit in the VWORD slot of a VARG"
|
||||||
|
|
||||||
|
<DEFMAC VTRNN ('V 'BIT)
|
||||||
|
<FORM N==? <FORM CHTYPE <FORM ANDB .BIT <FORM VWORD .V>> FIX> 0>>
|
||||||
|
|
||||||
|
"VTBIT & VCBIT interact as follows:
|
||||||
|
vtbit
|
||||||
|
vcbit
|
||||||
|
|
||||||
|
1 1 = TAKE -- try to take, care if can't ('TURN WITH x')
|
||||||
|
1 0 = TRY -- try to take, don't care if can't ('READ x')
|
||||||
|
0 1 = MUST -- must already have object ('ATTACK TROLL WITH x')
|
||||||
|
0 0 = NO-TAKE (default) -- don't try, don't care ('TAKE x')
|
||||||
|
"
|
||||||
|
|
||||||
|
;"VERB -- name and function to apply to handle verb"
|
||||||
|
|
||||||
|
<NEWSTRUC VERB VECTOR VNAME PSTRING VFCN RAPPLIC>
|
||||||
|
|
||||||
|
;"ORPHANS -- mysterious vector of orphan data"
|
||||||
|
|
||||||
|
<NEWSTRUC (ORPHANS)
|
||||||
|
VECTOR
|
||||||
|
OFLAG
|
||||||
|
<OR FALSE ATOM>
|
||||||
|
OVERB
|
||||||
|
<OR FALSE VERB>
|
||||||
|
OSLOT1
|
||||||
|
<OR FALSE OBJECT>
|
||||||
|
OPREP
|
||||||
|
<OR FALSE PREP>
|
||||||
|
ONAME
|
||||||
|
<OR FALSE STRING>>
|
||||||
|
|
||||||
|
;"prepositional phrases"
|
||||||
|
|
||||||
|
<NEWSTRUC PHRASE VECTOR PPREP PREP POBJ OBJECT>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
;"BITS FOR 2ND ARG OF CALL TO TELL (DEFAULT IS 1)"
|
||||||
|
|
||||||
|
<MSETG LONG-TELL *400000000000*>
|
||||||
|
|
||||||
|
<MSETG PRE-CRLF 2>
|
||||||
|
|
||||||
|
<MSETG POST-CRLF 1>
|
||||||
|
|
||||||
|
<MSETG NO-CRLF 0>
|
||||||
|
|
||||||
|
<MSETG LONG-TELL1 <+ ,LONG-TELL ,POST-CRLF>>
|
||||||
|
|
||||||
|
<PSETG NULL-DESC "">
|
||||||
|
|
||||||
|
<PSETG NULL-EXIT <CHTYPE [] EXIT>>
|
||||||
|
|
||||||
|
<PSETG NULL-SYN ![!]>
|
||||||
|
|
||||||
|
;"adventurer"
|
||||||
|
|
||||||
|
<NEWSTRUC ADV
|
||||||
|
VECTOR
|
||||||
|
AROOM
|
||||||
|
ROOM ;"where he is"
|
||||||
|
AOBJS
|
||||||
|
<LIST [REST OBJECT]> ;"what he's carrying"
|
||||||
|
ASCORE
|
||||||
|
FIX ;"score"
|
||||||
|
AVEHICLE
|
||||||
|
<OR FALSE OBJECT> ;"what he's riding in"
|
||||||
|
AOBJ
|
||||||
|
OBJECT ;"what he is"
|
||||||
|
AACTION
|
||||||
|
RAPPLIC ;"special action for robot, etc."
|
||||||
|
ASTRENGTH
|
||||||
|
FIX ;"fighting strength"
|
||||||
|
AFLAGS
|
||||||
|
FIX ;"flags THIS MUST BE SAME OFFSET AS OFLAGS!">
|
||||||
|
|
||||||
|
"bits in <AFLAGS adv>:
|
||||||
|
bit-name"
|
||||||
|
|
||||||
|
<FLAGWORD ASTAGGERED ;"staggered?">
|
||||||
|
|
||||||
|
;"object"
|
||||||
|
|
||||||
|
<NEWSTRUC OBJECT
|
||||||
|
VECTOR
|
||||||
|
ONAMES
|
||||||
|
<UVECTOR [REST PSTRING]> ;"synonyms"
|
||||||
|
OADJS
|
||||||
|
<UVECTOR [REST ADJECTIVE]> ;"adjectives for this"
|
||||||
|
ODESC2
|
||||||
|
STRING ;"short description"
|
||||||
|
OFLAGS
|
||||||
|
FIX ;"flags THIS MUST BE SAME OFFSET AS AFLAGS!"
|
||||||
|
OACTION
|
||||||
|
RAPPLIC ;"object-action"
|
||||||
|
OCONTENTS
|
||||||
|
<LIST [REST OBJECT]> ;"list of contents"
|
||||||
|
OCAN
|
||||||
|
<OR FALSE OBJECT> ;"what contains this"
|
||||||
|
OROOM
|
||||||
|
<OR FALSE ROOM> ;"what room its in"
|
||||||
|
OPROPS
|
||||||
|
<LIST [REST ATOM ANY]> ;"property list">
|
||||||
|
|
||||||
|
;"For funny slots in objects"
|
||||||
|
|
||||||
|
<MAKE-SLOT OTVAL FIX 0>
|
||||||
|
|
||||||
|
;"value when placed in trophy case"
|
||||||
|
|
||||||
|
<MAKE-SLOT OFVAL FIX 0>
|
||||||
|
|
||||||
|
;"value when found"
|
||||||
|
|
||||||
|
<MAKE-SLOT OSIZE FIX 5>
|
||||||
|
|
||||||
|
;"size"
|
||||||
|
|
||||||
|
<MAKE-SLOT OCAPAC FIX 0>
|
||||||
|
|
||||||
|
;"capacity"
|
||||||
|
|
||||||
|
<MAKE-SLOT ODESCO <OR STRING FALSE> <>>
|
||||||
|
|
||||||
|
;"first description"
|
||||||
|
|
||||||
|
<MAKE-SLOT ODESC1 STRING "">
|
||||||
|
|
||||||
|
;"long description"
|
||||||
|
|
||||||
|
<MAKE-SLOT OREAD <OR STRING FALSE> <>>
|
||||||
|
|
||||||
|
;"reading material"
|
||||||
|
|
||||||
|
<MAKE-SLOT OGLOBAL FIX 0>
|
||||||
|
|
||||||
|
;"global bit for this object"
|
||||||
|
|
||||||
|
<MAKE-SLOT OVTYPE FIX 0>
|
||||||
|
|
||||||
|
;"vehicle's type spec"
|
||||||
|
|
||||||
|
<MAKE-SLOT OACTOR ADV <>>
|
||||||
|
|
||||||
|
;"adventurer for actors"
|
||||||
|
|
||||||
|
<MAKE-SLOT OLINT <OR FALSE <VECTOR FIX CEVENT>> <>>
|
||||||
|
|
||||||
|
;"light interrupts"
|
||||||
|
|
||||||
|
<MAKE-SLOT OMATCH FIX 0>
|
||||||
|
|
||||||
|
;"# of matches"
|
||||||
|
|
||||||
|
<MAKE-SLOT OFMSGS <OR UVECTOR FALSE> <>>
|
||||||
|
|
||||||
|
;"melee messages"
|
||||||
|
|
||||||
|
<MAKE-SLOT OBVERB <OR FALSE VERB> <>>
|
||||||
|
|
||||||
|
;"bunch verb"
|
||||||
|
|
||||||
|
<MAKE-SLOT OSTRENGTH FIX 0>
|
||||||
|
|
||||||
|
;"strength for melee"
|
||||||
|
|
||||||
|
<DEFINE OID (OBJ) #DECL ((OBJ) OBJECT (VALUE) PSTRING) <1 <ONAMES .OBJ>>>
|
||||||
|
|
||||||
|
;"bits in <OFLAGS object>:
|
||||||
|
bit-name bit-tester"
|
||||||
|
|
||||||
|
<FLAGWORD OVISON ;"visible?"
|
||||||
|
READBIT ;"readable?"
|
||||||
|
TAKEBIT ;"takeable?"
|
||||||
|
DOORBIT ;"object is door"
|
||||||
|
TRANSBIT ;"object is transparent"
|
||||||
|
FOODBIT ;"object is food"
|
||||||
|
NDESCBIT ;"object not describable"
|
||||||
|
DRINKBIT ;"object is drinkable"
|
||||||
|
CONTBIT ;"object can be opened/closed"
|
||||||
|
LIGHTBIT ;"object can provide light"
|
||||||
|
VICBIT ;"object is victim"
|
||||||
|
BURNBIT ;"object is flammable"
|
||||||
|
FLAMEBIT ;"object is on fire"
|
||||||
|
TOOLBIT ;"object is a tool"
|
||||||
|
TURNBIT ;"object can be turned"
|
||||||
|
VEHBIT ;"object is a vehicle"
|
||||||
|
FINDMEBIT ;"can be reached from a vehicle"
|
||||||
|
SLEEPBIT ;"object is asleep"
|
||||||
|
SEARCHBIT ;"allow multi-level access into this"
|
||||||
|
SACREDBIT ;"thief can't take this"
|
||||||
|
TIEBIT ;"object can be tied"
|
||||||
|
CLIMBBIT ;"can be climbed (former ECHO-ROOM-BIT)"
|
||||||
|
ACTORBIT ;"object is an actor"
|
||||||
|
WEAPONBIT ;"object is a weapon"
|
||||||
|
FIGHTBIT ;"object is in melee"
|
||||||
|
VILLAIN ;"object is a bad guy"
|
||||||
|
STAGGERED ;"object can't fight this turn"
|
||||||
|
TRYTAKEBIT ;"object wants to handle not being taken"
|
||||||
|
NO-CHECK-BIT ;"no checks (put & drop): for EVERY and VALUA"
|
||||||
|
OPENBIT ;"object is open"
|
||||||
|
TOUCHBIT ;"has this been touched?"
|
||||||
|
ONBIT ;"light on?"
|
||||||
|
DIGBIT ;"I can dig this"
|
||||||
|
BUNCHBIT ;"*BUN*, all, etc.">
|
||||||
|
|
||||||
|
"extra stuff for flagword for objects"
|
||||||
|
|
||||||
|
"can i be opened?"
|
||||||
|
|
||||||
|
<DEFMAC OPENABLE? ('OBJ) <FORM TRNN .OBJ <FORM + ,DOORBIT ,CONTBIT>>>
|
||||||
|
|
||||||
|
"complement of the bit state"
|
||||||
|
|
||||||
|
<DEFMAC DESCRIBABLE? ('OBJ) <FORM NOT <FORM TRNN .OBJ ,NDESCBIT>>>
|
||||||
|
|
||||||
|
"if object is a light or aflame, then flaming"
|
||||||
|
|
||||||
|
<DEFMAC FLAMING? ('OBJ "AUX" (CONST <+ ,FLAMEBIT ,LIGHTBIT ,ONBIT>))
|
||||||
|
<FORM ==? <FORM CHTYPE <FORM ANDB <FORM OFLAGS .OBJ> .CONST> FIX> .CONST>>
|
||||||
|
|
||||||
|
"if object visible and open or transparent, can see inside it"
|
||||||
|
|
||||||
|
<DEFMAC SEE-INSIDE? ('OBJ)
|
||||||
|
<FORM AND <FORM TRNN .OBJ ,OVISON>
|
||||||
|
<FORM OR <FORM TRNN .OBJ ,TRANSBIT> <FORM TRNN .OBJ ,OPENBIT>>>>
|
||||||
|
|
||||||
|
<DEFMAC GLOBAL? ('OBJ)
|
||||||
|
<FORM NOT <FORM 0? <FORM CHTYPE <FORM ANDB ',STAR-BITS <FORM OGLOBAL .OBJ>> FIX>>>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
;"demons"
|
||||||
|
|
||||||
|
<NEWSTRUC HACK
|
||||||
|
VECTOR
|
||||||
|
HACTION
|
||||||
|
RAPPLIC
|
||||||
|
HOBJS
|
||||||
|
<LIST [REST ANY]>
|
||||||
|
"REST"
|
||||||
|
HROOMS
|
||||||
|
<LIST [REST ROOM]>
|
||||||
|
HROOM
|
||||||
|
ROOM
|
||||||
|
HOBJ
|
||||||
|
OBJECT
|
||||||
|
HFLAG
|
||||||
|
ANY>
|
||||||
|
|
||||||
|
;"Clock interrupts"
|
||||||
|
|
||||||
|
<NEWSTRUC CEVENT
|
||||||
|
VECTOR
|
||||||
|
CTICK
|
||||||
|
FIX
|
||||||
|
CACTION
|
||||||
|
<OR ATOM NOFFSET>
|
||||||
|
CFLAG
|
||||||
|
<OR ATOM FALSE>
|
||||||
|
CID
|
||||||
|
ATOM
|
||||||
|
CDEATH
|
||||||
|
<OR ATOM FALSE>>
|
||||||
|
|
||||||
|
;"Questions for end game"
|
||||||
|
|
||||||
|
<NEWSTRUC QUESTION VECTOR QSTR STRING ;"question to ask"
|
||||||
|
QANS VECTOR ;"answers (as returned by LEX)">
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
<SETG LOAD-MAX 100>
|
||||||
|
|
||||||
|
<SETG SCORE-MAX 0>
|
||||||
|
|
||||||
|
<SETG EG-SCORE-MAX 0>
|
||||||
|
|
||||||
|
<SETG EG-SCORE 0>
|
||||||
|
|
||||||
|
"SET WHEN IN LONG TELL"
|
||||||
|
|
||||||
|
<SETG IN-TELL 0>
|
||||||
|
|
||||||
|
"SET BY CTRL-S HANDLER TO CAUSE TELL TO FLUSH"
|
||||||
|
|
||||||
|
<SETG NO-TELL 0>
|
||||||
|
|
||||||
|
<GDECL (RAW-SCORE LOAD-MAX SCORE-MAX EG-SCORE-MAX EG-SCORE IN-TELL NO-TELL)
|
||||||
|
FIX
|
||||||
|
(RANDOM-LIST ROOMS SACRED-PLACES)
|
||||||
|
<LIST [REST ROOM]>
|
||||||
|
(STARS OBJECTS WEAPONS NASTIES)
|
||||||
|
<LIST [REST OBJECT]>
|
||||||
|
(PRSVEC)
|
||||||
|
<VECTOR VERB <OR FALSE OBJECT DIRECTION> <OR FALSE OBJECT>>
|
||||||
|
(WINNER PLAYER)
|
||||||
|
ADV
|
||||||
|
(HERE)
|
||||||
|
ROOM
|
||||||
|
(INCHAN OUTCHAN)
|
||||||
|
CHANNEL
|
||||||
|
(DEMONS)
|
||||||
|
LIST
|
||||||
|
(MOVES DEATHS)
|
||||||
|
FIX
|
||||||
|
(DUMMY YUKS)
|
||||||
|
<VECTOR [REST STRING]>
|
||||||
|
(SWORD-DEMON)
|
||||||
|
HACK
|
||||||
|
(CPOBJS) UVECTOR
|
||||||
|
(CPHERE) FIX>
|
||||||
|
|
||||||
|
\
|
||||||
|
; "SUBTITLE POBLIST HACKS"
|
||||||
|
<SETG PPSTRING <ISTRING 5>>
|
||||||
|
|
||||||
|
<DEFINE PLOOKUP (NAME OBL "AUX" BUCK TL)
|
||||||
|
#DECL ((NAME) <OR STRING <PRIMTYPE WORD>> (OBL) POBLIST (BUCK) FIX)
|
||||||
|
<COND (<TYPE? .NAME STRING>
|
||||||
|
<SET NAME <PSTRING .NAME>>)
|
||||||
|
(<NOT <TYPE? .NAME PSTRING>>
|
||||||
|
<SET NAME <CHTYPE .NAME PSTRING>>)>
|
||||||
|
<COND (<SET TL <MEMQ .NAME <NTH .OBL <HASH .NAME .OBL>>>>
|
||||||
|
<2 .TL>)>>
|
||||||
|
|
||||||
|
<DEFINE HASH (NAME OBL)
|
||||||
|
#DECL ((NAME) <PRIMTYPE WORD> (OBL) POBLIST)
|
||||||
|
<+ 1 <MOD <CHTYPE .NAME FIX> <LENGTH .OBL>>>>
|
||||||
|
\
|
||||||
|
|
||||||
|
"UTILITY MACROS"
|
||||||
|
|
||||||
|
"TO CHECK VERBS"
|
||||||
|
|
||||||
|
<DEFMAC VERB? ("ARGS" AL)
|
||||||
|
<COND (<1? <LENGTH .AL>>
|
||||||
|
<FORM ==? <FORM VNAME '<PRSA>> <PSTRING <1 .AL>>>)
|
||||||
|
(ELSE
|
||||||
|
<FORM PROG ((VA <FORM VNAME '<PRSA>>))
|
||||||
|
#DECL ((VA) PSTRING)
|
||||||
|
<FORM OR
|
||||||
|
!<MAPF ,LIST
|
||||||
|
<FUNCTION (A)
|
||||||
|
<FORM ==? <FORM LVAL VA> <PSTRING .A>>>
|
||||||
|
.AL>>>)>>
|
||||||
|
|
||||||
|
<DEFMAC GET-DOOR-ROOM ('RM 'LEAVINGS)
|
||||||
|
<FORM PROG <LIST <LIST EL <FORM DROOM1 .LEAVINGS>>>
|
||||||
|
#DECL ((EL) ROOM)
|
||||||
|
<FORM COND
|
||||||
|
(<FORM ==? .RM <FORM LVAL EL>>
|
||||||
|
<FORM DROOM2 .LEAVINGS>)
|
||||||
|
(<FORM LVAL EL>)>>>
|
||||||
|
|
||||||
|
"APPLY AN OBJECT FUNCTION"
|
||||||
|
|
||||||
|
<DEFMAC APPLY-OBJECT ('OBJ)
|
||||||
|
<FORM PROG ((FOO <FORM OACTION .OBJ>))
|
||||||
|
#DECL ((FOO) RAPPLIC)
|
||||||
|
<FORM COND (<FORM NOT <FORM LVAL FOO>> <>)
|
||||||
|
(<FORM TYPE? <FORM LVAL FOO> ATOM>
|
||||||
|
<FORM APPLY <FORM GVAL <FORM LVAL FOO>>>)
|
||||||
|
(<FORM DISPATCH <FORM LVAL FOO>>)>>>
|
||||||
|
|
||||||
|
<DEFMAC CLOCK-DISABLE ('EV)
|
||||||
|
<FORM PUT .EV ,CFLAG <>>>
|
||||||
|
|
||||||
|
<DEFMAC CLOCK-ENABLE ('EV)
|
||||||
|
<FORM PUT .EV ,CFLAG T>>
|
||||||
|
|
||||||
|
<DEFMAC APPLY-RANDOM ('FROB "OPTIONAL" ('MUMBLE <>))
|
||||||
|
<COND (<TYPE? .FROB ATOM>
|
||||||
|
<COND (.MUMBLE
|
||||||
|
<FORM APPLY <FORM GVAL .FROB> .MUMBLE>)
|
||||||
|
(<FORM APPLY <FORM GVAL .FROB>>)>)
|
||||||
|
(T
|
||||||
|
<FORM COND
|
||||||
|
(<FORM TYPE? .FROB ATOM>
|
||||||
|
<COND (.MUMBLE
|
||||||
|
<FORM APPLY <FORM GVAL .FROB> .MUMBLE>)
|
||||||
|
(<FORM APPLY <FORM GVAL .FROB>>)>)
|
||||||
|
(T <FORM DISPATCH .FROB .MUMBLE>)>)>>
|
||||||
|
|
||||||
|
<DEFINE OGET (O P "AUX" V)
|
||||||
|
#DECL ((O) <OR OBJECT ROOM> (P) ATOM (V) <LIST [REST ATOM ANY]>)
|
||||||
|
<COND (<TYPE? .O OBJECT> <SET V <OPROPS .O>>)
|
||||||
|
(ELSE <SET V <RPROPS .O>>)>
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<EMPTY? .V> <RETURN <>>)
|
||||||
|
(<==? <1 .V> .P> <RETURN <2 .V>>)
|
||||||
|
(ELSE <SET V <REST .V 2>>)>>>
|
||||||
|
|
||||||
|
<DEFINE OPUT (O P X "OPTIONAL" (ADD? <>) "AUX" V)
|
||||||
|
#DECL ((O) <OR OBJECT ROOM> (P) ATOM (V) <LIST [REST ATOM ANY]> (X) ANY
|
||||||
|
(ADD?) <OR ATOM FALSE>)
|
||||||
|
<COND (<TYPE? .O OBJECT> <SET V <OPROPS .O>>)
|
||||||
|
(ELSE <SET V <RPROPS .O>>)>
|
||||||
|
<REPEAT ((VV .V))
|
||||||
|
<COND (<EMPTY? .VV>
|
||||||
|
<COND (.ADD?
|
||||||
|
<COND (<TYPE? .O OBJECT>
|
||||||
|
<PUT .O ,OPROPS (.P .X !.V)>)
|
||||||
|
(<PUT .O ,RPROPS (.P .X !.V)>)>)>
|
||||||
|
<RETURN .O>)
|
||||||
|
(<==? <1 .VV> .P> <PUT .VV 2 .X> <RETURN .O>)
|
||||||
|
(ELSE <SET VV <REST .VV 2>>)>>>
|
||||||
|
|
||||||
|
<DEFINE FIND-VERB (STR "AUX" (WORDS ,WORDS-POBL))
|
||||||
|
#DECL ((STR) STRING (WORDS) POBLIST)
|
||||||
|
<COND (<PLOOKUP .STR .WORDS>)
|
||||||
|
(<PINSERT .STR .WORDS <CHTYPE [<PSTRING .STR> T] VERB>>)>>
|
||||||
|
|
||||||
|
<DEFINE FIND-DIR (STR)
|
||||||
|
#DECL ((STR) STRING (VALUE) DIRECTION)
|
||||||
|
<COND (<PLOOKUP .STR ,DIRECTIONS-POBL>)
|
||||||
|
(<ERROR NOT-FOUND!-ERRORS FIND-DIR .STR>)>>
|
||||||
|
|
||||||
|
<DEFINE FIND-ACTION (STR)
|
||||||
|
#DECL ((STR) STRING (VALUE) ACTION)
|
||||||
|
<COND (<PLOOKUP .STR ,ACTIONS-POBL>)
|
||||||
|
(<ERROR NOT-FOUND!-ERRORS FIND-ACTION .STR>)>>
|
||||||
|
|
||||||
|
<DEFINE FIND-ROOM (STR)
|
||||||
|
#DECL ((STR) <OR STRING <PRIMTYPE WORD>> (VALUE) ROOM)
|
||||||
|
<COND (<PLOOKUP .STR ,ROOM-POBL>)
|
||||||
|
(<ERROR NOT-FOUND!-ERRORS FIND-ROOM .STR>)>>
|
||||||
|
|
||||||
|
<DEFMAC SFIND-ROOM ('STR)
|
||||||
|
<COND (<TYPE? .STR STRING>
|
||||||
|
<FORM FIND-ROOM <PSTRING .STR>>)
|
||||||
|
(<FORM FIND-ROOM .STR>)>>
|
||||||
|
|
||||||
|
<DEFMAC SFIND-OBJ ('STR)
|
||||||
|
<COND (<TYPE? .STR STRING>
|
||||||
|
<FORM FIND-OBJ <PSTRING .STR>>)
|
||||||
|
(<FORM FIND-OBJ .STR>)>>
|
||||||
|
|
||||||
|
<DEFINE FIND-OBJ (STR)
|
||||||
|
#DECL ((STR) <OR STRING <PRIMTYPE WORD>> (VALUE) OBJECT)
|
||||||
|
<COND (<PLOOKUP .STR ,OBJECT-POBL>)
|
||||||
|
(<ERROR NOT-FOUND!-ERRORS FIND-OBJ .STR>)>>
|
||||||
|
|
||||||
|
<DEFINE FIND-DOOR (RM OBJ)
|
||||||
|
#DECL ((RM) ROOM (OBJ) OBJECT)
|
||||||
|
<REPEAT ((L <REXITS .RM>) TD)
|
||||||
|
#DECL ((L) <<PRIMTYPE VECTOR> [REST DIRECTION <OR DOOR ROOM CEXIT NEXIT>]>)
|
||||||
|
<COND (<EMPTY? .L>
|
||||||
|
<RETURN <>>)
|
||||||
|
(<AND <TYPE? <SET TD <2 .L>> DOOR>
|
||||||
|
<==? <DOBJ .TD> .OBJ>>
|
||||||
|
<RETURN .TD>)>
|
||||||
|
<SET L <REST .L 2>>>>
|
||||||
|
|
||||||
|
<SETG ROOMS ()>
|
||||||
|
|
||||||
|
<SETG OBJECTS ()>
|
||||||
|
|
||||||
|
<SETG ACTORS ()>
|
||||||
|
|
||||||
|
<SETG BIGFIX </ <CHTYPE <MIN> FIX> 2>>
|
|
@ -0,0 +1,105 @@
|
||||||
|
<DEFINE DISPATCH-HACK ("AUX" Y)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) OBJECT)
|
||||||
|
<PUT .X ,OACTION <DISP-FROB <OACTION .X>>>>
|
||||||
|
,OBJECTS>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) ROOM)
|
||||||
|
<PUT .X ,RACTION <DISP-FROB <RACTION .X>>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
<COND (<TYPE? .X CEXIT>
|
||||||
|
<PUT .X ,CXACTION <DISP-FROB <CXACTION .X>>>)
|
||||||
|
(<TYPE? .X DOOR>
|
||||||
|
<PUT .X ,DACTION <DISP-FROB <DACTION .X>>>)>>
|
||||||
|
<REXITS .X>>>
|
||||||
|
,ROOMS>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) HACK)
|
||||||
|
<PUT .X ,HACTION <DISP-FROB <HACTION .X>>>>
|
||||||
|
,DEMONS>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) LIST)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
<COND (<TYPE? .X VERB>
|
||||||
|
<PUT .X ,VFCN <DISP-FROB <VFCN .X>>>)>>
|
||||||
|
.X>>
|
||||||
|
,WORDS-POBL>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) LIST)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) ATOM)
|
||||||
|
<COND (<AND <GASSIGNED? .X>
|
||||||
|
<TYPE? <SET Y ,.X> CEVENT>>
|
||||||
|
<PUT .Y ,CACTION <DISP-FROB <CACTION .Y>>>)>>
|
||||||
|
.X>>
|
||||||
|
<GET INITIAL OBLIST>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) ADV)
|
||||||
|
<PUT .X ,AACTION <DISP-FROB <AACTION .X>>>>
|
||||||
|
,ACTORS>
|
||||||
|
<SETG DISPATCH-TABLE <UVECTOR !<REST ,OFFL>>>
|
||||||
|
<GUNASSIGN OFFL>
|
||||||
|
<GUNASSIGN OFFLT>
|
||||||
|
<GUNASSIGN COFFSET>
|
||||||
|
"DONE">
|
||||||
|
|
||||||
|
<SETG COFFSET 0>
|
||||||
|
<GDECL (COFFSET) FIX (OFFL OFFLT) LIST>
|
||||||
|
<SETG OFFL (-1)>
|
||||||
|
<SETG OFFLT ,OFFL>
|
||||||
|
<DEFINE DISP-FROB (MUMBLE "AUX" TL X (CF ,COFFSET))
|
||||||
|
#DECL ((TL) LIST (CF) FIX)
|
||||||
|
<COND (<AND <TYPE? .MUMBLE ATOM>
|
||||||
|
<GASSIGNED? .MUMBLE>>
|
||||||
|
<COND (<TYPE? <SET X ,.MUMBLE> RSUBR-ENTRY>
|
||||||
|
<COND (<L? .CF 0>
|
||||||
|
<SETG COFFSET <+ <- .CF> 2>>)
|
||||||
|
(<SETG COFFSET <+ .CF 1>>)>
|
||||||
|
<SET TL <INST-GEN .X>>
|
||||||
|
<SETG OFFLT <REST <PUTREST ,OFFLT .TL> <LENGTH .TL>>>
|
||||||
|
<SETG .MUMBLE <CHTYPE ,COFFSET NOFFSET>>)
|
||||||
|
(<TYPE? .X NOFFSET>
|
||||||
|
.X)
|
||||||
|
(.MUMBLE)>)
|
||||||
|
(.MUMBLE)>>
|
||||||
|
|
||||||
|
<DEFINE INST-GEN (RENTRY "AUX" CV CV1 IOFFS)
|
||||||
|
#DECL ((RENTRY) RSUBR-ENTRY (CV CV1) <<PRIMTYPE UVECTOR> [REST <PRIMTYPE WORD>]>)
|
||||||
|
<SET IOFFS <ENTRY-LOC .RENTRY>>
|
||||||
|
<SET CV <REST <SET CV1 <1 <1 .RENTRY>>> .IOFFS>>
|
||||||
|
<REPEAT FOO (INST)
|
||||||
|
<SET INST <1 .CV>>
|
||||||
|
<COND (<==? <GOPCODE .INST> ,PUSHJ>
|
||||||
|
<COND (<NOT <INDIRECT? .INST>>
|
||||||
|
<SET IOFFS <GETADR .INST>>
|
||||||
|
<RETURN (<CHTYPE <ORB ,BASE-INST .IOFFS> WORD>)>)
|
||||||
|
(<SETG COFFSET <- ,COFFSET>>
|
||||||
|
<REPEAT (TOFFS)
|
||||||
|
<SET INST <1 <SET CV <BACK .CV>>>>
|
||||||
|
<COND (<==? <GOPCODE .INST> ,ADDI>
|
||||||
|
<SET TOFFS <GETADR .INST>>
|
||||||
|
<SET IOFFS <GETADR <NTH .CV1 <+ .TOFFS 1>>>>
|
||||||
|
<RETURN
|
||||||
|
(<CHTYPE <ORB ,BASE-INST .IOFFS> WORD>
|
||||||
|
<CHTYPE <ORB ,BASE-INST <GETADR <NTH .CV1 .TOFFS>>> WORD>)
|
||||||
|
.FOO>)>>)>)>
|
||||||
|
<SET CV <REST .CV>>>>
|
||||||
|
|
||||||
|
<DEFMAC GETADR ('FROB)
|
||||||
|
<FORM CHTYPE <FORM GETBITS .FROB <BITS 18 0>> FIX>>
|
||||||
|
|
||||||
|
<DEFMAC GOPCODE ('FROB)
|
||||||
|
<FORM CHTYPE <FORM GETBITS .FROB <BITS 9 27>> FIX>>
|
||||||
|
|
||||||
|
<DEFMAC INDIRECT? ('FROB)
|
||||||
|
<FORM 1? <FORM CHTYPE <FORM GETBITS .FROB <BITS 1 22>> FIX>>>
|
||||||
|
|
||||||
|
<SETG PUSHJ *260*>
|
||||||
|
<SETG ADDI *271*>
|
||||||
|
<SETG BASE-INST *260755000000*> ; " PUSHJ P,(M)"
|
||||||
|
<MANIFEST PUSHJ ADDI BASE-INST>
|
|
@ -0,0 +1,977 @@
|
||||||
|
|
||||||
|
"(c) Copyright 1979, Massachusetts Institute of Technology. All rights reserved."
|
||||||
|
|
||||||
|
<OR <TYPE? ,REP SUBR>
|
||||||
|
<SETG SAVEREP ,REP>>
|
||||||
|
|
||||||
|
<DEFINE ZGO ()
|
||||||
|
<SETG REP ,ZREP>
|
||||||
|
<ON "BLOCKED"
|
||||||
|
<FUNCTION (FOO)
|
||||||
|
<PRINC !\:>>
|
||||||
|
5>
|
||||||
|
<ERRET>>
|
||||||
|
|
||||||
|
<DEFINE ZREP ZTOP ("AUX" RD)
|
||||||
|
#DECL ((ZTOP) <SPECIAL ACTIVATION> (RD) ANY)
|
||||||
|
<REPEAT ()
|
||||||
|
<CRLF>
|
||||||
|
<SET RD <READ>>
|
||||||
|
<CRLF>
|
||||||
|
<SET RD <ZEVAL .RD>>
|
||||||
|
<ZPRINT .RD>
|
||||||
|
.RD>>
|
||||||
|
|
||||||
|
<DEFINE ZPRINT (ITEM)
|
||||||
|
#DECL ((ITEM) ANY)
|
||||||
|
<COND (<TYPE? .ITEM OBJECT>
|
||||||
|
<ZOBJ-PRINT .ITEM>)
|
||||||
|
(<TYPE? .ITEM ROOM>
|
||||||
|
<ZRM-PRINT .ITEM>)
|
||||||
|
(<TYPE? .ITEM VERB>
|
||||||
|
<PRINC "Verb = ">
|
||||||
|
<PRINC <STRINGP <1 .ITEM>>>)
|
||||||
|
(<TYPE? .ITEM CEVENT>
|
||||||
|
<ZEV-PRINT .ITEM>)
|
||||||
|
(<TYPE? .ITEM LIST>
|
||||||
|
<ZLST-PRINT .ITEM>)
|
||||||
|
(<==? .ITEM T>
|
||||||
|
<PRINC "True">)
|
||||||
|
(<==? .ITEM <>>
|
||||||
|
<PRINC "False">)
|
||||||
|
(<PRIN1 .ITEM>)>>
|
||||||
|
|
||||||
|
<DEFINE ZEV-PRINT (CEV)
|
||||||
|
#DECL ((CEV) CEVENT)
|
||||||
|
<PRINC "Running ">
|
||||||
|
<PRINC <SPNAME <2 .CEV>>>
|
||||||
|
<PRINC " in ">
|
||||||
|
<PRIN1 <1 .CEV>>
|
||||||
|
<PRINC " moves">
|
||||||
|
<COND (<NOT <3 .CEV>>
|
||||||
|
<PRINC " (disabled)">)>>
|
||||||
|
|
||||||
|
<DEFINE ZLST-PRINT (LST)
|
||||||
|
#DECL ((LST) LIST)
|
||||||
|
<PRINC "List containing:">
|
||||||
|
<ZPC .LST>>
|
||||||
|
|
||||||
|
<DEFINE ZOBJ-PRINT (OBJ)
|
||||||
|
#DECL ((OBJ) OBJECT)
|
||||||
|
<PRINC "Object = ">
|
||||||
|
<PRINC <ODESC2 .OBJ>>
|
||||||
|
<COND (<OCAN .OBJ>
|
||||||
|
<PRINC " (in ">
|
||||||
|
<PRINC <ODESC2 <OCAN .OBJ>>>
|
||||||
|
<PRINC ")">)>
|
||||||
|
<COND (<NOT <EMPTY? <OCONTENTS .OBJ>>>
|
||||||
|
<PRINC " /Contains:">
|
||||||
|
<ZPC <OCONTENTS .OBJ>>)>>
|
||||||
|
|
||||||
|
<DEFINE ZPC (LST)
|
||||||
|
#DECL ((LST) LIST)
|
||||||
|
<PRINC !\ >
|
||||||
|
<MAPR <>
|
||||||
|
<FUNCTION (LST2 "AUX" (ITEM <1 .LST2>))
|
||||||
|
#DECL ((LST2) LIST (ITEM) ANY)
|
||||||
|
<COND (<TYPE? .ITEM OBJECT>
|
||||||
|
<PRINC <ODESC2 .ITEM>>)
|
||||||
|
(<PRIN1 .ITEM>)>
|
||||||
|
<OR <LENGTH? .LST2 1>
|
||||||
|
<PRINC " & ">>>
|
||||||
|
.LST>>
|
||||||
|
|
||||||
|
<DEFINE ZRM-PRINT (RM "AUX" (OBJS <ROBJS .RM>))
|
||||||
|
#DECL ((RM) ROOM (OBJS) <LIST [REST OBJECT]>)
|
||||||
|
<PRINC "Room = ">
|
||||||
|
<PRINC <RDESC2 .RM>>
|
||||||
|
<COND (<NOT <EMPTY? .OBJS>>
|
||||||
|
<PRINC "
|
||||||
|
Contains:">
|
||||||
|
<ZPC .OBJS>)>
|
||||||
|
<PRINC "
|
||||||
|
Exits to: ">
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (ITM)
|
||||||
|
#DECL ((ITM) ANY)
|
||||||
|
<COND (<TYPE? .ITM DIRECTION>
|
||||||
|
<PRINC <STRINGP .ITM>>
|
||||||
|
<PRINC !\ >)>>
|
||||||
|
<REXITS .RM>>>
|
||||||
|
|
||||||
|
<SET ZFLUSH
|
||||||
|
<ON "CHAR"
|
||||||
|
<FUNCTION (CHR CHN)
|
||||||
|
#DECL ((CHR) CHARACTER (CHN) CHANNEL)
|
||||||
|
<COND (<==? .CHR <ASCII 7>>
|
||||||
|
<INT-LEVEL 0>
|
||||||
|
<AND <GET BLOCKED!-INTERRUPTS INTERRUPT>
|
||||||
|
<OFF "BLOCKED">>
|
||||||
|
<SETG REP ,SAVEREP>
|
||||||
|
<LISTEN>)>>
|
||||||
|
8 0 ,INCHAN>>
|
||||||
|
|
||||||
|
<DEFINE ZEVAL (ITEM "OPTIONAL" (FLAG <>) "AUX" OPER TEMP)
|
||||||
|
#DECL ((ITEM TEMP) ANY (OPER) STRING (FLAG) <OR ATOM FALSE>)
|
||||||
|
<COND (<TYPE? .ITEM FIX FLOAT STRING> .ITEM)
|
||||||
|
(<TYPE? .ITEM FORM> <EVAL .ITEM>)
|
||||||
|
(<TYPE? .ITEM ATOM>
|
||||||
|
<SET OPER <SPNAME .ITEM>>
|
||||||
|
<COND (<SET TEMP <ZLOOKUP .OPER ,ZERO-POBL>>
|
||||||
|
<APPLY .TEMP>)
|
||||||
|
(<ZLOOKUP .OPER ,ZVARS-POBL>)
|
||||||
|
(<PLOOKUP .OPER ,OBJECT-POBL>)
|
||||||
|
(<PLOOKUP .OPER ,ROOM-POBL>)
|
||||||
|
(<PLOOKUP .OPER ,WORDS-POBL>)
|
||||||
|
(<ZLOOKUP .OPER ,ZOBITS-POBL>)
|
||||||
|
(<ZLOOKUP .OPER ,ZRBITS-POBL>)
|
||||||
|
(.FLAG #LOSE 0)
|
||||||
|
(ELSE <ILLEGAL "Unknown word: " .OPER>)>)
|
||||||
|
(<TYPE? .ITEM LIST>
|
||||||
|
<REPEAT (R I S)
|
||||||
|
#DECL ((R I) ANY (S) STRING)
|
||||||
|
<COND (<EMPTY? .ITEM> <RETURN <AND <ASSIGNED? R> .R>>)>
|
||||||
|
<SET I <1 .ITEM>>
|
||||||
|
<COND (<TYPE? .I ATOM>
|
||||||
|
<SET S <SPNAME .I>>
|
||||||
|
<COND (<SET TEMP <ZLOOKUP .S ,ZERO-POBL>>
|
||||||
|
<SET R <APPLY .TEMP>>)
|
||||||
|
(<SET TEMP <ZLOOKUP .S ,ONE-POBL>>
|
||||||
|
<COND (<EMPTY? <SET ITEM <REST .ITEM>>>
|
||||||
|
<TOOFEW .S>)
|
||||||
|
(ELSE
|
||||||
|
<SET R
|
||||||
|
<APPLY .TEMP
|
||||||
|
<ZEVAL <1 .ITEM>>>>)>)
|
||||||
|
(<SET TEMP <ZLOOKUP .S ,TWO-POBL>>
|
||||||
|
<COND (<EMPTY? <SET ITEM <REST .ITEM>>>
|
||||||
|
<TOOFEW .S>)
|
||||||
|
(<ASSIGNED? R>
|
||||||
|
<SET R
|
||||||
|
<APPLY .TEMP
|
||||||
|
.R
|
||||||
|
<ZEVAL <1 .ITEM>>>>)
|
||||||
|
(ELSE
|
||||||
|
<TOOFEW .S>)>)
|
||||||
|
(<SET TEMP <ZLOOKUP .S ,ANY-POBL>>
|
||||||
|
<COND (<EMPTY? <SET ITEM <REST .ITEM>>>
|
||||||
|
<TOOFEW .S>)
|
||||||
|
(ELSE
|
||||||
|
<SET R
|
||||||
|
<APPLY .TEMP
|
||||||
|
<OR <NOT <ASSIGNED? R>>
|
||||||
|
.R>
|
||||||
|
.ITEM>>
|
||||||
|
<RETURN .R>)>)
|
||||||
|
(ELSE <SET R <ZEVAL .I>>)>)
|
||||||
|
(ELSE <SET R <ZEVAL .I>>)>
|
||||||
|
<SET ITEM <REST .ITEM>>>)
|
||||||
|
(<ILLEGAL "ZEVAL of non list, form or atom.">)>>
|
||||||
|
|
||||||
|
<DEFINE ZIN (ITM1 ITM2)
|
||||||
|
#DECL ((ITM1 ITM2) ANY)
|
||||||
|
<COND (<TYPE? .ITM2 LIST>
|
||||||
|
<AND <MEMQ .ITM1 .ITM2> T>)
|
||||||
|
(<TYPE? .ITM1 OBJECT>
|
||||||
|
<COND (<TYPE? .ITM2 OBJECT>
|
||||||
|
<==? <OCAN .ITM1> .ITM2>)
|
||||||
|
(<TYPE? .ITM2 ROOM>
|
||||||
|
<AND <MEMQ .ITM1 <ROBJS .ITM2>> T>)
|
||||||
|
(<TYPE? .ITM2 ADV>
|
||||||
|
<AND <MEMQ .ITM1 <AOBJS ,WINNER>> T>)
|
||||||
|
(<ILLEGAL "Illegal container - " .OBJ2>)>)
|
||||||
|
(<ILLEGAL "Illegal object?">)>>
|
||||||
|
|
||||||
|
<DEFINE ZEQUALS (ITM1 ITM2)
|
||||||
|
#DECL ((ITM1 ITM2) ANY)
|
||||||
|
<COND (<==? <TYPE .ITM1> <TYPE .ITM2>>
|
||||||
|
<==? .ITM1 .ITM2>)
|
||||||
|
(<TYPE? .ITM2 FIX>
|
||||||
|
<COND (<TYPE? .ITM1 OBJECT> <TRNN .ITM1 .ITM2>)
|
||||||
|
(<TYPE? .ITM1 ROOM> <RTRNN .ITM1 .ITM2>)
|
||||||
|
(<ILLEGAL "Unknown type?">)>)>>
|
||||||
|
|
||||||
|
"ZIF -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZIF (DUMMY LST "AUX" P (TOKEN then) (R <>))
|
||||||
|
<COND (<SET P <ZEVAL <1 .LST>>>)
|
||||||
|
(ELSE <SET TOKEN else>)>
|
||||||
|
<COND (<SET LST <MEMQ .TOKEN .LST>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (I)
|
||||||
|
<AND <==? .I else> <MAPLEAVE .R>>
|
||||||
|
<SET R <ZEVAL .I>>>
|
||||||
|
<REST .LST>>)
|
||||||
|
(ELSE <ILLEGAL "If lacks then/else">)>>
|
||||||
|
|
||||||
|
"ZCASE -- fsubr"
|
||||||
|
|
||||||
|
<SETG EXPR <ILIST 3>>
|
||||||
|
|
||||||
|
<DEFINE ZCASE (DUMMY LST "AUX" OBJ (E ,EXPR))
|
||||||
|
<SET OBJ <1 .LST>>
|
||||||
|
<COND (<TYPE? .OBJ ATOM>)(ELSE <SET OBJ <ZEVAL .OBJ>>)>
|
||||||
|
<SET LST <REST .LST>>
|
||||||
|
<COND (<EMPTY? .LST> <TOOFEW "case">)
|
||||||
|
(<TYPE? <SET OPR <1 .LST>> ATOM>
|
||||||
|
<SET LST <REST .LST>>)>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (I)
|
||||||
|
<PUT .E 1 .OBJ>
|
||||||
|
<PUT .E 2 .OPR>
|
||||||
|
<PUT .E 3 <1 .I>>
|
||||||
|
<COND (<OR <==? <1 .I> else> <ZEVAL .E>>
|
||||||
|
<MAPLEAVE <ZEVAL <REST .I>>>)>>
|
||||||
|
.LST>>
|
||||||
|
|
||||||
|
"ZFOR-EACH -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZFOR-EACH (DUMMY ARGL)
|
||||||
|
#DECL ((ARGL) LIST)
|
||||||
|
<COND (<LENGTH? .ARGL 1>
|
||||||
|
<TOOFEW>)
|
||||||
|
(<TYPE? <SET LST <ZEVAL <1 .ARGL>>> LIST>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (ZITS)
|
||||||
|
#DECL ((ZITS) <SPECIAL ANY>)
|
||||||
|
<ZEVAL <REST .ARGL>>>
|
||||||
|
.LST>)
|
||||||
|
(<ILLEGAL "Argument-not-list/FOR-EACH">)>>
|
||||||
|
|
||||||
|
"ZPLUS -- two args"
|
||||||
|
|
||||||
|
<DEFINE ZPLUS (A B)
|
||||||
|
<COND (<ASSIGNED? B> <+ .A .B>)
|
||||||
|
(ELSE .A)>>
|
||||||
|
|
||||||
|
"ZMINUS -- two args"
|
||||||
|
|
||||||
|
<DEFINE ZMINUS (A B)
|
||||||
|
<COND (<ASSIGNED? B> <- .A .B>)
|
||||||
|
(ELSE .A)>>
|
||||||
|
|
||||||
|
"ZTIMES -- two args"
|
||||||
|
|
||||||
|
<DEFINE ZTIMES (A B)
|
||||||
|
<COND (<ASSIGNED? B> <* .A .B>)
|
||||||
|
(ELSE .A)>>
|
||||||
|
|
||||||
|
"ZDIVIDED -- two args"
|
||||||
|
|
||||||
|
<DEFINE ZDIVIDED (A B)
|
||||||
|
<COND (<ASSIGNED? B> </ .A .B>)
|
||||||
|
(ELSE .A)>>
|
||||||
|
|
||||||
|
"ZLESS -- two args"
|
||||||
|
|
||||||
|
<DEFINE ZLESS (A B)
|
||||||
|
<COND (<ASSIGNED? B> <L? .A .B>)
|
||||||
|
(ELSE .A)>>
|
||||||
|
|
||||||
|
"ZGREATER -- two args"
|
||||||
|
|
||||||
|
<DEFINE ZGREATER (A B)
|
||||||
|
<COND (<ASSIGNED? B> <G? .A .B>)
|
||||||
|
(ELSE .A)>>
|
||||||
|
|
||||||
|
"ZEQUAL -- two args"
|
||||||
|
|
||||||
|
<DEFINE ZEQUAL (A B)
|
||||||
|
<COND (<ASSIGNED? B> <==? .A .B>)
|
||||||
|
(ELSE .A)>>
|
||||||
|
|
||||||
|
"ZAND -- two args"
|
||||||
|
|
||||||
|
<DEFINE ZAND (A B)
|
||||||
|
<COND (<ASSIGNED? B> <AND .A .B>)
|
||||||
|
(ELSE .A)>>
|
||||||
|
|
||||||
|
"ZOR -- two args"
|
||||||
|
|
||||||
|
<DEFINE ZOR (A B)
|
||||||
|
<COND (<ASSIGNED? B> <OR .A .B>)
|
||||||
|
(ELSE .A)>>
|
||||||
|
|
||||||
|
"ZIS -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZIS (OBJ LIST)
|
||||||
|
<ZPRED .OBJ .LIST>>
|
||||||
|
|
||||||
|
"ZISNT -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZISNT (OBJ LIST)
|
||||||
|
<NOT <ZPRED .OBJ .LIST>>>
|
||||||
|
|
||||||
|
"ZPRED -- general predicates"
|
||||||
|
|
||||||
|
<DEFINE ZPRED (OBJ EXPR "OPTIONAL" (TTYPE <>)
|
||||||
|
"AUX" (NTTYPE <>) (VAL <>) (NOT? <>) (BOOL? <>))
|
||||||
|
#DECL ((OBJ) ANY (EXPR) <OR ATOM LIST>)
|
||||||
|
<COND (<TYPE? .EXPR ATOM>
|
||||||
|
<COND (<NOT .TTYPE>
|
||||||
|
<ZEQUALS .OBJ <ZEVAL .EXPR>>)
|
||||||
|
(<=? .TTYPE in>
|
||||||
|
<ZIN .OBJ <ZEVAL .EXPR>>)
|
||||||
|
(ELSE <ERROR UNKNOWN-TTYPE .TTYPE>)>)
|
||||||
|
(ELSE
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (E)
|
||||||
|
#DECL ((E) <OR ATOM LIST>)
|
||||||
|
<COND (<AND <TYPE? .E ATOM> <MEMQ .E ,BUZZ>>)
|
||||||
|
(<==? .E or> <SET BOOL? <>>)
|
||||||
|
(<==? .E and> <SET BOOL? T>)
|
||||||
|
(<==? .E not> <SET NOT? <NOT .NOT?>>)
|
||||||
|
(<MEMQ .E ,TEST-TYPES> <SET NTTYPE .E>)
|
||||||
|
(ELSE
|
||||||
|
<SET NVAL <ZPRED .OBJ .E <OR .NTTYPE .TTYPE>>>
|
||||||
|
<SET NTTYPE <>>
|
||||||
|
<COND (.NOT?
|
||||||
|
<SET NVAL <NOT .NVAL>>
|
||||||
|
<SET NOT? <>>)>
|
||||||
|
<COND (.BOOL?
|
||||||
|
<SET VAL <AND .VAL .NVAL>>)
|
||||||
|
(ELSE
|
||||||
|
<SET VAL <OR .VAL .NVAL>>)>)>>
|
||||||
|
.EXPR>
|
||||||
|
.VAL)>>
|
||||||
|
|
||||||
|
"ZLOOKUP -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZLKUP (DUMMY ARGL "AUX" M LST)
|
||||||
|
#DECL ((ARGL) LIST (M) <OR FALSE LIST> (LST) ANY)
|
||||||
|
<COND (<LENGTH? .ARGL 1> <TOOFEW>)
|
||||||
|
(<TYPE? <SET LST <ZEVAL <2 .ARGL>>> LIST>
|
||||||
|
<AND <SET M <MEMQ <ZEVAL <1 .ARGL>> .LST>>
|
||||||
|
<NOT <LENGTH? .M 1>>>
|
||||||
|
<2 .M>)
|
||||||
|
(<ILLEGAL "Lookup in non-list?">)>>
|
||||||
|
|
||||||
|
"ZCONTENTS -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZCONTENTS (DUMMY ARGL "AUX" (ARG .ARGL) ITEM)
|
||||||
|
#DECL ((ARGL ARG) LIST (ITEM) ANY)
|
||||||
|
<COND (<OR <EMPTY? .ARGL>
|
||||||
|
<AND <==? <1 .ARGL> of>
|
||||||
|
<SET ARG <REST .ARG>>
|
||||||
|
<LENGTH? .ARGL 1>>>
|
||||||
|
<TOOFEW>)>
|
||||||
|
<COND (<TYPE? <SET ITEM <ZEVAL <1 .ARG>>> OBJECT>
|
||||||
|
<OCONTENTS .ITEM>)
|
||||||
|
(<TYPE? .ITEM ROOM>
|
||||||
|
<ROBJS .ITEM>)
|
||||||
|
(<TYPE? .ITEM ADV>
|
||||||
|
<AOBJS .ITEM>)
|
||||||
|
(<ILLEGAL "Unknown/CONTENTS">)>>
|
||||||
|
|
||||||
|
"ZSET -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZSET (DUMMY ARGL)
|
||||||
|
#DECL ((ARGL) LIST)
|
||||||
|
<COND (<LENGTH? .ARGL 1>
|
||||||
|
<TOOFEW>)
|
||||||
|
(<TYPE? <1 .ARGL> ATOM>
|
||||||
|
<ZINSERT <SPNAME <1 .ARGL>> ,ZVARS-POBL <ZEVAL <2 .ARGL>>>)
|
||||||
|
(<ILLEGAL "Non-atomic set?">)>>
|
||||||
|
|
||||||
|
"ZDEFINE -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZDEFINE (DUMMY ARGL "AUX" STR)
|
||||||
|
#DECL ((ARGL) LIST (STR) STRING)
|
||||||
|
<COND (<N==? <LENGTH .ARGL> 2>
|
||||||
|
<WNA>)
|
||||||
|
(<ZINSERT <SET STR <SPNAME <1 .ARGL>>>
|
||||||
|
,ZVARS-POBL
|
||||||
|
<2 .ARGL>>
|
||||||
|
<ZFUNCTION .STR>
|
||||||
|
<1 .ARGL>)>>
|
||||||
|
|
||||||
|
<DEFINE ZFUNCTION (STR)
|
||||||
|
#DECL ((STR) STRING)
|
||||||
|
<ZINSERT .STR
|
||||||
|
<GET INITIAL OBLIST>
|
||||||
|
<CHTYPE <LIST () <FORM ZEVAL <FORM ZLOOKUP .STR ,ZVARS-POBL>>> FUNCTION>>>
|
||||||
|
|
||||||
|
"ZLOAD -- one arg"
|
||||||
|
|
||||||
|
<DEFINE ZLOAD (ARG "AUX" STR)
|
||||||
|
#DECL ((ARG) ANY (STR) ANY)
|
||||||
|
<COND (<AND <TYPE? .ARG STRING> <SET STR .ARG>>
|
||||||
|
<COND (<SET C <OPEN "READ" .STR>>
|
||||||
|
<SET <ZATOM <7 .C>>
|
||||||
|
<MAPF ,LIST
|
||||||
|
<FUNCTION ()
|
||||||
|
#DECL ((ITM) ANY)
|
||||||
|
<SET ITM <READ .C '<MAPSTOP>>>
|
||||||
|
<COND (<TYPE? .ITM LIST>
|
||||||
|
<ZEVAL .ITM>)>
|
||||||
|
.ITM>>>
|
||||||
|
<CLOSE .C>
|
||||||
|
"Done")
|
||||||
|
(<ILLEGAL "File not found.">)>)
|
||||||
|
(<ILLEGAL "Non-string file name?">)>>
|
||||||
|
|
||||||
|
"ZATOM -- ??"
|
||||||
|
|
||||||
|
<DEFINE ZATOM (STR)
|
||||||
|
#DECL ((STR) STRING)
|
||||||
|
<OR <LOOKUP .STR <GET INITIAL OBLIST>>
|
||||||
|
<INSERT .STR <GET INITIAL OBLIST>>>>
|
||||||
|
|
||||||
|
"ZDUMP -- one arg"
|
||||||
|
|
||||||
|
<DEFINE ZDUMP (ARG "AUX" STR ATM LST)
|
||||||
|
#DECL ((ARG) ANY (STR LST) ANY (ATM) ATOM)
|
||||||
|
<COND (<AND <TYPE? .ARG STRING> <SET STR .ARG>>
|
||||||
|
<COND (<SET C <OPEN "PRINT" .STR>>
|
||||||
|
<COND (<AND <ASSIGNED? <SET ATM <ZATOM <7 .C>>>>
|
||||||
|
<TYPE? <SET LST ..ATM> LIST>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (ITM)
|
||||||
|
#DECL ((ITM) ANY)
|
||||||
|
<COND (<AND <TYPE? .ITM LIST>
|
||||||
|
<==? <1 .ITM> define>>
|
||||||
|
<PPRINT (define
|
||||||
|
<2 .ITM>
|
||||||
|
<ZLOOKUP <SPNAME <2 .ITM>>
|
||||||
|
,ZVARS-POBL>)
|
||||||
|
.C>)
|
||||||
|
(<PPRINT .ITM .C>)>>
|
||||||
|
.LST>
|
||||||
|
<CLOSE .C>
|
||||||
|
<TELL "Done" 0>)
|
||||||
|
(<ILLEGAL "Not a group?">)>)
|
||||||
|
(<ILLEGAL "Can't open channel?">)>)
|
||||||
|
(<ILLEGAL "Non-string file name?">)>>
|
||||||
|
|
||||||
|
"ZPPRINT -- one arg"
|
||||||
|
|
||||||
|
<DEFINE ZPPRINT (DUMMY ARG)
|
||||||
|
#DECL ((ARG) ANY)
|
||||||
|
<ZEDIT <> .ARG T>>
|
||||||
|
|
||||||
|
"ZRUN -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZRUN (DUMMY ARGL "AUX" STR ARG VAL (CEV <>))
|
||||||
|
#DECL ((ARGL) LIST (STR) STRING (VAL ARG) ANY (CEV) <OR FALSE CEVENT>)
|
||||||
|
<COND (<EMPTY? .ARGL> <TOOFEW>)
|
||||||
|
(<AND <TYPE? <SET ARG <1 .ARGL>> ATOM>
|
||||||
|
<TYPE? <SET VAL <ZLOOKUP <SET STR <SPNAME .ARG>> ,ZVARS-POBL>> LIST>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (ITEM)
|
||||||
|
<COND (<MEMQ .ITEM '[in moves]>)
|
||||||
|
(<TYPE? .ITEM FIX>
|
||||||
|
<SET CEV
|
||||||
|
<COND (<ZLOOKUP .STR ,ZINT-POBL>)
|
||||||
|
(<ZINSERT .STR
|
||||||
|
,ZINT-POBL
|
||||||
|
<CEVENT 0
|
||||||
|
<ZATOM .STR>
|
||||||
|
<>
|
||||||
|
"**::**">>)>>
|
||||||
|
<COND (<MEMQ .CEV ,ZINTS>)
|
||||||
|
(<SETG ZINTS (<LOOKUP .STR ,ZINT-POBL>
|
||||||
|
.CEV
|
||||||
|
!,ZINTS)>)>
|
||||||
|
<MAPLEAVE <CLOCK-ENABLE <CLOCK-INT .CEV .ITEM>>>)
|
||||||
|
(<ILLEGAL "Bad argument/RUN">)>>
|
||||||
|
<REST .ARGL>>
|
||||||
|
<OR .CEV <ZEVAL .VAL>>)
|
||||||
|
(<ILLEGAL "Not applicable?">)>>
|
||||||
|
|
||||||
|
"ZENABLE -- one arg"
|
||||||
|
|
||||||
|
<DEFINE ZENABLE (ARG "AUX")
|
||||||
|
#DECL ((ARG) ANY)
|
||||||
|
<CLOCK-ENABLE <ZINT-FIND .ARG>>>
|
||||||
|
|
||||||
|
"ZDISABLE -- one arg"
|
||||||
|
|
||||||
|
<DEFINE ZDISABLE (ARG "AUX")
|
||||||
|
#DECL ((ARG) ANY)
|
||||||
|
<CLOCK-DISABLE <ZINT-FIND .ARG>>>
|
||||||
|
|
||||||
|
<DEFINE ZINT-FIND (ITEM "AUX" (VARS ,ZVARS-POBL))
|
||||||
|
#DECL ((ITEM) ANY (VARS) OBLIST)
|
||||||
|
<COND (<AND <TYPE? .ITEM LIST>
|
||||||
|
<REPEAT ((L ,ZINTS))
|
||||||
|
#DECL ((L) <LIST [REST ATOM CEVENT]>)
|
||||||
|
<COND (<EMPTY? .L> <RETURN <>>)
|
||||||
|
(<==? <ZLOOKUP <SPNAME <1 .L>> .VARS> .ITEM>
|
||||||
|
<RETURN <2 .L>>)
|
||||||
|
(<SET L <REST .L 2>>)>>>)
|
||||||
|
(<ILLEGAL "Not an interrupt">)>>
|
||||||
|
|
||||||
|
"ZEDIT -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZEDIT (DUMMY ARGL "OPTIONAL" (PRINT? <>) "AUX" L ARG STR)
|
||||||
|
#DECL ((ARGL) LIST (ARG) ANY (L) ANY (PRINT?) <OR FALSE ATOM> (STR) STRING)
|
||||||
|
<COND (<EMPTY? .ARGL> <TOOFEW>)
|
||||||
|
(<TYPE? <SET ARG <1 .ARGL>> ATOM>
|
||||||
|
<COND (<TYPE? <SET L <ZLOOKUP <SET STR <SPNAME .ARG>> ,ZVARS-POBL>> LIST>
|
||||||
|
<ZINSERT <SPNAME .ARG> ,ZVARS-POBL <ZEP .L .PRINT?>>
|
||||||
|
.ARG)
|
||||||
|
(<TYPE? .L ROOM OBJECT>
|
||||||
|
<SET VAL <ZEP <ZLOOKUP <SPNAME .ARG> ,ZDEFS-POBL> .PRINT?>>
|
||||||
|
<ZINSERT .STR ,ZDEFS-POBL .VAL>
|
||||||
|
<COND (<TYPE? .L ROOM>
|
||||||
|
<RM/OBJ-CREATE .VAL <>>)
|
||||||
|
(<RM/OBJ-CREATE .VAL>)>)
|
||||||
|
(<ILLEGAL "Value of atom not a list?">)>)
|
||||||
|
(<ILLEGAL "Must edit an atom.">)>>
|
||||||
|
|
||||||
|
<DEFINE ZEP (OBJ PRINT?)
|
||||||
|
#DECL ((OBJ) LIST (PRINT?) <OR ATOM FALSE>)
|
||||||
|
<COND (.PRINT?
|
||||||
|
<PPRINT .OBJ>
|
||||||
|
.OBJ)
|
||||||
|
(<TELL " Starting edit." 0>
|
||||||
|
<EDIT OBJ>
|
||||||
|
<TELL "
|
||||||
|
Return from edit.">
|
||||||
|
.OBJ)>>
|
||||||
|
|
||||||
|
"zero-arg goodies"
|
||||||
|
|
||||||
|
<DEFINE ZWINNER () ,WINNER>
|
||||||
|
|
||||||
|
<DEFINE ZTRUE () T>
|
||||||
|
|
||||||
|
<DEFINE ZFALSE () <>>
|
||||||
|
|
||||||
|
<DEFINE ZSCORE () <ASCORE ,WINNER>>
|
||||||
|
|
||||||
|
<DEFINE ZPRSO () <PRSO>>
|
||||||
|
|
||||||
|
<DEFINE ZROOM () ,HERE>
|
||||||
|
|
||||||
|
<DEFINE ZPRSI () <PRSI>>
|
||||||
|
|
||||||
|
<DEFINE ZVERB () <PRSA>>
|
||||||
|
|
||||||
|
<DEFINE ZIT () .ZITS>
|
||||||
|
|
||||||
|
<DEFINE ZZORK () <OFF "BLOCKED"> <DC>>
|
||||||
|
|
||||||
|
"ZTAKE -- one arg"
|
||||||
|
|
||||||
|
<DEFINE ZTAKE (ARG "AUX" OBJ)
|
||||||
|
#DECL ((ARG) ANY (OBJ) ANY)
|
||||||
|
<COND (<TYPE? .ARG OBJECT>
|
||||||
|
<REMOVE-OBJECT .OBJ>
|
||||||
|
<TAKE-OBJECT .OBJ>)>>
|
||||||
|
|
||||||
|
"ZREMOVE -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZREMOVE (DUMMY LST "AUX" OBJ)
|
||||||
|
#DECL ((LST) LIST (OBJ) ANY)
|
||||||
|
<COND (<EMPTY? .LST>
|
||||||
|
<TOOFEW>)
|
||||||
|
(<MAPF <>
|
||||||
|
<FUNCTION (ITM)
|
||||||
|
#DECL ((ITM) ANY)
|
||||||
|
<COND (<==? .ITM and>)
|
||||||
|
(<TYPE? <SET OBJ <ZEVAL .ITM>> OBJECT>
|
||||||
|
<REMOVE-OBJECT .OBJ>)
|
||||||
|
(<ILLEGAL "Not an object/REMOVE">)>>
|
||||||
|
.LST>)
|
||||||
|
(<ILLEGAL "Not an object/REMOVE">)>>
|
||||||
|
|
||||||
|
"ZPUTIN -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZPUTIN (DUMMY LST "AUX" OBJ)
|
||||||
|
#DECL ((LST) LIST (OBJ) ANY)
|
||||||
|
<COND (<LENGTH? .LST 1>
|
||||||
|
<TOOFEW>)
|
||||||
|
(ELSE
|
||||||
|
<SET OBJ2 <COND (<MEMQ <2 .LST> ![in into to]>
|
||||||
|
<COND (<LENGTH? .LST 2>
|
||||||
|
<TOOFEW>)
|
||||||
|
(<ZEVAL <3 .LST>>)>)
|
||||||
|
(<ZEVAL <2 .LST>>)>>
|
||||||
|
<COND (<TYPE? .OBJ2 LIST>
|
||||||
|
<CONS <ZEVAL <1 .LST>> .OBJ2>)
|
||||||
|
(<TYPE? <SET OBJ <ZEVAL <1 .LST>>> OBJECT>
|
||||||
|
<REMOVE-OBJECT .OBJ>
|
||||||
|
<COND (<TYPE? .OBJ2 ROOM>
|
||||||
|
<INSERT-OBJECT .OBJ .OBJ2>)
|
||||||
|
(<TYPE? .OBJ2 OBJECT>
|
||||||
|
<INSERT-INTO .OBJ2 .OBJ>)
|
||||||
|
(<TYPE? .OBJ2 ADV>
|
||||||
|
<TAKE-OBJECT .OBJ>)
|
||||||
|
(<ILLEGAL "Illegal operator/INSERT">)>)
|
||||||
|
(<ILLEGAL "Not an object/INSERT">)>)>>
|
||||||
|
|
||||||
|
"ZTELL -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZTELL (DUMMY LST)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (ITEM)
|
||||||
|
<COND (<TYPE? .ITEM STRING>
|
||||||
|
<TELL .ITEM 0>)
|
||||||
|
(<==? .ITEM crlf>
|
||||||
|
<TELL "">)
|
||||||
|
(<TYPE? <SET VAL <ZEVAL .ITEM>> OBJECT>
|
||||||
|
<TELL <ODESC2 .VAL> 0>)
|
||||||
|
(<ILLEGAL "Unknown print operator.">)>>
|
||||||
|
.LST>>
|
||||||
|
|
||||||
|
"ZGOTO -- one arg"
|
||||||
|
|
||||||
|
<DEFINE ZGOTO (ARG)
|
||||||
|
#DECL ((ARG) ANY)
|
||||||
|
<COND (<TYPE? .ARG ROOM> <GOTO .ARG>)
|
||||||
|
(<ILLEGAL "Not a room/GOTO">)>>
|
||||||
|
|
||||||
|
"ZMAKE -- fsubr"
|
||||||
|
|
||||||
|
<DEFINE ZMAKE (DUMMY LST "AUX" OBJ (NOT? <MEMQ not .LST>))
|
||||||
|
#DECL ((LST) LIST (OBJ) ANY (NOT?) <OR FALSE LIST>)
|
||||||
|
<COND (<OR <AND .NOT? <LENGTH? .LST 2>>
|
||||||
|
<LENGTH? .LST 1>>
|
||||||
|
<TOOFEW>)
|
||||||
|
(<TYPE? <SET OBJ <ZEVAL <1 .LST>>> OBJECT>
|
||||||
|
<COND (<SET M <ZLOOKUP <SPNAME <COND (.NOT? <3 .LST>) (<2 .LST>)>>
|
||||||
|
,ZOBITS-POBL>>
|
||||||
|
<COND (.NOT?
|
||||||
|
<TRZ .OBJ .M>)
|
||||||
|
(<TRO .OBJ .M>)>)
|
||||||
|
(<ILLEGAL "Not an object flag/MAKE">)>)
|
||||||
|
(<TYPE? .OBJ ROOM>
|
||||||
|
<COND (<SET M <ZLOOKUP <SPNAME <COND (.NOT? <3 .LST>) (<2 .LST>)>>
|
||||||
|
,ZRBITS-POBL>>
|
||||||
|
<COND (.NOT?
|
||||||
|
<RTRZ .OBJ .M>)
|
||||||
|
(<RTRO .OBJ .M>)>)
|
||||||
|
(<ILLEGAL "Not a room flag/MAKE">)>)
|
||||||
|
(<ILLEGAL "Not a room or object/MAKE">)>>
|
||||||
|
|
||||||
|
<DEFINE ZTOPLEVEL () <ERRET>>
|
||||||
|
|
||||||
|
<DEFINE ZSTACK& () <ZSTACK T>>
|
||||||
|
|
||||||
|
<DEFINE ZSTACK ("OPTIONAL" (FLG <>) "AUX" (F <FRAME>) (LEVEL -1) ARG)
|
||||||
|
#DECL ((FLG) <OR ATOM FALSE> (F) FRAME (LEVEL) FIX (ARG) ANY)
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<==? <FUNCT .F> TOPLEVEL>
|
||||||
|
<PRINC "toplevel">
|
||||||
|
<RETURN>)
|
||||||
|
(<AND <==? <FUNCT .F> EVAL>
|
||||||
|
<TYPE? <SET ARG <1 <ARGS .F>>> FORM>
|
||||||
|
<OR <==? <1 .ARG> ZEVAL>
|
||||||
|
<==? <1 .ARG> ZPRED>
|
||||||
|
<==? <1 .ARG> ILLEGAL>>>
|
||||||
|
<PRIN1 <SET LEVEL <+ .LEVEL 1>>>
|
||||||
|
<PRINC !\ >
|
||||||
|
<PRIN1 <1 .ARG>>
|
||||||
|
<INDENT-TO 10>
|
||||||
|
<COND (.FLG
|
||||||
|
<&1 <EVAL <2 .ARG> .F>>
|
||||||
|
<AND <==? <1 .ARG> ZPRED>
|
||||||
|
<CRLF>
|
||||||
|
<INDENT-TO 10>
|
||||||
|
<&1 <EVAL <3 .ARG> .F>>>)
|
||||||
|
(<EPRIN1 <EVAL <2 .ARG> .F>>
|
||||||
|
<AND <==? <1 .ARG> ZPRED>
|
||||||
|
<CRLF>
|
||||||
|
<INDENT-TO 10>
|
||||||
|
<EPRIN1 <EVAL <3 .ARG> .F>>>)>
|
||||||
|
<CRLF>)>
|
||||||
|
<SET F <FRAME .F>>>
|
||||||
|
,NULL>
|
||||||
|
|
||||||
|
<DEFINE ZRETURN (DUMMY ARGL)
|
||||||
|
#DECL ((ARGL) LIST)
|
||||||
|
<ZRETRY <ZEVAL <2 .ARGL>> <ZEVAL <1 .ARGL>>>>
|
||||||
|
|
||||||
|
<DEFINE ZRETRY (TARGET "OPTIONAL" (VAL #LOSE 0) "AUX" (LEVEL -1) (F <FRAME>) ARG)
|
||||||
|
#DECL ((TARGET LEVEL) FIX (ARG VAL) ANY (F) FRAME)
|
||||||
|
<COND (<TYPE? .TARGET FIX>
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<==? <FUNCT .F> TOPLEVEL>
|
||||||
|
<PRINC "Beyond toplevel?">
|
||||||
|
<RETURN>)
|
||||||
|
(<AND <==? <FUNCT .F> EVAL>
|
||||||
|
<TYPE? <SET ARG <1 <ARGS .F>>> FORM>
|
||||||
|
<OR <==? <1 .ARG> ZEVAL>
|
||||||
|
<==? <1 .ARG> ZPRED>
|
||||||
|
<==? <1 .ARG> ILLEGAL>>
|
||||||
|
<==? <SET LEVEL <+ .LEVEL 1>> .TARGET>>
|
||||||
|
<COND (<TYPE? .VAL LOSE>
|
||||||
|
<RETRY .F>)
|
||||||
|
(<ERRET .VAL .F>)>)>
|
||||||
|
<SET F <FRAME .F>>>)
|
||||||
|
(<ILLEGAL "Bad argument to RETRY/RETURN">)>>
|
||||||
|
|
||||||
|
<DEFINE ZCREATE (DUMMY ARGL "AUX" TYP)
|
||||||
|
#DECL ((ARGL) LIST (TYP) ANY)
|
||||||
|
<COND (<==? <SET TYP <1 .ARGL>> room>
|
||||||
|
<RM/OBJ-CREATE <REST .ARGL> <>>)
|
||||||
|
(<==? .TYP object>
|
||||||
|
<RM/OBJ-CREATE <REST .ARGL>>)
|
||||||
|
(<==? .TYP syntax>
|
||||||
|
<SYNTAX-CREATE <REST .ARGL>>)
|
||||||
|
(<==? .TYP list>
|
||||||
|
<MAPF ,LIST ,ZEVAL <REST .ARGL>>)
|
||||||
|
(<ILLEGAL "Unknown type/CREATE">)>>
|
||||||
|
|
||||||
|
<SETG HI-RM/OBJ 0>
|
||||||
|
|
||||||
|
<DEFINE NEXT-RM/OBJ ()
|
||||||
|
<STRING "Z" <UNPARSE <SETG HI-RM/OBJ <+ ,HI-RM/OBJ 1>>>>>
|
||||||
|
|
||||||
|
<DEFINE RM/OBJ-CREATE (ARGL "OPTIONAL" (OBJ? T)
|
||||||
|
"AUX" NAME (OBJS ()) RM OBJ SYN ADJ)
|
||||||
|
#DECL ((ARGL) LIST (NAME) ATOM (OBJS) <LIST [REST OBJECT]>
|
||||||
|
(RM) ROOM (OBJECT) OBJECT (OBJ?) <OR ATOM FALSE>
|
||||||
|
(SYN) <UVECTOR [REST PSTRING]> (ADJ) <UVECTOR [REST ADJECTIVE]>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (ITEM "AUX" OPER VAL VAL2)
|
||||||
|
#DECL ((ITEM OPER VAL VAL2) ANY)
|
||||||
|
<COND (<TYPE? .ITEM ATOM>
|
||||||
|
<SET NAME .ITEM>
|
||||||
|
<SET VAL <ZLOOKUP <SPNAME .NAME> ,ZVARS-POBL>>
|
||||||
|
<COND (.OBJ?
|
||||||
|
<SET OBJ
|
||||||
|
<COND (<TYPE? .VAL OBJECT> .VAL)
|
||||||
|
(<GET-OBJ <NEXT-RM/OBJ>>)>>)
|
||||||
|
(<SET RM
|
||||||
|
<COND (<TYPE? .VAL ROOM> .VAL)
|
||||||
|
(<GET-ROOM <NEXT-RM/OBJ>>)>>)>)
|
||||||
|
(<TYPE? .ITEM LIST>
|
||||||
|
<COND (<LENGTH? .ITEM 1>
|
||||||
|
<ILLEGAL "Bad format/CREATE">)
|
||||||
|
(<==? <SET OPER <1 .ITEM>> property>
|
||||||
|
<COND (.OBJ?
|
||||||
|
<PUT .OBJ
|
||||||
|
,OFLAGS
|
||||||
|
<BITS-GET ,ZOBITS-POBL <REST .ITEM>>>)
|
||||||
|
(<PUT .RM
|
||||||
|
,RBITS
|
||||||
|
<BITS-GET ,ZRBITS-POBL <REST .ITEM>>>
|
||||||
|
<RTRO .RM ,RLANDBIT>)>)
|
||||||
|
(<AND <SET VAL <2 .ITEM>> <>>)
|
||||||
|
(<==? .OPER name>
|
||||||
|
<COND (.OBJ?
|
||||||
|
<PUT .OBJ ,ODESC2 .VAL>)
|
||||||
|
(<PUT .RM ,RDESC2 .VAL>)>)
|
||||||
|
(<==? .OPER description>
|
||||||
|
<COND (.OBJ?
|
||||||
|
<OPUT .OBJ ODESC1 .VAL T>)
|
||||||
|
(<PUT .RM ,RDESC1 .VAL>)>)
|
||||||
|
(<==? .OPER run>
|
||||||
|
<COND (<TYPE? .VAL ATOM>
|
||||||
|
<COND (<GASSIGNED? .VAL>)
|
||||||
|
(<SETG .VAL ,ZFALSE>)>
|
||||||
|
<COND (.OBJ?
|
||||||
|
<PUT .OBJ ,OACTION .VAL>)
|
||||||
|
(<PUT .RM ,RACTION .VAL>)>)
|
||||||
|
(<ILLEGAL "Bad routine/CREATE">)>)
|
||||||
|
(<==? .OPER contents>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (FOO)
|
||||||
|
#DECL ((FOO) ANY)
|
||||||
|
<COND (<TYPE? <SET VAL2 <ZEVAL .FOO T>>
|
||||||
|
OBJECT>
|
||||||
|
<REMOVE-OBJECT .VAL2>)
|
||||||
|
(<TYPE? .VAL2 LOSE>
|
||||||
|
<SET VAL2
|
||||||
|
<RM/OBJ-CREATE (.FOO)>>)
|
||||||
|
(<ILLEGAL "Bad object/CREATE">)>
|
||||||
|
<SET OBJS (.VAL2 !.OBJS)>>
|
||||||
|
<REST .ITEM>>)
|
||||||
|
(<AND <NOT .OBJ?> <==? .OPER exit>>
|
||||||
|
<ZEXIT .RM <REST .ITEM>>)
|
||||||
|
(<AND .OBJ? <==? .OPER synonym>>
|
||||||
|
<SET SYN
|
||||||
|
<MAPF ,UVECTOR
|
||||||
|
<FUNCTION (NAM)
|
||||||
|
#DECL ((NAM) ANY)
|
||||||
|
<COND (<TYPE? .NAM ATOM>
|
||||||
|
<ZSYN .NAM .OBJ>)
|
||||||
|
(<ILLEGAL "Bad synonym/CREATE">)>>
|
||||||
|
<REST .ITEM>>>)
|
||||||
|
(<AND .OBJ? <==? .OPER adjective>>
|
||||||
|
<SET ADJ
|
||||||
|
<MAPF ,UVECTOR
|
||||||
|
<FUNCTION (NAM)
|
||||||
|
#DECL ((NAM) ANY)
|
||||||
|
<COND (<TYPE? .NAM ATOM>
|
||||||
|
<ADD-ZORK ADJECTIVE <SPNAME .NAM>>)
|
||||||
|
(<ILLEGAL "Bad adjective/CREATE">)>>
|
||||||
|
<REST .ITEM>>>)
|
||||||
|
(<ILLEGAL "Bad identifier/CREATE">)>)>>
|
||||||
|
.ARGL>
|
||||||
|
<ZINSERT <SPNAME .NAME> ,ZDEFS-POBL .ARGL>
|
||||||
|
<COND (.OBJ?
|
||||||
|
<PUT .OBJ ,OCONTENTS ()>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (NOBJ) #DECL ((NOBJ) OBJECT)
|
||||||
|
<INSERT-INTO .OBJ .NOBJ>>
|
||||||
|
.OBJS>
|
||||||
|
<AND <ASSIGNED? SYN> <PUT .OBJ ,ONAMES .SYN>>
|
||||||
|
<AND <ASSIGNED? ADJ> <PUT .OBJ ,OADJS .ADJ>>
|
||||||
|
<ZINSERT <SPNAME .NAME> ,ZVARS-POBL .OBJ>
|
||||||
|
.OBJ)
|
||||||
|
(<PUT .RM ,ROBJS ()>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (NOBJ) #DECL ((NOBJ) OBJECT)
|
||||||
|
<INSERT-OBJECT .NOBJ .RM>>
|
||||||
|
.OBJS>
|
||||||
|
<ZINSERT <SPNAME .NAME> ,ZVARS-POBL .RM>
|
||||||
|
.RM)>>
|
||||||
|
|
||||||
|
<DEFINE ZSYN (NAM OBJ "AUX" (S <SPNAME .NAM>) STR)
|
||||||
|
#DECL ((NAM) ATOM (S STR) STRING (OBJ) OBJECT)
|
||||||
|
<SET STR <UPPERCASE <SUBSTRUC .S 0 <MIN <LENGTH .S> 5>>>>
|
||||||
|
<PINSERT .STR ,OBJECT-POBL .OBJ>
|
||||||
|
<PSTRING .STR>>
|
||||||
|
|
||||||
|
<DEFINE ZEXIT (THIS LST "AUX" DIR RM RM? (NEXIT <>) (CEXIT <>) (CFCN <>) M EXIT)
|
||||||
|
#DECL ((LST) LIST (DIR) <OR DIRECTION FALSE> (RM?) ANY (RM THIS) ROOM
|
||||||
|
(NEXIT) <OR STRING FALSE> (CEXIT CFCN) <OR FALSE ATOM> (EXIT) ANY
|
||||||
|
(M) <OR FALSE <VECTOR [REST DIRECTION ANY]>>)
|
||||||
|
<COND (<LENGTH? .LST 2>
|
||||||
|
<TOOFEW>)
|
||||||
|
(<SET DIR <PLOOKUP <UPPERCASE <PNAME <1 .LST>>> ,DIRECTIONS-POBL>>
|
||||||
|
<COND (<==? <2 .LST> to>
|
||||||
|
<COND (<TYPE? <SET RM? <ZEVAL <3 .LST> T>> ROOM>)
|
||||||
|
(<TYPE? .RM? LOSE>
|
||||||
|
<SET RM? <RM/OBJ-CREATE (<3 .LST>) <>>>)
|
||||||
|
(<TYPE? .RM? STRING>
|
||||||
|
<SET NEXIT .RM?>)
|
||||||
|
(<ILLEGAL "Not-a-room/EXIT">)>
|
||||||
|
<SET RM .RM?>
|
||||||
|
<SET LST <REST .LST 3>>
|
||||||
|
<COND (<EMPTY? .LST>)
|
||||||
|
(<AND <==? <1 .LST> if>
|
||||||
|
<NOT <LENGTH? .LST 1>>>
|
||||||
|
<COND (<==? <2 .LST> run>
|
||||||
|
<COND (<LENGTH? .LST 2>
|
||||||
|
<SET CFCN <3 .LST>>)
|
||||||
|
(<ILLEGAL "Bad format/EXIT">)>)
|
||||||
|
(<SET CEXIT <2 .LST>>)>)
|
||||||
|
(<ILLEGAL "Bad format/EXIT">)>
|
||||||
|
<SET EXIT
|
||||||
|
<COND (.NEXIT <CHTYPE .NEXIT STRING>)
|
||||||
|
(.CEXIT <CEXIT <SPNAME .CEXIT> <RID .RM> "" <> <>>)
|
||||||
|
(.CFCN <CEXIT "FROBOZZ" <RID .RM> "" <> .CFCN>)
|
||||||
|
(.RM)>>
|
||||||
|
<COND (<SET M <MEMQ .DIR <REXITS .THIS>>>
|
||||||
|
<PUT .M 2 .EXIT>)
|
||||||
|
(<PUT .THIS ,REXITS <VECTOR .DIR .EXIT !<REXITS .THIS>>>)>)
|
||||||
|
(<ILLEGAL "Bad format/EXIT">)>)
|
||||||
|
(<ILLEGAL "Unknown-direction: " <1 .LST>>)>>
|
||||||
|
|
||||||
|
<DEFINE BITS-GET (POBL ARGL "AUX" FX)
|
||||||
|
#DECL ((ARGL) LIST (POBL) OBLIST (FX) <OR FIX FALSE>)
|
||||||
|
<MAPF ,+
|
||||||
|
<FUNCTION (ITEM)
|
||||||
|
<COND (<AND <TYPE? .ITEM ATOM>
|
||||||
|
<SET FX <ZLOOKUP <SPNAME .ITEM> .POBL>>>)
|
||||||
|
(<ILLEGAL "Illegal property.">)>>
|
||||||
|
.ARGL>>
|
||||||
|
|
||||||
|
<DEFINE ZOBLIST (ATM NUM)
|
||||||
|
<SETG .ATM <MOBLIST .ATM .NUM>>>
|
||||||
|
|
||||||
|
<DEFINE ZLOOKUP (STR OBL "AUX" ATM)
|
||||||
|
#DECL ((STR) STRING (OBL) OBLIST (ATM) <OR FALSE ATOM>)
|
||||||
|
<AND <SET ATM <LOOKUP .STR .OBL>> ,.ATM>>
|
||||||
|
|
||||||
|
<DEFINE ZINSERT (STR OBL VAL)
|
||||||
|
#DECL ((STR) STRING (OBL) OBLIST (VAL) ANY)
|
||||||
|
<SETG <OR <LOOKUP .STR .OBL> <INSERT .STR .OBL>> .VAL>>
|
||||||
|
|
||||||
|
<DEFINE PINS (POBL VEC)
|
||||||
|
#DECL ((POBL) OBLIST (VEC) <VECTOR [REST <OR STRING ATOM> ANY]>)
|
||||||
|
<REPEAT ((V .VEC) ELEM)
|
||||||
|
#DECL ((V) <VECTOR [REST <OR STRING ATOM> ANY]> (ELEM) <OR STRING ATOM>)
|
||||||
|
<ZINSERT <COND (<TYPE? <SET ELEM <1 .V>> ATOM>
|
||||||
|
<PNAME .ELEM>)
|
||||||
|
(.ELEM)>
|
||||||
|
.POBL
|
||||||
|
<2 .V>>
|
||||||
|
<COND (<EMPTY? <SET V <REST .V 2>>>
|
||||||
|
<RETURN>)>>>
|
||||||
|
|
||||||
|
<ZOBLIST ZOBITS-POBL 17>
|
||||||
|
<ZOBLIST ZRBITS-POBL 17>
|
||||||
|
<ZOBLIST ZVARS-POBL 17>
|
||||||
|
<ZOBLIST ZDEFS-POBL 17>
|
||||||
|
<ZOBLIST ZINT-POBL 17>
|
||||||
|
|
||||||
|
<ZOBLIST ZERO-POBL 17>
|
||||||
|
<ZOBLIST ONE-POBL 17>
|
||||||
|
<ZOBLIST TWO-POBL 17>
|
||||||
|
<ZOBLIST ANY-POBL 17>
|
||||||
|
|
||||||
|
<SETG ZINTS ()>
|
||||||
|
|
||||||
|
<GDECL (ZINTS) <LIST [REST ATOM CEVENT]>>
|
||||||
|
|
||||||
|
<PINS ,ANY-POBL
|
||||||
|
["edit" ,ZEDIT "pprint" ,ZPPRINT
|
||||||
|
"if" ,ZIF "case" ,ZCASE "for-each" ,ZFOR-EACH "contents" ,ZCONTENTS
|
||||||
|
"is" ,ZIS "isnt" ,ZISNT
|
||||||
|
"define" ,ZDEFINE "set" ,ZSET "run" ,ZRUN "lookup" ,ZLKUP
|
||||||
|
"remove" ,ZREMOVE "insert" ,ZPUTIN "return" ,ZRETURN "put" ,ZPUTIN
|
||||||
|
"print" ,ZTELL "make" ,ZMAKE "create" ,ZCREATE]>
|
||||||
|
|
||||||
|
<PINS ,TWO-POBL
|
||||||
|
["and" ,ZAND "or" ,ZOR "plus" ,ZPLUS "minus" ,ZMINUS
|
||||||
|
"times" ,ZTIMES "divided-by" ,ZDIVIDED "is-greater-than" ,ZGREATER
|
||||||
|
"is-less-than" ,ZLESS "gt" ,ZGREATER "lt" ,ZLESS "eq" ,ZEQUAL
|
||||||
|
"equals" ,ZEQUAL]>
|
||||||
|
|
||||||
|
<PINS ,ONE-POBL
|
||||||
|
["retry" ,ZRETRY "goto" ,ZGOTO "take" ,ZTAKE
|
||||||
|
"load" ,ZLOAD "dump" ,ZDUMP "enable" ,ZENABLE "disable" ,ZDISABLE
|
||||||
|
]>
|
||||||
|
|
||||||
|
<PINS ,ZERO-POBL
|
||||||
|
["stack" ,ZSTACK "stack&" ,ZSTACK& "toplevel" ,ZTOPLEVEL
|
||||||
|
"me" ,ZWINNER "hand" ,ZWINNER "player" ,ZWINNER
|
||||||
|
"handled" ,ZTRUE
|
||||||
|
"not-handled" ,ZFALSE
|
||||||
|
"room" ,ZROOM "here" ,ZROOM
|
||||||
|
"verb" ,ZVERB "zork" ,ZZORK
|
||||||
|
"objo" ,ZPRSO "direct-object" ,ZPRSO "object" ,ZPRSO
|
||||||
|
"indirect-object" ,ZPRSI "obji" ,ZPRSI "it" ,ZIT
|
||||||
|
"score" ,ZSCORE]>
|
||||||
|
|
||||||
|
<PINS ,ZOBITS-POBL
|
||||||
|
["visible" ,OVISON "readable" ,READBIT "burnable" ,BURNBIT
|
||||||
|
"weapon" ,WEAPONBIT "takeable" ,TAKEBIT "villain" ,VILLAIN
|
||||||
|
"container" ,CONTBIT "edible" ,FOODBIT "transparent" ,TRANSBIT
|
||||||
|
"indescribable" ,NDESCBIT "drinkable" ,DRINKBIT "potable" ,DRINKBIT
|
||||||
|
"light" ,LIGHTBIT "victim" ,VICBIT "flaming" ,FLAMEBIT "tool" ,TOOLBIT
|
||||||
|
"turnable" ,TURNBIT "vehicle" ,VEHBIT "sacred" ,SACREDBIT "tieable"
|
||||||
|
,TIEBIT "climbable" ,CLIMBBIT "open" ,OPENBIT "touched" ,TOUCHBIT
|
||||||
|
"on" ,ONBIT]>
|
||||||
|
|
||||||
|
<PINS ,ZRBITS-POBL
|
||||||
|
["land" ,RLANDBIT "seen" ,RSEENBIT "illuminated" ,RLIGHTBIT
|
||||||
|
"sacred" ,RSACREDBIT "reservoir" ,RFILLBIT
|
||||||
|
"inaccessible" ,RMUNGBIT "wallless" ,RNWALLBIT]>
|
||||||
|
|
||||||
|
<SETG BUZZ ![a the is]>
|
||||||
|
|
||||||
|
<SETG NOTS [not isnt]>
|
||||||
|
|
||||||
|
<SETG TEST-TYPES [in]>
|
||||||
|
|
||||||
|
<DEFINE ILLEGAL ("OPTIONAL" (STR "Illegal operation.") (STR2 ""))
|
||||||
|
#DECL ((STR) STRING)
|
||||||
|
<TELL .STR 0 .STR2>
|
||||||
|
<LISTEN>>
|
||||||
|
|
||||||
|
<DEFINE TOOFEW ("OPTIONAL" WHAT)
|
||||||
|
<TELL "Too few arguments" 0>
|
||||||
|
<AND <ASSIGNED? WHAT> <TELL " to " 0 .WHAT>>
|
||||||
|
<LISTEN>>
|
||||||
|
|
||||||
|
<DEFINE WNA ()
|
||||||
|
<TELL "Wrong number of arguments." 0>
|
||||||
|
<LISTEN>>
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,344 @@
|
||||||
|
|
||||||
|
<GDECL (GLOHI STAR-BITS) FIX>
|
||||||
|
|
||||||
|
<DEFINE MPOBLIST (ATM LEN)
|
||||||
|
#DECL ((ATM) ATOM (LEN) FIX)
|
||||||
|
<SETG .ATM <CHTYPE <IUVECTOR .LEN ()> POBLIST>>>
|
||||||
|
|
||||||
|
<DEFINE PINSERT (NAME OBL VAL "AUX" BUCKET BUCK TL)
|
||||||
|
#DECL ((NAME) <OR STRING <PRIMTYPE WORD>> (OBL) POBLIST (VAL) ANY (BUCK) FIX
|
||||||
|
(TL) <OR LIST FALSE>)
|
||||||
|
<COND (<TYPE? .NAME STRING>
|
||||||
|
<SET NAME <PSTRING .NAME>>)
|
||||||
|
(<NOT <TYPE? .NAME PSTRING>>
|
||||||
|
<SET NAME <CHTYPE .NAME PSTRING>>)>
|
||||||
|
<SET BUCK <HASH .NAME .OBL>>
|
||||||
|
<COND (<SET TL <MEMQ .NAME <SET BUCKET <NTH .OBL .BUCK>>>>
|
||||||
|
<PUT .TL 2 .VAL>)
|
||||||
|
(T
|
||||||
|
<PUT .OBL .BUCK (.NAME .VAL !.BUCKET)>)>
|
||||||
|
.VAL>
|
||||||
|
|
||||||
|
<DEFINE CEVENT (TICK APP FLG NAME "OPTIONAL" (DEATH <>)
|
||||||
|
"AUX" (OBL <GET INITIAL OBLIST>) ATM)
|
||||||
|
#DECL ((TICK) FIX (APP) <OR ATOM NOFFSET> (FLG DEATH) <OR ATOM FALSE>
|
||||||
|
(OBL) OBLIST (NAME) <OR ATOM STRING> (ATM) <OR ATOM FALSE>)
|
||||||
|
<COND (<TYPE? .NAME STRING>
|
||||||
|
<COND (<SET ATM <LOOKUP .NAME .OBL>>)
|
||||||
|
(T <SET ATM <INSERT .NAME .OBL>>)>)
|
||||||
|
(<SET ATM .NAME>)>
|
||||||
|
<SETG .ATM <CHTYPE [.TICK .APP .FLG .ATM .DEATH] CEVENT>>>
|
||||||
|
|
||||||
|
<DEFINE CEXIT (FLID RMID "OPTIONAL" (STR <>) (FLAG <>) (FUNCT <>) "AUX" ATM)
|
||||||
|
#DECL ((STR) <OR FALSE STRING> (FLID RMID) <OR ATOM STRING>
|
||||||
|
(ATM FUNCT) <OR ATOM FALSE> (FLAG) <OR ATOM FALSE>)
|
||||||
|
<COND (<TYPE? .FLID ATOM> <SET FLID <SPNAME .FLID>>)>
|
||||||
|
<SET ATM <OR <LOOKUP .FLID <GET FLAG OBLIST>>
|
||||||
|
<INSERT .FLID <GET FLAG OBLIST>>>>
|
||||||
|
<SETG .ATM .FLAG>
|
||||||
|
<CHTYPE <VECTOR .ATM <GET-ROOM .RMID> .STR .FUNCT> CEXIT>>
|
||||||
|
|
||||||
|
<DEFINE DOOR (OID RM1 RM2 "OPTIONAL" (STR <>) (FN <>) "AUX" (OBJ <GET-OBJ .OID>))
|
||||||
|
#DECL ((OID) STRING (STR) <OR STRING FALSE> (FN) <OR ATOM FALSE>
|
||||||
|
(OBJ) OBJECT (RM1 RM2) <OR STRING ROOM>)
|
||||||
|
<COND (<FIND-DOOR <SET RM1 <GET-ROOM .RM1>> .OBJ>)
|
||||||
|
(<FIND-DOOR <SET RM2 <GET-ROOM .RM2>> .OBJ>)
|
||||||
|
(<CHTYPE [.OBJ .RM1 .RM2 .STR .FN] DOOR>)>>
|
||||||
|
|
||||||
|
<DEFINE EXIT ("TUPLE" PAIRS
|
||||||
|
"AUX" (DOBL ,DIRECTIONS-POBL) (FROB <IVECTOR <LENGTH .PAIRS>>)
|
||||||
|
DIR)
|
||||||
|
#DECL ((PAIRS) <TUPLE [REST STRING <OR DOOR NEXIT CEXIT STRING ATOM>]>
|
||||||
|
(DIR) DIRECTION (FROB) VECTOR (DOBL) POBLIST)
|
||||||
|
<REPEAT ((F .FROB))
|
||||||
|
#DECL ((F) VECTOR)
|
||||||
|
<COND (<SET DIR <PLOOKUP <1 .PAIRS> .DOBL>>
|
||||||
|
<PUT .F 1 .DIR>
|
||||||
|
<COND (<TYPE? <2 .PAIRS> STRING>
|
||||||
|
<PUT .F 2 <GET-ROOM <2 .PAIRS>>>)
|
||||||
|
(<PUT .F 2 <2 .PAIRS>>)>
|
||||||
|
<SET F <REST .F 2>>)>
|
||||||
|
<COND (<EMPTY? <SET PAIRS <REST .PAIRS 2>>> <RETURN>)>>
|
||||||
|
<CHTYPE .FROB EXIT>>
|
||||||
|
|
||||||
|
<DEFINE ROOM (ID D1 D2 EX
|
||||||
|
"OPTIONAL" (OBJS ()) (APP <>) (BIT ,RLANDBIT) (PROPS ())
|
||||||
|
"AUX" (RM <GET-ROOM .ID>) VAL M)
|
||||||
|
#DECL ((ID D1 D2) STRING (EX) EXIT (APP) <OR FALSE ATOM> (BIT VAL) FIX
|
||||||
|
(RM) ROOM (PROPS) <LIST [REST ATOM ANY]>
|
||||||
|
(M) <OR FALSE <LIST ATOM FIX>>)
|
||||||
|
<SET VAL <COND (<SET M <MEMQ RVAL .PROPS>> <2 .M>) (0)>>
|
||||||
|
<COND (<NOT <0? <CHTYPE <ANDB .BIT ,RENDGAME> FIX>>>
|
||||||
|
<SETG EG-SCORE-MAX <+ ,EG-SCORE-MAX .VAL>>)
|
||||||
|
(<SETG SCORE-MAX <+ ,SCORE-MAX .VAL>>)>
|
||||||
|
<COND (<SET M <MEMQ RGLOBAL .PROPS>> <PUT .M 2 <+ <2 .M> ,STAR-BITS>>)>
|
||||||
|
<PUT .RM ,ROBJS .OBJS>
|
||||||
|
<PUT .RM ,RDESC1 .D1>
|
||||||
|
<PUT .RM ,RDESC2 .D2>
|
||||||
|
<PUT .RM ,REXITS .EX>
|
||||||
|
<PUT .RM ,RACTION .APP>
|
||||||
|
<PUT .RM ,RPROPS .PROPS>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) OBJECT) <PUT .X ,OROOM .RM>>
|
||||||
|
<ROBJS .RM>>
|
||||||
|
<PUT .RM ,RBITS .BIT>
|
||||||
|
.RM>
|
||||||
|
|
||||||
|
<DEFINE FIND-PREP (STR "AUX" VAL)
|
||||||
|
#DECL ((STR) STRING)
|
||||||
|
<COND (<SET VAL <PLOOKUP .STR ,WORDS-POBL>>
|
||||||
|
<COND (<TYPE? .VAL PREP> .VAL)
|
||||||
|
(<ERROR NO-PREP!-ERRORS>)>)
|
||||||
|
(<PINSERT .STR ,WORDS-POBL <CHTYPE <PSTRING .STR> PREP>>)>>
|
||||||
|
|
||||||
|
<DEFINE ADD-ACTION (NAM STR "TUPLE" DECL "AUX" (ACTIONS ,ACTIONS-POBL))
|
||||||
|
#DECL ((NAM STR) STRING (DECL) <TUPLE [REST VECTOR]>
|
||||||
|
(ACTIONS) POBLIST)
|
||||||
|
<PINSERT .NAM .ACTIONS <CHTYPE [<PSTRING .NAM> <MAKE-ACTION !.DECL> .STR] ACTION>>>
|
||||||
|
|
||||||
|
<DEFINE ADD-DIRECTIONS ("TUPLE" NMS "AUX" (DIR ,DIRECTIONS-POBL))
|
||||||
|
#DECL ((NMS) <TUPLE [REST STRING]> (DIR) POBLIST)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) <PINSERT .X .DIR <CHTYPE <PSTRING .X> DIRECTION>>>
|
||||||
|
.NMS>>
|
||||||
|
|
||||||
|
<DEFINE DSYNONYM (STR
|
||||||
|
"TUPLE" NMS
|
||||||
|
"AUX" (DIR ,DIRECTIONS-POBL) (VAL <PLOOKUP .STR .DIR>))
|
||||||
|
#DECL ((STR) STRING (NMS) <TUPLE [REST STRING]> (VAL) DIRECTION (DIR) POBLIST)
|
||||||
|
<MAPF <> <FUNCTION (X) <PINSERT .X .DIR .VAL>> .NMS>>
|
||||||
|
|
||||||
|
<DEFINE VSYNONYM (N1 "TUPLE" N2 "AUX" VAL (ACTIONS ,ACTIONS-POBL))
|
||||||
|
#DECL ((N1) STRING (N2) <TUPLE [REST STRING]> (VAL) ANY (ACTIONS) POBLIST)
|
||||||
|
<COND (<SET VAL <PLOOKUP .N1 .ACTIONS>>
|
||||||
|
<MAPF <> <FUNCTION (X) <PINSERT .X .ACTIONS .VAL>> .N2>)>>
|
||||||
|
|
||||||
|
"STUFF FOR ADDING TO VOCABULARY, ADDING TO LISTS (OF DEMONS, FOR EXAMPLE)."
|
||||||
|
|
||||||
|
<DEFINE ADD-BUZZ ("TUPLE" W)
|
||||||
|
#DECL ((W) <TUPLE [REST STRING]>)
|
||||||
|
<ADD-ZORK BUZZ !.W>>
|
||||||
|
|
||||||
|
<DEFINE ADD-ZORK (NM "TUPLE" W)
|
||||||
|
#DECL ((NM) ATOM (W) <TUPLE [REST STRING]>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) STRING)
|
||||||
|
<PINSERT .X ,WORDS-POBL <CHTYPE <PSTRING .X> .NM>>>
|
||||||
|
.W>>
|
||||||
|
|
||||||
|
<DEFINE SYNONYM (N1 "TUPLE" N2 "AUX" VAL (WORDS ,WORDS-POBL))
|
||||||
|
#DECL ((N1) STRING (N2) <TUPLE [REST STRING]> (VAL) ANY (WORDS) POBLIST)
|
||||||
|
<COND (<SET VAL <PLOOKUP .N1 .WORDS>>
|
||||||
|
<MAPF <> <FUNCTION (X) <PINSERT .X .WORDS .VAL>> .N2>)>>
|
||||||
|
|
||||||
|
<DEFINE ADD-DEMON (X) #DECL ((X) HACK)
|
||||||
|
<COND (<MAPR <>
|
||||||
|
<FUNCTION (Y) #DECL ((Y) <LIST [REST HACK]>)
|
||||||
|
<COND (<==? <HACTION <1 .Y>> <HACTION .X>>
|
||||||
|
<PUT .Y 1 .X>
|
||||||
|
<MAPLEAVE T>)>>
|
||||||
|
,DEMONS>)
|
||||||
|
(<SETG DEMONS (.X !,DEMONS)>)>>
|
||||||
|
|
||||||
|
<DEFINE ADD-ACTOR (ADV "AUX" (ACTORS ,ACTORS))
|
||||||
|
#DECL ((ADV) ADV (ACTORS) <LIST [REST ADV]>)
|
||||||
|
<COND (<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) ADV)
|
||||||
|
<COND (<==? <AOBJ .X> <AOBJ .ADV>>
|
||||||
|
<MAPLEAVE T>)>>
|
||||||
|
.ACTORS>)
|
||||||
|
(<SETG ACTORS (.ADV !.ACTORS)>)>
|
||||||
|
.ADV>
|
||||||
|
|
||||||
|
<DEFINE SADD-ACTION (STR1 ATM)
|
||||||
|
<ADD-ACTION .STR1 "" [[.STR1 .ATM]]>>
|
||||||
|
|
||||||
|
<DEFINE 1ADD-ACTION (STR1 STR2 ATM)
|
||||||
|
<ADD-ACTION .STR1 .STR2 [OBJ [.STR1 .ATM]]>>
|
||||||
|
|
||||||
|
<DEFINE 1NRADD-ACTION (STR1 STR2 ATM)
|
||||||
|
<ADD-ACTION .STR1 .STR2 [NROBJ [.STR1 .ATM]]>>
|
||||||
|
|
||||||
|
"MAKE-ACTION: Function for creating a verb. Takes;
|
||||||
|
|
||||||
|
vspec => [objspec {\"prep\"} {objspec} [pstring fcn] extras]
|
||||||
|
|
||||||
|
objspec => OBJ | objlist
|
||||||
|
|
||||||
|
objlist => ( objbits {fwimbits} {NO-TAKE} {MUST-HAVE} {TRY-TAKE} {=} )
|
||||||
|
|
||||||
|
extras => DRIVER FLIP
|
||||||
|
|
||||||
|
Creates a VSPEC.
|
||||||
|
"
|
||||||
|
|
||||||
|
<DEFINE MAKE-ACTION ("TUPLE" SPECS "AUX" VV SUM (PREP <>) ATM VERB)
|
||||||
|
#DECL ((SPECS) TUPLE (VV) <PRIMTYPE VECTOR> (SUM) FIX (PREP ATM) ANY
|
||||||
|
(VERB) VERB)
|
||||||
|
<CHTYPE
|
||||||
|
<MAPF ,UVECTOR
|
||||||
|
<FUNCTION (SP "AUX" (SYN <VECTOR <> <> <> 0>) (WHR 1))
|
||||||
|
#DECL ((SP) VECTOR (SYN) VECTOR (WHR) FIX)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (ITM)
|
||||||
|
#DECL ((ITM) ANY)
|
||||||
|
<COND (<TYPE? .ITM STRING> <SET PREP <FIND-PREP .ITM>>)
|
||||||
|
(<AND <==? .ITM OBJ>
|
||||||
|
<SET ITM '(-1 REACH ROBJS AOBJS)>
|
||||||
|
<>>)
|
||||||
|
(<AND <==? .ITM NROBJ>
|
||||||
|
<SET ITM '(-1 ROBJS AOBJS)>
|
||||||
|
<>>)
|
||||||
|
(<TYPE? .ITM LIST>
|
||||||
|
<SET VV <IVECTOR 4>>
|
||||||
|
<PUT .VV ,VBIT <1 .ITM>>
|
||||||
|
<COND (<AND <NOT <LENGTH? .ITM 1>>
|
||||||
|
<TYPE? <2 .ITM> FIX>>
|
||||||
|
<PUT .VV ,VFWIM <2 .ITM>>)
|
||||||
|
(ELSE
|
||||||
|
<PUT .VV ,VBIT -1>
|
||||||
|
<PUT .VV ,VFWIM <1 .ITM>>)>
|
||||||
|
<AND <MEMQ = .ITM> <PUT .VV ,VBIT <VFWIM .VV>>>
|
||||||
|
<PUT .VV ,VPREP .PREP>
|
||||||
|
<SET SUM 0>
|
||||||
|
<SET PREP <>>
|
||||||
|
<AND <MEMQ AOBJS .ITM> <SET SUM <+ .SUM ,VABIT>>>
|
||||||
|
<AND <MEMQ ROBJS .ITM> <SET SUM <+ .SUM ,VRBIT>>>
|
||||||
|
<AND <MEMQ NO-TAKE .ITM> <SET SUM .SUM>>
|
||||||
|
<AND <MEMQ HAVE .ITM> <SET SUM <+ .SUM ,VCBIT>>>
|
||||||
|
<AND <MEMQ REACH .ITM> <SET SUM <+ .SUM ,VFBIT>>>
|
||||||
|
<AND <MEMQ TRY .ITM> <SET SUM <+ .SUM ,VTBIT>>>
|
||||||
|
<AND <MEMQ TAKE .ITM>
|
||||||
|
<SET SUM <+ .SUM ,VTBIT ,VCBIT>>>
|
||||||
|
<PUT .VV ,VWORD .SUM>
|
||||||
|
<PUT .SYN .WHR <CHTYPE .VV VARG>>
|
||||||
|
<SET WHR <+ .WHR 1>>)
|
||||||
|
(<TYPE? .ITM VECTOR>
|
||||||
|
<SET VERB <FIND-VERB <1 .ITM>>>
|
||||||
|
<COND (<==? <VFCN .VERB> T>
|
||||||
|
<PUT .VERB ,VFCN <2 .ITM>>)>
|
||||||
|
<PUT .SYN ,SFCN .VERB>)
|
||||||
|
(<==? .ITM DRIVER>
|
||||||
|
<PUT .SYN
|
||||||
|
,SFLAGS
|
||||||
|
<CHTYPE <ORB <SFLAGS .SYN> ,SDRIVER> FIX>>)
|
||||||
|
(<==? .ITM FLIP>
|
||||||
|
<PUT .SYN
|
||||||
|
,SFLAGS
|
||||||
|
<CHTYPE <ORB <SFLAGS .SYN> ,SFLIP> FIX>>)>>
|
||||||
|
.SP>
|
||||||
|
<OR <SYN1 .SYN> <PUT .SYN ,SYN1 ,EVARG>>
|
||||||
|
<OR <SYN2 .SYN> <PUT .SYN ,SYN2 ,EVARG>>
|
||||||
|
<CHTYPE .SYN SYNTAX>>
|
||||||
|
.SPECS>
|
||||||
|
VSPEC>>
|
||||||
|
|
||||||
|
"Default value for syntax slots not specified"
|
||||||
|
|
||||||
|
<SETG EVARG <CHTYPE [0 0 <> 0] VARG>>
|
||||||
|
|
||||||
|
<GDECL (EVARG) VARG>
|
||||||
|
|
||||||
|
;"To add VERBs to the BUNCHERS list"
|
||||||
|
|
||||||
|
<DEFINE ADD-BUNCHER ("TUPLE" STRS)
|
||||||
|
#DECL ((STRS) <TUPLE [REST STRING]>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (STR)
|
||||||
|
#DECL ((STR) STRING)
|
||||||
|
<SETG BUNCHERS
|
||||||
|
(<FIND-VERB .STR> !,BUNCHERS)>>
|
||||||
|
.STRS>>
|
||||||
|
|
||||||
|
; "For making end game questions"
|
||||||
|
|
||||||
|
<DEFINE ADD-QUESTION (STR VEC)
|
||||||
|
#DECL ((STR) STRING (VEC) VECTOR)
|
||||||
|
<PUT <SETG QVEC <BACK ,QVEC>>
|
||||||
|
1
|
||||||
|
<CHTYPE [.STR .VEC] QUESTION>>
|
||||||
|
<AND <TYPE? <1 .VEC> OBJECT>
|
||||||
|
<ADD-INQOBJ <1 .VEC>>>>
|
||||||
|
|
||||||
|
<DEFINE ADD-INQOBJ (OBJ)
|
||||||
|
#DECL ((OBJ) OBJECT)
|
||||||
|
<SETG INQOBJS (.OBJ !,INQOBJS)>>
|
||||||
|
|
||||||
|
<GDECL (GLOBAL-OBJECTS) <LIST [REST OBJECT]>>
|
||||||
|
|
||||||
|
<DEFINE GOBJECT (NAM IDS ADJS STR FLAGS
|
||||||
|
"OPTIONAL" (APP <>) (CONTS ()) (PROPS (OGLOBAL 0))
|
||||||
|
"AUX" OBJ BITS)
|
||||||
|
#DECL ((IDS ADJS) <VECTOR [REST STRING]> (STR) STRING (FLAGS) FIX
|
||||||
|
(APP) <OR ATOM FALSE> (OBJ) OBJECT
|
||||||
|
(NAM) <OR FALSE ATOM> (CONTS) LIST (PROPS) LIST)
|
||||||
|
<SET OBJ <OBJECT .IDS .ADJS .STR .FLAGS .APP .CONTS .PROPS>>
|
||||||
|
<COND (.NAM
|
||||||
|
<COND (<GASSIGNED? .NAM> <SET BITS ,.NAM>)
|
||||||
|
(<SETG GLOHI <SET BITS <* ,GLOHI 2>>>
|
||||||
|
<SETG .NAM .BITS>)>)
|
||||||
|
(<SETG GLOHI <SET BITS <* ,GLOHI 2>>>
|
||||||
|
<SETG STAR-BITS <+ ,STAR-BITS .BITS>>)>
|
||||||
|
<OGLOBAL .OBJ .BITS>
|
||||||
|
<COND (<NOT <GASSIGNED? GLOBAL-OBJECTS>>
|
||||||
|
<SETG GLOBAL-OBJECTS ()>)>
|
||||||
|
<COND (<NOT <MEMQ .OBJ ,GLOBAL-OBJECTS>>
|
||||||
|
<SETG GLOBAL-OBJECTS (.OBJ !,GLOBAL-OBJECTS)>)>
|
||||||
|
.OBJ>
|
||||||
|
|
||||||
|
<DEFINE OBJECT (NAMES ADJS DESC FLAGS
|
||||||
|
"OPTIONAL" (ACTION <>) (CONTENTS ()) (PROPS ())
|
||||||
|
"AUX" (OBJ <GET-OBJ <1 .NAMES>>) (OBJS ,OBJECT-POBL))
|
||||||
|
#DECL ((NAMES ADJS) <VECTOR [REST STRING]> (DESC) STRING (FLAGS) FIX
|
||||||
|
(ACTION) <OR FALSE RAPPLIC> (CONTENTS) <LIST [REST OBJECT]>
|
||||||
|
(PROPS) <LIST [REST ATOM ANY]> (OBJ) OBJECT (OBJS) POBLIST)
|
||||||
|
<PUT .OBJ ,ONAMES
|
||||||
|
<MAPF ,UVECTOR
|
||||||
|
<FUNCTION (X) #DECL ((X) STRING)
|
||||||
|
<COND (<PLOOKUP .X .OBJS>
|
||||||
|
<PSTRING .X>)
|
||||||
|
(T
|
||||||
|
<PINSERT .X .OBJS .OBJ>
|
||||||
|
<PSTRING .X>)>>
|
||||||
|
.NAMES>>
|
||||||
|
<PUT .OBJ
|
||||||
|
,OADJS
|
||||||
|
<MAPF ,UVECTOR <FUNCTION (W) <ADD-ZORK ADJECTIVE .W>> .ADJS>>
|
||||||
|
<CHUTYPE <OADJS .OBJ> ADJECTIVE>
|
||||||
|
<PUT .OBJ ,ODESC2 .DESC>
|
||||||
|
<PUT .OBJ ,OFLAGS .FLAGS>
|
||||||
|
<PUT .OBJ ,OACTION .ACTION>
|
||||||
|
<PUT .OBJ ,OCONTENTS .CONTENTS>
|
||||||
|
<MAPF <> <FUNCTION (X) <PUT .X ,OCAN .OBJ>> .CONTENTS>
|
||||||
|
<PUT .OBJ ,OPROPS .PROPS>
|
||||||
|
<SETG SCORE-MAX <+ ,SCORE-MAX <OTVAL .OBJ> <OFVAL .OBJ>>>
|
||||||
|
.OBJ>
|
||||||
|
|
||||||
|
<DEFINE GET-OBJ (STR "AUX" ATM OBJ O)
|
||||||
|
#DECL ((STR) STRING (ATM) <OR FALSE ATOM> (OBJ) OBJECT (O) <OR FALSE OBJECT>)
|
||||||
|
<COND (<AND <SET O <PLOOKUP .STR ,OBJECT-POBL>>
|
||||||
|
<==? <PSTRING .STR> <OID .O>>> .O)
|
||||||
|
(<PINSERT .STR ,OBJECT-POBL
|
||||||
|
<SET OBJ <CHTYPE [<UVECTOR <PSTRING .STR>>
|
||||||
|
'![] "" 0 <> () <> <> ()] OBJECT>>>
|
||||||
|
<SETG OBJECTS (.OBJ !,OBJECTS)>
|
||||||
|
.OBJ)>>
|
||||||
|
|
||||||
|
<DEFINE GET-ROOM (ID "AUX" ROOM)
|
||||||
|
#DECL ((ID) <OR ATOM STRING> (VALUE) ROOM (ROOM) ROOM)
|
||||||
|
<COND (<PLOOKUP .ID ,ROOM-POBL>)
|
||||||
|
(<PINSERT .ID
|
||||||
|
,ROOM-POBL
|
||||||
|
<SET ROOM
|
||||||
|
<CHTYPE <VECTOR <PSTRING .ID>
|
||||||
|
,NULL-DESC
|
||||||
|
,NULL-DESC
|
||||||
|
,NULL-EXIT
|
||||||
|
()
|
||||||
|
<>
|
||||||
|
0
|
||||||
|
()>
|
||||||
|
ROOM>>>
|
||||||
|
<SETG ROOMS (.ROOM !,ROOMS)>
|
||||||
|
.ROOM)>>
|
|
@ -0,0 +1,324 @@
|
||||||
|
|
||||||
|
"
|
||||||
|
0 -- attacker misses
|
||||||
|
1 -- defender unconscious
|
||||||
|
2 -- defender dead
|
||||||
|
3 -- defender lightly wounded
|
||||||
|
4 -- defender seriously wounded
|
||||||
|
5 -- staggered
|
||||||
|
6 -- loses weapon
|
||||||
|
7 -- hesitate (miss on free swing)
|
||||||
|
8 -- sitting duck (crunch!)
|
||||||
|
"
|
||||||
|
|
||||||
|
<MSETG MISSED 0>
|
||||||
|
|
||||||
|
<MSETG UNCONSCIOUS 1>
|
||||||
|
|
||||||
|
<MSETG KILLED 2>
|
||||||
|
|
||||||
|
<MSETG LIGHT-WOUND 3>
|
||||||
|
|
||||||
|
<MSETG SERIOUS-WOUND 4>
|
||||||
|
|
||||||
|
<MSETG STAGGER 5>
|
||||||
|
|
||||||
|
<MSETG LOSE-WEAPON 6>
|
||||||
|
|
||||||
|
<MSETG HESITATE 7>
|
||||||
|
|
||||||
|
<MSETG SITTING-DUCK 8>
|
||||||
|
|
||||||
|
<SETG STRENGTH-MAX 7>
|
||||||
|
|
||||||
|
<SETG STRENGTH-MIN 2>
|
||||||
|
|
||||||
|
<SETG CURE-WAIT 30>
|
||||||
|
|
||||||
|
<GDECL (DEF1-RES DEF2-RES DEF3-RES)
|
||||||
|
<UVECTOR [REST UVECTOR]>
|
||||||
|
(DEF1 DEF2A DEF2B DEF3A DEF3B DEF3C)
|
||||||
|
<UVECTOR [REST FIX]>
|
||||||
|
(OPPV) VECTOR
|
||||||
|
(VILLAINS) <LIST [REST OBJECT]>
|
||||||
|
(VILLAIN-PROBS) <UVECTOR [REST FIX]>
|
||||||
|
(STRENGTH-MIN STRENGTH-MAX CURE-WAIT) FIX>
|
||||||
|
|
||||||
|
|
||||||
|
<DEFINE FIGHTING (FROB "AUX" (HERE ,HERE) (OPPS ,OPPV) (HERO ,PLAYER) (FIGHT? <>)
|
||||||
|
RANDOM-ACTION (THIEF <SFIND-OBJ "THIEF">))
|
||||||
|
#DECL ((FROB) HACK (OPPS) <VECTOR [REST <OR OBJECT FALSE>]> (HERO) ADV
|
||||||
|
(HERE) ROOM (FIGHT?) <OR ATOM FALSE> (THIEF) OBJECT
|
||||||
|
(RANDOM-ACTION) <OR ATOM NOFFSET FALSE>)
|
||||||
|
<COND
|
||||||
|
(<AND ,PARSE-WON <NOT ,DEAD!-FLAG>>
|
||||||
|
<MAPR <>
|
||||||
|
<FUNCTION (OO OV VOUT "AUX" (O <1 .OO>) (S <OSTRENGTH .O>))
|
||||||
|
#DECL ((OO) <LIST [REST OBJECT]> (OV) VECTOR
|
||||||
|
(VOUT) <UVECTOR [REST FIX]> (O) OBJECT (S) FIX)
|
||||||
|
<PUT .OV 1 <>>
|
||||||
|
<SET RANDOM-ACTION <OACTION .O>>
|
||||||
|
<COND (<==? .HERE <OROOM .O>>
|
||||||
|
<COND (<AND <==? .O .THIEF>
|
||||||
|
,THIEF-ENGROSSED!-FLAG>
|
||||||
|
<SETG THIEF-ENGROSSED!-FLAG <>>)
|
||||||
|
(<L? .S 0>
|
||||||
|
<COND (<AND <NOT <0? <1 .VOUT>>>
|
||||||
|
<PROB <1 .VOUT>
|
||||||
|
</ <+ <1 .VOUT> 100> 2>>>
|
||||||
|
<OSTRENGTH .O <- .S>>
|
||||||
|
<PUT .VOUT 1 0>
|
||||||
|
<AND .RANDOM-ACTION
|
||||||
|
<PERFORM .RANDOM-ACTION
|
||||||
|
<FIND-VERB "IN!">>>)
|
||||||
|
(<PUT .VOUT 1 <+ <1 .VOUT> 10>>)>)
|
||||||
|
(<TRNN .O ,FIGHTBIT>
|
||||||
|
<SET FIGHT? T>
|
||||||
|
<PUT .OV 1 .O>)
|
||||||
|
(.RANDOM-ACTION
|
||||||
|
<COND (<PERFORM .RANDOM-ACTION <FIND-VERB "1ST?">>
|
||||||
|
<SET FIGHT? T>
|
||||||
|
<TRO .O ,FIGHTBIT>
|
||||||
|
<SETG PARSE-CONT <>>
|
||||||
|
<PUT .OV 1 .O>)>)>)
|
||||||
|
(<N==? .HERE <OROOM .O>>
|
||||||
|
<COND (<TRNN .O ,FIGHTBIT>
|
||||||
|
<COND (.RANDOM-ACTION
|
||||||
|
<PERFORM .RANDOM-ACTION <FIND-VERB "FGHT?">>)>)>
|
||||||
|
<AND <==? .O .THIEF>
|
||||||
|
<SETG THIEF-ENGROSSED!-FLAG <>>>
|
||||||
|
<ATRZ .HERO ,ASTAGGERED>
|
||||||
|
<TRZ .O ,STAGGERED>
|
||||||
|
<TRZ .O ,FIGHTBIT>
|
||||||
|
<COND (<L? .S 0>
|
||||||
|
<OSTRENGTH .O <- .S>>
|
||||||
|
<COND (.RANDOM-ACTION
|
||||||
|
<PERFORM .RANDOM-ACTION <FIND-VERB "IN!">>)>)>)>>
|
||||||
|
,VILLAINS
|
||||||
|
.OPPS
|
||||||
|
,VILLAIN-PROBS>
|
||||||
|
<COND (.FIGHT?
|
||||||
|
<CLOCK-INT ,CURIN>
|
||||||
|
<REPEAT ((OUT <>) RES)
|
||||||
|
#DECL ((OUT) <OR FIX FALSE> (RES) <OR FIX FALSE>)
|
||||||
|
<COND (<MAPF <>
|
||||||
|
<FUNCTION (O)
|
||||||
|
#DECL ((O) <OR OBJECT FALSE>)
|
||||||
|
<COND (<NOT .O>)
|
||||||
|
(<AND <SET RANDOM-ACTION <OACTION .O>>
|
||||||
|
<PERFORM .RANDOM-ACTION <FIND-VERB "FGHT?">>>)
|
||||||
|
(<NOT <SET RES
|
||||||
|
<BLOW .HERO .O <OFMSGS .O> <> .OUT>>>
|
||||||
|
<MAPLEAVE <>>)
|
||||||
|
(<==? .RES ,UNCONSCIOUS>
|
||||||
|
<SET OUT <+ 2 <MOD <RANDOM> 3>>>)
|
||||||
|
(T)>>
|
||||||
|
.OPPS>
|
||||||
|
<COND (<NOT .OUT> <RETURN>)
|
||||||
|
(<0? <SET OUT <- .OUT 1>>> <RETURN>)>)
|
||||||
|
(ELSE <RETURN>)>>)>)>>
|
||||||
|
|
||||||
|
<DEFINE PRES (TAB A D W "AUX" (L <LENGTH .TAB>))
|
||||||
|
#DECL ((TAB) <UVECTOR [REST VECTOR]> (A D) STRING
|
||||||
|
(W) <OR STRING FALSE>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (S)
|
||||||
|
<COND (<TYPE? .S STRING> <TELL .S 0>)
|
||||||
|
(<TYPE? .S ATOM>
|
||||||
|
<COND (<==? .S A> <TELL .A 0>)
|
||||||
|
(<==? .S D> <TELL .D 0>)
|
||||||
|
(<AND .W <==? .S W>> <TELL .W 0>)>)>>
|
||||||
|
<NTH .TAB <+ 1 <MOD <RANDOM> .L>>>>
|
||||||
|
<TELL "" 1>>
|
||||||
|
|
||||||
|
"The <MAX 1 ...> is strictly a patch, to keep the thing from dying. I doubt
|
||||||
|
it's the right thing.--taa"
|
||||||
|
"It wasn't."
|
||||||
|
|
||||||
|
<DEFINE FIGHT-STRENGTH (HERO "OPTIONAL" (ADJUST? T)
|
||||||
|
"AUX" S (SMAX ,STRENGTH-MAX) (SMIN ,STRENGTH-MIN))
|
||||||
|
#DECL ((HERO) ADV (S SMAX SMIN VALUE) FIX (ADJUST?) <OR ATOM FALSE>)
|
||||||
|
<SET S
|
||||||
|
<+ .SMIN
|
||||||
|
<FIX <+ .5
|
||||||
|
<* <- .SMAX .SMIN>
|
||||||
|
</ <FLOAT <ASCORE .HERO>>
|
||||||
|
<FLOAT ,SCORE-MAX>>>>>>>
|
||||||
|
<COND (.ADJUST? <+ .S <ASTRENGTH .HERO>>)(ELSE .S)>>
|
||||||
|
|
||||||
|
<DEFINE VILLAIN-STRENGTH (VILLAIN
|
||||||
|
"AUX" (OD <OSTRENGTH .VILLAIN>) WV)
|
||||||
|
#DECL ((VILLAIN) OBJECT (WV) <OR FALSE VECTOR>
|
||||||
|
(OD VALUE) FIX)
|
||||||
|
<COND (<G=? .OD 0>
|
||||||
|
<COND (<AND <==? .VILLAIN <SFIND-OBJ "THIEF">>
|
||||||
|
,THIEF-ENGROSSED!-FLAG>
|
||||||
|
<SET OD <MIN .OD 2>>
|
||||||
|
<SETG THIEF-ENGROSSED!-FLAG <>>)>
|
||||||
|
<COND (<AND <NOT <EMPTY? <PRSI>>>
|
||||||
|
<TRNN <PRSI> ,WEAPONBIT>
|
||||||
|
<SET WV <MEMQ .VILLAIN ,BEST-WEAPONS>>
|
||||||
|
<==? <2 .WV> <PRSI>>>
|
||||||
|
<SET OD <MAX 1 <- .OD <3 .WV>>>>)>)>
|
||||||
|
.OD>
|
||||||
|
|
||||||
|
<GDECL (CURIN) CEVENT (BEST-WEAPONS) <VECTOR [REST OBJECT OBJECT FIX]>>
|
||||||
|
|
||||||
|
<DEFINE BLOW (HERO VILLAIN REMARKS HERO? OUT?
|
||||||
|
"AUX" DWEAPON (VDESC <ODESC2 .VILLAIN>) ATT DEF OA OD TBL RES
|
||||||
|
NWEAPON RANDOM-ACTION)
|
||||||
|
#DECL ((HERO) ADV (VILLAIN) OBJECT (DWEAPON NWEAPON) <OR OBJECT FALSE>
|
||||||
|
(RES OA OD ATT DEF FIX) FIX (REMARKS) <UVECTOR [REST UVECTOR]>
|
||||||
|
(HERO?) <OR ATOM FALSE> (VDESC) STRING (TBL) <UVECTOR [REST FIX]>
|
||||||
|
(OUT?) <OR FIX FALSE> (RANDOM-ACTION) <OR ATOM FALSE NOFFSET>)
|
||||||
|
<PROG ()
|
||||||
|
<COND (.HERO?
|
||||||
|
<TRO .VILLAIN ,FIGHTBIT>
|
||||||
|
<COND (<ATRNN .HERO ,ASTAGGERED>
|
||||||
|
<TELL
|
||||||
|
"You are still recovering from that last blow, so your attack is
|
||||||
|
ineffective.">
|
||||||
|
<ATRZ .HERO ,ASTAGGERED>
|
||||||
|
<RETURN>)>
|
||||||
|
<SET OA <SET ATT <MAX 1 <FIGHT-STRENGTH .HERO>>>>
|
||||||
|
<COND (<0? <SET OD <SET DEF <VILLAIN-STRENGTH .VILLAIN>>>>
|
||||||
|
<COND (<==? .VILLAIN <SFIND-OBJ "#####">>
|
||||||
|
<RETURN <JIGS-UP
|
||||||
|
"Well, you really did it that time. Is suicide painless?">>)>
|
||||||
|
<TELL "Attacking the " 1 .VDESC " is pointless.">
|
||||||
|
<RETURN>)>
|
||||||
|
<SET DWEAPON
|
||||||
|
<AND <NOT <EMPTY? <OCONTENTS .VILLAIN>>>
|
||||||
|
<1 <OCONTENTS .VILLAIN>>>>)
|
||||||
|
(ELSE
|
||||||
|
<SETG PARSE-CONT <>>
|
||||||
|
<COND (<ATRNN .HERO ,ASTAGGERED> <ATRZ .HERO ,ASTAGGERED>)>
|
||||||
|
<COND (<TRNN .VILLAIN ,STAGGERED>
|
||||||
|
<TELL "The "
|
||||||
|
1
|
||||||
|
.VDESC
|
||||||
|
" slowly regains his feet.">
|
||||||
|
<TRZ .VILLAIN ,STAGGERED>
|
||||||
|
<RETURN 0>)>
|
||||||
|
<SET OA <SET ATT <VILLAIN-STRENGTH .VILLAIN>>>
|
||||||
|
<COND (<L=? <SET DEF <FIGHT-STRENGTH .HERO>> 0> <RETURN>)>
|
||||||
|
<SET OD <FIGHT-STRENGTH .HERO <>>>
|
||||||
|
<SET DWEAPON <FWIM ,WEAPONBIT <AOBJS .HERO> T>>)>
|
||||||
|
<COND (<L? .DEF 0>
|
||||||
|
<COND (.HERO?
|
||||||
|
<TELL "The unconscious " 1 .VDESC
|
||||||
|
" cannot defend himself: He dies.">)>
|
||||||
|
<SET RES ,KILLED>)
|
||||||
|
(ELSE
|
||||||
|
<COND (<1? .DEF>
|
||||||
|
<COND (<G? .ATT 2> <SET ATT 3>)>
|
||||||
|
<SET TBL <NTH ,DEF1-RES .ATT>>)
|
||||||
|
(<==? .DEF 2>
|
||||||
|
<COND (<G? .ATT 3> <SET ATT 4>)>
|
||||||
|
<SET TBL <NTH ,DEF2-RES .ATT>>)
|
||||||
|
(<G? .DEF 2>
|
||||||
|
<SET ATT <- .ATT .DEF>>
|
||||||
|
<COND (<L? .ATT -1> <SET ATT -2>)
|
||||||
|
(<G? .ATT 1> <SET ATT 2>)>
|
||||||
|
<SET TBL <NTH ,DEF3-RES <+ .ATT 3>>>)>
|
||||||
|
<SET RES <NTH .TBL <+ 1 <MOD <RANDOM> 9>>>>
|
||||||
|
<COND (.OUT?
|
||||||
|
<COND (<==? .RES ,STAGGER> <SET RES ,HESITATE>)
|
||||||
|
(ELSE <SET RES ,SITTING-DUCK>)>)>
|
||||||
|
<COND (<AND <==? .RES ,STAGGER>
|
||||||
|
.DWEAPON
|
||||||
|
<PROB 25 <COND (.HERO? 10)(ELSE 50)>>>
|
||||||
|
<SET RES ,LOSE-WEAPON>)>
|
||||||
|
<PRES <NTH .REMARKS <+ .RES 1>>
|
||||||
|
<COND (.HERO? "Adventurer") (ELSE .VDESC)>
|
||||||
|
<COND (.HERO? .VDESC) (ELSE "Adventurer")>
|
||||||
|
<AND .DWEAPON <ODESC2 .DWEAPON>>>)>
|
||||||
|
<COND (<OR <==? .RES ,MISSED> <==? .RES ,HESITATE>>)
|
||||||
|
(<==? .RES ,UNCONSCIOUS>
|
||||||
|
<COND (.HERO? <SET DEF <- .DEF>>)>)
|
||||||
|
(<OR <==? .RES ,KILLED> <==? .RES ,SITTING-DUCK>> <SET DEF 0>)
|
||||||
|
(<==? .RES ,LIGHT-WOUND> <SET DEF <MAX 0 <- .DEF 1>>>)
|
||||||
|
(<==? .RES ,SERIOUS-WOUND> <SET DEF <MAX 0 <- .DEF 2>>>)
|
||||||
|
(<==? .RES ,STAGGER>
|
||||||
|
<COND (.HERO? <TRO .VILLAIN ,STAGGERED>)
|
||||||
|
(ELSE <ATRO .HERO ,ASTAGGERED>)>)
|
||||||
|
(<AND <==? .RES ,LOSE-WEAPON> .DWEAPON>
|
||||||
|
<COND (.HERO?
|
||||||
|
<REMOVE-OBJECT .DWEAPON>
|
||||||
|
<INSERT-OBJECT .DWEAPON ,HERE>)
|
||||||
|
(ELSE
|
||||||
|
<DROP-OBJECT .DWEAPON .HERO>
|
||||||
|
<INSERT-OBJECT .DWEAPON ,HERE>
|
||||||
|
<COND (<SET NWEAPON <FWIM ,WEAPONBIT <AOBJS .HERO> T>>
|
||||||
|
<TELL
|
||||||
|
"Fortunately, you still have a " 1 <ODESC2 .NWEAPON> ".">)>)>)
|
||||||
|
(ELSE <ERROR MELEE "CHOMPS" .RES .HERO? .ATT .DEF .TBL>)>
|
||||||
|
<COND (<NOT .HERO?>
|
||||||
|
<PUT .HERO ,ASTRENGTH <COND (<0? .DEF> -10000)(<- .DEF .OD>)>>
|
||||||
|
<COND (<L? <- .DEF .OD> 0>
|
||||||
|
<CLOCK-ENABLE ,CURIN>
|
||||||
|
<PUT ,CURIN ,CTICK ,CURE-WAIT>)>
|
||||||
|
<COND (<L=? <FIGHT-STRENGTH .HERO> 0>
|
||||||
|
<PUT .HERO ,ASTRENGTH <+ 1 <- <FIGHT-STRENGTH .HERO <>>>>>
|
||||||
|
<JIGS-UP
|
||||||
|
"It appears that that last blow was too much for you. I'm afraid you
|
||||||
|
are dead.">
|
||||||
|
<>)
|
||||||
|
(.RES)>)
|
||||||
|
(ELSE
|
||||||
|
<OSTRENGTH .VILLAIN .DEF>
|
||||||
|
<COND (<0? .DEF>
|
||||||
|
<TRZ .VILLAIN ,FIGHTBIT>
|
||||||
|
<TELL
|
||||||
|
"Almost as soon as the " ,LONG-TELL .VDESC " breathes his last breath, a cloud
|
||||||
|
of sinister black fog envelops him, and when the fog lifts, the
|
||||||
|
carcass has disappeared.">
|
||||||
|
<REMOVE-OBJECT .VILLAIN>
|
||||||
|
<COND (<SET RANDOM-ACTION <OACTION .VILLAIN>>
|
||||||
|
<PERFORM .RANDOM-ACTION <FIND-VERB "DEAD!">>)>
|
||||||
|
<TELL "">
|
||||||
|
.RES)
|
||||||
|
(<==? .RES ,UNCONSCIOUS>
|
||||||
|
<COND (<SET RANDOM-ACTION <OACTION .VILLAIN>>
|
||||||
|
<PERFORM .RANDOM-ACTION <FIND-VERB "OUT!">>)>
|
||||||
|
.RES)
|
||||||
|
(.RES)>)>>>
|
||||||
|
|
||||||
|
<DEFINE WINNING? (V H "AUX" (VS <OSTRENGTH .V>) (PS <- .VS <FIGHT-STRENGTH .H>>))
|
||||||
|
#DECL ((V) OBJECT (H) ADV (VS PS) FIX)
|
||||||
|
<COND (<G? .PS 3> <PROB 90 100>)
|
||||||
|
(<G? .PS 0> <PROB 75 85>)
|
||||||
|
(<0? .PS> <PROB 50 30>)
|
||||||
|
(<G? .VS 1> <PROB 25>)
|
||||||
|
(ELSE <PROB 10 0>)>>
|
||||||
|
|
||||||
|
<DEFINE CURE-CLOCK ("AUX" (HERO ,PLAYER) (S <ASTRENGTH .HERO>) (I ,CURIN))
|
||||||
|
#DECL ((HERO) ADV (S) FIX (I) CEVENT)
|
||||||
|
<COND (<G? .S 0> <PUT .HERO ,ASTRENGTH <SET S 0>>)
|
||||||
|
(<L? .S 0> <PUT .HERO ,ASTRENGTH <SET S <+ .S 1>>>)>
|
||||||
|
<COND (<L? .S 0> <PUT .I ,CTICK ,CURE-WAIT>)
|
||||||
|
(ELSE <CLOCK-DISABLE .I>)>>
|
||||||
|
|
||||||
|
<DEFINE DIAGNOSE ("AUX" (W ,WINNER) (MS <FIGHT-STRENGTH .W <>>)
|
||||||
|
(WD <ASTRENGTH .W>) (RS <+ .MS .WD>) (I <CTICK ,CURIN>))
|
||||||
|
#DECL ((W) ADV (MS WD RD I) FIX)
|
||||||
|
<COND (<NOT <CFLAG ,CURIN>>
|
||||||
|
<SET WD 0>)
|
||||||
|
(<SET WD <- .WD>>)>
|
||||||
|
<COND (<0? .WD> <TELL "You are in perfect health.">)
|
||||||
|
(<1? .WD> <TELL "You have a light wound," 0>)
|
||||||
|
(<==? .WD 2> <TELL "You have a serious wound," 0>)
|
||||||
|
(<==? .WD 3> <TELL "You have several wounds," 0>)
|
||||||
|
(<G? .WD 3> <TELL "You have serious wounds," 0>)>
|
||||||
|
<COND (<NOT <0? .WD>>
|
||||||
|
<TELL " which will be cured after " 0>
|
||||||
|
<PRINC <+ <* ,CURE-WAIT <- .WD 1>> .I>>
|
||||||
|
<TELL " moves.">)>
|
||||||
|
<COND (<0? .RS> <TELL "You are at death's door.">)
|
||||||
|
(<1? .RS> <TELL "You can be killed by one more light wound.">)
|
||||||
|
(<==? .RS 2> <TELL "You can be killed by a serious wound.">)
|
||||||
|
(<==? .RS 3> <TELL "You can survive one serious wound.">)
|
||||||
|
(<G? .RS 3> <TELL "You are strong enough to take several wounds.">)>
|
||||||
|
<COND (<NOT <0? ,DEATHS>>
|
||||||
|
<TELL "You have been killed " 1 <COND (<1? ,DEATHS> "once.")
|
||||||
|
(T "twice.")>>)>>
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,102 @@
|
||||||
|
"(c) Copyright 1978, Massachusetts Institute of Technology. All rights reserved."
|
||||||
|
<DEFINE MSETG (FOO BAR)
|
||||||
|
#DECL ((FOO) ATOM (BAR) ANY)
|
||||||
|
<COND (<AND <GASSIGNED? .FOO> <N=? .BAR ,.FOO>>
|
||||||
|
<ERROR MSETG .FOO ALREADY-GASSIGNED ,.FOO>)
|
||||||
|
(ELSE
|
||||||
|
<SETG .FOO .BAR>
|
||||||
|
<MANIFEST .FOO>)>>
|
||||||
|
|
||||||
|
<DEFINE PSETG (FOO BAR "AUX" PL)
|
||||||
|
#DECL ((FOO) ATOM (PL) <LIST [REST ATOM]>)
|
||||||
|
<SETG .FOO .BAR>
|
||||||
|
<COND (<GASSIGNED? PURE-LIST> <SET PL ,PURE-LIST>)
|
||||||
|
(ELSE <SET PL <SETG PURE-LIST ()>>)>
|
||||||
|
<COND (<NOT <MEMQ .FOO .PL>>
|
||||||
|
<SETG PURE-LIST <SET PL (.FOO !.PL)>>)
|
||||||
|
(<AND <GASSIGNED? PURE-CAREFUL> ,PURE-CAREFUL>
|
||||||
|
<ERROR PSETG-DUPLICATE .FOO>)>
|
||||||
|
.BAR>
|
||||||
|
|
||||||
|
<DEFINE FLAGWORD ("TUPLE" FS "AUX" (TOT 1) (CNT 1))
|
||||||
|
#DECL ((FS) <TUPLE [REST <OR ATOM FALSE>]> (TOT CNT) FIX)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (F)
|
||||||
|
#DECL ((F) <OR ATOM FALSE>)
|
||||||
|
<COND (<TYPE? .F ATOM>
|
||||||
|
<COND (<NOT <LOOKUP "GROUP-GLUE" <GET INITIAL OBLIST>>>
|
||||||
|
<MSETG .F .TOT>)>)>
|
||||||
|
<SET TOT <* 2 .TOT>>
|
||||||
|
<COND (<G? <SET CNT <+ .CNT 1>> 36>
|
||||||
|
<ERROR FLAGWORD .CNT>)>>
|
||||||
|
.FS>
|
||||||
|
.CNT>
|
||||||
|
|
||||||
|
<DEFINE NEWSTRUC (NAM PRIM
|
||||||
|
"ARGS" ELEM
|
||||||
|
"AUX" (LL <FORM <FORM PRIMTYPE .PRIM>>) (L .LL)
|
||||||
|
R RR (CNT 1) OFFS DEC)
|
||||||
|
#DECL ((NAM) <OR ATOM <LIST [REST ATOM]>> (PRIM) ATOM
|
||||||
|
(LL L RR R) <PRIMTYPE LIST>
|
||||||
|
(CNT) FIX (OFFS DEC) ANY (ELEM) LIST)
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<EMPTY? .ELEM>
|
||||||
|
<COND (<ASSIGNED? RR> <PUTREST .R (<VECTOR !.RR>)>)>
|
||||||
|
<COND (<TYPE? .NAM ATOM>
|
||||||
|
<COND (<LOOKUP "COMPILE" <ROOT>>
|
||||||
|
<NEWTYPE .NAM .PRIM .LL>)
|
||||||
|
(<NEWTYPE .NAM .PRIM>)>)
|
||||||
|
(ELSE
|
||||||
|
<PUT .LL 1 .PRIM>
|
||||||
|
<EVAL <FORM GDECL .NAM .LL>>
|
||||||
|
<SET NAM <1 .NAM>>)>
|
||||||
|
<RETURN .NAM>)
|
||||||
|
(<LENGTH? .ELEM 1> <ERROR NEWSTRUC>)>
|
||||||
|
<SET OFFS <1 .ELEM>>
|
||||||
|
<SET DEC <2 .ELEM>>
|
||||||
|
<COND (<OR <NOT .OFFS> <TYPE? .OFFS FORM>>
|
||||||
|
<SET CNT <+ .CNT 1>>
|
||||||
|
<SET ELEM <REST .ELEM>>
|
||||||
|
<AGAIN>)>
|
||||||
|
<COND (<AND <TYPE? .OFFS STRING> <=? .OFFS "REST">>
|
||||||
|
<AND <ASSIGNED? RR> <ERROR NEWSTRUC TWO-RESTS>>
|
||||||
|
<SET R .L>
|
||||||
|
<SET RR <SET L <LIST REST>>>
|
||||||
|
<SET ELEM <REST .ELEM>>
|
||||||
|
<AGAIN>)
|
||||||
|
(<LOOKUP "GROUP-GLUE" <GET INITIAL OBLIST>>)
|
||||||
|
(<TYPE? .OFFS ATOM>
|
||||||
|
<MSETG .OFFS .CNT>)
|
||||||
|
(<TYPE? .OFFS LIST>
|
||||||
|
<MAPF <> <FUNCTION (A) <MSETG .A .CNT>> .OFFS>)
|
||||||
|
(ELSE <ERROR NEWSTRUC>)>
|
||||||
|
<SET CNT <+ .CNT 1>>
|
||||||
|
<PUTREST .L <SET L (.DEC)>>
|
||||||
|
<SET ELEM <REST .ELEM 2>>>>
|
||||||
|
|
||||||
|
"MAKE-SLOT -- define a funny slot in an object"
|
||||||
|
|
||||||
|
<SETG SLOTS ()>
|
||||||
|
|
||||||
|
<DEFINE MAKE-SLOT (NAME 'TYP 'DEF)
|
||||||
|
#DECL ((NAME) ATOM (TYP) <OR ATOM FORM> (DEF) ANY)
|
||||||
|
<COND
|
||||||
|
(<OR <NOT <GASSIGNED? .NAME>>
|
||||||
|
<AND <ASSIGNED? REDEFINE> .REDEFINE>
|
||||||
|
<ERROR SLOT-NAME-ALREADY-USED!-ERRORS .NAME>>
|
||||||
|
<SETG SLOTS
|
||||||
|
(<EVAL <FORM DEFMAC
|
||||||
|
.NAME
|
||||||
|
'('OBJ "OPTIONAL" 'VAL)
|
||||||
|
<FORM COND
|
||||||
|
('<ASSIGNED? VAL>
|
||||||
|
<FORM FORM OPUT '.OBJ .NAME '.VAL>)
|
||||||
|
(<FORM FORM
|
||||||
|
PROG
|
||||||
|
'()
|
||||||
|
<CHTYPE ('(VALUE) .TYP) DECL>
|
||||||
|
<FORM FORM
|
||||||
|
COND
|
||||||
|
(<FORM FORM OGET '.OBJ .NAME>)
|
||||||
|
(ELSE <FORM QUOTE .DEF>)>>)>>>
|
||||||
|
!,SLOTS)>)>>
|
|
@ -0,0 +1,445 @@
|
||||||
|
|
||||||
|
<SETG SAVSTR <ISTRING 5>>
|
||||||
|
|
||||||
|
<SETG SAVE-VERSION -1>
|
||||||
|
|
||||||
|
<GDECL (SAVE-VERSION) FIX (SRUV) <UVECTOR [REST FIX]>>
|
||||||
|
|
||||||
|
;"CONSTANTS FOR SAVE-RESTORE UVECTOR"
|
||||||
|
|
||||||
|
<MSETG OBJSVLN 3600>
|
||||||
|
|
||||||
|
;"Length of ROOMS block"
|
||||||
|
|
||||||
|
<MSETG RMSVLN 2000>
|
||||||
|
|
||||||
|
;"Length of DEMONS block"
|
||||||
|
|
||||||
|
<MSETG DMNSVLN 225>
|
||||||
|
|
||||||
|
;"Length of <HOBJS <robber>> block"
|
||||||
|
|
||||||
|
<MSETG HOBJSVLN 17>
|
||||||
|
|
||||||
|
;"Starting offset of CLOCKER slots"
|
||||||
|
|
||||||
|
<MSETG CEVSVOFF 20>
|
||||||
|
|
||||||
|
;"Length of CEVENT slots (33 CEVENTS x 3 slots)"
|
||||||
|
|
||||||
|
<MSETG CEVSVLN 99>
|
||||||
|
|
||||||
|
;"Length of ACTORs block"
|
||||||
|
|
||||||
|
<SETG ACTSVLN 122>
|
||||||
|
|
||||||
|
;"Length of WINNER block"
|
||||||
|
|
||||||
|
<MSETG WSVLN 22>
|
||||||
|
|
||||||
|
;"Length of MONAD GVAL block"
|
||||||
|
|
||||||
|
<MSETG MGSVLN 125>
|
||||||
|
|
||||||
|
;"Length of ROOM GVAL block"
|
||||||
|
|
||||||
|
<MSETG RMGSVLN 15>
|
||||||
|
|
||||||
|
;"Length of OBJECT GVAL block"
|
||||||
|
|
||||||
|
<MSETG OBJGSVLN 10>
|
||||||
|
|
||||||
|
;"# of slots for OBJECTs"
|
||||||
|
|
||||||
|
<MSETG PUZSVLN 164>
|
||||||
|
|
||||||
|
<MSETG SAVLENGTH
|
||||||
|
<+ 1 ,OBJSVLN ,RMSVLN ,DMNSVLN ,ACTSVLN ,MGSVLN ,RMGSVLN ,OBJGSVLN ,PUZSVLN>>
|
||||||
|
|
||||||
|
<MSETG ORECLN 12>
|
||||||
|
|
||||||
|
;"# of slots for ROOMs"
|
||||||
|
|
||||||
|
<MSETG RRECLN 8>
|
||||||
|
|
||||||
|
;"# of slots for CEVENT"
|
||||||
|
|
||||||
|
<MSETG CRECLN 3>
|
||||||
|
|
||||||
|
;"Names of slots to be saved from OBJECTS"
|
||||||
|
|
||||||
|
<PSETG OSNAMES
|
||||||
|
'![OID OCAN OFLAGS OROOM ORAND OFVAL OSIZE OCAPAC OLINT OMATCH
|
||||||
|
OSTRENGTH!]>
|
||||||
|
|
||||||
|
;"Types of these slots (rested once)"
|
||||||
|
|
||||||
|
<PSETG OSTYPES '![OBJECT FIX ROOM FIX FIX FIX FIX FIX FIX FIX!]>
|
||||||
|
|
||||||
|
;"Names of slots to be saved from ROOMS"
|
||||||
|
|
||||||
|
<PSETG RSNAMES '![RID RVARS RBITS RRAND RVAL!]>
|
||||||
|
|
||||||
|
;"Types of these slots (rested once)"
|
||||||
|
|
||||||
|
<PSETG RSTYPES '![FIX WORD FIX FIX!]>
|
||||||
|
|
||||||
|
;"Names of slots to be saved from CEVENTS"
|
||||||
|
|
||||||
|
<PSETG CSNAMES '![CID CTICK CFLAG!]>
|
||||||
|
|
||||||
|
;"Types of these slots"
|
||||||
|
|
||||||
|
<PSETG CSTYPES '![FIX FIX!]>
|
||||||
|
|
||||||
|
<GDECL (OSNAMES RSNAMES CSNAMES OSTYPES RSTYPES CSTYPES) <UVECTOR [REST ATOM]>>
|
||||||
|
|
||||||
|
<DEFINE POS (OBJ LST "AUX" M)
|
||||||
|
#DECL ((OBJ) ANY (LST) LIST (M) <OR FALSE LIST>)
|
||||||
|
<AND <SET M <MEMQ .OBJ .LST>>
|
||||||
|
<+ 1 <- <LENGTH .LST> <LENGTH .M>>>>>
|
||||||
|
|
||||||
|
; "Get the FIX code for any item."
|
||||||
|
<GDECL (CLOCKER) HACK (CLOCK-CALLERS) LIST (ACTORS) <LIST [REST ADV]>>
|
||||||
|
|
||||||
|
<DEFINE SCODE (ITM "AUX" RI)
|
||||||
|
#DECL ((ITM) ANY (RI) <VECTOR FIX CEVENT>)
|
||||||
|
<COND (<==? .ITM T> 10223616)
|
||||||
|
(<NOT .ITM> 2883584)
|
||||||
|
(<TYPE? .ITM ADV> 0)
|
||||||
|
(<TYPE? .ITM ATOM PSTRING> <ATMFIX .ITM>)
|
||||||
|
(<==? <PRIMTYPE .ITM> WORD> <CHTYPE .ITM FIX>)
|
||||||
|
(<TYPE? .ITM ROOM> <ATMFIX <RID .ITM>>)
|
||||||
|
(<TYPE? .ITM OBJECT> <ATMFIX <OID .ITM>>)
|
||||||
|
(<DECL? .ITM '<VECTOR FIX CEVENT>>
|
||||||
|
<SET RI .ITM>
|
||||||
|
<PUTBITS <PUTBITS 3145728
|
||||||
|
<BITS 18 0>
|
||||||
|
<POS <2 .RI> <HOBJS ,CLOCKER>>>
|
||||||
|
<BITS 9 9>
|
||||||
|
<1 .RI>>)
|
||||||
|
(5505024)>>
|
||||||
|
|
||||||
|
;"Get an object from any FIX code (inverse of SCODE)"
|
||||||
|
|
||||||
|
<DEFINE SDECODE (FX TYP "AUX" ATM)
|
||||||
|
#DECL ((FX) FIX (TYP) ATOM (ATM) <OR ATOM FALSE>)
|
||||||
|
<COND (<==? .FX *47000000*>)
|
||||||
|
(<==? .FX *13000000*> <>)
|
||||||
|
(<==? .FX *25000000*> #FALSE (1))
|
||||||
|
(<==? <GETBITS .FX <BITS 18 18>> #WORD *14*>
|
||||||
|
<VECTOR <CHTYPE <GETBITS .FX <BITS 9 9>> FIX>
|
||||||
|
<NTH <HOBJS ,CLOCKER> <CHTYPE <GETBITS .FX <BITS 9 0>> FIX>>>)
|
||||||
|
(<==? .TYP OBJECT>
|
||||||
|
<COND (<0? .FX> <>)
|
||||||
|
(<FIND-OBJ <FIXSTR .FX>>)>)
|
||||||
|
(<==? .TYP ROOM>
|
||||||
|
<COND (<0? .FX> <>)
|
||||||
|
(<NOT <PLOOKUP <FIXSTR .FX> ,ROOM-POBL>>
|
||||||
|
<FIND-ROOM "FCHMP">)
|
||||||
|
(<FIND-ROOM <FIXSTR .FX>>)>)
|
||||||
|
(<==? .TYP CEVENT>
|
||||||
|
<COND (<0? .FX> <>)
|
||||||
|
(<SET ATM <LOOKUP <FIXSTR .FX> <GET INITIAL OBLIST>>>
|
||||||
|
,.ATM)>)
|
||||||
|
(<CHTYPE .FX .TYP>)>>
|
||||||
|
|
||||||
|
; "Save elements from a list of items:
|
||||||
|
Arg 1: The code UVECTOR
|
||||||
|
Arg 2: The list of items (e.g. ,ROOMS ,OBJECTS)
|
||||||
|
Arg 3: Number of elements to REST off Arg 1 when finished
|
||||||
|
Arg 4: A UVECTOR of offsets for each item to be saved
|
||||||
|
Arg 5: The number of slots to be used for each item in the UVECTOR"
|
||||||
|
|
||||||
|
<DEFINE UNSAVORY-CODE (SU L OFF NUVEC RECLEN "AUX" (NU .SU))
|
||||||
|
#DECL ((L) LIST (OFF RECLEN) FIX (SU NU) <UVECTOR [REST FIX]>
|
||||||
|
(NUVEC) <UVECTOR [REST ATOM]>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (ITM "AUX" (U .NU))
|
||||||
|
#DECL ((ITM) <PRIMTYPE VECTOR> (U) <UVECTOR [REST FIX]>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (SLT "AUX" VAL)
|
||||||
|
#DECL ((SLT) ATOM (VAL) ANY)
|
||||||
|
<SET VAL <SRGET .ITM .SLT>>
|
||||||
|
<PUT .U
|
||||||
|
1
|
||||||
|
<SCODE .VAL>>
|
||||||
|
<SET U <REST .U 1>>>
|
||||||
|
.NUVEC>
|
||||||
|
<SET NU <REST .NU .RECLEN>>>
|
||||||
|
.L>
|
||||||
|
<REST .SU .OFF>>
|
||||||
|
|
||||||
|
; "Restore elements from an object
|
||||||
|
Arg 1: The code UVECTOR
|
||||||
|
Arg 2: The object
|
||||||
|
Arg 3: A UVECTOR of offsets into the object
|
||||||
|
Arg 4: A UVECTOR of types for these offsets (ATOMs)"
|
||||||
|
|
||||||
|
<DEFINE UNRESTFUL-CODE (U OBJ NUVEC TUVEC "AUX" M)
|
||||||
|
#DECL ((U) <UVECTOR [REST FIX]> (TUVEC NUVEC) <UVECTOR [REST ATOM]>
|
||||||
|
(OBJ) <PRIMTYPE VECTOR> (M) <OR FALSE <VECTOR OBJECT ATOM ATOM>>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (SLT TYP "AUX" TMP)
|
||||||
|
#DECL ((SLT TYP) ATOM)
|
||||||
|
<COND (<OR <SET TMP <SDECODE <1 .U> .TYP>> <EMPTY? .TMP>>
|
||||||
|
<SRPUT .OBJ .SLT .TMP>)>
|
||||||
|
<SET U <REST .U 1>>>
|
||||||
|
.NUVEC
|
||||||
|
.TUVEC>>
|
||||||
|
|
||||||
|
<DEFINE SRGET (OBJ SLT "AUX" HOW)
|
||||||
|
#DECL ((OBJ) <PRIMTYPE VECTOR> (SLT) ATOM (HOW) APPLICABLE)
|
||||||
|
<COND (<AND <GASSIGNED? .SLT>
|
||||||
|
<TYPE? <SET HOW ,.SLT> FIX>>
|
||||||
|
<NTH .OBJ .HOW>)
|
||||||
|
(<==? .SLT OID>
|
||||||
|
<OID .OBJ>)
|
||||||
|
(<OGET .OBJ .SLT>)>>
|
||||||
|
|
||||||
|
<DEFINE SRPUT (OBJ SLT VAL "AUX" HOW M)
|
||||||
|
#DECL ((OBJ) <PRIMTYPE VECTOR> (SLT) ATOM (VAL) ANY (HOW) APPLICABLE
|
||||||
|
(M) <OR FALSE <VECTOR OBJECT ATOM ATOM>>)
|
||||||
|
<COND (<SET M <MEMQ .OBJ ,OFIXUPS>>
|
||||||
|
<COND (<==? <2 .M> .SLT> <SET SLT <3 .M>>)>)>
|
||||||
|
<COND (<AND <GASSIGNED? .SLT>
|
||||||
|
<TYPE? <SET HOW ,.SLT> FIX>>
|
||||||
|
<PUT .OBJ .HOW .VAL>)
|
||||||
|
(<OPUT .OBJ .SLT .VAL>)>>
|
||||||
|
|
||||||
|
;
|
||||||
|
"Save GVALs
|
||||||
|
Arg 1: The code UVECTOR
|
||||||
|
Arg 2: A UVECTOR of ATOMS (which must have GVALs!
|
||||||
|
Arg 3: Number of times to rest UVECTOR when done"
|
||||||
|
|
||||||
|
<DEFINE SAVE-GVAL (V GV RST)
|
||||||
|
#DECL ((V) <UVECTOR [REST FIX]> (GV) <UVECTOR [REST ATOM]> (RST) FIX)
|
||||||
|
<MAPR <>
|
||||||
|
<FUNCTION (ATMS VEC)
|
||||||
|
#DECL ((ATMS) <UVECTOR [REST ATOM]> (VEC) <UVECTOR [REST FIX]>)
|
||||||
|
<PUT .VEC 1 <SCODE <GVAL <1 .ATMS>>>>>
|
||||||
|
.GV
|
||||||
|
.V>
|
||||||
|
<REST .V .RST>>
|
||||||
|
|
||||||
|
; "Restore GVALs
|
||||||
|
Args 1-3: As above
|
||||||
|
Arg 4: The type (ATOM) to restore"
|
||||||
|
|
||||||
|
<DEFINE REST-GVAL (V GV RST TYP)
|
||||||
|
#DECL ((V) <UVECTOR [REST FIX]> (GV) <UVECTOR [REST ATOM]> (RST) FIX (TYP) ATOM)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (ATM VAL)
|
||||||
|
#DECL ((ATM) ATOM (VAL) FIX)
|
||||||
|
<SETG .ATM <SDECODE .VAL .TYP>>>
|
||||||
|
.GV
|
||||||
|
.V>
|
||||||
|
<REST .V .RST>>
|
||||||
|
|
||||||
|
; "Restore a LIST of OBJECTs
|
||||||
|
Arg 1: The code UVECTOR
|
||||||
|
Stops when a 0 is encountered"
|
||||||
|
|
||||||
|
<DEFINE REST-LIST (V)
|
||||||
|
#DECL ((V) <UVECTOR [REST FIX]>)
|
||||||
|
<MAPF ,LIST
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) FIX)
|
||||||
|
<COND (<0? .X> <MAPSTOP>)
|
||||||
|
(<SDECODE .X OBJECT>)>>
|
||||||
|
.V>>
|
||||||
|
|
||||||
|
; "Restore ROOMS/OBJECTS
|
||||||
|
Arg 1: The code UVECTOR
|
||||||
|
Arg 2: A UVECTOR of offsets into the objects (FIX)
|
||||||
|
Arg 3: A UVECTOR of types of the offsets (ATOM)
|
||||||
|
Arg 4: The length of each record
|
||||||
|
Arg 5: OBJECT/ROOM flag
|
||||||
|
Gets the item (ROOM or OBJECT) from the ID slot and then
|
||||||
|
calls UNRESTFUL-CODE to fill the elements (note that this
|
||||||
|
function is called with names = <REST ,xSNAMES>
|
||||||
|
This function also fixes up OCONTENTS and OROOM slots."
|
||||||
|
|
||||||
|
<DEFINE REST-ITEMS (V NAMES TYPES RECLEN TYPE "AUX" D C)
|
||||||
|
#DECL ((V) <UVECTOR [REST FIX]> (TYPES NAMES) <UVECTOR [REST ATOM]>
|
||||||
|
(RECLEN) FIX (TYPE) ATOM (C) <OR FALSE <PRIMTYPE VECTOR>>
|
||||||
|
(D) <OR FALSE DOOR>)
|
||||||
|
<REPEAT (OBJ)
|
||||||
|
#DECL ((OBJ) <OR FALSE <PRIMTYPE VECTOR>>)
|
||||||
|
<COND
|
||||||
|
(<SET OBJ <SDECODE <1 .V> .TYPE>>
|
||||||
|
<UNRESTFUL-CODE <REST .V> .OBJ .NAMES .TYPES>
|
||||||
|
<COND (<==? .TYPE OBJECT>
|
||||||
|
<COND (<SET C <OCAN .OBJ>>
|
||||||
|
<PUT .C ,OCONTENTS (.OBJ !<OCONTENTS .C>)>)
|
||||||
|
(<SET C <OROOM .OBJ>>
|
||||||
|
<PUT .C ,ROBJS (.OBJ !<ROBJS .C>)>
|
||||||
|
<COND (<AND <TRNN .OBJ ,DOORBIT>
|
||||||
|
<SET D <FIND-DOOR .C .OBJ>>>
|
||||||
|
<SET C <GET-DOOR-ROOM .C .D>>
|
||||||
|
<PUT .C ,ROBJS (.OBJ !<ROBJS .C>)>)>)>)>
|
||||||
|
<SET V <REST .V .RECLEN>>)
|
||||||
|
(<RETURN>)>>>
|
||||||
|
|
||||||
|
<DEFINE GET-SRUV ()
|
||||||
|
<COND (<GASSIGNED? SRUV>
|
||||||
|
<MAPR <>
|
||||||
|
<FUNCTION (X) #DECL ((X) <UVECTOR [REST FIX]>)
|
||||||
|
<PUT .X 1 0>>
|
||||||
|
,SRUV>
|
||||||
|
,SRUV)
|
||||||
|
(<BLOAT <+ ,SAVLENGTH 2>>
|
||||||
|
<SETG SRUV <IUVECTOR ,SAVLENGTH 0>>)>>
|
||||||
|
|
||||||
|
; "Save the game -- linear sequence of calls to above"
|
||||||
|
|
||||||
|
<DEFINE SAVE-GAME (CH "AUX" V VV (C ,CLOCKER) (H ,ROBBER-DEMON))
|
||||||
|
#DECL ((V VV) <UVECTOR [REST FIX]> (C H) HACK (CH) CHANNEL)
|
||||||
|
<SET V <GET-SRUV>> ;"Save objects"
|
||||||
|
<PUT .V 1 ,SAVE-VERSION>
|
||||||
|
<SET V <REST .V>>
|
||||||
|
<SET V <UNSAVORY-CODE .V ,OBJECTS ,OBJSVLN ,OSNAMES ,ORECLN>>
|
||||||
|
;"Save rooms"
|
||||||
|
<SET V <UNSAVORY-CODE .V ,ROOMS ,RMSVLN ,RSNAMES ,RRECLN>>
|
||||||
|
;"Save robber's booty"
|
||||||
|
<SET VV <UNSAVORY-CODE .V <HOBJS .H> ,HOBJSVLN '![OID] 1>>
|
||||||
|
;"Save robber stuff"
|
||||||
|
<PUT .VV 1 <SCODE <1 <HROOMS .H>>>>
|
||||||
|
<PUT .VV 2 <SCODE <HROOM .H>>>
|
||||||
|
<PUT .VV 3 <SCODE <HFLAG .H>>>
|
||||||
|
<PUT .VV 4 <COND (<HACTION .H> 1)
|
||||||
|
(0)>>
|
||||||
|
<PUT .VV 5 <COND (<HACTION ,SWORD-DEMON> 1)
|
||||||
|
(0)>>
|
||||||
|
;"Save clocker"
|
||||||
|
<SET VV
|
||||||
|
<UNSAVORY-CODE <REST .VV 5> <HOBJS .C> ,CEVSVLN ,CSNAMES ,CRECLN>>
|
||||||
|
<SET V <SET VV <REST .V ,DMNSVLN>>> ;"Save winners"
|
||||||
|
<MAPF <> <FUNCTION (X) <SET VV <WINSAVE .VV .X>>> ,ACTORS>
|
||||||
|
<SET V <REST .V ,ACTSVLN>> ;"Save GVALs (MONAD, ROOM, OBJECT)"
|
||||||
|
<SET V <SAVE-GVAL .V ,MGVALS ,MGSVLN>>
|
||||||
|
<SET V <SAVE-GVAL .V ,RMGVALS ,RMGSVLN>>
|
||||||
|
<SET V <SAVE-GVAL .V ,OBJGVALS ,OBJGSVLN>>
|
||||||
|
<SAVE-PUZZLE .V>
|
||||||
|
<PRINTB <TOP .V> .CH>
|
||||||
|
<CLOSE .CH>
|
||||||
|
"DONE">
|
||||||
|
|
||||||
|
<DEFINE SAVE-PUZZLE (U "AUX" (BUCK 1))
|
||||||
|
#DECL ((U) <UVECTOR [REST FIX]> (BUCK) FIX)
|
||||||
|
<COND (<==? <LENGTH <TOP .U>> ,SAVLENGTH>
|
||||||
|
<PUT ,CPOBJS ,CPHERE <ROBJS <SFIND-ROOM "CP">>>
|
||||||
|
<SUBSTRUC ,CPUVEC 0 64 .U>
|
||||||
|
<SET U <REST .U 64>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (LST)
|
||||||
|
#DECL ((LST) LIST)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (OBJ)
|
||||||
|
#DECL ((OBJ) OBJECT)
|
||||||
|
<PUT .U 1 <SCODE .OBJ>>
|
||||||
|
<PUT .U 2 .BUCK>
|
||||||
|
<SET U <REST .U 2>>>
|
||||||
|
.LST>
|
||||||
|
<SET BUCK <+ .BUCK 1>>>
|
||||||
|
,CPOBJS>)>>
|
||||||
|
|
||||||
|
<DEFINE RESTORE-PUZZLE (U "AUX" (OBJS ,CPOBJS) WHR)
|
||||||
|
#DECL ((U) <UVECTOR [REST FIX]> (OBJS) <UVECTOR [REST LIST]> (WHR) FIX)
|
||||||
|
<COND (<==? <LENGTH <TOP .U>> ,SAVLENGTH>
|
||||||
|
<SUBSTRUC .U 0 64 ,CPUVEC>
|
||||||
|
<SET U <REST .U 64>>
|
||||||
|
<MAPR <>
|
||||||
|
<FUNCTION (UVC)
|
||||||
|
#DECL ((UVC) <UVECTOR [REST LIST]>)
|
||||||
|
<PUT .UVC 1 '()>>
|
||||||
|
.OBJS>
|
||||||
|
<REPEAT ()
|
||||||
|
<COND (<0? <1 .U>>
|
||||||
|
<RETURN>)
|
||||||
|
(<PUT .OBJS
|
||||||
|
<SET WHR <2 .U>>
|
||||||
|
(<SDECODE <1 .U> OBJECT> !<NTH .OBJS .WHR>)>)>
|
||||||
|
<SET U <REST .U 2>>>
|
||||||
|
<OR <0? ,CPHERE>
|
||||||
|
<PUT <SFIND-ROOM "CP"> ,ROBJS <NTH ,CPOBJS ,CPHERE>>>)>>
|
||||||
|
|
||||||
|
<DEFINE WINSAVE (V W)
|
||||||
|
#DECL ((V) <UVECTOR [REST FIX]> (W) ADV)
|
||||||
|
<PUT .V 1 <SCODE <AROOM .W>>>
|
||||||
|
<PUT .V 2 <SCODE <ASCORE .W>>>
|
||||||
|
<PUT .V 3 <SCODE <AVEHICLE .W>>>
|
||||||
|
<PUT .V 4 <SCODE <AOBJ .W>>>
|
||||||
|
<PUT .V 5 <SCODE <ASTRENGTH .W>>>
|
||||||
|
<UNSAVORY-CODE <REST .V 5> <AOBJS .W> ,WSVLN '![OID!] 1>>
|
||||||
|
|
||||||
|
<DEFINE RESTORE-GAME RG (CH "AUX" V VV (H ,ROBBER-DEMON) (C ,CLOCKER)
|
||||||
|
(CSNAMES ,CSNAMES) (CSTYPES ,CSTYPES) (CNT 2))
|
||||||
|
#DECL ((CH) CHANNEL (V VV) <UVECTOR [REST FIX]> (C H) HACK
|
||||||
|
(CSNAMES CSTYPES) UVECTOR (CNT) FIX (RG) ACTIVATION)
|
||||||
|
<SET V <GET-SRUV>>
|
||||||
|
<COND (<READB .V .CH>
|
||||||
|
<COND (<N==? <1 .V> ,SAVE-VERSION>
|
||||||
|
<TELL
|
||||||
|
"ERROR--Save file is incompatible with this version of Dungeon.">
|
||||||
|
<CLOSE .CH>
|
||||||
|
<RETURN <> .RG>)>
|
||||||
|
<SET V <REST .V>>
|
||||||
|
<CLOSE .CH>
|
||||||
|
; "Clear slots"
|
||||||
|
<MAPF <> <FUNCTION (X) #DECL ((X) OBJECT) <PUT .X ,OCONTENTS ()>> ,OBJECTS>
|
||||||
|
<MAPF <> <FUNCTION (X) #DECL ((X) ROOM) <PUT .X ,ROBJS ()>> ,ROOMS>
|
||||||
|
; "Retrieve clocker first!"
|
||||||
|
<PUT .C ,HOBJS
|
||||||
|
<MAPR ,LIST
|
||||||
|
<FUNCTION (UV "AUX" CV)
|
||||||
|
#DECL ((UV) UVECTOR (CV) <OR FALSE CEVENT>)
|
||||||
|
<COND (<0? <SET CNT <MOD <+ .CNT 1> 3>>>
|
||||||
|
<COND (<SET CV <SDECODE <1 .UV> CEVENT>>
|
||||||
|
<UNRESTFUL-CODE <REST .UV> .CV
|
||||||
|
<REST .CSNAMES> .CSTYPES>
|
||||||
|
<MAPRET .CV>)
|
||||||
|
(<MAPSTOP>)>)
|
||||||
|
(<MAPRET>)>>
|
||||||
|
<REST .V <+ ,OBJSVLN ,RMSVLN ,HOBJSVLN 5>>>>
|
||||||
|
; "Get objects"
|
||||||
|
<REST-ITEMS .V <REST ,OSNAMES> ,OSTYPES ,ORECLN OBJECT>
|
||||||
|
; "Get rooms"
|
||||||
|
<REST-ITEMS <SET V <REST .V ,OBJSVLN>> <REST ,RSNAMES> ,RSTYPES ,RRECLN ROOM>
|
||||||
|
; "Get robber"
|
||||||
|
<PUT .H ,HOBJS <REST-LIST <SET V <REST .V ,RMSVLN>>>>
|
||||||
|
<SET VV <REST .V ,HOBJSVLN>>
|
||||||
|
<PUT .H ,HROOMS <MEMQ <SDECODE <1 .VV> ROOM> ,ROOMS>>
|
||||||
|
<PUT .H ,HROOM <SDECODE <2 .VV> ROOM>>
|
||||||
|
<PUT .H ,HFLAG <SDECODE <3 .VV> FIX>>
|
||||||
|
<COND (<1? <4 .VV>>
|
||||||
|
<PUT .H ,HACTION <COND (<TYPE? ,ROBBER NOFFSET> ,ROBBER)
|
||||||
|
(ROBBER)>>)
|
||||||
|
(T <PUT .H ,HACTION <>>)>
|
||||||
|
<COND (<1? <5 .VV>>
|
||||||
|
<PUT ,SWORD-DEMON ,HACTION <COND (<TYPE? ,SWORD-GLOW NOFFSET>
|
||||||
|
,SWORD-GLOW)
|
||||||
|
(SWORD-GLOW)>>)>
|
||||||
|
<SET V <SET VV <REST .V ,DMNSVLN>>>
|
||||||
|
; "Get winner"
|
||||||
|
<MAPF <> <FUNCTION (X) #DECL ((X) ADV) <SET VV <WINREST .VV .X>>> ,ACTORS>
|
||||||
|
<SET V <REST .V ,ACTSVLN>>
|
||||||
|
; "Get GVALS"
|
||||||
|
<SET V <REST-GVAL .V ,MGVALS ,MGSVLN FIX>>
|
||||||
|
<SET V <REST-GVAL .V ,RMGVALS ,RMGSVLN ROOM>>
|
||||||
|
<SET V <REST-GVAL .V ,OBJGVALS ,OBJGSVLN OBJECT>>
|
||||||
|
<RESTORE-PUZZLE .V>
|
||||||
|
"DONE")>>
|
||||||
|
|
||||||
|
<DEFINE WINREST (V W "AUX" T)
|
||||||
|
#DECL ((V) <UVECTOR [REST FIX]> (W) ADV (T) OBJECT)
|
||||||
|
<PUT .W ,AROOM <SDECODE <1 .V> ROOM>>
|
||||||
|
<PUT .W ,ASCORE <SDECODE <2 .V> FIX>>
|
||||||
|
<PUT .W ,AVEHICLE <SDECODE <3 .V> OBJECT>>
|
||||||
|
<PUT .W ,AOBJ <OPUT <SET T <SDECODE <4 .V> OBJECT>> OACTOR .W>>
|
||||||
|
<PUT .W ,ASTRENGTH <SDECODE <5 .V> FIX>>
|
||||||
|
<PUT .W ,AOBJS <REST-LIST <SET V <REST .V 5>>>>
|
||||||
|
<REST .V ,WSVLN>>
|
||||||
|
|
||||||
|
<GDECL (OFIXUPS) <VECTOR [REST OBJECT ATOM ATOM]>>
|
Binary file not shown.
|
@ -0,0 +1,128 @@
|
||||||
|
|
||||||
|
<DEFINE CEVENT-PRINT (EV "AUX" (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((EV) CEVENT)
|
||||||
|
<PRINC "#CEVENT [">
|
||||||
|
<COND (<CFLAG .EV> <PRINC "ENABLED">)
|
||||||
|
(<PRINC "DISABLED">)>
|
||||||
|
<PRINC " @ ">
|
||||||
|
<PRIN1 <CTICK .EV>>
|
||||||
|
<PRINC " -> ">
|
||||||
|
<FUNCTION-PRINT <CACTION .EV>>
|
||||||
|
<PRINC "]">>
|
||||||
|
|
||||||
|
<PRINTTYPE CEVENT ,CEVENT-PRINT>
|
||||||
|
|
||||||
|
<DEFINE FUNCTION-PRINT (FROB "AUX" (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((FROB) <OR ATOM NOFFSET APPLICABLE FALSE> (OUTCHAN) CHANNEL)
|
||||||
|
<COND (<NOT .FROB> <PRINC "<>">)
|
||||||
|
(<TYPE? .FROB RSUBR RSUBR-ENTRY>
|
||||||
|
<PRIN1 <2 .FROB>>)
|
||||||
|
(<TYPE? .FROB ATOM>
|
||||||
|
<PRIN1 .FROB>)
|
||||||
|
(<TYPE? .FROB NOFFSET>
|
||||||
|
<PRINC "#NOFFSET ">
|
||||||
|
<PRIN1 <GET-ATOM .FROB>>)
|
||||||
|
(<PRINC "#FUNCTION ">
|
||||||
|
<PRIN1 <GET-ATOM .FROB>>)>>
|
||||||
|
|
||||||
|
<DEFINE OFF-APPLY (FOO "TUPLE" ARGS)
|
||||||
|
#DECL ((FOO) NOFFSET)
|
||||||
|
<COND (<G? <LENGTH .ARGS> 1>
|
||||||
|
<ERROR TOO-MANY-ARGS OFF-APPLY>)
|
||||||
|
(<OR <EMPTY? .ARGS>
|
||||||
|
<NOT <1 .ARGS>>>
|
||||||
|
<DISPATCH .FOO>)
|
||||||
|
(T
|
||||||
|
<DISPATCH .FOO <1 .ARGS>>)>>
|
||||||
|
|
||||||
|
<DEFINE OFF-PRINT (FOO)
|
||||||
|
#DECL ((FOO) NOFFSET)
|
||||||
|
<PRINC "#NOFFSET ">
|
||||||
|
<PRIN1 <GET-ATOM .FOO>>>
|
||||||
|
|
||||||
|
<APPLYTYPE NOFFSET ,OFF-APPLY>
|
||||||
|
|
||||||
|
<PRINTTYPE NOFFSET ,OFF-PRINT>
|
||||||
|
|
||||||
|
<DEFINE ROOM-PRINT (ROOM)
|
||||||
|
#DECL ((ROOM) ROOM)
|
||||||
|
<PRINC "#ROOM [">
|
||||||
|
<PSTRING-PRINT <RID .ROOM> <>>
|
||||||
|
<PRINC " \\\"">
|
||||||
|
<PRINC <RDESC2 .ROOM>>
|
||||||
|
<PRINC "\\\"">
|
||||||
|
<COND (<EMPTY? <REXITS .ROOM>>)
|
||||||
|
(<PRINC " ">
|
||||||
|
<REPEAT ((EX <REXITS .ROOM>))
|
||||||
|
<PRINC <1 .EX>>
|
||||||
|
<COND (<EMPTY? <SET EX <REST .EX 2>>> <RETURN>)
|
||||||
|
(<PRINC " ">)>>)>
|
||||||
|
<COND (<EMPTY? <ROBJS .ROOM>>)
|
||||||
|
(<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) OBJECT)
|
||||||
|
<PRINC " ">
|
||||||
|
<PRINC <OID .X>>>
|
||||||
|
<ROBJS .ROOM>>)>
|
||||||
|
<PRINC " ">
|
||||||
|
<FUNCTION-PRINT <RACTION .ROOM>>
|
||||||
|
<PRINC "]">>
|
||||||
|
|
||||||
|
<PRINTTYPE ROOM ,ROOM-PRINT>
|
||||||
|
|
||||||
|
<DEFINE OBJ-PRINT (OBJ)
|
||||||
|
#DECL ((OBJ) OBJECT)
|
||||||
|
<PRINC "#OBJECT [">
|
||||||
|
<COND (<EMPTY? <ONAMES .OBJ>> <PRINC !\?>)
|
||||||
|
(<PSTRING-PRINT <OID .OBJ> <>>)>
|
||||||
|
<PRINC " ">
|
||||||
|
<PRINC <ODESC2 .OBJ>>
|
||||||
|
<COND (<NOT <EMPTY? <OCONTENTS .OBJ>>>
|
||||||
|
<PRINC " ">
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) <PRINC <OID .X>> <PRINC " ">>
|
||||||
|
<OCONTENTS .OBJ>>)
|
||||||
|
(<OCAN .OBJ> <PRINC " in "> <PRINC <OID <OCAN .OBJ>>> <PRINC " ">)
|
||||||
|
(<PRINC " ">)>
|
||||||
|
<FUNCTION-PRINT <OACTION .OBJ>>
|
||||||
|
<PRINC "]">>
|
||||||
|
|
||||||
|
<PRINTTYPE OBJECT ,OBJ-PRINT>
|
||||||
|
|
||||||
|
<DEFINE HACK-PRINT (HACK)
|
||||||
|
#DECL ((HACK) HACK)
|
||||||
|
<PRINC "#HACK [">
|
||||||
|
<FUNCTION-PRINT <HACTION .HACK>>
|
||||||
|
<PRINC !\ >
|
||||||
|
<PRIN1 <HOBJS .HACK>>
|
||||||
|
<PRINC !\]>>
|
||||||
|
|
||||||
|
<PRINTTYPE HACK ,HACK-PRINT>
|
||||||
|
|
||||||
|
<DEFINE ACTION-PRINT (ACT "AUX" (OUTCHAN .OUTCHAN))
|
||||||
|
#DECL ((ACT) ACTION (OUTCHAN) CHANNEL)
|
||||||
|
<PRINC "#ACTION ">
|
||||||
|
<PRINC <VSTR .ACT>>>
|
||||||
|
|
||||||
|
<PRINTTYPE ACTION ,ACTION-PRINT>
|
||||||
|
|
||||||
|
<DEFINE PSTRING-PRINT (OBJ "OPTIONAL" (TYPE-PRINT T) "AUX" (BP 36) C)
|
||||||
|
#DECL ((OBJ) <PRIMTYPE WORD> (BP C) FIX (TYPE-PRINT) <OR ATOM FALSE>)
|
||||||
|
<COND (.TYPE-PRINT <PRINC !\#> <PRIN1 <TYPE .OBJ>> <PRINC !\ >)>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION ()
|
||||||
|
<COND (<G? <SET BP <- .BP 7>> 0>
|
||||||
|
<COND (<N==? <SET C <CHTYPE <GETBITS .OBJ <BITS 7 .BP>> FIX>>
|
||||||
|
0>
|
||||||
|
<PRINC <ASCII .C>>)>)
|
||||||
|
(T <MAPLEAVE .OBJ>)>>>>
|
||||||
|
|
||||||
|
<PRINTTYPE PSTRING ,PSTRING-PRINT>
|
||||||
|
|
||||||
|
<PRINTTYPE PREP ,PSTRING-PRINT>
|
||||||
|
|
||||||
|
<PRINTTYPE DIRECTION ,PSTRING-PRINT>
|
||||||
|
|
||||||
|
<PRINTTYPE ADJECTIVE ,PSTRING-PRINT>
|
||||||
|
|
||||||
|
<PRINTTYPE BUZZ ,PSTRING-PRINT>
|
|
@ -0,0 +1,257 @@
|
||||||
|
"(c) Copyright 1978, Massachusetts Institute of Technology. All rights reserved."
|
||||||
|
"UTILITY FUNCTIONS ONLY!"
|
||||||
|
|
||||||
|
;"Functions for hacking objects, rooms, winner, etc.
|
||||||
|
REMOVE-OBJECT <obj>
|
||||||
|
Remove an object from any room or ,WINNER or its container.
|
||||||
|
INSERT-OBJECT <obj> <room>
|
||||||
|
Put the object into the room.
|
||||||
|
REMOVE-FROM <obj1> <obj2>
|
||||||
|
Make obj1 no longer contain obj2.
|
||||||
|
INSERT-INTO <obj1> <obj2>
|
||||||
|
Make obj1 contain obj2.
|
||||||
|
TAKE-OBJECT <obj> {OPTIONAL} <adv>
|
||||||
|
Make <obj> one of <adv>'s possessions.
|
||||||
|
DROP-OBJECT <obj> {OPTIONAL} <adv>
|
||||||
|
Remove <obj> from <adv>'s possessions.
|
||||||
|
DROP-IF <obj> {OPTIONAL} <adv>
|
||||||
|
Do a DROP-OBJECT if <adv> has <obj> as a possession.
|
||||||
|
SNARF-OBJECT <obj1> <obj2>
|
||||||
|
Find <obj1>, REMOVE-OBJECT it, and <INSERT-INTO <obj2> <obj1>.
|
||||||
|
|
||||||
|
IN-ROOM? <obj> {OPTIONAL} <room>
|
||||||
|
Is <obj> anywhere inside the room (but not with ,WINNER)?
|
||||||
|
IN-ROOM? does not check OVISON!
|
||||||
|
|
||||||
|
HACKABLE?
|
||||||
|
Is <obj> either in ,HERE or in current vehicle.
|
||||||
|
Uses SEARCH-LIST so completely groks visibility, containers, etc.
|
||||||
|
|
||||||
|
"
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
<DEFINE REMOVE-OBJECT (OBJ "OPTIONAL" (WINNER ,WINNER) "AUX" OCAN OROOM)
|
||||||
|
#DECL ((OBJ) OBJECT (OCAN) <OR OBJECT FALSE> (OROOM) <OR FALSE ROOM>
|
||||||
|
(WINNER) ADV)
|
||||||
|
<COND (<SET OCAN <OCAN .OBJ>>
|
||||||
|
<PUT .OCAN ,OCONTENTS <SPLICE-OUT .OBJ <OCONTENTS .OCAN>>>)
|
||||||
|
(<SET OROOM <OROOM .OBJ>>
|
||||||
|
<PUT .OROOM ,ROBJS <SPLICE-OUT .OBJ <ROBJS .OROOM>>>)
|
||||||
|
(<MEMQ .OBJ <AOBJS .WINNER>>
|
||||||
|
<PUT .WINNER ,AOBJS <SPLICE-OUT .OBJ <AOBJS .WINNER>>>)>
|
||||||
|
<PUT .OBJ ,OROOM <>>
|
||||||
|
<PUT .OBJ ,OCAN <>>>
|
||||||
|
|
||||||
|
<DEFINE INSERT-OBJECT (OBJ ROOM)
|
||||||
|
#DECL ((OBJ) OBJECT (ROOM) ROOM)
|
||||||
|
<PUT .ROOM ,ROBJS (<PUT .OBJ ,OROOM .ROOM> !<ROBJS .ROOM>)>>
|
||||||
|
|
||||||
|
<DEFINE INSERT-INTO (CNT OBJ)
|
||||||
|
#DECL ((OBJ CNT) OBJECT)
|
||||||
|
<PUT .CNT ,OCONTENTS (.OBJ !<OCONTENTS .CNT>)>
|
||||||
|
<PUT .OBJ ,OCAN .CNT>
|
||||||
|
<PUT .OBJ ,OROOM <>>>
|
||||||
|
|
||||||
|
<DEFINE REMOVE-FROM (CNT OBJ)
|
||||||
|
#DECL ((OBJ CNT) OBJECT)
|
||||||
|
<PUT .CNT ,OCONTENTS <SPLICE-OUT .OBJ <OCONTENTS .CNT>>>
|
||||||
|
<PUT .OBJ ,OCAN <>>>
|
||||||
|
|
||||||
|
<DEFINE TAKE-OBJECT (OBJ "OPTIONAL" (WINNER ,WINNER))
|
||||||
|
#DECL ((OBJ) OBJECT (WINNER) ADV)
|
||||||
|
<TRO .OBJ ,TOUCHBIT>
|
||||||
|
<PUT .WINNER ,AOBJS (<PUT .OBJ ,OROOM <>> !<AOBJS .WINNER>)>>
|
||||||
|
|
||||||
|
<DEFINE DROP-OBJECT (OBJ "OPTIONAL" (WINNER ,WINNER))
|
||||||
|
#DECL ((OBJ) OBJECT (WINNER) ADV)
|
||||||
|
<PUT .WINNER ,AOBJS <SPLICE-OUT .OBJ <AOBJS .WINNER>>>>
|
||||||
|
|
||||||
|
<DEFINE DROP-IF (OBJ "OPTIONAL" (WINNER ,WINNER))
|
||||||
|
#DECL ((OBJ) OBJECT (WINNER) ADV)
|
||||||
|
<AND <MEMQ .OBJ <AOBJS .WINNER>>
|
||||||
|
<DROP-OBJECT .OBJ .WINNER>>>
|
||||||
|
|
||||||
|
<DEFINE SNARF-OBJECT (WHO WHAT)
|
||||||
|
#DECL ((WHO WHAT) OBJECT)
|
||||||
|
<COND (<AND <N==? <OCAN .WHAT> .WHO>
|
||||||
|
<OR <OROOM .WHAT>
|
||||||
|
<OCAN .WHAT>>>
|
||||||
|
<REMOVE-OBJECT .WHAT>
|
||||||
|
<INSERT-INTO .WHO .WHAT>)
|
||||||
|
(.WHO)>>
|
||||||
|
|
||||||
|
<DEFINE IN-ROOM? (OBJ "OPTIONAL" (HERE ,HERE) "AUX" TOBJ)
|
||||||
|
#DECL ((OBJ) OBJECT (HERE) ROOM (TOBJ) <OR OBJECT FALSE>)
|
||||||
|
<COND (<SET TOBJ <OCAN .OBJ>>
|
||||||
|
<COND (<==? <OROOM .TOBJ> .HERE>)
|
||||||
|
(<TRNN .TOBJ ,SEARCHBIT>
|
||||||
|
<IN-ROOM? .TOBJ .HERE>)>)
|
||||||
|
(<==? <OROOM .OBJ> .HERE>)>>
|
||||||
|
|
||||||
|
<DEFINE HACKABLE? (OBJ RM "AUX" (AV <AVEHICLE ,WINNER>))
|
||||||
|
#DECL ((OBJ) OBJECT (RM) ROOM (AV) <OR FALSE OBJECT>)
|
||||||
|
<COND (.AV
|
||||||
|
<SEARCH-LIST <OID .OBJ> <OCONTENTS .AV> <>>)
|
||||||
|
(<SEARCH-LIST <OID .OBJ> <ROBJS .RM> <>>)>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
"Villains, thieves, and scoundrels"
|
||||||
|
|
||||||
|
"ROB-ADV: TAKE ALL OF THE VALUABLES A HACKER IS CARRYING"
|
||||||
|
|
||||||
|
<DEFINE ROB-ADV (WIN NEWLIST)
|
||||||
|
#DECL ((WIN) ADV (NEWLIST) <LIST [REST OBJECT]>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) OBJECT)
|
||||||
|
<COND (<AND <G? <OTVAL .X> 0> <NOT <TRNN .X ,SACREDBIT>>>
|
||||||
|
<PUT .WIN ,AOBJS <SPLICE-OUT .X <AOBJS .WIN>>>
|
||||||
|
<SET NEWLIST (.X !.NEWLIST)>)>>
|
||||||
|
<AOBJS .WIN>>
|
||||||
|
.NEWLIST>
|
||||||
|
|
||||||
|
"ROB-ROOM: TAKE VALUABLES FROM A ROOM, PROBABILISTICALLY"
|
||||||
|
|
||||||
|
<DEFINE ROB-ROOM (RM NEWLIST PROB)
|
||||||
|
#DECL ((RM) ROOM (NEWLIST) <LIST [REST OBJECT]> (PROB) FIX)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) OBJECT)
|
||||||
|
<COND (<AND <G? <OTVAL .X> 0>
|
||||||
|
<NOT <TRNN .X ,SACREDBIT>>
|
||||||
|
<TRNN .X ,OVISON>
|
||||||
|
<PROB .PROB>>
|
||||||
|
<REMOVE-OBJECT .X>
|
||||||
|
<TRO .X ,TOUCHBIT>
|
||||||
|
<SET NEWLIST (.X !.NEWLIST)>)
|
||||||
|
(<OACTOR .X>
|
||||||
|
<SET NEWLIST <ROB-ADV <OACTOR .X> .NEWLIST>>)>>
|
||||||
|
<ROBJS .RM>>
|
||||||
|
.NEWLIST>
|
||||||
|
|
||||||
|
<DEFINE GET-DEMON (ID "AUX" (OBJ <FIND-OBJ .ID>) (DEMS ,DEMONS))
|
||||||
|
#DECL ((ID) STRING (OBJ) OBJECT (DEMS) <LIST [REST HACK]>)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) HACK)
|
||||||
|
<COND (<==? <HOBJ .X> .OBJ> <MAPLEAVE .X>)>>
|
||||||
|
.DEMS>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
; "The guiding light"
|
||||||
|
|
||||||
|
<DEFINE LIGHT-SOURCE (ME)
|
||||||
|
#DECL ((ME) ADV)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) OBJECT)
|
||||||
|
<COND (<NOT <TRNN .X ,LIGHTBIT>>
|
||||||
|
<MAPLEAVE .X>)>>
|
||||||
|
<AOBJS .ME>>>
|
||||||
|
|
||||||
|
;"LIT? --
|
||||||
|
IS THERE ANY LIGHT SOURCE IN THIS ROOM"
|
||||||
|
|
||||||
|
<SETG ALWAYS-LIT <>>
|
||||||
|
|
||||||
|
<DEFINE LIT? (RM "AUX" (WIN ,WINNER))
|
||||||
|
#DECL ((RM) ROOM (WIN) ADV)
|
||||||
|
<OR <RTRNN .RM ,RLIGHTBIT>
|
||||||
|
<LFCN <ROBJS .RM>>
|
||||||
|
<AND <==? ,HERE .RM> <LFCN <AOBJS .WIN>>>
|
||||||
|
<AND <N==? .WIN ,PLAYER>
|
||||||
|
<==? ,HERE <AROOM ,PLAYER>>
|
||||||
|
<LFCN <AOBJS ,PLAYER>>>
|
||||||
|
,ALWAYS-LIT>>
|
||||||
|
|
||||||
|
<DEFINE LFCN LFCN (L "AUX" Y)
|
||||||
|
#DECL ((L) <LIST [REST OBJECT]> (Y) ADV (LFCN) ACTIVATION)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X)
|
||||||
|
#DECL ((X) OBJECT)
|
||||||
|
<AND <TRNN .X ,ONBIT> <MAPLEAVE T>>
|
||||||
|
<COND (<AND <TRNN .X ,OVISON>
|
||||||
|
<OR <TRNN .X ,OPENBIT>
|
||||||
|
<TRNN .X ,TRANSBIT>>>
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X) #DECL ((X) OBJECT)
|
||||||
|
<COND (<TRNN .X ,ONBIT>
|
||||||
|
<RETURN T .LFCN>)>>
|
||||||
|
<OCONTENTS .X>>)>
|
||||||
|
<COND (<AND <TRNN .X ,ACTORBIT>
|
||||||
|
<LFCN <AOBJS <SET Y <OACTOR .X>>>>>
|
||||||
|
<MAPLEAVE T>)>>
|
||||||
|
.L>>
|
||||||
|
|
||||||
|
\
|
||||||
|
; "Random Utilities"
|
||||||
|
|
||||||
|
<DEFINE PICK-ONE (VEC)
|
||||||
|
#DECL ((VEC) VECTOR)
|
||||||
|
<NTH .VEC <+ 1 <MOD <RANDOM> <LENGTH .VEC>>>>>
|
||||||
|
|
||||||
|
<SETG LUCKY!-FLAG T>
|
||||||
|
|
||||||
|
<DEFINE PROB (GOODLUCK "OPTIONAL" (BADLUCK .GOODLUCK))
|
||||||
|
#DECL ((GOODLUCK BADLUCK) FIX)
|
||||||
|
<L=? <MOD <RANDOM> 100>
|
||||||
|
<COND (,LUCKY!-FLAG .GOODLUCK)
|
||||||
|
(.BADLUCK)>>>
|
||||||
|
|
||||||
|
<DEFINE YES/NO (NO-IS-BAD? "AUX" (INBUF ,INBUF) (INCHAN ,INCHAN))
|
||||||
|
#DECL ((INBUF) STRING (NO-IS-BAD?) <OR ATOM FALSE> (INCHAN) CHANNEL)
|
||||||
|
<RESET .INCHAN>
|
||||||
|
<TTY-INIT <>>
|
||||||
|
<READST .INBUF "" <>>
|
||||||
|
<COND (.NO-IS-BAD?
|
||||||
|
<NOT <MEMQ <1 .INBUF> "NnfF">>)
|
||||||
|
(T
|
||||||
|
<MEMQ <1 .INBUF> "TtYy">)>>
|
||||||
|
|
||||||
|
<DEFINE SPLICE-OUT (OBJ AL)
|
||||||
|
#DECL ((AL) LIST (OBJ) ANY)
|
||||||
|
<COND (<==? <1 .AL> .OBJ> <REST .AL>)
|
||||||
|
(T
|
||||||
|
<REPEAT ((NL <REST .AL>) (OL .AL))
|
||||||
|
#DECL ((NL) LIST (OL) <LIST ANY>)
|
||||||
|
<COND (<==? <1 .NL> .OBJ>
|
||||||
|
<PUTREST .OL <REST .NL>>
|
||||||
|
<RETURN .AL>)
|
||||||
|
(<SET OL .NL> <SET NL <REST .NL>>)>>)>>
|
||||||
|
|
||||||
|
\
|
||||||
|
|
||||||
|
; "These are for debugging only!"
|
||||||
|
|
||||||
|
<DEFINE FLUSH-OBJ ("TUPLE" OBJS "AUX" (WINNER ,WINNER))
|
||||||
|
#DECL ((OBJS) <TUPLE [REST STRING]> (WINNER) ADV)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X "AUX" (Y <FIND-OBJ .X>))
|
||||||
|
#DECL ((X) STRING (Y) OBJECT)
|
||||||
|
<AND <MEMQ .Y <AOBJS .WINNER>>
|
||||||
|
<DROP-OBJECT <FIND-OBJ .X> .WINNER>>>
|
||||||
|
.OBJS>>
|
||||||
|
|
||||||
|
<DEFINE CONS-OBJ ("TUPLE" OBJS "AUX" (WINNER ,WINNER))
|
||||||
|
#DECL ((OBJS) <TUPLE [REST STRING]> (WINNER) ADV)
|
||||||
|
<MAPF <>
|
||||||
|
<FUNCTION (X "AUX" (Y <FIND-OBJ .X>))
|
||||||
|
#DECL ((Y) OBJECT (X) STRING)
|
||||||
|
<OR <MEMQ .Y <AOBJS .WINNER>>
|
||||||
|
<TAKE-OBJECT <FIND-OBJ .X> .WINNER>>>
|
||||||
|
.OBJS>>
|
||||||
|
|
||||||
|
|
||||||
|
; "No applause, please."
|
||||||
|
|
||||||
|
<DEFINE PERFORM (FCN VB "OPTIONAL" (OBJ1 <>) (OBJ2 <>)
|
||||||
|
"AUX" R (PV ,PRSVEC) (PRSA <PRSA>) (PRSO <PRSO>) (PRSI <PRSI>))
|
||||||
|
#DECL ((VB PRSA) VERB (OBJ1 OBJ2 PRSO PRSI) <OR FALSE OBJECT>
|
||||||
|
(R) ANY (PV) VECTOR (FCN) <OR ATOM NOFFSET APPLICABLE>)
|
||||||
|
<PUT <PUT <PUT .PV 3 .OBJ2> 2 .OBJ1> 1 .VB>
|
||||||
|
<SET R <COND (<TYPE? .FCN ATOM NOFFSET> <APPLY-RANDOM .FCN>)
|
||||||
|
(<APPLY .FCN>)>>
|
||||||
|
<PUT <PUT <PUT .PV 3 .PRSI> 2 .PRSO> 1 .PRSA>
|
||||||
|
.R>
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue