1152 lines
29 KiB
Plaintext
1152 lines
29 KiB
Plaintext
"MISC for
|
||
SHOGUN
|
||
(c) Copyright 1988 Infocom, Inc. All Rights Reserved."
|
||
|
||
<BEGIN-SEGMENT 0>
|
||
|
||
<PROPDEF SCENE <> (SCENE "MANY" S:FIX = <> "MANY" <BYTE .S>)>
|
||
<PROPDEF SCORE <> (SCORE N:FIX = 2 <BYTE 0> <BYTE .N>)>
|
||
|
||
;"tell macro and friends"
|
||
|
||
;"moved tell-tokens to DEFS"
|
||
|
||
<ROUTINE PRINT-HIM/HER (X)
|
||
<COND (<FSET? .X ,PLURAL>
|
||
<TELL "them">)
|
||
(<FSET? .X ,PERSON>
|
||
<COND (<EQUAL? .X ,ME ,WINNER>
|
||
<TELL "yourself">)
|
||
(<FSET? .X ,FEMALE>
|
||
<TELL "her">)
|
||
(ELSE <TELL "him">)>)
|
||
(ELSE <TELL "it">)>>
|
||
|
||
<ROUTINE CPRINT-HE/SHE (X)
|
||
<COND (<FSET? .X ,PLURAL>
|
||
<TELL "They">)
|
||
(<FSET? .X ,PERSON>
|
||
<COND (<EQUAL? .X ,ME ,WINNER>
|
||
<TELL "You">)
|
||
(<FSET? .X ,FEMALE>
|
||
<TELL "She">)
|
||
(ELSE <TELL "He">)>)
|
||
(ELSE <TELL "It">)>>
|
||
|
||
<ROUTINE PRINT-HE/SHE (X)
|
||
<COND (<FSET? .X ,PLURAL>
|
||
<TELL "they">)
|
||
(<FSET? .X ,PERSON>
|
||
<COND (<EQUAL? .X ,ME ,WINNER>
|
||
<TELL "yourself">)
|
||
(<FSET? .X ,FEMALE>
|
||
<TELL "she">)
|
||
(ELSE <TELL "he">)>)
|
||
(ELSE <TELL "it">)>>
|
||
|
||
<ROUTINE PRINT-HIS/HER (X)
|
||
<COND (<FSET? .X ,PLURAL>
|
||
<TELL "their">)
|
||
(<FSET? .X ,PERSON>
|
||
<COND (<EQUAL? .X ,ME ,WINNER>
|
||
<TELL "your">)
|
||
(<FSET? .X ,FEMALE>
|
||
<TELL "her">)
|
||
(ELSE <TELL "his">)>)
|
||
(ELSE <TELL "its">)>>
|
||
|
||
<ROUTINE PRINT-PLURAL (OBJ)
|
||
<COND (<NOT <FSET? .OBJ ,PLURAL>>
|
||
<TELL "s">)>>
|
||
|
||
<ROUTINE PRINTUNDER (X)
|
||
<HLIGHT ,H-UNDER>
|
||
<PRINT .X>
|
||
<HLIGHT ,H-NORMAL>>
|
||
|
||
<ROUTINE CTHE-PRINT-PRSO ()
|
||
<THE-PRINT ,PRSO T>>
|
||
|
||
<ROUTINE CTHE-PRINT-PRSI ()
|
||
<THE-PRINT ,PRSI T>>
|
||
|
||
<ROUTINE CTHE-PRINT (O)
|
||
<THE-PRINT .O T>>
|
||
|
||
<ROUTINE THE-PRINT-PRSO ()
|
||
<THE-PRINT ,PRSO>>
|
||
|
||
<ROUTINE THE-PRINT-PRSI ()
|
||
<THE-PRINT ,PRSI>>
|
||
|
||
<ROUTINE THE-PRINT (O "OPTIONAL" (CAP? <>))
|
||
<DPRINT .O .CAP? <NOT <FSET? .O ,NOTHEBIT>>>>
|
||
|
||
<ROUTINE CPRINTA-PRSO ()
|
||
<PRINTA ,PRSO T>>
|
||
|
||
;<ROUTINE CPRINTA-PRSI ()
|
||
<PRINTA ,PRSI T>>
|
||
|
||
;<ROUTINE CPRINTA (O)
|
||
<PRINTA .O T>>
|
||
|
||
<ROUTINE PRINTA-PRSO ()
|
||
<PRINTA ,PRSO>>
|
||
|
||
<ROUTINE PRINTA-PRSI ()
|
||
<PRINTA ,PRSI>>
|
||
|
||
<ROUTINE PRINTA (O "OPT" (CAP? <>))
|
||
<COND (<FSET? .O ,THE>
|
||
<COND (.CAP? <PRINTI "The ">)
|
||
(ELSE <PRINTI "the ">)>)
|
||
(<NOT <FSET? .O ,NOABIT>>
|
||
<COND (<FSET? .O ,AN>
|
||
<COND (.CAP? <PRINTI "An ">)
|
||
(ELSE <PRINTI "an ">)>)
|
||
(.CAP? <PRINTI "A ">)
|
||
(ELSE <PRINTI "a ">)>)>
|
||
<IPRINT .O>>
|
||
|
||
<ROUTINE DPRINT-PRSO ()
|
||
<DPRINT ,PRSO>>
|
||
|
||
<ROUTINE DPRINT-PRSI ()
|
||
<DPRINT ,PRSI>>
|
||
|
||
;<ROUTINE CDPRINT-PRSO ()
|
||
<DPRINT ,PRSO T>>
|
||
|
||
;<ROUTINE CDPRINT-PRSI ()
|
||
<DPRINT ,PRSI T>>
|
||
|
||
;<ROUTINE CDPRINT (O)
|
||
<DPRINT .O T>>
|
||
|
||
<ROUTINE DPRINT (O "OPTIONAL" (CAP? <>) (THE? <>) "AUX" S)
|
||
<COND (<EQUAL? .O ,PLAYER ,ME>
|
||
<COND (.CAP? <TELL "You">)
|
||
(ELSE <TELL "you">)>)
|
||
(<AND <EQUAL? .O ,RUTTER> .CAP?>
|
||
<TELL "Your rutter">)
|
||
(ELSE
|
||
<COND (<AND <SET S <GET-OWNER .O>>
|
||
<NOT <EQUAL? .S <GETP .O ,P?OWNER>>>>
|
||
<COND (<EQUAL? .S ,PLAYER>
|
||
<COND (.CAP? <TELL "Your ">)
|
||
(T <TELL "your ">)>)
|
||
(ELSE
|
||
<DPRINT .S .CAP? ;.THE?>
|
||
<TELL "'s ">)>)
|
||
(<OR .THE? <FSET? .O ,THE>>
|
||
<COND (.CAP? <PRINTI "The ">)
|
||
(T <PRINTI "the ">)>)>
|
||
<IPRINT .O>)>>
|
||
|
||
<ROUTINE IPRINT (O "AUX" TMP)
|
||
<COND ;(<AND <EQUAL? .O ,PSEUDO-OBJECT>
|
||
<NOT ,P-MERGED>
|
||
<EQUAL? .O ,PRSO ,PRSI>>
|
||
<THING-PRINT ,PSEUDO-PRSO ;"<EQUAL? .O ,PRSO>">)
|
||
(<SET TMP <GETP .O ,P?SDESC>>
|
||
<PRINT .TMP>)
|
||
(ELSE
|
||
<PRINTD .O>)>>
|
||
|
||
<COND (<GASSIGNED? ZILCH>
|
||
<DEFINE PE (F I)
|
||
<COND (<TYPE? .I LIST>
|
||
<FORM .F !.I>)
|
||
(ELSE
|
||
<FORM .F .I>)>>
|
||
|
||
<DEFMAC P? ('V "OPT" ('O '*) ('I '*) ('W '*) "AUX" (L ()))
|
||
<COND (<N==? .I '*>
|
||
<SET L (<PE PRSI? .I> !.L)>)>
|
||
<COND (<N==? .O '*>
|
||
<COND (<OR <==? .V 'WALK>
|
||
<==? .V ',V?WALK>>
|
||
<SET L (<PE DIR? .O> !.L)>)
|
||
(ELSE
|
||
<SET L (<PE PRSO? .O> !.L)>)>)>
|
||
<COND (<N==? .V '*>
|
||
<SET L (<PE VERB? .V> !.L)>)>
|
||
<COND (<N==? .W '*>
|
||
<SET L (<PE WINNER? .W> !.L)>)>
|
||
<COND (<EMPTY? <REST .L>>
|
||
<1 .L>)
|
||
(ELSE <FORM AND !.L>)>>
|
||
|
||
<DEFMAC NOT-SOLVED? ('OBJ)
|
||
<FORM FSET? .OBJ ',SCOREBIT>>
|
||
|
||
<DEFMAC SOLVED? ('OBJ)
|
||
<FORM NOT <FORM FSET? .OBJ ',SCOREBIT>>>
|
||
|
||
<DEFMAC VERB? ("ARGS" ATMS)
|
||
<MULTIFROB ',PRSA .ATMS>>
|
||
|
||
<DEFMAC SCENE? ("ARGS" ATMS)
|
||
<MULTIFROB ',SCENE .ATMS>>
|
||
|
||
<DEFMAC CONTEXT? ("ARGS" ATMS)
|
||
<MULTIFROB '.RARG .ATMS>>
|
||
|
||
<DEFMAC ADJ? ("ARGS" ATMS)
|
||
<MULTIFROB '<PARSE-ADJ ,PARSE-RESULT> .ATMS>>
|
||
|
||
<SETG RARG? ,CONTEXT?>
|
||
|
||
<DEFMAC WINNER? ("ARGS" ATMS)
|
||
<MULTIFROB ',WINNER .ATMS>>
|
||
|
||
<DEFMAC PRSO? ("ARGS" ATMS)
|
||
<MULTIFROB ',PRSO .ATMS>>
|
||
|
||
<DEFMAC DIR? ("ARGS" ATMS)
|
||
<MULTIFROB ',P-WALK-DIR .ATMS>>
|
||
|
||
<DEFMAC PRSI? ("ARGS" ATMS)
|
||
<MULTIFROB ',PRSI .ATMS>>
|
||
|
||
<DEFMAC HERE? ("ARGS" ATMS)
|
||
<MULTIFROB ',HERE .ATMS>>
|
||
|
||
<SETG ROOM? ,HERE?>
|
||
|
||
<DEFINE MULTIFROB (X ATMS "AUX" (OO (OR)) (O .OO) (L ()) ATM SP)
|
||
<REPEAT ()
|
||
<COND (<EMPTY? .ATMS>
|
||
<RETURN!- <COND (<LENGTH? .OO 1> <ERROR .X>)
|
||
(<LENGTH? .OO 2> <NTH .OO 2>)
|
||
(ELSE <CHTYPE .OO FORM>)>>)>
|
||
<REST
|
||
<PUTREST
|
||
.O
|
||
<SET O
|
||
(<REPEAT
|
||
((LL <FORM EQUAL? .X>)
|
||
(L <REST .LL>))
|
||
<COND (<OR <EMPTY? .ATMS>
|
||
<==? <LENGTH <REST .LL 2>> 3>>
|
||
<RETURN!- .LL>)>
|
||
<SET ATM <NTH .ATMS 1>>
|
||
<PUTREST
|
||
.L
|
||
<SET L
|
||
(<COND
|
||
(<TYPE? .ATM ATOM>
|
||
<SET SP <SPNAME .ATM>>
|
||
<MAKE-GVAL
|
||
<COND (<==? .X ',PRSA>
|
||
<PARSE <STRING "V?" .SP>>)
|
||
(<==? .X ',P-WALK-DIR>
|
||
<COND (<AND <G? <LENGTH .SP> 2>
|
||
<==? <1 .SP> !\P>
|
||
<==? <2 .SP> !\?>>
|
||
.ATM)
|
||
(ELSE
|
||
<PARSE
|
||
<STRING "P?" .SP>>)>)
|
||
(<==? .X '.RARG>
|
||
<COND (<AND <G? <LENGTH .SP> 2>
|
||
<==? <1 .SP> !\M>
|
||
<==? <2 .SP> !\->>
|
||
.ATM)
|
||
(ELSE
|
||
<PARSE
|
||
<STRING "M-" .SP>>)>)
|
||
(ELSE .ATM)>>)
|
||
(ELSE .ATM)>)>>
|
||
<SET ATMS <REST .ATMS>>>)>>>>>)
|
||
(ELSE
|
||
<DEFINE P? (V "OPT" (O '*) (I '*) (W '*) "AUX" (L <>))
|
||
<AND <OR <==? .W '*> <WINNER? .W>>
|
||
<OR <==? .V '*> <VERB? .V>>
|
||
<OR <==? .O '*> <PRSO? .O>>
|
||
<OR <==? .I '*> <PRSI? .I>>>>
|
||
|
||
<DEFINE VERB? ("TUPLE" ATMS)
|
||
<MAPF <>
|
||
<FUNCTION (A "AUX" ATM)
|
||
<COND (<TYPE? .A ATOM>
|
||
<COND (<SET ATM
|
||
<LOOKUP <STRING "V?" <SPNAME .A>>
|
||
<MOBLIST INITIAL>>>
|
||
<COND (<EQUAL? ,PRSA ,.ATM>
|
||
<MAPLEAVE T>)>)
|
||
(ELSE
|
||
<ERROR NOT-A-VERB? .A>)>)
|
||
(<EQUAL? ,PRSA .A>
|
||
<MAPLEAVE T>)>>
|
||
.ATMS>>
|
||
<DEFINE CONTEXT? ("TUPLE" ATMS)
|
||
<MAPF <>
|
||
<FUNCTION (A "AUX" ATM)
|
||
<COND (<TYPE? .A ATOM>
|
||
<COND (<AND <G? <LENGTH <SET ATM <SPNAME .A>>> 2>
|
||
<==? <1 .ATM> !\M>
|
||
<==? <2 .ATM> !\->>
|
||
<COND (<EQUAL? .RARG ,.ATM>
|
||
<MAPLEAVE T>)>)
|
||
(<SET ATM
|
||
<LOOKUP <STRING "M-" <SPNAME .A>>
|
||
<MOBLIST INITIAL>>>
|
||
<COND (<EQUAL? .RARG ,.ATM>
|
||
<MAPLEAVE T>)>)
|
||
(ELSE
|
||
<ERROR NOT-A-CONTEXT? .A>)>)
|
||
(<EQUAL? .RARG .A>
|
||
<MAPLEAVE T>)>>
|
||
.ATMS>>
|
||
<SETG RARG? ,CONTEXT?>
|
||
<DEFINE WINNER? ("TUPLE" ATMS)
|
||
<MULTIFROB ,WINNER .ATMS>>
|
||
<DEFINE PRSO? ("TUPLE" ATMS)
|
||
<MULTIFROB ,PRSO .ATMS>>
|
||
<DEFINE PRSI? ("TUPLE" ATMS)
|
||
<MULTIFROB ,PRSI .ATMS>>
|
||
<DEFINE HERE? ("TUPLE" ATMS)
|
||
<MULTIFROB HERE .ATMS>>
|
||
<SETG ROOM? ,HERE?>
|
||
<DEFINE MULTIFROB (X ATMS)
|
||
<MAPF <>
|
||
<FUNCTION (A)
|
||
<COND (<TYPE? .A ATOM> <SET A ,.A>)>
|
||
<COND (<EQUAL? .X .A>
|
||
<MAPLEAVE T>)>>
|
||
.ATMS>>)>
|
||
|
||
<COND (<GASSIGNED? ZILCH>
|
||
<DEFMAC BSET ('OBJ "ARGS" BITS)
|
||
<MULTIBITS FSET .OBJ .BITS>>
|
||
|
||
<DEFMAC BCLEAR ('OBJ "ARGS" BITS)
|
||
<MULTIBITS FCLEAR .OBJ .BITS>>
|
||
|
||
<DEFMAC BSET? ('OBJ "ARGS" BITS)
|
||
<MULTIBITS FSET? .OBJ .BITS>>
|
||
|
||
<DEFINE MULTIBITS (X OBJ ATMS
|
||
"AUX" (OT <COND (<==? .X FSET?> <FORM OR>)
|
||
(ELSE <FORM PROG ()>)>)
|
||
(OO <COND (<LENGTH? .OT 1> .OT)
|
||
(ELSE <REST .OT>)>)
|
||
(O .OO)
|
||
ATM)
|
||
<REPEAT ()
|
||
<COND (<EMPTY? .ATMS>
|
||
<RETURN!- .OT>)>
|
||
<SET ATM <NTH .ATMS 1>>
|
||
<SET ATMS <REST .ATMS>>
|
||
<PUTREST .O
|
||
<SET O
|
||
(<FORM .X
|
||
.OBJ
|
||
<COND (<TYPE? .ATM FORM> .ATM)
|
||
(ELSE <MAKE-GVAL .ATM>)>>)>>>>)
|
||
(ELSE
|
||
<DEFINE BSET (OBJ "TUPLE" BITS)
|
||
<MULTIBITS ,FSET .OBJ .BITS>>
|
||
|
||
<DEFINE BCLEAR (OBJ "TUPLE" BITS)
|
||
<MULTIBITS ,FCLEAR .OBJ .BITS>>
|
||
|
||
<DEFINE BSET? (OBJ "TUPLE" BITS)
|
||
<MAPF <>
|
||
<FUNCTION (A)
|
||
<COND (<FSET? .OBJ ,.A> <MAPLEAVE T>)>>
|
||
.BITS>>
|
||
|
||
<DEFINE MULTIBITS (X OBJ ATMS)
|
||
<MAPF <>
|
||
<FUNCTION (A)
|
||
<APPLY!- .X .OBJ ,.A>>
|
||
.ATMS>>)>
|
||
|
||
<DEFMAC RFATAL ()
|
||
'<RETURN ,M-FATAL>>
|
||
|
||
<COND (<GASSIGNED? ZILCH>
|
||
<DEFMAC PROB ('BASE?)
|
||
<FORM NOT <FORM L? .BASE? '<RANDOM 100>>>>)
|
||
(ELSE
|
||
<DEFINE PROB (BASE?)
|
||
<NOT <L? .BASE? <RANDOM 100>>>>)>
|
||
|
||
<ROUTINE PICK-ONE (FROB
|
||
"AUX" (L <GET .FROB 0>) (CNT <GET .FROB 1>) RND MSG RFROB)
|
||
<SET L <- .L 1>>
|
||
<SET FROB <REST .FROB 2>>
|
||
<SET RFROB <REST .FROB <* .CNT 2>>>
|
||
<SET RND <RANDOM <- .L .CNT>>>
|
||
<SET MSG <GET .RFROB .RND>>
|
||
<PUT .RFROB .RND <GET .RFROB 1>>
|
||
<PUT .RFROB 1 .MSG>
|
||
<SET CNT <+ .CNT 1>>
|
||
<COND (<==? .CNT .L> <SET CNT 0>)>
|
||
<PUT .FROB 0 .CNT>
|
||
.MSG>
|
||
|
||
;<ROUTINE RANDOM-ELEMENT (FROB)
|
||
<GET .FROB <RANDOM <GET .FROB 0>>>>
|
||
|
||
<DEFMAC APPLE? ()
|
||
'<EQUAL? ,MACHINE ,APPLE-2E ,APPLE-2C ,APPLE-2GS>>
|
||
|
||
|
||
|
||
;"former MAIN.ZIL stuff"
|
||
|
||
<GLOBAL P-WON <>>
|
||
|
||
<GLOBAL SCENE 0>
|
||
|
||
<ROUTINE SCENE-SELECT ("OPT" (FULL? <>) "AUX" TMP M WID WHICH L Y END)
|
||
<SET L <+ <GET ,PART-MENU ;.MEN 0> 1>>
|
||
<SET END <+ 1 <WINGET ,S-FULL ,WHIGH>>>
|
||
<COND (<APPLE?> <SET L <+ .L 2>>)>
|
||
<SET TMP <* .L ,FONT-Y>>
|
||
<SET Y <- .END .TMP>>
|
||
<COND (<APPLE?> <SET Y <- .Y <* 2 ,FONT-Y>>>)>
|
||
<WINDEF ,S-TEXT
|
||
.Y <WINGET ,S-TEXT ,WLEFT>
|
||
.TMP <WINGET ,S-TEXT ,WWIDE>>
|
||
<RESET-MARGIN>
|
||
<REPEAT ()
|
||
<CLEAR ,S-TEXT>
|
||
<SCREEN ,S-TEXT>
|
||
<SET WHICH
|
||
<GET-FROM-MENU "You may choose to: "
|
||
,PART-MENU
|
||
,SCENE-SELECT-F
|
||
1>>
|
||
<COND (.WHICH <RTRUE>)>>>
|
||
|
||
<ROUTINE SCENE-SELECT-F (TMP M)
|
||
<COND (<EQUAL? .TMP 1>
|
||
<SETUP-TEXT-AND-STATUS>
|
||
;<SPLIT <* ,FONT-Y ,STATUS-LINES>>
|
||
<SETG SCENE <GET ,SCENES 1>>)
|
||
(<EQUAL? .TMP 2>
|
||
<CLEAR ,S-TEXT>
|
||
<V-RESTORE>
|
||
<RESET-MARGIN>
|
||
<CLEAR ,S-TEXT>
|
||
<RFALSE>)
|
||
(<EQUAL? .TMP 3>
|
||
<CLEAR ,S-TEXT>
|
||
<V-QUIT T <>>
|
||
<RESET-MARGIN>
|
||
<CLEAR ,S-TEXT>
|
||
<RFALSE>)>>
|
||
|
||
|
||
|
||
"SCENES AND PARTS"
|
||
|
||
<CONSTANT PART-MENU
|
||
<LTABLE <TABLE (PURE STRING LENGTH) "START the game ">
|
||
<TABLE (PURE STRING LENGTH) "RESTORE a saved game ">
|
||
<TABLE (PURE STRING LENGTH) "QUIT the game ">>>
|
||
|
||
<CONSTANT SCENE-NAMES
|
||
<PLTABLE "Erasmus"
|
||
"Anjiro"
|
||
"Yabu"
|
||
"Pit" ;"omi & yabu"
|
||
"Rodrigues" ;"crew out of pit"
|
||
"Voyage to Osaka" ;"rod's advice"
|
||
"Toranaga" ;"ishido vs. t."
|
||
"Prison" ;"how to help"
|
||
"Mariko" ;"alvito & ferriera"
|
||
"Escape" ;"hatamoto"
|
||
"Earthquake" ;"zataki"
|
||
"Journey to Yedo" ;"delay, etc."
|
||
"Ochiba"
|
||
"Departure" ;"council"
|
||
"Seppuku"
|
||
"Ninja" ;"etsu's death"
|
||
"Yokohama"
|
||
"Aftermath"
|
||
"Epilogue">>
|
||
|
||
<DEFMAC SCENE-CONSTANTS ("TUPLE" SS "AUX" (CNT 0))
|
||
<MAPF ,PLTABLE
|
||
<FUNCTION (S)
|
||
<EVAL <FORM CONSTANT .S <SET CNT <+ .CNT 1>>>>>
|
||
.SS>>
|
||
|
||
<CONSTANT SCENES
|
||
<SCENE-CONSTANTS S-ERASMUS
|
||
S-ANJIRO
|
||
S-YABU
|
||
S-PIT
|
||
S-RODRIGUES
|
||
S-VOYAGE
|
||
S-TORANAGA
|
||
S-PRISON
|
||
S-MARIKO
|
||
S-ESCAPE
|
||
S-QUAKE
|
||
S-JOURNEY
|
||
S-OCHIBA
|
||
S-DEPARTURE
|
||
S-SEPPUKU
|
||
S-NINJA
|
||
S-YOKOHAMA
|
||
S-AFTERMATH
|
||
S-EPILOGUE>>
|
||
|
||
<CONSTANT SCENE-LOCS
|
||
<PLTABLE BRIDGE-OF-ERASMUS ;"S-ERASMUS"
|
||
MURA-HOUSE ;"S-ANJIRO"
|
||
VILLAGE-SQUARE ;"S-YABU"
|
||
PIT ;"S-PIT"
|
||
ANJIRO-WATERFRONT ;"S-RODRIGUES"
|
||
GALLEY ;"S-VOYAGE"
|
||
OUTER-CORRIDOR ;"S-TORANAGA"
|
||
PRISON ;"S-PRISON"
|
||
MAPLE-GLADE ;"S-MARIKO"
|
||
COURTYARD ;"S-ESCAPE"
|
||
PLATEAU ;"S-QUAKE"
|
||
YOKOSE-BATH-HOUSE ;"S-JOURNEY"
|
||
OCHIBA-ROOM ;"S-OCHIBA"
|
||
FORECOURT ;"S-DEPARTURE"
|
||
FORMAL-GARDEN ;"S-SEPPUKU"
|
||
PRIVATE-QUARTERS ;"S-NINJA"
|
||
YOKOHAMA ;"S-YOKOHAMA"
|
||
STABLE ;"S-AFTERMATH"
|
||
SEKIGAHARA ;"S-EPILOGUE">>
|
||
|
||
<CONSTANT SCENE-PICS
|
||
<TABLE (PURE BYTE LENGTH)
|
||
P-STORM ;"S-ERASMUS"
|
||
P-GARDEN ;"S-ANJIRO"
|
||
P-YABU-SEG ;"S-YABU"
|
||
P-PIT ;"S-PIT"
|
||
P-RODRIGUES-SEG ;"S-RODRIGUES"
|
||
P-CONFUSION ;"S-VOYAGE"
|
||
P-OSAKA ;"S-TORANAGA"
|
||
P-PRISON-SEG ;"S-PRISON"
|
||
P-MARIKO-SEG ;"S-MARIKO"
|
||
P-PROCESSION ;"S-ESCAPE"
|
||
P-QUAKE ;"S-QUAKE"
|
||
P-BATH ;"S-JOURNEY"
|
||
P-OCHIBA-SEG ;"S-OCHIBA"
|
||
P-DEPARTURE-SEG ;"S-DEPARTURE"
|
||
P-SEPPUKU ;"S-SEPPUKU"
|
||
P-NINJA ;"S-NINJA"
|
||
P-VINCK ;"S-YOKOHAMA"
|
||
P-AFTERMATH-SEG ;"S-AFTERMATH"
|
||
P-CREST ;"S-EPILOGUE">>
|
||
|
||
<GLOBAL MACHINE <>>
|
||
<GLOBAL WIDTH 0>
|
||
|
||
<END-SEGMENT ;"0">
|
||
|
||
<BEGIN-SEGMENT STARTUP>
|
||
|
||
<ROUTINE GO ()
|
||
<MOUSE-LIMIT -1>
|
||
<SETG MACHINE <LOWCORE INTID>>
|
||
<COND ;(<EQUAL? ,MACHINE ,AMIGA> ;"sigh, all Amiga colors are ugly"
|
||
<SETG FG-COLOR ,C-BLACK>
|
||
<SETG BG-COLOR 10 ;"light gray">
|
||
<COLOR ,FG-COLOR ,BG-COLOR>)
|
||
(ELSE
|
||
<SETG FG-COLOR <LOWCORE (CLRWRD 1)>>
|
||
<SETG BG-COLOR <LOWCORE (CLRWRD 0)>>)>
|
||
<COND (<APPLE?>
|
||
<SETG TEXT-MARGIN 0>
|
||
<COND (<PICINF ,P-BORDER ,YX-TBL>
|
||
<SETG BORDER-HEIGHT <GET ,YX-TBL 0>>)>)
|
||
(ELSE <SETG TEXT-MARGIN 2>)>
|
||
<SETG LIT T>
|
||
<SETG CLOCK-HAND <REST ,C-TABLE ,C-TABLELEN>>
|
||
<SETG PLAYER ,BLACKTHORNE>
|
||
<SETUP-FULL>
|
||
<TITLE-SCREEN>
|
||
<COND (,DEMO-VERSION?
|
||
<SLIDE-SHOW>
|
||
<AGAIN>)>
|
||
<SETUP-DISPLAY>
|
||
<SCENE-SELECT>
|
||
<GOTO-SCENE ,SCENE <>>
|
||
<MAIN-LOOP>>
|
||
|
||
<ROUTINE SLIDE-SHOW ()
|
||
<CLEAR -1>
|
||
<TELL
|
||
"This is a demonstration version of SHOGUN.|
|
||
|
|
||
First you will see a few samples of the graphic screens that await you
|
||
in SHOGUN. We've used graphics in surprising new ways to enhance the
|
||
story without detracting from Infocom's traditional richness and depth.|
|
||
Then you will be able to interact with a small section of
|
||
SHOGUN. Feel free to try the new friendlier parser, the optional mouse
|
||
interface, and the on-screen hints.|
|
||
SHOGUN is an adaptation of James Clavell's novel,
|
||
which has sold over 7 million copies and inspired the popular T.V.
|
||
mini-series. Dave Lebling, while collaborating with Clavell, has
|
||
incorporated the creative style and rich prose that have made his
|
||
earlier ZORK titles so popular.|
|
||
In SHOGUN you are transcended into the world of Clavell's saga, which
|
||
combines all of the mystery and action of a great adventure story with
|
||
the intensity and romance of a classic love story. Whether you find
|
||
yourself matching wits with tyrannical Japanese aristocrats or fighting
|
||
off attacks by Ninja assassins, you are sure to be both challenged and
|
||
entertained. Both the action and the intriguing, historical locale set
|
||
the stage for unparalleled fun and excitement.|
|
||
">
|
||
<TYPE-ANY-KEY>
|
||
<END-DEMO>>
|
||
|
||
<ROUTINE END-DEMO ()
|
||
<CLEAR -1>
|
||
<TELL "|
|
||
You have reached the end of this demonstration version of|">
|
||
<V-VERSION>
|
||
<TELL "||">
|
||
<TYPE-ANY-KEY>
|
||
<SCREEN ,S-TEXT>
|
||
;<DEFAULT-COLORS> ;"return to default before screen clears"
|
||
<RESTART>
|
||
<TELL ,FAILED>
|
||
<AGAIN>>
|
||
|
||
<END-SEGMENT ;"STARTUP">
|
||
|
||
<BEGIN-SEGMENT 0>
|
||
|
||
<CONSTANT S-FULL 7>
|
||
|
||
<ROUTINE SETUP-FULL ("AUX" (HIGH <LOWCORE VWRD>) (WIDE <LOWCORE HWRD>) X)
|
||
<WINDEF ,S-FULL 1 1 .HIGH .WIDE>
|
||
<SET X <WINGET ,S-TEXT ,WFSIZE>>
|
||
<SETG FONT-Y <HIGH-BYTE .X>>
|
||
<SETG FONT-X <LOW-BYTE .X>>>
|
||
|
||
<ROUTINE SETUP-DISPLAY ("AUX" (HIGH <LOWCORE VWRD>) (WIDE <LOWCORE HWRD>))
|
||
<MOUSE-LIMIT -1>
|
||
<SETUP-FULL>
|
||
<SETUP-TEXT-AND-STATUS>
|
||
<SET WIDE <WINGET ,S-TEXT ,WWIDE>>
|
||
<MARGIN ,TEXT-MARGIN ,TEXT-MARGIN ,S-TEXT>
|
||
<SET WIDE <- .WIDE <* 2 ,TEXT-MARGIN>>>
|
||
<SETG WIDTH <GETB ,P-INBUF 0>>
|
||
<SET WIDE </ .WIDE ,FONT-X>>
|
||
<COND (<L? .WIDE ,WIDTH>
|
||
<SETG WIDTH .WIDE>
|
||
<PUTB ,P-INBUF 0
|
||
<COND (<G? .WIDE ,INBUF-LENGTH>
|
||
,INBUF-LENGTH)
|
||
(T
|
||
.WIDE)>>)>>
|
||
|
||
<ROUTINE REPAINT-DISPLAY ("OPT" (NO-BORDER? <>))
|
||
<RESET-MARGIN>
|
||
<NORMAL-COLOR>
|
||
<SETUP-DISPLAY>
|
||
<COND (<OR <APPLE?> <NOT .NO-BORDER?>>
|
||
<DISPLAY-BORDER>)>
|
||
<INIT-STATUS-LINE T>
|
||
<COND (<HERE? ,MAZE>
|
||
<DISPLAY-MAZE>)>>
|
||
|
||
<ROUTINE GOTO-SCENE (SC "OPT" (OSC ,SCENE))
|
||
<CLEAR ,S-TEXT>
|
||
<COND (<AND <APPLE?> <NOT .OSC>>
|
||
<SCREEN ,S-STATUS>
|
||
<CLEAR ,S-STATUS>
|
||
<DISPLAY-BORDER ,P-EBORDER>)
|
||
(<NOT <EQUAL? ,CURRENT-BORDER ,P-BORDER>>
|
||
<DISPLAY-BORDER ,P-BORDER>)>
|
||
<END-QUOTE>
|
||
<RESET-MARGIN>
|
||
<DEQUEUE-ALL>
|
||
<SETG ORPHAN-ANSWER <>>
|
||
<SETG SCENE .SC>
|
||
<SETG HERE <GET ,SCENE-LOCS ,SCENE>>
|
||
<TOUCH-SEG <GETB ,SCENE-PICS ,SCENE>>
|
||
<FCLEAR ,HERE ,TOUCHBIT>
|
||
<SETG QCONTEXT <>>
|
||
<MOVE-ALL ,BLACKTHORNE>
|
||
<MOVE ,BLACKTHORNE ,HERE>
|
||
<FCLEAR ,BLACKTHORNE ,RMUNGBIT>
|
||
<SETG P-IT-OBJECT <>>
|
||
<SETG P-HIM-OBJECT <>>
|
||
<SETG P-HER-OBJECT <>>
|
||
<SETG P-THEM-OBJECT <>>
|
||
<B-STAND>
|
||
<SETG OPPONENT <>>
|
||
<APPLY <GETP ,HERE ,P?ACTION> ,M-SCENE-SETUP>
|
||
<SETG WINNER ,PLAYER>
|
||
<CLEAR ,S-TEXT>
|
||
<COND (<ZERO? .OSC>
|
||
<CLEAR ,S-STATUS>
|
||
<INIT-STATUS-LINE>)
|
||
(ELSE <UPDATE-STATUS-LINE T>)>
|
||
<GOTO ,HERE>
|
||
<COND (<ZERO? .OSC>
|
||
<CLOCKER> ;"simulate a previous move..."
|
||
<SETG MOVES 0>)>
|
||
<RTRUE>>
|
||
|
||
<ROUTINE TOUCH-SEG (S)
|
||
<COND (<OR <APPLE?> <EQUAL? ,MACHINE ,IBM>>
|
||
<PICINF .S ,YX-TBL>)>>
|
||
|
||
;<GLOBAL WAS-IT? <>>
|
||
;<GLOBAL WAS-THEM? <>>
|
||
;<GLOBAL WAS-HIM? <>>
|
||
;<GLOBAL WAS-HER? <>>
|
||
|
||
;<GLOBAL PERFORM-DEPTH 0> ;"number recursive calls to perform"
|
||
|
||
;<CONSTANT P-MATCHLEN 0>
|
||
;<ROUTINE OBJECT-SUBSTITUTE (OBJ VAR "AUX" (TMP <>) (CNT 0) ICNT OCNT)
|
||
<COND (<AND .VAR <ACCESSIBLE? .VAR>>
|
||
<SET ICNT <GET ,P-PRSI ,P-MATCHLEN>>
|
||
<SET OCNT <GET ,P-PRSO ,P-MATCHLEN>>
|
||
<REPEAT ()
|
||
<COND (<G? <SET CNT <+ .CNT 1>> .ICNT>
|
||
<RETURN>)
|
||
(T
|
||
<COND (<EQUAL? <GET ,P-PRSI .CNT> .OBJ>
|
||
<PUT ,P-PRSI .CNT .VAR>
|
||
<SET TMP T>
|
||
<RETURN>)>)>>
|
||
<SET CNT 0>
|
||
<REPEAT ()
|
||
<COND (<G? <SET CNT <+ .CNT 1>> .OCNT>
|
||
<RETURN>)
|
||
(T
|
||
<COND (<EQUAL? <GET ,P-PRSO .CNT> .OBJ>
|
||
<PUT ,P-PRSO .CNT .VAR>
|
||
<SET TMP T>
|
||
<RETURN>)>)>>
|
||
.TMP)>>
|
||
|
||
;<GLOBAL PSEUDO-PRSO <>> ;"T IF ORIGINAL PRSO WAS PSEUDO-OBJECT"
|
||
|
||
<ROUTINE GAME-VERB? ()
|
||
<COND (<AND <VERB? TELL> ,P-CONT> <RTRUE>)
|
||
(<AND <VERB? HELP>
|
||
<NOT ,PRSO>>
|
||
<RTRUE>)
|
||
(<VERB? QUIT VERSION BRIEF SUPER-BRIEF VERBOSE COLOR
|
||
$VERIFY RESTART SAVE RESTORE SCRIPT UNSCRIPT UNDO
|
||
SCORE TIME DEFINE $REFRESH NOTIFY HINT HINTS-OFF
|
||
CREDITS>
|
||
<RTRUE>)
|
||
(<VERB? $RANDOM $COMMAND $RECORD $UNRECORD
|
||
;$SCENE ;$SHOW ;$W ;$P ;$D ;$I ;$G ;$X ;$M>
|
||
<RTRUE>)>>
|
||
|
||
"MULTIPLE-EXCEPTION? -- return true if an object found by all should not
|
||
be included when the crunch comes."
|
||
|
||
;<ROUTINE MULTIPLE-EXCEPTION? (OBJ1 "AUX" (L <LOC .OBJ1>))
|
||
<COND (<EQUAL? .OBJ1 ,NOT-HERE-OBJECT>
|
||
<SETG P-NOT-HERE <+ ,P-NOT-HERE 1>>
|
||
<RTRUE>)
|
||
(<AND <VERB? TAKE>
|
||
,PRSI
|
||
<NOT <IN? ,PRSO ,PRSI>>>
|
||
;"TAKE X FROM Y and x not in y"
|
||
<RTRUE>)
|
||
(<NOT <ACCESSIBLE? .OBJ1>>
|
||
;"can't get at object"
|
||
<RTRUE>)
|
||
(<EQUAL? ,P-GETFLAGS ,P-ALL>
|
||
;"cases for ALL"
|
||
<COND (<AND ,PRSI
|
||
<PRSO? ,PRSI>>
|
||
;"VERB ALL and prso = prsi"
|
||
<RTRUE>)
|
||
(<AND <VERB? TAKE> <NOT ,PRSI>>
|
||
<COND (<OR <AND <NOT <EQUAL? .L ,WINNER ,HERE ,PRSI>>
|
||
<NOT <EQUAL? .L <LOC ,WINNER>>>
|
||
<NOT <FSET? .L ,SURFACEBIT>>
|
||
<NOT <FSET? .L ,SEARCHBIT>>>
|
||
<AND <NOT <FSET? .OBJ1 ,TAKEBIT>>
|
||
<NOT <FSET? .OBJ1 ,TRYTAKEBIT>>>>
|
||
;"TAKE ALL and object not accessible or takeable"
|
||
<RTRUE>)
|
||
(<OR <FSET? .L ,PERSON>
|
||
<FSET? <LOC .L> ,PERSON>>
|
||
;"TAKE ALL held by a person (use TAKE ALL FROM)"
|
||
<RTRUE>)
|
||
(<HELD? ,PRSO>
|
||
;"TAKE ALL and one object has others in it"
|
||
<RTRUE>)>)
|
||
(<VERB? DROP GIVE>
|
||
<COND (<NOT <IN? .OBJ1 ,WINNER>>
|
||
;"GIVE/DROP ALL and object not held"
|
||
<RTRUE>)
|
||
(<FSET? .OBJ1 ,WEARBIT>
|
||
;"GIVE/DROP ALL and object worn"
|
||
<RTRUE>)>)
|
||
(<AND <VERB? PUT>
|
||
<NOT <IN? ,PRSO ,WINNER>>
|
||
<HELD? ,PRSO ,PRSI>>
|
||
;"PUT ALL IN X and object already in x"
|
||
<RTRUE>)>)>>
|
||
|
||
;<ROUTINE SAVE-INPUT (TBL "AUX" (OFFS 0) CNT TMP)
|
||
<SET CNT <+ <GETB ,P-LEXV <SET TMP <* 4 ,P-INPUT-WORDS>>>
|
||
<GETB ,P-LEXV <+ .TMP 1>>>>
|
||
<COND (<EQUAL? .CNT 0> ;"failed"
|
||
<RFALSE>)>
|
||
<SET CNT <- .CNT 1>>
|
||
<REPEAT ()
|
||
<COND (<EQUAL? .OFFS .CNT>
|
||
<PUTB .TBL .OFFS 0>
|
||
<RETURN>)
|
||
(T
|
||
<PUTB .TBL .OFFS <GETB ,P-INBUF <+ .OFFS 1>>>)>
|
||
<SET OFFS <+ .OFFS 1>>>
|
||
<RTRUE>>
|
||
|
||
;<ROUTINE RESTORE-INPUT (TBL "AUX" CHR)
|
||
<REPEAT ()
|
||
<COND (<EQUAL? <SET CHR <GETB .TBL 0>> 0>
|
||
<RETURN>)
|
||
(T
|
||
<PRINTC .CHR>
|
||
<SET TBL <REST .TBL>>)>>>
|
||
|
||
<GLOBAL P-MULT <>>
|
||
|
||
<GLOBAL P-NOT-HERE 0>
|
||
|
||
|
||
;<GLOBAL WHAT-DO-YOU-WANT-TO "What do you want to ">
|
||
|
||
;<ROUTINE FAKE-ORPHAN ("AUX" TMP)
|
||
<ORPHAN ,P-SYNTAX <>>
|
||
<TELL ,WHAT-DO-YOU-WANT-TO>
|
||
<SET TMP <GET ,P-OTBL ,P-VERBN>>
|
||
<COND (<EQUAL? .TMP 0>
|
||
<TELL "tell">)
|
||
(<ZERO? <GETB ,P-VTBL 2>>
|
||
<PRINTB <GET .TMP 0>>)
|
||
(T
|
||
<WORD-PRINT <GETB .TMP 2> <GETB .TMP 3>>
|
||
<PUTB ,P-VTBL 2 0>)>
|
||
<SETG P-OFLAG T>
|
||
<SETG P-WON <>>
|
||
<PREP-PRINT
|
||
<GETB ,P-SYNTAX ,P-SPREP1>>
|
||
<TELL "?" CR>>
|
||
|
||
<ROUTINE END-QUOTE ()
|
||
<SETG P-CONT <>>
|
||
<RFATAL>>
|
||
|
||
;"former CLOCK.ZIL stuff"
|
||
|
||
<GLOBAL CLOCK-WAIT <>>
|
||
|
||
<GLOBAL C-TABLE <ITABLE 13 <> <>>>
|
||
|
||
<CONSTANT C-INTLEN 4> ;"length of an interrupt entry in bytes"
|
||
<CONSTANT C-RTN 0> ;"word offset of routine name"
|
||
<CONSTANT C-TICK 1> ;"word offset of count"
|
||
|
||
<CONSTANT C-TABLELEN 52> ;"length of interrupt table in bytes"
|
||
<GLOBAL C-INTS 52> ;"start of queued interrupts in bytes"
|
||
|
||
<ROUTINE DEQUEUE (RTN "AUX" TIM)
|
||
<COND (<SET RTN <QUEUED? .RTN>>
|
||
<SET TIM <GET .RTN ,C-TICK>>
|
||
<PUT .RTN ,C-RTN 0>
|
||
.TIM)>>
|
||
|
||
<ROUTINE QUEUED? (RTN "AUX" C E)
|
||
<SET E <REST ,C-TABLE ,C-TABLELEN>>
|
||
<SET C <REST ,C-TABLE ,C-INTS>>
|
||
<REPEAT ()
|
||
<COND (<EQUAL? .C .E> <RFALSE>)
|
||
(<EQUAL? <GET .C ,C-RTN> .RTN>
|
||
<COND (<ZERO? <GET .C ,C-TICK>>
|
||
<RFALSE>)
|
||
(T <RETURN .C>)>)>
|
||
<SET C <REST .C ,C-INTLEN>>>>
|
||
|
||
"this version of QUEUE automatically enables as well"
|
||
|
||
"QUEUE routine when fresh?:t means only queue if not currently queued"
|
||
|
||
<ROUTINE QUEUE (RTN TICK "OPT" (I? <>) "AUX" C E (INT <>))
|
||
<SET E <REST ,C-TABLE ,C-TABLELEN>>
|
||
<SET C <REST ,C-TABLE ,C-INTS>>
|
||
<REPEAT ()
|
||
<COND (<EQUAL? .C .E>
|
||
<COND (.INT
|
||
<SET C .INT>)
|
||
(ELSE
|
||
<SETG C-INTS <- ,C-INTS ,C-INTLEN>>
|
||
<SET INT <REST ,C-TABLE ,C-INTS>>)>
|
||
<PUT .INT ,C-RTN .RTN>
|
||
<RETURN>)
|
||
(<EQUAL? <GET .C ,C-RTN> .RTN>
|
||
<COND (.I? <RFALSE>)
|
||
(ELSE
|
||
<SET INT .C>
|
||
<RETURN>)>)
|
||
(<ZERO? <GET .C ,C-RTN>>
|
||
<SET INT .C>)>
|
||
<SET C <REST .C ,C-INTLEN>>>
|
||
<COND (%<COND (<GASSIGNED? ZILCH>
|
||
'<G? .INT ,CLOCK-HAND>)
|
||
(ELSE
|
||
'<L=? <LENGTH .INT> <LENGTH ,CLOCK-HAND>>)>
|
||
<SET TICK <- <+ .TICK 3>>>)>
|
||
<PUT .INT ,C-TICK .TICK>
|
||
.INT>
|
||
|
||
<GLOBAL STATIONARY? <>> ;"winner not walking around?"
|
||
<GLOBAL STATIONARY-CNT <>> ;"and for how long"
|
||
|
||
<GLOBAL CLOCK-HAND <>>
|
||
|
||
<ROUTINE CLOCKER ("AUX" E TICK RTN (FLG <>) (Q? <>) OWINNER TMP)
|
||
<COND (,CLOCK-WAIT <SETG CLOCK-WAIT <>> <RFALSE>)>
|
||
<COND (<EQUAL? ,HERE ,STATIONARY?>
|
||
<SETG STATIONARY-CNT <+ ,STATIONARY-CNT 1>>)
|
||
(ELSE
|
||
<SETG STATIONARY? ,HERE>
|
||
<SETG STATIONARY-CNT 0>)>
|
||
<SETG CLOCK-HAND <REST ,C-TABLE ,C-INTS>>
|
||
<SET E <REST ,C-TABLE ,C-TABLELEN>>
|
||
<SET OWINNER ,WINNER>
|
||
<SETG WINNER ,PLAYER>
|
||
<REPEAT ()
|
||
<COND (,NEW-SCENE-NUMBER
|
||
<I-NEW-SCENE>
|
||
<SETG CLOCK-HAND <REST ,C-TABLE ,C-INTS>>
|
||
<SET FLG T>)>
|
||
<COND (<EQUAL? ,CLOCK-HAND .E>
|
||
<SETG MOVES <+ ,MOVES 1>>
|
||
<SETG WINNER .OWINNER>
|
||
<RETURN .FLG>)
|
||
(<NOT <ZERO? <GET ,CLOCK-HAND ,C-RTN>>>
|
||
<SET TICK <GET ,CLOCK-HAND ,C-TICK>>
|
||
<COND (<L? .TICK -1>
|
||
<PUT ,CLOCK-HAND ,C-TICK <- <- .TICK> 3>>
|
||
<SET Q? ,CLOCK-HAND>)
|
||
(<NOT <ZERO? .TICK>>
|
||
<COND (<G? .TICK 0>
|
||
<SET TICK <- .TICK 1>>
|
||
<PUT ,CLOCK-HAND ,C-TICK .TICK>)>
|
||
<COND (<NOT <ZERO? .TICK>>
|
||
<SET Q? ,CLOCK-HAND>)>
|
||
<COND (<NOT <G? .TICK 0>>
|
||
<SET RTN
|
||
%<COND (<GASSIGNED? ZILCH>
|
||
'<GET ,CLOCK-HAND ,C-RTN>)
|
||
(ELSE
|
||
'<NTH ,CLOCK-HAND
|
||
<+ <* ,C-RTN 2>
|
||
1>>)>>
|
||
<COND (<ZERO? .TICK>
|
||
<PUT ,CLOCK-HAND ,C-RTN 0>)>
|
||
<COND (<SET TMP <APPLY .RTN>>
|
||
<SET FLG .TMP>)>
|
||
<COND (<AND <NOT .Q?>
|
||
<NOT
|
||
<ZERO?
|
||
<GET ,CLOCK-HAND
|
||
,C-RTN>>>>
|
||
<SET Q? T>)>)>)>)>
|
||
<COND (,NEW-SCENE-NUMBER ;"new scene during int?"
|
||
<SETG CLOCK-HAND <REST ,C-TABLE ,C-INTS>>)
|
||
(<EQUAL? .FLG ,M-FATAL>
|
||
<SETG CLOCK-HAND .E>)
|
||
(<NOT <EQUAL? ,CLOCK-HAND .E>>
|
||
<SETG CLOCK-HAND <REST ,CLOCK-HAND ,C-INTLEN>>
|
||
<COND (<NOT .Q?>
|
||
<SETG C-INTS <+ ,C-INTS ,C-INTLEN>>)>)>>>
|
||
|
||
<ROUTINE DEQUEUE-ALL ("AUX" E TICK RTN (FLG <>) (Q? <>))
|
||
<COND (,CLOCK-WAIT <SETG CLOCK-WAIT <>> <RFALSE>)>
|
||
<SETG CLOCK-HAND <REST ,C-TABLE ,C-INTS>>
|
||
<SET E <REST ,C-TABLE ,C-TABLELEN>>
|
||
<REPEAT ()
|
||
<COND (<EQUAL? ,CLOCK-HAND .E>
|
||
<SETG CLOCK-HAND .E>
|
||
<RETURN>)
|
||
(ELSE
|
||
<PUT ,CLOCK-HAND ,C-TICK 0>
|
||
<PUT ,CLOCK-HAND ,C-RTN 0>)>
|
||
<SETG CLOCK-HAND <REST ,CLOCK-HAND ,C-INTLEN>>
|
||
<SETG C-INTS <+ ,C-INTS ,C-INTLEN>>>>
|
||
|
||
<DEFINE PSEUDO ("TUPLE" V)
|
||
<MAPF ,PLTABLE
|
||
<FUNCTION (OBJ)
|
||
<COND (<N==? <LENGTH .OBJ> 3>
|
||
<ERROR BAD-THING .OBJ>)>
|
||
<MAPRET <COND (<NTH .OBJ 1>
|
||
<VOC <SPNAME <NTH .OBJ 1>> ADJECTIVE>)>
|
||
<COND (<NTH .OBJ 2>
|
||
<VOC <SPNAME <NTH .OBJ 2>> NOUN>)>
|
||
;<3 .OBJ>>>
|
||
.V>>
|
||
|
||
<ROUTINE PERFORM-PRSA ("OPT" (O <>) (I <>))
|
||
<PERFORM ,PRSA .O .I>>
|
||
|
||
<ROUTINE NEW-VERB (V)
|
||
<PERFORM .V ,PRSO ,PRSI>>
|
||
|
||
<ROUTINE SWAP-VERB (V)
|
||
<PERFORM .V ,PRSI ,PRSO>>
|
||
|
||
<ROUTINE NEW-PRSO (O)
|
||
<PERFORM-PRSA .O ,PRSI>>
|
||
|
||
;<ROUTINE NEW-PRSI (I)
|
||
<PERFORM-PRSA ,PRSO .I>>
|
||
|
||
<ROUTINE NEW-WINNER-PRSO (A "OPT" (O <>) (I <>) "AUX" OW)
|
||
<SET OW ,WINNER>
|
||
<SETG WINNER ,PRSO>
|
||
<PERFORM .A .O .I>
|
||
<SETG WINNER .OW>
|
||
<RTRUE>>
|
||
|
||
<ROUTINE REDIRECT (FROM TO "AUX" O I)
|
||
<SET O <COND (<PRSO? .FROM> .TO) (ELSE ,PRSO)>>
|
||
<SET I <COND (<PRSI? .FROM> .TO) (ELSE ,PRSI)>>
|
||
<PERFORM-PRSA .O .I>
|
||
<RTRUE>>
|
||
|
||
<GLOBAL DELAY-CNT 0>
|
||
|
||
<COND (<GASSIGNED? ZILCH>
|
||
<DEFMAC ZLINES ('VAR:<PRIMTYPE ATOM> "ARGS" LINES:LIST
|
||
"AUX" (CNT:FIX 0) SETTER:ATOM
|
||
(DELAYS:<OR FALSE LIST> <>))
|
||
<COND (<TYPE? .VAR ATOM>
|
||
<EVAL <FORM GLOBAL .VAR 0>>
|
||
<SET SETTER <CHTYPE .VAR GVAL>>)
|
||
(<TYPE? .VAR GVAL>
|
||
<EVAL <FORM GLOBAL <CHTYPE .VAR ATOM> 0>>
|
||
<SET SETTER 'SETG>)
|
||
(<TYPE? .VAR LVAL>
|
||
<EVAL <FORM GLOBAL <CHTYPE .VAR ATOM> 0>>
|
||
<SET SETTER 'SET>)>
|
||
<SET DELAYS
|
||
<MAPF ,LIST
|
||
<FUNCTION (LINE:LIST)
|
||
<COND (<EMPTY? .LINE> <MAPRET>)
|
||
(<==? <1 .LINE> DELAY>
|
||
<MAPRET (<FORM EQUAL? .VAR .CNT>
|
||
!<REST .LINE>)>)
|
||
(ELSE
|
||
<COND (<AND <NOT <EMPTY? .LINE>>
|
||
<TYPE? <1 .LINE> FIX>>
|
||
<SET CNT <+ .CNT <1 .LINE>>>
|
||
<SET LINE <REST .LINE>>)
|
||
(ELSE
|
||
<SET CNT <+ .CNT 1>>)>
|
||
<MAPRET>)>>
|
||
.LINES>>
|
||
<SET CNT 0>
|
||
<COND (<NOT <EMPTY? .DELAYS>>
|
||
<SET DELAYS
|
||
('<SETG DELAY-CNT <+ ,DELAY-CNT 1>>
|
||
<FORM COND !.DELAYS>
|
||
'<SETG DELAY-CNT 0>)>)>
|
||
<FORM PROG ()
|
||
!.DELAYS
|
||
<FORM .SETTER <CHTYPE .VAR ATOM> <FORM + .VAR 1>>
|
||
<FORM COND
|
||
!<MAPF ,LIST
|
||
<FUNCTION (LINE:LIST)
|
||
<COND (<NOT <EMPTY? .LINE>>
|
||
<COND (<==? <1 .LINE> DELAY>
|
||
<MAPRET>)
|
||
(<TYPE? <1 .LINE> FIX>
|
||
<SET CNT
|
||
<+ .CNT <1 .LINE>>>
|
||
<SET LINE <REST .LINE>>)
|
||
(ELSE
|
||
<SET CNT <+ .CNT 1>>)>
|
||
<LIST <FORM EQUAL? .VAR .CNT>
|
||
!.LINE>)
|
||
(ELSE
|
||
<ERROR BAD-ZLINES>)>>
|
||
.LINES>>>>)
|
||
(ELSE
|
||
<DEFINE ZLINES (VAR "ARGS" LINES)
|
||
<RFALSE>>)>
|
||
|
||
<COND (<GASSIGNED? ZILCH>
|
||
<DEFMAC FOR ('X "ARGS" BODY)
|
||
<FORM REPEAT (<1 .X>)
|
||
<FORM COND (<FORM NOT <2 .X>> '<RETURN>)>
|
||
!.BODY
|
||
<3 .X>>>)>
|
||
|
||
<ROUTINE CREWMAN? (OBJ)
|
||
<AND <NOT <EQUAL? .OBJ ,CREWMEN ,LG-CREWMEN>>
|
||
<FSET? .OBJ ,DUTCHBIT>>>
|
||
|
||
|
||
|
||
"stuff for handling opcodes that want pixels"
|
||
|
||
<ROUTINE WINDEF (W TOP LEFT HIGH WIDE)
|
||
<WINPOS .W .TOP .LEFT>
|
||
<WINSIZE .W .HIGH .WIDE>>
|
||
|
||
<GLOBAL FONT-X 7>
|
||
<GLOBAL FONT-Y 10>
|
||
|
||
<ROUTINE C-PIXELS (X)
|
||
<+ <* <- .X 1> ,FONT-X> 1>>
|
||
|
||
<ROUTINE L-PIXELS (Y)
|
||
<+ <* <- .Y 1> ,FONT-Y> 1>>
|
||
|
||
<ROUTINE CCURSET (Y X)
|
||
<CURSET <L-PIXELS .Y> <C-PIXELS .X>>>
|
||
|
||
<ROUTINE IN-SCENE? (OBJ "AUX" SC PT)
|
||
<COND (<NOT <SET SC <GETPT .OBJ ,P?SCENE>>>
|
||
<RTRUE>)
|
||
(ELSE
|
||
<SET PT <PTSIZE .SC>>
|
||
<COND (<INTBL? ,SCENE .SC .PT 1> <RTRUE>)
|
||
(ELSE <RFALSE>)>)>>
|
||
|
||
<ROUTINE REPLACE-SYNONYM (OBJ OLD NEW "OPT" (DUP? <>) "AUX" TMP S L)
|
||
<COND (<SET S <GETPT .OBJ ,P?SYNONYM>>
|
||
<SET L </ <PTSIZE .S> 2>>
|
||
<COND (<AND <NOT .DUP?> <INTBL? .NEW .S .L>>
|
||
<RTRUE>)
|
||
(<SET TMP <INTBL? .OLD .S .L>>
|
||
<PUT .TMP 0 .NEW>)>)>>
|
||
|
||
<ROUTINE REPLACE-ADJECTIVE (OBJ OLD NEW "OPT" (DUP? <>) "AUX" TMP S L)
|
||
<COND (<SET S <GETPT .OBJ ,P?ADJECTIVE>>
|
||
<SET L </ <PTSIZE .S> 2>>
|
||
<COND (<AND <NOT .DUP?> <INTBL? .NEW .S .L>>
|
||
<RTRUE>)
|
||
(<SET TMP <INTBL? .OLD .S .L>>
|
||
<PUT .TMP 0 .NEW>)>)>>
|
||
|
||
<ROUTINE CURSOR-OFF ()
|
||
<CURSET -1>>
|
||
|
||
<ROUTINE CURSOR-ON ()
|
||
<CURSET -2>>
|
||
|
||
<END-SEGMENT ;"0">
|