924 lines
25 KiB
Plaintext
924 lines
25 KiB
Plaintext
|
||
"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>)>> |