1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750 |
- "GUTS OF FROB: BASIC VERBS, COMMAND READER, PARSER, VOCABULARY HACKERS."
- <SETG ALT-FLAG T>
- <GDECL (MUDDLE) FIX (TENEX?) <OR ATOM FALSE> (VERS DEV SNM SCRATCH-STR) STRING>
- <DEFINE SAVE-IT ("OPTIONAL" (FN <COND (<L? ,MUDDLE 100>"MADMAN;MADADV SAVE")
- (T "<MDL>MADADV.SAVE")>)
- "AUX" (MUDDLE ,MUDDLE) STV (ST <REMARKABLY-DISGUSTING-CODE>))
- #DECL ((FN) STRING (MUDDLE) FIX (STV) <OR STRING FIX>)
- <PUT <FIND-OBJ "PAPER"> ,ODESC1 <UNSPEAKABLE-CODE>>
- <SETG VERS .ST>
- <SETG SCRIPT-CHANNEL <>>
- <SETG RAW-SCORE 0>
- <SET IH <ON "IPC" ,ILO 1>>
- <HANDLER ,DIVERT-INT ,DIVERT-HAND>
- <COND (<G? .MUDDLE 100>
- <SETG SCRATCH-STR <ISTRING 32>>
- <SETG DEV "DSK">
- <SETG SNM "MDL">)
- (<SNAME "">
- <SETG DEV "DSK">
- <SETG SNM "MADMAN">)>
- <INT-LEVEL 100000>
- <COND (<=? <SAVE .FN> "SAVED"> <INT-LEVEL 0> T)
- (T
- ; "STARTER on 10x sets up tty correctly, setg's DEV to \"MDL\"
- if that device exists; if not, (sort of) returns directory muddle
- came from. On its it returns # zorkers currently in existence."
- <COND (<AND <TYPE? <SET STV <STARTER>> FIX>
- <G? .STV 3>>
- <OR <MEMBER <SETG XUNM <XUNAME>> ,WINNERS>
- <=? ,XUNM "SEC">
- <=? ,XUNM "ELBOW">
- <AND <OFF "CHAR" ,INCHAN>
- <TELL
- "There appears before you a threatening figure clad all over
- in heavy black armor. His legs seem like the massive trunk
- of the oak tree. His broad shoulders and helmeted head loom
- high over your own puny frame and you realize that his powerful
- arms could easily crush the very life from your body. There
- hangs from his belt a veritable arsenal of deadly weapons:
- sword, mace, ball and chain, dagger, lance, and trident.
- He speaks with a commanding voice:
- \"YOU SHALL NOT PASS \"
- As he grabs you by the neck all grows dim about you.">
- <QUIT>>>)
- (<TYPE? .STV STRING>
- <SETG SNM <SUBSTRUC ,SCRATCH-STR
- 0
- <- <LENGTH ,SCRATCH-STR>
- <LENGTH <MEMQ !\ .STV>>>>>)>
- <COND (<G? ,MUDDLE 100> <SETG TENEX? <GETSYS>>)
- (<APPLY ,IPC-OFF>
- <APPLY ,IPC-ON <UNAME> "ZORK">)>
- <SET BH <ON "BLOCKED" ,BLO 100>>
- <START "WHOUS" .ST>)>>
- "Stuff for diverting gc's"
- <SETG DIVERT-CNT 0>
- <SETG DIVERT-MAX 99>
- <SETG DIVERT-INC 4000>
- <SETG DIVERT-AMT 0>
- <SETG DIVERT-LMT 100000>
- <GDECL (DIVERT-CNT DIVERT-MAX DIVERT-INC DIVERT-AMT DIVERT-LMT) FIX>
- <DEFINE DIVERT-FCN (AMT REASON)
- <SETG DIVERT-CNT <+ ,DIVERT-CNT 1>>
- <SETG DIVERT-AMT <+ ,DIVERT-AMT ,DIVERT-INC .AMT>>
- <COND (<OR <G? ,DIVERT-CNT ,DIVERT-MAX>
- <G? ,DIVERT-AMT ,DIVERT-LMT>> ;"Too much diversion ?"
- <SETG DIVERT-AMT <SETG DIVERT-CNT 0>>
- <GC-FCN>
- <GC>)
- (ELSE ;"Divert this request for storage"
- <COND (<1? ,DIVERT-CNT> ;"First diversion ?"
- <HANDLER ,GC-INT ,GC-HAND>)>
- <BLOAT <+ .AMT ,DIVERT-INC>>
- ;"Get storage desired plus extra increment")>>
- <SETG DIVERT-HAND <HANDLER <SETG DIVERT-INT <EVENT "DIVERT-AGC" 1000>>
- ,DIVERT-FCN>>
- <OFF ,DIVERT-HAND>
- <DEFINE GC-FCN ("TUPLE" T)
- <OFF ,GC-HAND>
- <SETG DIVERT-AMT <SETG DIVERT-CNT 0>>>
- <SETG GC-HAND <HANDLER <SETG GC-INT <EVENT "GC" 11>>
- ,GC-FCN>>
- <OFF ,GC-HAND>
- <DEFINE XUNAME ()
- #DECL ((VALUE) STRING)
- <MAPF ,STRING
- <FUNCTION (X)
- #DECL ((X) CHARACTER)
- <COND (<OR <0? <ASCII .X>>
- <==? <ASCII .X> 32>>
- <MAPSTOP>)
- (T .X)>>
- <GXUNAME>>>
- <DEFINE ITS-GET-NAME (UNAME "AUX" (NM <FIELD .UNAME ,$NAME>) CMA JR LFST LLST
- TLEN TSTR STR)
- #DECL ((STR TSTR UNAME) STRING (NM CMA JR) <OR STRING FALSE>
- (TLEN LLST LFST) FIX)
- <COND (.NM
- <COND (<SET CMA <MEMQ !\, .NM>>
- <SET LLST <- <LENGTH .NM> <LENGTH .CMA>>>
- <SET CMA <REST .CMA>>
- <SET LFST <LENGTH .CMA>>
- <COND (<SET JR <MEMQ !\, .CMA>>
- <SET LFST <- .LFST <LENGTH .JR>>>)>
- <REPEAT ()
- <COND (<EMPTY? .CMA> <RETURN>)
- (<MEMQ <1 .CMA> %<STRING <ASCII 32> <ASCII 9>>>
- <SET CMA <REST .CMA>>
- <SET LFST <- .LFST 1>>)
- (ELSE <RETURN>)>>
- <SET TLEN <+ .LFST 1 .LLST <LENGTH .JR>>>
- <SET STR <ISTRING .TLEN !\ >>
- <SET TSTR .STR>
- <SUBSTRUC .CMA 0 .LFST .TSTR>
- <SET TSTR <REST .TSTR <+ .LFST 1>>>
- <SUBSTRUC .NM 0 .LLST .TSTR>
- <AND .JR <SUBSTRUC .JR 0 <LENGTH .JR> <REST .TSTR .LLST>>>
- <SETG USER-NAME .STR>)
- (ELSE <SETG USER-NAME .NM>)>)>>
- <DEFINE UNSPEAKABLE-CODE ("AUX" STR NSTR (LEN-I 0) (O <FIND-OBJ "PAPER">))
- #DECL ((O) OBJECT (NSTR STR) STRING (LEN-I) FIX)
- <SET STR <MEMQ !\/ <OREAD .O>>>
- <COND (<==? <1 <BACK .STR 2>> !\1>
- <SET STR <BACK .STR 2>>
- <SET LEN-I 1>)
- (<SET STR <BACK .STR 1>>)>
- <SET NSTR <REST <MEMQ !\/ <REST <MEMQ !\/ .STR>>> 3>>
- <STRING "There is an issue of US NEWS & DUNGEON REPORT dated "
- <SUBSTRUC .STR 0 <- <LENGTH .STR> <LENGTH .NSTR>>>
- " here.">>
- <DEFINE REMARKABLY-DISGUSTING-CODE ("AUX" (N <DSKDATE>))
- #DECL ((N) <PRIMTYPE WORD>)
- <STRING
- "This version created "
- <NTH ,MONTHS <CHTYPE <GETBITS .N <BITS 4 23>> FIX>>
- !\
- <UNPARSE <CHTYPE <GETBITS .N <BITS 5 18>> FIX>>
- !\.>>
- <DEFINE VERSION ()
- <TELL ,VERS>>
- <SETG PLAYED-TIME 0>
- <GDECL (PLAYED-TIME) FIX>
- <DEFINE GET-TIME ("AUX" (NOW <DSKDATE>) (THEN ,INTIME))
- #DECL ((NOW THEN) <PRIMTYPE WORD>)
- <+ <COND (<N==? <CHTYPE <GETBITS .NOW <BITS 18 18>> FIX>
- <CHTYPE <GETBITS .THEN <BITS 18 18>> FIX>>
- </ <- <+ <CHTYPE <GETBITS .NOW <BITS 18 0>> FIX>
- <* 24 7200>>
- <CHTYPE <GETBITS .THEN <BITS 18 0>> FIX>>
- 2>)
- (</ <- <CHTYPE <GETBITS .NOW <BITS 18 0>> FIX>
- <CHTYPE <GETBITS .THEN <BITS 18 0>> FIX>>
- 2>)>
- ,PLAYED-TIME>>
- <DEFINE PLAY-TIME ("OPTIONAL" (OUTCHAN ,OUTCHAN) (LOSER? T)
- "AUX" TIME MINS)
- #DECL ((MINS TIME) FIX (OUTCHAN) <SPECIAL CHANNEL> (LOSER?) <OR ATOM FALSE>)
- <SET TIME <GET-TIME>>
- <SETG TELL-FLAG T>
- <COND (.LOSER? <PRINC "You have been playing DUNGEON for ">)
- (T
- <PRINC "Played for ">)>
- <AND <G? <SET MINS </ .TIME 3600>> 0>
- <PRIN1 .MINS>
- <PRINC " hour">
- <OR <1? .MINS> <PRINC "s">>
- <PRINC ", ">>
- <COND (<G? <SET MINS <MOD </ .TIME 60> 60>> 0>
- <PRIN1 .MINS>
- <PRINC " minute">
- <COND (<NOT <1? .MINS>> <PRINC "s">)>
- <PRINC ", and ">)>
- <PRIN1 <SET MINS <MOD .TIME 60>>>
- <PRINC " second">
- <OR <1? .MINS> <PRINC "s">>
- <COND (.LOSER? <PRINC ".
- ">)
- (<PRINC ".">)>
- .TIME>
- <DEFINE PC () T>
- <DEFINE HANDLE (FRM "TUPLE" ZORK "AUX" ZF)
- #DECL ((ZF) ANY)
- <PUT ,OUTCHAN 13 80>
- <PUT <1 <BACK ,INCHAN>> 6 #LOSE 27>
- <COND (<AND <OR <NOT <GASSIGNED? XUNM>>
- <MEMBER ,XUNM ,WINNERS>>
- <PC>>
- <AND <GASSIGNED? SAVEREP> <SETG REP ,SAVEREP>>
- <AND <ASSIGNED? BH> <OFF .BH>>
- <INT-LEVEL 0>
- <SETG DBG T>
- <SETG ALT-FLAG T>)
- (T
- <COND (<AND <NOT <EMPTY? .ZORK>>
- <==? <1 .ZORK> CONTROL-G?!-ERRORS>>
- <INT-LEVEL 0>
- <FINISH>
- <PUT <1 <BACK ,INCHAN>> 6 <COND (<G? ,MUDDLE 100>
- <COND (,TENEX? #LOSE *37*)
- (T #LOSE *000000000012*)>)
- (T #LOSE *000000000015*)>>
- <ERRET T .FRM>)
- (<AND <==? <LENGTH .ZORK> 3>
- <==? <1 .ZORK> FILE-SYSTEM-ERROR!-ERRORS>
- <NOT <SET ZF <3 .ZORK>>>
- <==? <LENGTH .ZF> 3>
- <=? <1 .ZF>
- "ILLEGAL CHR AFTER CNTRL P ON TTY DISPLAY">>
- ; "HACK FOR ILLEGAL CHR AFTER CTRL-P"
- <PUT <1 <BACK ,INCHAN>> 6 #LOSE *000000000015*>
- <INT-LEVEL 0>
- <ERRET T .FRM>)
- (<TELL
- "I'm sorry, you seem to have encountered an error in the program.
- Send mail to DUNGEON@MIT-DMS describing what it was you tried to do.">
- <TELL ,VERS>
- <MAPF <> <FUNCTION (X) <PRINT .X>> .ZORK>
- <FINISH #FALSE (". Error.")>)>)>>
- <PSETG WINNERS '["BKD" "TAA" "MARC" "PDL" "MDL"]>
- <GDECL (WINNERS) <VECTOR [REST STRING]>>
- <OR <LOOKUP "COMPILE" <ROOT>>
- <LOOKUP "GLUE" <GET PACKAGE OBLIST>>
- <SETG ERRH
- <HANDLER <OR <GET ERROR!-INTERRUPTS INTERRUPT> <EVENT "ERROR" 8>>
- ,HANDLE>>>
- <GDECL (MOVES) FIX (SCRIPT-CHANNEL) <OR CHANNEL FALSE>>
- <DEFINE START (RM "OPTIONAL" (ST "") "AUX" FN (MUDDLE ,MUDDLE) (XUNM <XUNAME>))
- #DECL ((ST RM) STRING (MUDDLE) FIX (XUNM) STRING (FN) <OR FALSE STRING>)
- <SETG XUNM .XUNM>
- <SETG PTEMP <CHTYPE [<CHTYPE WITH!-WORDS PREP> <FIND-OBJ "!!!!!">] PHRASE>>
- <SETG INTIME <DSKDATE>>
- <COND (<L? .MUDDLE 100>
- <AND <G? <LENGTH .XUNM> 2> <=? <SUBSTRUC .XUNM 0 3> "___"> <QUIT>>
- <SET FN <ITS-GET-NAME .XUNM>>)
- (<SET FN <GET-NAME>>)>
- <COND (.FN
- <SETG USER-NAME .FN>)
- (<SETG USER-NAME .XUNM>)>
- <SETG DEATHS 0>
- <SETG MOVES 0>
- <SETG WINNER ,PLAYER>
- <PUT ,WINNER ,AROOM <SETG HERE <FIND-ROOM .RM>>>
- <TELL "Welcome to Dungeon.
- " 1 .ST>
- <RANDOM <CHTYPE <DSKDATE> FIX>>
- <INT-LEVEL 0>
- <CONTIN>>
- <DEFINE CONTIN ()
- <SETG ALT-FLAG <>>
- <PUT <1 <BACK ,INCHAN>> 6 <COND (<G? ,MUDDLE 100>
- <COND (,TENEX? #LOSE *37*)
- (T #LOSE *000000000012*)>)
- (T #LOSE *000000000015*)>>
- <SETG SAVEREP ,REP>
- <SETG REP ,RDCOM>
- <RESET ,INCHAN>
- <SETG WINNER ,PLAYER>
- <PUT ,PRSVEC 2 <>>
- ,NULL>
- <SETG MY-SCRIPT <>>
- <GDECL (MY-SCRIPT) <OR ATOM FALSE>>
- <DEFINE MAKE-SCRIPT ("AUX" CH)
- #DECL ((CH) <OR CHANNEL FALSE>)
- <COND (,SCRIPT-CHANNEL
- <>)
- (<SET CH <OPEN "PRINT" <STRING "MARC;%Z" ,XUNM " >">>>
- <PUT <TOP ,INCHAN> 1 (.CH)>
- <PUT <TOP ,OUTCHAN> 1 (.CH)>
- <SETG SCRIPT-CHANNEL .CH>
- <SETG MY-SCRIPT T>)>>
- <DEFINE FLUSH-ME ()
- <UNWIND
- <PROG ()
- <TELL
- "Suddenly, a sinister, wraithlike figure appears before you, seeming
- to float in the air. He glows with an eldritch light. In a barely
- audible voice he says, \"Begone, defiler! Your presence upsets the
- very balance of the System itself!\" With a sinister chuckle, he
- raises his oaken staff, taps you on the head, and fades into the
- gloom. In his place appears a tastefully lettered sign reading:
- DUNGEON CLOSED
- At that instant, you disappear, and all your belongings clatter to
- the ground.
- ">
- <FINISH <>>>
- <FINISH <>>>>
- <DEFINE DO-SCRIPT ("AUX" CH (UNM ,XUNM) (MUDDLE ,MUDDLE))
- #DECL ((CH) <OR CHANNEL FALSE> (UNM) STRING (MUDDLE) FIX)
- <COND (,MY-SCRIPT
- <DO-UNSCRIPT <>>)>
- <COND (,SCRIPT-CHANNEL
- <TELL "You are already scripting.">)
- (<AND
- <OR <G? .MUDDLE 100>
- <AND <NOT <MEMBER "GUEST" .UNM>>
- <SET CH <OPEN "READ" ".FILE." "(DIR)" "DSK" .UNM>>
- <CLOSE .CH>
- <SET CH <OPEN "READ" "_MSGS_" .UNM "DSK" .UNM>>
- <CLOSE .CH>>>
- <SET CH <OPEN "PRINT" "ZORK" "SCRIPT" "DSK" .UNM>>>
- <PUT <TOP ,INCHAN> 1 (.CH)>
- <PUT <TOP ,OUTCHAN> 1 (.CH)>
- <SETG SCRIPT-CHANNEL .CH>
- <COND (<L? ,MUDDLE 100>
- <TELL "Scripting to " 1 ,XUNM ";ZORK SCRIPT">)
- (T
- <TELL "Scripting to <" 1 ,XUNM ">ZORK.SCRIPT">)>)
- (T
- <TELL "I can't open the script channel.">)>>
- <DEFINE DO-UNSCRIPT ("OPTIONAL" (VERBOSE T))
- #DECL ((VERBOSE) <OR ATOM FALSE>)
- <COND (,SCRIPT-CHANNEL
- <PUT <TOP ,INCHAN> 1 ()>
- <PUT <TOP ,OUTCHAN> 1 ()>
- <CLOSE ,SCRIPT-CHANNEL>
- <SETG SCRIPT-CHANNEL <>>
- <AND .VERBOSE <TELL "Scripting off.">>)
- (<AND .VERBOSE <TELL "Scripting wasn't on.">>)>>
- <GDECL (THEN) FIX>
- <DEFINE DO-SAVE ("AUX" (MUDDLE ,MUDDLE) CH (UNM ,XUNM))
- #DECL ((CH) <OR CHANNEL FALSE> (MUDDLE) FIX (UNM) STRING)
- <COND (<OR <G? .MUDDLE 100>
- <AND <NOT <MEMBER "GUEST" .UNM>>
- <SET CH <OPEN "READ" ".FILE." "(DIR)" "DSK" .UNM>>
- <CLOSE .CH>>>
- <COND (<OR <G? .MUDDLE 100>
- <AND <SET CH <OPEN "READ" "_MSGS_" .UNM "DSK" .UNM>>
- <CLOSE .CH>>>
- <AND ,SCRIPT-CHANNEL <DO-UNSCRIPT>>
- <TELL "Saving.">
- <INT-LEVEL 100000>
- <OFF "CHAR" ,INCHAN>
- <SETG THEN <CHTYPE <DSKDATE> FIX>>
- <SETG PLAYED-TIME <GET-TIME>>
- <COND (<SET CH <OPEN "PRINTB"
- <COND (<L? .MUDDLE 100>
- <STRING "DSK:" .UNM ";ZORK SAVE">)
- (T
- <STRING "DSK:<" .UNM ">ZORK.SAVE">)>>>
- <SAVE-GAME .CH>
- <FINISH <CHTYPE '(". Saved.") FALSE>>)
- (<TELL "Save failed.">
- <TELL <1 .CH> 1 " " <2 .CH>>)>)
- (<TELL "Can't open channel for save.">)>)
- (T <TELL "Can't open channel for save.">)>>
- <DEFINE DO-RESTORE ("AUX" CH STR (MUDDLE ,MUDDLE) NOWD NOW THEND)
- #DECL ((CH) <OR CHANNEL FALSE> (STR) STRING (NOWD NOW THEND MUDDLE) FIX)
- <COND (<L? .MUDDLE 100>
- <SET STR <STRING "DSK:" ,XUNM ";ZORK SAVE">>)
- (T
- <SET STR <STRING "DSK:<" ,XUNM ">ZORK.SAVE">>)>
- <PROG ((FOO T) (SNM <SNAME>))
- #DECL ((FOO) <OR ATOM FALSE> (SNM) <SPECIAL STRING>)
- <COND (<SET CH <OPEN "READB" .STR>>
- <COND (<RESTORE-GAME .CH>
- <COND (<MEMBER ,XUNM ,WINNERS>)
- (<==? <SET NOWD
- <CHTYPE <GETBITS <SET NOW
- <CHTYPE <DSKDATE> FIX>>
- <BITS 18 18>>
- FIX>>
- <SET THEND
- <CHTYPE <GETBITS ,THEN <BITS 18 18>> FIX>>>
- <COND (<G=? <- .NOW ,THEN> 2400>)
- (<TELL "It's too soon.">
- <COND (<G? ,MUDDLE 100>
- <OFF "CHAR" ,INCHAN>
- <INT-LEVEL 10000>
- <QUIT>)>
- <QUIT>)>)
- (<1? <- .NOWD .THEND>>
- <COND (<G=? <- <+ <CHTYPE <GETBITS .NOW <BITS 18 0>> FIX>
- <* 24 7200>>
- <CHTYPE <GETBITS .NOW <BITS 18 0>> FIX>>
- 2400>)
- (<TELL "It's too soon.">
- <QUIT>)>)>
- <SETG INTIME .NOW>
- <TELL "Restored.">)
- (<TELL "Restore failed.">)>
- <ROOM-DESC>)
- (<AND .FOO <G? .MUDDLE 100>>
- <SET STR <STRING <SNAME> "ZORK.SAVE">>
- <SET FOO <>>
- <AGAIN>)
- (<TELL <2 .CH> 1 " " <1 .CH>>)>>>
- <DEFINE PROB (NUM) #DECL ((NUM) FIX) <L=? <MOD <RANDOM> 100> .NUM>>
- "GET-ATOM TAKES A VALUE AND SEARCHES INITIAL FOR FIRST ATOM
- SETG'ED TO THAT."
- <DEFINE GET-ATOM ACT (VAL "AUX" (O <GET INITIAL OBLIST>))
- #DECL ((O) OBLIST)
- <MAPF <>
- <FUNCTION (X) #DECL ((X) <LIST [REST ATOM]>)
- <MAPF <>
- <FUNCTION (X) #DECL ((X) ATOM)
- <COND (<AND <GASSIGNED? .X>
- <==? ,.X .VAL>>
- <RETURN .X .ACT>)>>
- .X>>
- .O>>
- ;
- "ROOM-INFO --
- PRINT SOMETHING ABOUT THIS PLACE
- 1. CHECK FOR LIGHT --> ELSE WARN LOSER
- 2. GIVE A DESCRIPTION OF THE ROOM
- 3. TELL WHAT'S ON THE FLOOR IN THE WAY OF OBJECTS
- 4. SIGNAL ENTRY INTO THE ROOM
- "
- <SETG BRIEF!-FLAG <>>
- <SETG SUPER-BRIEF!-FLAG <>>
- <GDECL (SUPER-BRIEF!-FLAG BRIEF!-FLAG) <OR ATOM FALSE>>
- <DEFINE BRIEF ()
- <SETG BRIEF!-FLAG T>
- <TELL "Brief descriptions.">>
- <DEFINE SUPER-BRIEF ()
- <SETG SUPER-BRIEF!-FLAG T>
- <TELL "No long descriptions.">>
- <DEFINE UN-BRIEF ()
- <SETG BRIEF!-FLAG <>>
- <SETG SUPER-BRIEF!-FLAG <>>
- <TELL "Long descriptions.">>
- <DEFINE UN-SUPER-BRIEF ()
- <SETG SUPER-BRIEF!-FLAG <>>
- <TELL "Some long descriptions.">>
- <DEFINE ROOM-DESC () <ROOM-INFO T>>
- <DEFINE ROOM-INFO ("OPTIONAL" (FULL <>)
- "AUX" (AV <AVEHICLE ,WINNER>) (RM ,HERE) (PRSO <2 ,PRSVEC>)
- (WINOBJ <FIND-OBJ "#####">) (OUTCHAN ,OUTCHAN) RA)
- #DECL ((RM) ROOM (WINOBJ) OBJECT (AV) <OR FALSE OBJECT> (OUTCHAN) CHANNEL
- (PRSO) <OR DIRECTION FALSE OBJECT> (FULL) <OR ATOM FALSE>)
- <SETG TELL-FLAG T>
- <AND <TYPE? .PRSO DIRECTION> <PUT ,PRSVEC 2 <>>>
- <PROG ()
- <COND (<N==? ,HERE <AROOM ,PLAYER>>
- <PUT ,PRSVEC 1 ,WALK-IN!-WORDS>
- <TELL "Done.">
- <RETURN>)
- (<AND .PRSO
- <TYPE? .PRSO OBJECT>>
- <COND (<OBJECT-ACTION>)
- (<OREAD .PRSO>
- <TELL <OREAD .PRSO>>)
- (<TELL "I see nothing special about the "
- 1
- <ODESC2 .PRSO>
- ".">)>
- <RETURN>)
- (<NOT <LIT? .RM>>
- <TELL
- "It is pitch black. You are likely to be eaten by a grue.">
- <RETURN <>>)
- (<OR <AND <NOT .FULL> ,SUPER-BRIEF!-FLAG>
- <AND <RSEEN? .RM>
- <OR ,BRIEF!-FLAG <PROB 80>>
- <NOT .FULL>>>
- <TELL <RDESC2 .RM>>)
- (<AND <EMPTY? <RDESC1 .RM>> <SET RA <RACTION .RM>>>
- <PUT ,PRSVEC 1 ,LOOK!-WORDS>
- <APPLY-RANDOM .RA>
- <PUT ,PRSVEC 1 ,FOO!-WORDS> ; "Something innocuous")
- (<TELL <RDESC1 .RM>>)>
- <PUT .RM ,RSEEN? T>
- <AND .AV <TELL "You are in the " 1 <ODESC2 .AV> ".">>
- <MAPF <>
- <FUNCTION (X)
- #DECL ((X) OBJECT)
- <COND
- (<AND <OVIS? .X> <DESCRIBABLE? .X>>
- <COND (<==? .X .AV>)
- (T
- <COND (<LONG-DESC-OBJ .X>
- <AND .AV <TELL " [in the room]" 0>>
- <CRLF>)>)>
- <COND (<TRNN .X ,ACTORBIT>
- <INVENT <ORAND .X>>)
- (<SEE-INSIDE? .X>
- <PRINT-CONT
- .X .AV .WINOBJ ,INDENTSTR <COND (.FULL)
- (,SUPER-BRIEF!-FLAG <>)
- (,BRIEF!-FLAG <>)
- (T)>>)>)>>
- <ROBJS .RM>>
- <COND (<AND <SET RA <RACTION .RM>>
- <NOT .FULL>>
- <PUT ,PRSVEC 1 ,WALK-IN!-WORDS>
- <APPLY-RANDOM .RA>
- <PUT ,PRSVEC 1 ,FOO!-WORDS>)>
- T>>
- <PSETG INDENTSTR <REST <ISTRING 8> 8>>
- <DEFINE PRINT-CONT PRINT-C (OBJ AV WINOBJ INDENT "OPTIONAL" (CASE? T)
- "AUX" (CONT <OCONTENTS .OBJ>))
- #DECL ((AV) <OR FALSE OBJECT> (OBJ WINOBJ) OBJECT (INDENT) STRING
- (CONT) <LIST [REST OBJECT]> (CASE?) <OR ATOM FALSE>)
- <COND (<NOT <EMPTY? .CONT>>
- <COND (<==? .OBJ <FIND-OBJ "TCASE">>
- <COND (<NOT .CASE?> <RETURN T .PRINT-C>)>
- <TELL "Your collection of treasures consists of:">)
- (<NOT <AND <==? <LENGTH .CONT> 1>
- <==? <1 .CONT> <FIND-OBJ "#####">>>>
- <TELL .INDENT 0>
- <TELL "The " 1 <ODESC2 .OBJ> " contains:">)
- (<RETURN T .PRINT-C>)>
- <MAPF <>
- <FUNCTION (Y)
- #DECL ((Y) OBJECT)
- <COND (<AND .AV <==? .Y .WINOBJ>>)
- (<AND <OVIS? .Y> <DESCRIBABLE? .Y> <NOT <EMPTY? <ODESC2 .Y>>>>
- <TELL .INDENT 1 " A " <ODESC2 .Y>>)>
- <COND (<SEE-INSIDE? .Y>
- <PRINT-CONT .Y .AV .WINOBJ <BACK .INDENT>>)>>
- <OCONTENTS .OBJ>>)>>
- "GIVE LONG DESCRIPTION OF OBJECT"
- <DEFINE LONG-DESC-OBJ (OBJ "AUX" STR)
- #DECL ((OBJ) OBJECT)
- <COND (<OR <OTOUCH? .OBJ> <NOT <ODESCO .OBJ>>>
- <SET STR <ODESC1 .OBJ>>)
- (<SET STR <ODESCO .OBJ>>)>
- <COND (<EMPTY? .STR> <>)
- (<TELL .STR 0>)>>
- "TRUE IF PARSER WON: OTHERWISE INHIBITS OBJECT ACTIONS, CLOCKS (BUT NOT THIEF)."
- <GDECL (PARSE-WON) <OR ATOM FALSE>>
- <PSETG READER-STRING <STRING <ASCII 27> <ASCII 13> <ASCII 10>>>
- <DEFINE RDCOM ("OPTIONAL" (IVEC <>)
- "AUX" (STR ,READER-STRING) VC RVEC RM (INPLEN 1) (INBUF ,INBUF)
- (WINNER ,WINNER) AV (OUTCHAN ,OUTCHAN) RANDOM-ACTION)
- #DECL ((RVEC) <OR FALSE VECTOR> (RM) ROOM (INPLEN) FIX (INBUF) STRING
- (WINNER) ADV (AV) <OR FALSE OBJECT> (OUTCHAN) CHANNEL
- (IVEC) <OR FALSE VECTOR> (VC) VECTOR)
- <OR .IVEC <PROG ()
- <PUT .OUTCHAN 13 1000>
- <ROOM-INFO T>>>
- <REPEAT (VVAL CV)
- #DECL ((CV) <OR FALSE VERB>)
- <SET VVAL T>
- <COND (<NOT .IVEC>
- <SET RM ,HERE>
- <PRINC ">">
- <SETG TELL-FLAG <>>
- <SET INPLEN <READSTRING .INBUF ,INCHAN .STR>>
- <READCHR ,INCHAN>
- <OR ,ALT-FLAG <READCHR ,INCHAN>>
- <SET VC <LEX .INBUF <REST .INBUF .INPLEN> T>>)>
- <COND (<G? .INPLEN 0>
- <SETG MOVES <+ ,MOVES 1>>
- <COND (<SETG PARSE-WON
- <AND <EPARSE <OR .IVEC .VC> <>>
- <TYPE? <SET CV <1 <SET RVEC ,PRSVEC>>> VERB>>>
- <COND (<NOT <SET RANDOM-ACTION <AACTION .WINNER>>>)
- (<APPLY-RANDOM .RANDOM-ACTION>
- <RETURN>)>
- <AND <SET AV <AVEHICLE .WINNER>>
- <SET RANDOM-ACTION <OACTION .AV>>
- <SET VVAL <NOT <APPLY-RANDOM .RANDOM-ACTION READ-IN>>>>
- <COND (<AND .VVAL <SET RANDOM-ACTION <VFCN .CV>>
- <APPLY-RANDOM .RANDOM-ACTION>>
- <COND (<AND <SET RANDOM-ACTION <RACTION <SET RM ,HERE>>>
- <APPLY-RANDOM .RANDOM-ACTION>>)>)>)
- (.IVEC
- <COND (,TELL-FLAG
- <TELL "Please input entire command again.">)
- (<TELL "Nothing happens.">)>
- <RETURN>)>
- <OR ,TELL-FLAG <TELL "Nothing happens.">>)
- (T <SETG PARSE-WON <>> <TELL "Beg pardon?">)>
- <MAPF <>
- <FUNCTION (X)
- #DECL ((X) HACK)
- <COND (<SET RANDOM-ACTION <HACTION .X>>
- <APPLY-RANDOM .RANDOM-ACTION .X>)>>
- ,DEMONS>
- <AND ,PARSE-WON
- <SET AV <AVEHICLE .WINNER>>
- <SET RANDOM-ACTION <OACTION .AV>>
- <APPLY-RANDOM .RANDOM-ACTION READ-OUT>>
- <AND .IVEC <RETURN>>>>
- <DEFINE SCORE-OBJ (OBJ "AUX" TEMP) #DECL ((OBJ) OBJECT)
- <COND (<G? <SET TEMP <OFVAL .OBJ>> 0>
- <SCORE-UPD .TEMP>
- <PUT .OBJ ,OFVAL 0>)>>
- <DEFINE SCORE-ROOM (RM "AUX" TEMP) #DECL ((RM) ROOM)
- <COND (<G? <SET TEMP <RVAL .RM>> 0>
- <SCORE-UPD .TEMP>
- <PUT .RM ,RVAL 0>)>>
- <DEFINE SCORE-UPD (NUM "AUX" (WINNER ,WINNER)) #DECL ((NUM) FIX)
- <PUT .WINNER ,ASCORE <+ <ASCORE .WINNER> .NUM>>
- <SETG RAW-SCORE <+ ,RAW-SCORE .NUM>>>
- <DEFINE SCORE ("OPTIONAL" (ASK? T) "AUX" SCOR (OUTCHAN .OUTCHAN) PCT)
- #DECL ((ASK?) <OR ATOM FALSE> (SCOR) FIX (OUTCHAN) CHANNEL (PCT) FLOAT)
- <SETG TELL-FLAG T>
- <CRLF>
- <COND (.ASK? <PRINC
- "Your score would be ">)
- (<PRINC "Your score is ">)>
- <PRIN1 <SET SCOR
- <ASCORE ,WINNER>>>
- <PRINC " [total of ">
- <PRIN1 ,SCORE-MAX>
- <PRINC " points], in ">
- <PRIN1 ,MOVES>
- <COND (<1? ,MOVES> <PRINC " move.">)
- (<PRINC " moves.">)>
- <CRLF>
- <PRINC "This score gives you the rank of ">
- <SET PCT </ <FLOAT .SCOR> <FLOAT ,SCORE-MAX>>>
- <PRINC <COND (<1? .PCT> "Cheater")
- (<G? .PCT 0.95000000> "Wizard")
- (<G? .PCT 0.89999999> "Master")
- (<G? .PCT 0.79999999> "Winner")
- (<G? .PCT 0.60000000> "Hacker")
- (<G? .PCT 0.39999999> "Adventurer")
- (<G? .PCT 0.19999999> "Junior Adventurer")
- (<G? .PCT 0.09999999> "Novice Adventurer")
- (<G? .PCT 0.04999999> "Amateur Adventurer")
- ("Beginner")>>
- <PRINC ".">
- <CRLF>
- .SCOR>
- <DEFINE FINISH ("OPTIONAL" (ASK? T) "AUX" SCOR)
- #DECL ((ASK?) <OR ATOM FALSE> (SCOR) FIX)
- <UNWIND
- <PROG ()
- <SET SCOR <SCORE .ASK?>>
- <COND (<OR <AND .ASK?
- <TELL
- "Do you wish to leave the game? (Y is affirmative): ">
- <YES/NO <>>>
- <NOT .ASK?>>
- <RECORD .SCOR ,MOVES ,DEATHS .ASK? ,HERE>
- <QUIT>)>>
- <QUIT>>>
- "PRINT OUT DESCRIPTION OF LOSSAGE: WHEN PLAYED, SCORE, # MOVES, ETC."
- <SETG RECORD-STRING <ISTRING 5>>
- <GDECL (RECORD-STRING) STRING>
- <PSETG RECORDER-STRING <STRING <ASCII 26> <ASCII 3> <ASCII 0>>>
- <DEFINE RECORD RECORD (SCORE MOVES DEATHS QUIT? LOC
- "AUX" (CH <>) (STR ,RECORD-STRING) FL (CT 0) (MUDDLE ,MUDDLE)
- (DEV <VALUE DEV>) (SNM <VALUE SNM>))
- #DECL ((MUDDLE SCORE MOVES DEATHS) FIX (QUIT?) <OR ATOM FALSE> (LOC) ROOM
- (CH) <OR <CHANNEL FIX> FALSE> (STR) STRING (CT FL) FIX
- (DEV SNM) STRING)
- <UNWIND
- <PROG ()
- <PROG ()
- <COND (<SET CH <OPEN "READB" "ZORK" "LOG" .DEV .SNM>>
- <COND (<G=? <SET FL <FILE-LENGTH .CH>> 1>
- <ACCESS .CH <- .FL 1>>
- <SET CT <READSTRING .STR .CH ,RECORDER-STRING>>)>
- <CLOSE .CH>
- <COND (<SET CH <OPEN "PRINTO" "ZORK" "LOG" .DEV .SNM>>)
- (<AND <G? .MUDDLE 100> <==? <3 .CH> *600123*>>
- ; "Can't win--no write access"
- <RETURN T .RECORD>)
- (T <SLEEP 1> <AGAIN>)>
- <ACCESS .CH <MAX 0 <- .FL 1>>>
- <PRINTSTRING .STR .CH .CT>)
- (<OR <AND <L? .MUDDLE 100> <N==? <3 .CH> *4000000*>>
- <AND <G? .MUDDLE 100> <==? <3 .CH> *600130*>>>
- ;"on 10x, must get FILE BUSY to try again"
- <SLEEP 1>
- <AGAIN>)
- (<SET CH <OPEN "PRINT" "ZORK" "LOG" .DEV .SNM>>)
- (<AND <G? .MUDDLE 100> <==? <3 .CH> *600117*>>
- ; "No write access"
- <RETURN T .RECORD>)
- (<RETURN T .RECORD>)>>
- <CRLF .CH>
- <PRINC " " .CH>
- <PRINC ,USER-NAME .CH>
- <COND (<N=? ,USER-NAME ,XUNM>
- <PRINC " (" .CH>
- <PRINC ,XUNM .CH>
- <PRINC !\) .CH>)>
- <PRINC " " .CH>
- <PDSKDATE <DSKDATE> .CH>
- <CRLF .CH>
- <PLAY-TIME .CH <>>
- <CRLF .CH>
- <PRIN1 .SCORE .CH>
- <PRINC !\/ .CH>
- <PRIN1 ,SCORE-MAX .CH>
- <PRINC " points, " .CH>
- <PRIN1 .MOVES .CH>
- <PRINC " moves, " .CH>
- <PRIN1 .DEATHS .CH>
- <PRINC " death" .CH>
- <COND (<1? .DEATHS> <PRINC "." .CH>)
- (T <PRINC "s." .CH>)>
- <PRINC " In " .CH>
- <PRINC <RDESC2 .LOC> .CH>
- <COND (.QUIT? <PRINC ". Quit." .CH>)
- (<EMPTY? .QUIT?> <PRINC ". Died." .CH>)
- (<PRINC <1 .QUIT?> .CH>)>
- <CRLF .CH>
- <MAPF <>
- <FUNCTION (X Y)
- #DECL ((X) ATOM (Y) STRING)
- <COND (,.X <PRINC "/" .CH> <PRINC .Y .CH>)>>
- ,FLAG-NAMES
- ,SHORT-NAMES>
- <MAPF <>
- <FUNCTION (X Y)
- #DECL ((X) ATOM (Y) STRING)
- <COND (<0? ,.X> <PRINC "/" .CH> <PRINC .Y .CH>)>>
- ,VAL-NAMES
- ,SHORT-VAL-NAMES>
- <CRLF .CH>
- <CLOSE .CH>>
- <AND .CH <NOT <0? <1 .CH>>> <CLOSE .CH>>>>
- FLAG-NAMES
- <GDECL (FLAG-NAMES VAL-NAMES)
- <UVECTOR [REST ATOM]>
- (SHORT-NAMES SHORT-VAL-NAMES)
- <VECTOR [REST STRING]>>
- <BLOCK (<OR <GET FLAG OBLIST> <MOBLIST FLAG>> <GET INITIAL OBLIST> <ROOT>)>
- <PSETG FLAG-NAMES
- <UVECTOR KITCHEN-WINDOW
- TROLL-FLAG
- KEY-FLAG
- LOW-TIDE
- DOME-FLAG
- GLACIER-FLAG
- ECHO-FLAG
- RIDDLE-FLAG
- LLD-FLAG
- CYCLOPS-FLAG
- MAGIC-FLAG
- RAINBOW
- GNOME-DOOR
- CAROUSEL-FLIP
- CAGE-SOLVE>>
- <ENDBLOCK>
- <PSETG SHORT-NAMES
- <VECTOR "KI" "TR" "KE" "LO" "DO" "GL" "EC"
- "RI" "LL" "CY" "MA" "RA" "GN" "CA" "CG">>
- <PSETG VAL-NAMES <UVECTOR LIGHT-SHAFT>>
- <PSETG SHORT-VAL-NAMES <VECTOR "LI">>
- <DEFINE PDSKDATE (WD CH
- "AUX" (TIM <CHTYPE <GETBITS .WD <BITS 18 0>> FIX>) (A/P " AM")
- HR)
- #DECL ((WD) <PRIMTYPE WORD> (TIM HR) FIX (A/P) STRING (CH) CHANNEL)
- <PRINC " " .CH>
- <COND (<0? <CHTYPE .WD FIX>> <PRINC "unknown " .CH>)
- (T
- <PRINC <NTH ,MONTHS <CHTYPE <GETBITS .WD <BITS 4 23>> FIX>> .CH>
- <PRINC " " .CH>
- <PRIN1 <CHTYPE <GETBITS .WD <BITS 5 18>> FIX> .CH>
- <PRINC " at " .CH>
- <SET HR </ .TIM 7200>>
- <COND (<G=? .HR 12> <SET HR <- .HR 12>> <SET A/P " PM">)>
- <COND (<0? .HR> <SET HR 12>)>
- <PRIN1 .HR .CH>
- <PRINC ":" .CH>
- <SET HR </ <MOD .TIM 7200> 120>>
- <COND (<L? .HR 10> <PRINC "0" .CH>)>
- <PRIN1 .HR .CH>
- <PRINC .A/P .CH>)>>
- <PSETG MONTHS
- ["January"
- "February"
- "March"
- "April"
- "May"
- "June"
- "July"
- "August"
- "September"
- "October"
- "November"
- "December"]>
- <GDECL (MONTHS) <VECTOR [12 STRING]>>
- <DEFINE JIGS-UP (DESC
- "AUX" (WINNER ,WINNER) (DEATHS ,DEATHS) (AOBJS <AOBJS .WINNER>)
- (RANDOM-LIST ,RANDOM-LIST) (LAMP <FIND-OBJ "LAMP">)
- LAMP-LOCATION (VAL-LIST ()) LC)
- #DECL ((DESC) STRING (DEATHS) FIX (AOBJS) <LIST [REST OBJECT]>
- (VAL-LIST) <LIST [REST OBJECT]> (LAMP-LOCATION) <OR FALSE ROOM>
- (WINNER) ADV (RANDOM-LIST) <LIST [REST ROOM]> (LAMP) OBJECT)
- <COND
- (,DBG
- <TELL .DESC>)
- (<UNWIND
- <PROG ()
- <COND (<N==? .WINNER ,PLAYER>
- <TELL .DESC>
- <TELL "The " 1 <ODESC2 <AOBJ .WINNER>> " has died.">
- <REMOVE-OBJECT <AOBJ .WINNER>>
- <PUT .WINNER ,AROOM <FIND-ROOM "FCHMP">>
- <RETURN>)>
- <RESET ,INCHAN>
- <SCORE-UPD -10>
- <PUT .WINNER ,AVEHICLE <>>
- <COND (<G=? .DEATHS 2>
- <TELL .DESC>
- <TELL
- "You clearly are a suicidal maniac. We don't allow psychotics in the
- cave, since they may harm other adventurers. Your remains will
- installed in the Land of the Living Dead, where your fellow adventurers
- may gloat over them.">
- <FINISH <>>)
- (<SETG DEATHS <+ .DEATHS 1>>
- <TELL .DESC>
- <TELL "Do you want me to try to patch you?" 0>
- <COND (<NOT <YES/NO T>>
- <TELL
- "What? You don't trust me? Why, only last week I patched a running ITS
- and it survived for over 30 seconds. Oh, well." 2>
- <FINISH <>>)
- (T
- <TELL
- "Now, let me see...
- Well, we weren't quite able to restore your state. You can't have
- everything.">
- <COND (<SET LAMP-LOCATION <OROOM .LAMP>>
- <PUT .WINNER ,AOBJS (.LAMP !.AOBJS)>
- <COND (<MEMQ .LAMP <ROBJS .LAMP-LOCATION>>
- <REMOVE-OBJECT .LAMP>)
- (<SET LC <OCAN .LAMP>>
- <PUT .LC
- ,OCONTENTS
- <SPLICE-OUT .LAMP <OCONTENTS .LC>>>
- <PUT .LAMP ,OROOM <>>
- <PUT .LAMP ,OCAN <>>)>)
- (<MEMQ .LAMP .AOBJS>
- <PUT .WINNER ,AOBJS (.LAMP !<SPLICE-OUT .LAMP .AOBJS>)>)>
- <PUT <FIND-OBJ "DOOR"> ,OTOUCH? <>>
- <GOTO <FIND-ROOM "FORE1">>
- <SETG EGYPT-FLAG!-FLAG T>
- <SET VAL-LIST <ROB-ADV .WINNER .VAL-LIST>>
- <MAPF <>
- <FUNCTION (X Y)
- #DECL ((X) OBJECT (Y) ROOM)
- <INSERT-OBJECT .X .Y>>
- <SET AOBJS <AOBJS .WINNER>>
- .RANDOM-LIST>
- <COND (<G=? <LENGTH .RANDOM-LIST> <LENGTH .AOBJS>>
- <SET AOBJS .VAL-LIST>)
- (<EMPTY? .VAL-LIST>
- <SET AOBJS <REST .AOBJS <LENGTH .RANDOM-LIST>>>)
- (T
- <PUTREST <REST .VAL-LIST <- <LENGTH .VAL-LIST> 1>>
- <REST .AOBJS <LENGTH .RANDOM-LIST>>>
- <SET AOBJS .VAL-LIST>)>
- <MAPF <>
- <FUNCTION (X Y)
- #DECL ((X) OBJECT (Y) ROOM)
- <INSERT-OBJECT .X .Y>>
- .AOBJS
- ,ROOMS>
- <PUT .WINNER ,AOBJS ()>
- T)>)>>
- <PROG ()
- <RECORD <SCORE <>> ,MOVES ,DEATHS <> ,HERE>
- <QUIT>>>)>>
- <DEFINE INFO () <FILE-TO-TTY "MADADV" "INFO">>
- <DEFINE HELP () <FILE-TO-TTY "MADADV" "HELP">>
- <PSETG BREAKS <STRING <ASCII 3> <ASCII 0>>>
- <DEFINE FILE-TO-TTY (FILE1 FILE2 "OPTIONAL" (DEV <VALUE DEV>) (SNM <VALUE SNM>)
- "AUX" (CH <OPEN "READ" .FILE1 .FILE2 .DEV .SNM>)
- LEN
- (BUF ,INBUF) (BUFLEN <LENGTH .BUF>)
- ITER)
- #DECL ((BUF FILE1 FILE2 DEV SNM) STRING (CH) <OR CHANNEL FALSE>
- (ITER LEN BUFLEN) FIX)
- <COND (.CH
- <UNWIND
- <PROG ()
- <SET LEN <FILE-LENGTH .CH>>
- <SET ITER </ .LEN .BUFLEN>>
- <OR <0? <MOD .LEN .BUFLEN>> <SET ITER <+ .ITER 1>>>
- <CRLF ,OUTCHAN>
- <SETG TELL-FLAG T>
- <REPEAT (SLEN)
- #DECL ((SLEN) FIX)
- <COND (<1? .ITER>
- <SET SLEN <READSTRING .BUF .CH ,BREAKS>>)
- (<SET SLEN <READSTRING .BUF .CH .BUFLEN>>)>
- <PRINTSTRING .BUF ,OUTCHAN .SLEN>
- <COND (<0? <SET ITER <- .ITER 1>>>
- <CRLF ,OUTCHAN>
- <RETURN <CLOSE .CH>>)>>>
- <CLOSE .CH>>)
- (<TELL "File not found.">)>>
- <DEFINE INVENT ("OPTIONAL" (WIN ,WINNER) "AUX" (ANY <>) (OUTCHAN ,OUTCHAN))
- #DECL ((ANY) <OR ATOM FALSE> (OUTCHAN) CHANNEL (WIN) ADV)
- <MAPF <>
- <FUNCTION (X)
- #DECL ((X) OBJECT)
- <COND (<OVIS? .X>
- <OR .ANY <PROG ()
- <COND (<==? .WIN ,PLAYER>
- <TELL "You are carrying:">)
- (<TELL "The "
- 1
- <ODESC2 <AOBJ .WIN>>
- " is carrying:">)>
- <SET ANY T>>>
- <TELL "A " 0 <ODESC2 .X>>
- <COND (<OR <EMPTY? <OCONTENTS .X>> <NOT <SEE-INSIDE? .X>>>)
- (<TELL " with " 0>
- <PRINT-CONTENTS <OCONTENTS .X>>)>
- <CRLF>)>>
- <AOBJS .WIN>>
- <OR .ANY <N==? .WIN ,PLAYER> <TELL "You are empty handed.">>>
- <DEFINE PRINT-CONTENTS (OLST "AUX" (OUTCHAN ,OUTCHAN))
- #DECL ((OLST) <LIST [REST OBJECT]> (OUTCHAN) CHANNEL)
- <MAPR <>
- <FUNCTION (Y)
- #DECL ((Y) <LIST [REST OBJECT]>)
- <PRINC "a ">
- <PRINC <ODESC2 <1 .Y>>>
- <COND (<G? <LENGTH .Y> 2>
- <PRINC ", ">)
- (<==? <LENGTH .Y> 2>
- <PRINC ", and ">)>>
- .OLST>>
- ;"LIT? --
- IS THERE ANY LIGHT SOURCE IN THIS ROOM"
- <DEFINE LIT? (RM "AUX" (WIN ,WINNER))
- #DECL ((RM) ROOM (WIN) ADV)
- <OR <RLIGHT? .RM>
- <LFCN <ROBJS .RM>>
- <LFCN <AOBJS .WIN>>
- <AND <N==? .WIN ,PLAYER>
- <==? ,HERE <AROOM ,PLAYER>>
- <LFCN <AOBJS ,PLAYER>>>>>
- <DEFINE LFCN LFCN (L "AUX" Y)
- #DECL ((L) <LIST [REST OBJECT]> (Y) ADV)
- <MAPF <>
- <FUNCTION (X)
- #DECL ((X) OBJECT)
- <AND <G? <OLIGHT? .X> 0> <MAPLEAVE T>>
- <COND (<AND <OVIS? .X>
- <OR <OOPEN? .X>
- <TRANSPARENT? .X>>>
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<G? <OLIGHT? .X> 0>
- <RETURN T .LFCN>)>>
- <OCONTENTS .X>>)>
- <COND (<AND <TRNN .X ,ACTORBIT>
- <LFCN <AOBJS <SET Y <ORAND .X>>>>>
- <MAPLEAVE T>)>>
- .L>>
- ;"WALK --
- GIVEN A DIRECTION, WILL ATTEMPT TO WALK THERE"
- <DEFINE WALK ("AUX" LEAVINGS NRM (WHERE <CHTYPE <2 ,PRSVEC> ATOM>) (ME ,WINNER)
- (RM <1 .ME>) NL RANDOM-ACTION CXS)
- #DECL ((WHERE) ATOM (ME) ADV (RM) ROOM (LEAVINGS) <OR ATOM ROOM CEXIT NEXIT>
- (NRM) <OR FALSE
- <<PRIMTYPE VECTOR> [REST ATOM <OR ROOM NEXIT CEXIT>]>>
- (NL) <OR ATOM ROOM FALSE>)
- <COND (<AND <==? .ME ,PLAYER> <NOT <LIT? .RM>> <PROB 75>>
- <COND (<SET NRM <MEMQ .WHERE <REXITS .RM>>>
- <SET LEAVINGS <2 .NRM>>
- <COND (<AND <TYPE? .LEAVINGS ROOM> <LIT? .LEAVINGS>>
- <AND <GOTO .LEAVINGS> <ROOM-INFO <>>>)
- (<AND <TYPE? .LEAVINGS CEXIT>
- <SET LEAVINGS
- <COND (<AND <SET RANDOM-ACTION
- <CXACTION .LEAVINGS>>
- <APPLY-RANDOM .RANDOM-ACTION>>)
- (,<CXFLAG .LEAVINGS>
- <CXROOM .LEAVINGS>)>>
- <LIT? .LEAVINGS>>
- <OR <TYPE? .LEAVINGS ATOM>
- <AND <GOTO .LEAVINGS> <ROOM-INFO <>>>>)
- (<JIGS-UP
- "Oh, no! A fearsome grue slithered into the room and devoured you.">)>)
- (<JIGS-UP
- "Oh, no! You walked into the slavering fangs of a lurking grue.">)>)
- (<SET NRM <MEMQ .WHERE <REXITS .RM>>>
- <SET LEAVINGS <2 .NRM>>
- <COND (<TYPE? .LEAVINGS ROOM> <AND <GOTO .LEAVINGS> <ROOM-INFO <>>>)
- (<TYPE? .LEAVINGS CEXIT>
- <COND (<OR <AND <SET RANDOM-ACTION <CXACTION .LEAVINGS>>
- <SET NL <APPLY-RANDOM .RANDOM-ACTION>>>
- <AND ,<CXFLAG .LEAVINGS>
- <SET NL <CXROOM .LEAVINGS>>>>
- <OR <TYPE? .NL ATOM> <AND <GOTO .NL> <ROOM-INFO <>>>>)
- (<SET CXS <CXSTR .LEAVINGS>>
- <OR <EMPTY? .CXS>
- <TELL .CXS>>)
- (<TELL "There is no way to go in that direction.">)>)
- (T <TELL .LEAVINGS>)>)
- (<TELL "There is no way to go in that direction.">)>>
- <DEFINE TAKE ("OPTIONAL" (TAKE? T)
- "AUX" (WIN ,WINNER) (VEC ,PRSVEC) (RM <AROOM .WIN>) NOBJ
- (OBJ <2 .VEC>) (GETTER? <>) (ROBJS <ROBJS .RM>)
- (AOBJS <AOBJS .WIN>) (LOAD-MAX ,LOAD-MAX))
- #DECL ((WIN) ADV (VEC) VECTOR (OBJ NOBJ) OBJECT (RM) ROOM
- (GETTER? TAKE?) <OR ATOM FALSE> (LOAD-MAX) FIX
- (ROBJS AOBJS) <LIST [REST OBJECT]>)
- <PROG ()
- <COND (<TRNN .OBJ ,NO-CHECK-BIT>
- <RETURN <OBJECT-ACTION>>)>
- <COND (<OCAN .OBJ>
- <SET NOBJ <OCAN .OBJ>>
- <COND (<SEE-INSIDE? .NOBJ>
- <COND (<OOPEN? .NOBJ> <SET GETTER? T>)
- (<TELL "I can't reach that."> <RETURN <>>)>)
- (<TELL "I can't see one here."> <RETURN <>>)>)>
- <COND
- (<==? .OBJ <AVEHICLE .WIN>>
- <TELL "You are in it, loser!">
- <RETURN <>>)
- (<NOT <CAN-TAKE? .OBJ>>
- <OR <APPLY-OBJECT .OBJ> <TELL <PICK-ONE ,YUKS>>>
- <RETURN <>>)
- (<OR .GETTER? <MEMQ .OBJ .ROBJS>>
- <SET LOAD-MAX <+ .LOAD-MAX <FIX <* </ 1.0 .LOAD-MAX> <ASTRENGTH .WIN>>>>>
- <COND (<AND .GETTER? <MEMQ .NOBJ .AOBJS>>)
- (<G? <+ <WEIGHT .AOBJS> <WEIGHT <OCONTENTS .OBJ>> <OSIZE .OBJ>>
- .LOAD-MAX>
- <TELL
- "Your load is too heavy. You will have to leave something behind.">
- <RETURN <>>)>
- <COND (<NOT <APPLY-OBJECT .OBJ>>
- <COND (.GETTER?
- <PUT .NOBJ
- ,OCONTENTS
- <SPLICE-OUT .OBJ <OCONTENTS .NOBJ>>>
- <PUT .OBJ ,OROOM <>>
- <PUT .OBJ ,OCAN <>>)
- (<REMOVE-OBJECT .OBJ>)>
- <PUT .WIN ,AOBJS (.OBJ !.AOBJS)>
- <PUT .OBJ ,OTOUCH? T>
- <SCORE-OBJ .OBJ>
- <COND (.TAKE? <TELL "Taken.">) (T)>)
- (T)>)
- (<MEMQ .OBJ .AOBJS> <TELL "You already have it.">)
- (<TELL "I can't see one here."> <>)>>>
- <DEFINE PUTTER ("OPTIONAL" (OBJACT T)
- "AUX" (PV ,PRSVEC) (OBJO <2 .PV>) (OBJI <3 .PV>) (WIN ,WINNER)
- (AOBJS <AOBJS .WIN>) CROCK CAN (ROBJS <ROBJS ,HERE>)
- (OCAN <>))
- #DECL ((PV) <VECTOR [3 ANY]> (OBJO OBJI) OBJECT (WIN) ADV
- (AOBJS ROBJS) <LIST [REST OBJECT]> (CROCK CAN) OBJECT
- (OCAN) <OR FALSE OBJECT> (OBJACT) <OR ATOM FALSE>)
- <PROG ()
- <COND (<TRNN .OBJO ,NO-CHECK-BIT>
- <RETURN <OBJECT-ACTION>>)>
- <COND (<OR <MEMQ .OBJO ,STARS>
- <MEMQ .OBJI ,STARS>>
- <TELL "Nice try.">
- <RETURN <>>)>
- <COND (<OR <OOPEN? .OBJI>
- <OPENABLE? .OBJI>
- <TRNN .OBJI ,VEHBIT>>
- <SET CAN .OBJI>
- <SET CROCK .OBJO>)
- (<TELL "I can't do that."> <RETURN <>>)>
- <COND (<NOT <OOPEN? .CAN>>
- <TELL "I can't reach inside.">
- <RETURN <>>)
- (<==? .CAN .CROCK>
- <TELL "How can you do that?">
- <RETURN <>>)
- (<G? <+ <WEIGHT <OCONTENTS .CAN>> <OSIZE .CROCK>>
- <OCAPAC .CAN>>
- <TELL "It won't fit.">
- <RETURN <>>)>
- <COND (<OR <MEMQ .CROCK .ROBJS>
- <AND <SET OCAN <OCAN .CROCK>>
- <MEMQ .OCAN .ROBJS>>
- <AND .OCAN
- <SET OCAN <OCAN .OCAN>>
- <MEMQ .OCAN .ROBJS>>>
- <PUT .PV 1 ,TAKE!-WORDS>
- <PUT .PV 2 .CROCK>
- <PUT .PV 3 <>>
- <COND (<NOT <TAKE <>>> <RETURN <>>)
- (<SET AOBJS <AOBJS .WIN>>)>)
- (<SET OCAN <OCAN .CROCK>>
- <COND (<OOPEN? .OCAN>
- <PUT .WIN ,AOBJS <SET AOBJS (.CROCK !.AOBJS)>>
- <PUT .OCAN
- ,OCONTENTS
- <SPLICE-OUT .CROCK <OCONTENTS .OCAN>>>
- <PUT .CROCK ,OCAN <>>)
- (<TELL "I can't reach the " 1 <ODESC2 .CROCK>>
- <RETURN <>>)>)>
- <PUT .PV 1 ,PUT!-WORDS>
- <PUT .PV 2 .CROCK>
- <PUT .PV 3 .CAN>
- <COND (<AND .OBJACT <OBJECT-ACTION>> <RETURN>)
- (<PUT .WIN ,AOBJS <SPLICE-OUT .CROCK .AOBJS>>
- <PUT .CAN ,OCONTENTS (.CROCK !<OCONTENTS .CAN>)>
- <PUT .CROCK ,OCAN .CAN>
- <PUT .CROCK ,OROOM ,HERE>
- <TELL "Done.">)>>>
-
- <DEFINE DROPPER ("AUX" (WINNER ,WINNER) (AV <AVEHICLE .WINNER>)
- (AOBJS <AOBJS .WINNER>) (GETTER? <>) (VEC ,PRSVEC)
- (RM <AROOM .WINNER>) (OBJ <2 .VEC>) (PI <3 .VEC>) NOBJ)
- #DECL ((VEC) <VECTOR VERB OBJECT <OR FALSE OBJECT>>
- (OBJ NOBJ) OBJECT (PI AV) <OR FALSE OBJECT>
- (RM) ROOM (GETTER?) <OR ATOM FALSE>)
- <PROG ()
- <COND (<AND <MEMQ <VNAME <1 .VEC>> '[DROP!-WORDS POUR!-WORDS]>
- .PI>
- <PUT .VEC 1 ,PUT!-WORDS>
- <RETURN <PUTTER>>)
- (<AND .PI
- <NOT <OR <MEMQ .OBJ .AOBJS>
- <MEMQ <OCAN .OBJ> .AOBJS>>>>
- <PUT .VEC 2 .PI>
- <PUT .VEC 3 .OBJ>
- <SET OBJ <2 .VEC>>)>
- <COND (<TRNN .OBJ ,NO-CHECK-BIT>
- <RETURN <OBJECT-ACTION>>)>
- <COND (<AND <OCAN .OBJ> <SET NOBJ <OCAN .OBJ>> <MEMQ .NOBJ .AOBJS>>
- <COND (<OOPEN? .NOBJ> <SET GETTER? T>)
- (<TRANSPARENT? .NOBJ>
- <TELL "I can't reach that.">
- <RETURN>)
- (<TELL "I can't see that here.">)>)>
- <COND (<OR .GETTER? <MEMQ .OBJ .AOBJS>>
- <COND (.AV)
- (.GETTER?
- <PUT .NOBJ
- ,OCONTENTS
- <SPLICE-OUT .OBJ <OCONTENTS .NOBJ>>>
- <PUT .OBJ ,OCAN <>>)
- (<PUT .WINNER ,AOBJS <SPLICE-OUT .OBJ .AOBJS>>)>
- <COND (.AV <PUT .VEC 2 .OBJ> <PUT .VEC 3 .AV> <PUTTER <>>)
- (<INSERT-OBJECT .OBJ .RM>)>
- <COND (<OBJECT-ACTION>)
- (<==? <VNAME <1 .VEC>> DROP!-WORDS>
- <TELL "Dropped.">)
- (<==? <VNAME <1 .VEC>> THROW!-WORDS>
- <TELL "Thrown.">)>)
- (<TELL "You are not carrying that.">)>>>
- "STUFF FOR 'EVERYTHING' AND 'VALUABLES'"
- <SETG OBJ-UV <CHUTYPE <REST <IUVECTOR 20> 20> OBJECT>>
- <GDECL (OBJ-UV) <UVECTOR [REST OBJECT]>>
- <DEFINE FROB-LOTS (UV "AUX" (PRSVEC ,PRSVEC) (PA <1 .PRSVEC>) (RA <VFCN .PA>) PI
- (WINNER ,WINNER) (HERE ,HERE))
- #DECL ((UV) <UVECTOR [REST OBJECT]> (PRSVEC) <VECTOR VERB [2 ANY]>
- (PA) VERB (RA) RAPPLIC (PI) <OR OBJECT FALSE> (WINNER) ADV (HERE) ROOM)
- <COND (<==? .PA ,TAKE!-WORDS>
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<OR <CAN-TAKE? .X>
- <TRNN .X ,TRYTAKEBIT>>
- <PUT .PRSVEC 2 .X>
- <TELL <ODESC2 .X> 0 ":
- ">
- <APPLY-RANDOM .RA>
- <COND (<N==? .HERE <AROOM .WINNER>>
- <MAPLEAVE>)>)>>
- .UV>)
- (<OR <==? .PA ,DROP!-WORDS>
- <==? .PA ,PUT!-WORDS>>
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <PUT .PRSVEC 2 .X>
- <TELL <ODESC2 .X> 0 ":
- ">
- <APPLY-RANDOM .RA>
- <COND (<N==? .HERE <AROOM .WINNER>>
- <MAPLEAVE>)>>
- .UV>)>
- T>
- <PSETG LOSSTR "I can't do everything, because I ran out of room.">
- <DEFINE EVERYTHING ("AUX" (PRSVEC ,PRSVEC)
- (PA <1 .PRSVEC>) PI (SUV ,OBJ-UV) (TUV <TOP .SUV>)
- (LU <LENGTH .TUV>) (HERE ,HERE) (WINNER ,WINNER))
- #DECL ((PA) VERB (SUV TUV) <UVECTOR [REST OBJECT]> (LU) FIX (HERE) ROOM
- (WINNER) ADV (PI) OBJECT)
- <COND (<==? .PA ,TAKE!-WORDS>
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<AND <OVIS? .X> <NOT <TRNN .X ,ACTORBIT>>>
- <COND (<==? .SUV .TUV>
- <TELL ,LOSSTR>
- <MAPLEAVE>)>
- <SET SUV <BACK .SUV>>
- <PUT .SUV 1 .X>)>>
- <ROBJS .HERE>>)
- (<==? .PA ,DROP!-WORDS>
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <SET SUV <BACK .SUV>>
- <PUT .SUV 1 .X>>
- <AOBJS .WINNER>>)
- (<==? .PA ,PUT!-WORDS>
- <SET PI <3 .PRSVEC>>
- <PROG RP ()
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<AND <OVIS? .X> <N==? .X .PI> <NOT <TRNN .X ,ACTORBIT>>>
- <COND (<==? .SUV .TUV>
- <TELL ,LOSSTR>
- <RETURN T .RP>)>
- <SET SUV <BACK .SUV>>
- <PUT .SUV 1 .X>)>>
- <ROBJS .HERE>>
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<AND <==? .SUV .TUV>
- <N==? .X .PI>>
- <TELL ,LOSSTR>
- <RETURN T .RP>)>
- <SET SUV <BACK .SUV>>
- <PUT .SUV 1 .X>>
- <AOBJS .WINNER>>>)>
- <COND (<EMPTY? .SUV>
- <TELL "I couldn't find anything.">)
- (<FROB-LOTS .SUV>)>>
- <DEFINE VALUABLES ("AUX" (PRSVEC ,PRSVEC)
- (PA <1 .PRSVEC>) (SUV ,OBJ-UV) (TUV <TOP .SUV>) PI
- (LU <LENGTH .TUV>) (HERE ,HERE) (WINNER ,WINNER))
- #DECL ((PA) VERB (SUV TUV) <UVECTOR [REST OBJECT]> (LU) FIX (HERE) ROOM
- (WINNER) ADV (PI) OBJECT)
- <COND (<==? .PA ,TAKE!-WORDS>
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<AND <OVIS? .X>
- <NOT <TRNN .X ,ACTORBIT>>
- <NOT <0? <OTVAL .X>>>>
- <COND (<==? .SUV .TUV>
- <TELL ,LOSSTR>
- <MAPLEAVE>)>
- <SET SUV <BACK .SUV>>
- <PUT .SUV 1 .X>)>>
- <ROBJS .HERE>>)
- (<==? .PA ,DROP!-WORDS>
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<NOT <0? <OTVAL .X>>>
- <SET SUV <BACK .SUV>>
- <PUT .SUV 1 .X>)>>
- <AOBJS .WINNER>>)
- (<==? .PA ,PUT!-WORDS>
- <SET PI <3 .PRSVEC>>
- <PROG RP ()
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<AND <==? .SUV .TUV>
- <N==? .X .PI>>
- <TELL ,LOSSTR>
- <RETURN T .RP>)>
- <COND (<AND <OVIS? .X>
- <NOT <0? <OTVAL .X>>>>
- <SET SUV <BACK .SUV>>
- <PUT .SUV 1 .X>)>>
- <ROBJS .HERE>>
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<AND <==? .SUV .TUV>
- <N==? .X .PI>>
- <TELL ,LOSSTR>
- <RETURN T .RP>)>
- <COND (<NOT <0? <OTVAL .X>>>
- <SET SUV <BACK .SUV>>
- <PUT .SUV 1 .X>)>>
- <AOBJS .WINNER>>>)>
- <COND (<EMPTY? .SUV>
- <TELL "I couldn't find any valuables.">)
- (<FROB-LOTS .SUV>)>>
- <DEFINE OPENER OPEN-ACT ("AUX" (PV ,PRSVEC) (PRSO <2 .PV>) (OUTCHAN ,OUTCHAN))
- #DECL ((PRSO) OBJECT (PV) <VECTOR [3 ANY]> (OUTCHAN) CHANNEL)
- <COND (<OBJECT-ACTION>)
- (<NOT <TRNN .PRSO ,CONTBIT>>
- <TELL "You must tell me how to do that to a " 1 <ODESC2 .PRSO> ".">)
- (<N==? <OCAPAC .PRSO> 0>
- <COND (<OOPEN? .PRSO> <TELL "It is already open.">)
- (T
- <PUT .PRSO ,OOPEN? T>
- <COND (<OR <EMPTY? <OCONTENTS .PRSO>>
- <TRANSPARENT? .PRSO>>
- <TELL "Opened.">)
- (<SETG TELL-FLAG T>
- <TELL "Opening the " 0 <ODESC2 .PRSO> " reveals ">
- <PRINT-CONTENTS <OCONTENTS .PRSO>>
- <PRINC !\.>
- <CRLF>)>)>)
- (<TELL "The " 1 <ODESC2 .PRSO> " cannot be opened.">)>>
- <DEFINE CLOSER CLOSE-ACT ("AUX" (PV ,PRSVEC) (PRSO <2 .PV>))
- #DECL ((PV) <VECTOR [3 ANY]> (PRSO) OBJECT)
- <COND (<OBJECT-ACTION>)
- (<NOT <TRNN .PRSO ,CONTBIT>>
- <TELL "You must tell me how to do that to a " 1 <ODESC2 .PRSO> ".">)
- (<N==? <OCAPAC .PRSO> 0>
- <COND (<OOPEN? .PRSO> <PUT .PRSO ,OOPEN? <>> <TELL "Closed.">)
- (T <TELL "It is already closed.">)>)
- (<TELL "You cannot close that.">)>>
- <DEFINE FIND ("AUX" (PRSO <2 ,PRSVEC>))
- #DECL ((PRSO) <OR FALSE OBJECT>)
- <COND (<OBJECT-ACTION>)
- (.PRSO
- <FIND-FROB .PRSO
- <ROBJS ,HERE>
- ", which is in the room."
- "There is a "
- " here.">
- <FIND-FROB .PRSO
- <AOBJS ,WINNER>
- ", which you are carrying."
- "You are carrying a "
- ".">
- <COND (<NOT ,TELL-FLAG>
- <TELL "I can't see that here.">)>)
- (<TELL "I don't know what that is.">)>>
- <DEFINE FIND-FROB (PRSO OBJL STR1 STR2 STR3)
- #DECL ((OBJ) OBJECT (OBJL) <LIST [REST OBJECT]> (STR1 STR2 STR3) STRING)
- <MAPF <>
- <FUNCTION (X) #DECL ((X) OBJECT)
- <COND (<==? .X .PRSO>
- <TELL .STR2 1 <ODESC2 .X> .STR3>)
- (<OR <TRANSPARENT? .X>
- <AND <OPENABLE? .X> <OOPEN? .X>>>
- <MAPF <>
- <FUNCTION (Y) #DECL ((Y) OBJECT)
- <COND (<==? .Y .PRSO>
- <TELL .STR2 1 <ODESC2 .Y> .STR3>
- <TELL "It is in the "
- 1
- <ODESC2 .X>
- .STR1>)>>
- <OCONTENTS .X>>)>>
- .OBJL>>
- ;"OBJECT-ACTION --
- CALL OBJECT FUNCTIONS FOR DIRECT AND INDIRECT OBJECTS"
- <DEFINE OBJECT-ACTION ("AUX" (VEC ,PRSVEC) (PRSO <2 .VEC>) (PRSI <3 .VEC>))
- #DECL ((PRSO PRSI) <OR OBJECT FALSE> (VEC) VECTOR)
- <PROG ()
- <COND (.PRSI <AND <APPLY-OBJECT .PRSI> <RETURN T>>)>
- <COND (.PRSO <APPLY-OBJECT .PRSO>)>>>
- "SIMPLE OBJ-HERE: IS IT IN THE ROOM OR IN THE GUY'S HAND. TO DO FULL
- SEARCH, USE GET-OBJECT"
- <DEFINE OBJ-HERE? (OBJ "AUX" NOBJ (RM ,HERE) (WIN ,WINNER))
- #DECL ((OBJ) OBJECT (RM) ROOM (WIN) ADV (NOBJ) <OR FALSE OBJECT>)
- <PROG ()
- <COND (<NOT <OVIS? .OBJ>> <RETURN <>>)
- (<SET NOBJ <OCAN .OBJ>>
- <COND (<OOPEN? .NOBJ> <SET OBJ .NOBJ>) (<RETURN <>>)>)>
- <OR <MEMQ .OBJ <ROBJS .RM>> <MEMQ .OBJ <AOBJS .WIN>>>>>
- <DEFINE SPLICE-OUT (OBJ AL)
- #DECL ((AL) LIST)
- <COND (<==? <1 .AL> .OBJ> <REST .AL>)
- (T
- <REPEAT ((NL <REST .AL>) (OL .AL))
- #DECL ((NL OL) LIST)
- <COND (<==? <1 .NL> .OBJ>
- <PUTREST .OL <REST .NL>>
- <RETURN .AL>)
- (<SET OL .NL> <SET NL <REST .NL>>)>>)>>
- "WEIGHT: Get sum of OSIZEs of supplied list, recursing to the nth level."
- <DEFINE WEIGHT (OBJL "AUX" (BIGFIX ,BIGFIX))
- #DECL ((OBJL) <LIST [REST OBJECT]> (BIGFIX) FIX (VALUE) FIX)
- <MAPF ,+
- <FUNCTION (OBJ)
- #DECL ((OBJ) OBJECT)
- <+ <COND (<==? <OSIZE .OBJ> ,BIGFIX> 0)
- (<OSIZE .OBJ>)>
- <WEIGHT <OCONTENTS .OBJ>>>>
- .OBJL>>
- <DEFINE POUR () T>
- <DEFINE MOVE ("AUX" (VEC ,PRSVEC) (RM <AROOM ,WINNER>) (OBJ <2 .VEC>))
- #DECL ((VEC) VECTOR (RM) ROOM (OBJ) <OR ATOM OBJECT>)
- <COND (<MEMQ .OBJ <ROBJS .RM>> <OBJECT-ACTION>)
- (.OBJ
- <TELL "I can't get to that to move it.">)>>
- <DEFINE VICTIMS? (RM)
- #DECL ((RM) ROOM)
- <MAPF <>
- <FUNCTION (X)
- #DECL ((X) OBJECT)
- <COND (<TRNN .X ,VICBIT> <MAPLEAVE .X>)>>
- <ROBJS .RM>>>
- <DEFINE LAMP-ON LAMPO ("AUX" (PRSVEC ,PRSVEC) (ME ,WINNER) (OBJ <2 .PRSVEC>) (LIT?
- <LIT? ,HERE>))
- #DECL ((ME) ADV (OBJ) OBJECT (LAMPO) ACTIVATION)
- <COND (<AND <TRNN .OBJ ,BURNBIT>
- <3 .PRSVEC>
- <PUT .PRSVEC 1 ,BURN!-WORDS>>
- <BURNER>)
- (<OBJECT-ACTION>)
- (<COND (<AND <N==? <OLIGHT? .OBJ> 0>
- <MEMQ .OBJ <AOBJS .ME>>>)
- (T <TELL "You can't turn that on."> <RETURN T .LAMPO>)>
- <COND (<G? <OLIGHT? .OBJ> 0> <TELL "It is already on.">)
- (<PUT .OBJ ,OLIGHT? 1>
- <TELL "The " 1 <ODESC2 .OBJ> " is now on.">
- <COND (<NOT .LIT?>
- <PUT ,PRSVEC 2 <>>
- <ROOM-INFO <>>)>)>)>>
- <DEFINE LAMP-OFF LAMPO ("AUX" (ME ,WINNER) (OBJ <2 ,PRSVEC>))
- #DECL ((ME) ADV (OBJ) OBJECT (LAMPO) ACTIVATION)
- <COND (<OBJECT-ACTION>)
- (<COND (<AND <N==? <OLIGHT? .OBJ> 0>
- <MEMQ .OBJ <AOBJS .ME>>>)
- (<TELL "You can't turn that off."> <RETURN T .LAMPO>)>
- <COND (<L? <OLIGHT? .OBJ> 0> <TELL "It is already off.">)
- (<PUT .OBJ ,OLIGHT? -1>
- <TELL "The " 1 <ODESC2 .OBJ> " is now off.">
- <OR <LIT? ,HERE> <TELL "It is now pitch black.">>)>)>>
- "PARSER & AUXILIARIES"
- <SETG INBUF <ISTRING 100>>
- ;"SET UP INPUT ERROR HANDLER TO CAUSE EPARSE TO FALSE OUT"
- <PSETG CNTPRS "I can't parse that.">
- <SETG PRSVEC <IVECTOR 3 #FALSE ()>>
- <DEFINE WORD? (W) <LOOKUP .W ,WORDS>>
- <DEFINE THIS-IT? (OBJNAM OBJ ADJ)
- #DECL ((OBJNAM) ATOM (OBJ) OBJECT (ADJ) <OR FALSE ADJECTIVE>)
- <COND (<AND <OVIS? .OBJ>
- <OR <==? .OBJNAM <OID .OBJ>> <MEMQ .OBJNAM <ONAMES .OBJ>>>>
- <COND (<NOT .ADJ>) (<MEMQ .ADJ <OADJS .OBJ>>)>)>>
- <SETG LEXV <IVECTOR 10 '<REST <ISTRING 5> 5>>>
- <GDECL (LEXV) <VECTOR [REST STRING]> (BRKS) STRING>
- <DEFINE LEX (S
- "OPTIONAL" (SX <REST .S <LENGTH .S>>) (SILENT? <>)
- "AUX" (BRKS ,BRKS) (V ,LEXV) (S1 .S) (QUOT <>))
- #DECL ((S S1 SX BRKS) STRING
- (SILENT? QUOT) <OR ATOM FALSE> (VALUE) <OR FALSE VECTOR>
- (V) <VECTOR [REST STRING]>)
- <MAPR <>
- <FUNCTION (X "AUX" (STR <1 .X>))
- #DECL ((X) <VECTOR [REST STRING]> (STR) STRING)
- <PUT .X 1 <REST .STR <LENGTH .STR>>>>
- .V>
- <COND
- (<==? <1 .S> !\?> <PUT .V 1 <SUBSTRUC "HELP" 0 4 <BACK <1 .V> 4>>>)
- (<REPEAT (SLEN)
- #DECL ((SLEN) FIX)
- <COND
- (<OR <==? <LENGTH .S1> <LENGTH .SX>> <MEMQ <1 .S1> .BRKS>>
- <AND <G? <LENGTH .S1> <LENGTH .SX>>
- <OR <==? <1 .S1> !\'> <==? <1 .S1> !\">>
- <NOT .QUOT>
- <SET QUOT T>
- <SET V <REST .V>>>
- <COND
- (<N==? .S .S1>
- <COND
- (<EMPTY? .V> <OR .SILENT? <TELL "I'm too simple-minded for that.">>)
- (<PUT .V
- 1
- <UPPERCASE <SUBSTRUC .S
- 0
- <SET SLEN
- <MIN <- <LENGTH .S> <LENGTH .S1>>
- 5>>
- <BACK <1 .V> .SLEN>>>>
- <SET V <REST .V>>)>)>
- <COND (<==? <LENGTH .S1> <LENGTH .SX>> <RETURN .V>)>
- <SET S <REST .S1>>)>
- <SET S1 <REST .S1>>>)>
- ,LEXV>
- <PSETG BRKS "\"' :;.,?!
- ">
- <DEFINE ANYTHING (S SX)
- #DECL ((S SX) STRING)
- <MAPR <>
- <FUNCTION (X)
- <COND (<==? .X .SX> <MAPLEAVE <>>)
- (<NOT <MEMQ <1 .X> ,BRKS>> <MAPLEAVE .X>)>>
- .S>>
- <DEFINE UPPERCASE (STR)
- #DECL ((STR) STRING)
- <MAPR <>
- <FUNCTION (S "AUX" (C <ASCII <1 .S>>))
- <COND (<AND <G? .C 96> <L=? .C 122>>
- <PUT .S 1 <ASCII <- .C 32>>>)>>
- .STR>
- .STR>
- <DEFINE WAIT ("OPTIONAL" (NUM 3))
- #DECL ((NUM) FIX)
- <TELL "Time passes...">
- <REPEAT ((N .NUM))
- #DECL ((N) FIX)
- <COND (<OR <L? <SET N <- .N 1>> 0>
- <CLOCK-DEMON ,CLOCKER>>
- <RETURN>)>>>
- "RUNS ONLY IF PARSE WON, TO PREVENT SCREWS FROM TYPOS."
- <DEFINE CLOCK-DEMON (HACK "AUX" CA (FLG <>))
- #DECL ((HACK) HACK (FLG) <OR ATOM FALSE>)
- <COND (,PARSE-WON
- <PUT ,PRSVEC 2 <>>
- <PUT ,PRSVEC 3 <>>
- <MAPF <>
- <FUNCTION (EV "AUX" (TICK <CTICK .EV>))
- #DECL ((EV) CEVENT (TICK) FIX)
- <COND (<NOT <CFLAG .EV>>)
- (<0? .TICK>)
- (<L? .TICK 0>
- <PUT ,PRSVEC 1 ,C-INT!-WORDS>
- <COND (<TYPE? <SET CA <CACTION .EV>> OFFSET>
- <DISPATCH .CA>)
- (<APPLY .CA>)>)
- (<PUT .EV ,CTICK <SET TICK <- .TICK 1>>>
- <AND <0? .TICK>
- <SET FLG T>
- <PUT ,PRSVEC 1 ,C-INT!-WORDS>
- <COND (<TYPE? <SET CA <CACTION .EV>> OFFSET>
- <DISPATCH .CA>)
- (<APPLY .CA>)>>)>>
- <HOBJS .HACK>>)>
- .FLG>
- <GDECL (CLOCKER) HACK>
- <DEFINE CLOCK-INT (CEV "OPTIONAL" (NUM <>) (CLOCKER ,CLOCKER))
- #DECL ((CEV) CEVENT (NUM) <OR FIX FALSE> (CLOCKER) HACK)
- <COND (<NOT <MEMQ .CEV <HOBJS .CLOCKER>>>
- <PUT .CLOCKER ,HOBJS (.CEV !<HOBJS .CLOCKER>)>)>
- <COND (.NUM <PUT .CEV ,CTICK .NUM>)>>
- <SETG DEMONS ()>
- <OR <LOOKUP "COMPILE" <ROOT>>
- <GASSIGNED? GROUP-GLUE>
- <ADD-DEMON <SETG CLOCKER <CHTYPE [CLOCK-DEMON ()] HACK>>>>
- <DEFINE BOARD ("AUX" (OBJ <2 ,PRSVEC>) (WIN ,WINNER) (AV <AVEHICLE .WIN>))
- #DECL ((OBJ) OBJECT (WIN) ADV (AV) <OR FALSE OBJECT>)
- <COND (<NOT <MEMQ .OBJ <ROBJS ,HERE>>>
- <TELL "The " 1 <ODESC2 .OBJ> " must be on the ground to be boarded.">)
- (<TRNN .OBJ ,VEHBIT>
- <COND (.AV
- <TELL "You are already in a "
- 1
- <ODESC2 .OBJ>
- ", cretin!">)
- (T
- <COND (<OBJECT-ACTION>)
- (<TELL "You are in the " 1 <ODESC2 .OBJ> ".">
- <PUT .WIN ,AVEHICLE .OBJ>
- <PUT .OBJ
- ,OCONTENTS
- (<FIND-OBJ "#####"> !<OCONTENTS .OBJ>)>)>)>)
- (<TELL "I suppose you have a theory on boarding "
- 1
- <ODESC2 .OBJ>
- "s.">)>>
- <DEFINE UNBOARD ("AUX" (OBJ <2 ,PRSVEC>) (WIN ,WINNER) (AV <AVEHICLE .WIN>))
- #DECL ((OBJ) OBJECT (WIN) ADV (AV) <OR FALSE OBJECT>)
- <COND (<==? .AV .OBJ>
- <COND (<OBJECT-ACTION>)
- (<RTRNN ,HERE ,RLANDBIT>
- <TELL
- "You are on your own feet again.">
- <PUT .WIN ,AVEHICLE <>>
- <PUT .OBJ
- ,OCONTENTS
- <SPLICE-OUT <FIND-OBJ "#####"> <OCONTENTS .OBJ>>>)
- (<TELL
- "You realize, just in time, that disembarking here would probably be
- fatal.">)>)
- (<TELL
- "You aren't in that!">)>>
- <DEFINE GOTO (RM
- "AUX" (WIN ,WINNER) (AV <AVEHICLE ,WINNER>) (HERE ,HERE)
- (LB <RTRNN .RM ,RLANDBIT>))
- #DECL ((HERE RM) ROOM (WIN) ADV (AV) <OR FALSE OBJECT>
- (LB) <OR ATOM FALSE>)
- <COND (<OR <AND <NOT .LB> <OR <NOT .AV> <NOT <RTRNN .RM <ORAND .AV>>>>>
- <AND <RTRNN .HERE ,RLANDBIT>
- .LB
- .AV
- <N==? <ORAND .AV> ,RLANDBIT>
- <NOT <RTRNN .RM <ORAND .AV>>>>>
- <COND (.AV <TELL "You can't go there in a " 1 <ODESC2 .AV> ".">)
- (<TELL "You can't go there without a vehicle.">)>
- <>)
- (<RTRNN .RM ,RMUNGBIT> <TELL <RRAND .RM>>)
- (T
- <COND (<N==? .WIN ,PLAYER>
- <REMOVE-OBJECT <AOBJ .WIN>>
- <INSERT-OBJECT <AOBJ .WIN> .RM>)>
- <COND (.AV <REMOVE-OBJECT .AV> <INSERT-OBJECT .AV .RM>)>
- <PUT ,WINNER ,AROOM <SETG HERE .RM>>
- <SCORE-ROOM .RM>
- T)>>
- <DEFINE BACKER ()
- <TELL
- "He who puts his hand to the plow and looks back is not fit for the
- kingdom of winners. In any case, \"back\" doesn't work.">>
- <DEFINE ACT-HACK ()
- <OR <OBJECT-ACTION> T>>
- <DEFINE MUNG-ROOM (RM STR)
- #DECL ((RM) ROOM (STR) STRING)
- <RTRO .RM ,RMUNGBIT>
- <PUT .RM ,RRAND .STR>>
- <DEFINE COMMAND ("AUX" (PV ,PRSVEC) (PO <2 .PV>) (V <REST <MEMBER "" ,LEXV>>) (HS ,HERE)
- (WIN ,WINNER) (PLAY ,PLAYER))
- #DECL ((PO) OBJECT (PV V) VECTOR (HS) ROOM (WIN PLAY) ADV)
- <COND (<N==? .WIN .PLAY>
- <TELL "You cannot talk through another person!">)
- (<TRNN .PO ,ACTORBIT>
- <SETG WINNER <ORAND .PO>>
- <RDCOM .V>
- <SETG WINNER .PLAY>
- <SETG HERE .HS>)
- (<TELL "You cannot talk to that!">)>>
|