historicalsource
/
zork
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Original Source

master
historicalsource 2019-04-13 19:44:59 -04:00
commit c446b240a9
20 changed files with 20616 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.md Normal file
View File

@ -0,0 +1,2 @@
# zork
# zork

2040
act1.mud Normal file
View File

File diff suppressed because it is too large Load Diff

793
act2.mud Normal file
View File

@ -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>)>>

1538
act3.mud Normal file
View File

File diff suppressed because it is too large Load Diff

1151
act4.mud Normal file
View File

File diff suppressed because it is too large Load Diff

924
b.mud Normal file
View File

@ -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>)>>

650
defs.mud Normal file
View File

@ -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>>

105
disp1.mud Normal file
View File

@ -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>

6562
dung.mud Normal file
View File

File diff suppressed because it is too large Load Diff

977
impl.mud Normal file
View File

@ -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>>

344
makstr.mud Normal file
View File

@ -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)>>

324
melee.mud Normal file
View File

@ -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.")>>)>>

1021
parser.mud Normal file
View File

File diff suppressed because it is too large Load Diff

102
prim.mud Normal file
View File

@ -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)>)>>

1990
rooms.mud Normal file
View File

File diff suppressed because it is too large Load Diff

445
sr.mud Normal file
View File

@ -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]>>

BIN
syntax.mud Normal file
View File

Binary file not shown.

1263
tell.mud Normal file
View File

File diff suppressed because it is too large Load Diff

128
typhak.mud Normal file
View File

@ -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>

257
util.mud Normal file
View File

@ -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>