shogun/misc.zabstr

<BEGIN-SEGMENT 0> 
<PROPDEF SCENE <> (SCENE "MANY" S:FIX = <> "MANY" <BYTE .S>)> 
<PROPDEF SCORE <> (SCORE N:FIX = 2 <BYTE 0> <BYTE .N>)> 
<DEFINE-ROUTINE PRINT-HIM/HER> 
<DEFINE-ROUTINE CPRINT-HE/SHE> 
<DEFINE-ROUTINE PRINT-HE/SHE> 
<DEFINE-ROUTINE PRINT-HIS/HER> 
<DEFINE-ROUTINE PRINT-PLURAL> 
<DEFINE-ROUTINE PRINTUNDER> 
<DEFINE-ROUTINE CTHE-PRINT-PRSO> 
<DEFINE-ROUTINE CTHE-PRINT-PRSI> 
<DEFINE-ROUTINE CTHE-PRINT> 
<DEFINE-ROUTINE THE-PRINT-PRSO> 
<DEFINE-ROUTINE THE-PRINT-PRSI> 
<DEFINE-ROUTINE THE-PRINT> 
<DEFINE-ROUTINE CPRINTA-PRSO> 
<DEFINE-ROUTINE PRINTA-PRSO> 
<DEFINE-ROUTINE PRINTA-PRSI> 
<DEFINE-ROUTINE PRINTA> 
<DEFINE-ROUTINE DPRINT-PRSO> 
<DEFINE-ROUTINE DPRINT-PRSI> 
<DEFINE-ROUTINE DPRINT> 
<DEFINE-ROUTINE IPRINT> 
<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>>>>)> 
<DEFINE-ROUTINE PICK-ONE> 
<DEFMAC APPLE? () '<EQUAL? ,MACHINE ,APPLE-2E ,APPLE-2C ,APPLE-2GS>> 
<GLOBAL P-WON <>> 
<GLOBAL SCENE 0> 
<DEFINE-ROUTINE SCENE-SELECT> 
<DEFINE-ROUTINE SCENE-SELECT-F> 
<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" "Rodrigues"
"Voyage to Osaka" "Toranaga" "Prison" "Mariko" "Escape" "Earthquake"
"Journey to Yedo" "Ochiba" "Departure" "Seppuku" "Ninja" "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 MURA-HOUSE VILLAGE-SQUARE PIT
ANJIRO-WATERFRONT GALLEY OUTER-CORRIDOR PRISON MAPLE-GLADE COURTYARD PLATEAU
YOKOSE-BATH-HOUSE OCHIBA-ROOM FORECOURT FORMAL-GARDEN PRIVATE-QUARTERS YOKOHAMA
STABLE SEKIGAHARA>> 
<CONSTANT SCENE-PICS <TABLE (PURE BYTE LENGTH) P-STORM P-GARDEN P-YABU-SEG
P-PIT P-RODRIGUES-SEG P-CONFUSION P-OSAKA P-PRISON-SEG P-MARIKO-SEG
P-PROCESSION P-QUAKE P-BATH P-OCHIBA-SEG P-DEPARTURE-SEG P-SEPPUKU P-NINJA
P-VINCK P-AFTERMATH-SEG P-CREST>> 
<GLOBAL MACHINE <>> 
<GLOBAL WIDTH 0> 
<END-SEGMENT> 
<BEGIN-SEGMENT STARTUP> 
<DEFINE-ROUTINE GO> 
<DEFINE-ROUTINE SLIDE-SHOW> 
<DEFINE-ROUTINE END-DEMO> 
<END-SEGMENT> 
<BEGIN-SEGMENT 0> 
<CONSTANT S-FULL 7> 
<DEFINE-ROUTINE SETUP-FULL> 
<DEFINE-ROUTINE SETUP-DISPLAY> 
<DEFINE-ROUTINE REPAINT-DISPLAY> 
<DEFINE-ROUTINE GOTO-SCENE> 
<DEFINE-ROUTINE TOUCH-SEG> 
<DEFINE-ROUTINE GAME-VERB?> 
<GLOBAL P-MULT <>> 
<GLOBAL P-NOT-HERE 0> 
<DEFINE-ROUTINE END-QUOTE> 
<GLOBAL CLOCK-WAIT <>> 
<GLOBAL C-TABLE <ITABLE 13 <> <>>> 
<CONSTANT C-INTLEN 4> 
<CONSTANT C-RTN 0> 
<CONSTANT C-TICK 1> 
<CONSTANT C-TABLELEN 52> 
<GLOBAL C-INTS 52> 
<DEFINE-ROUTINE DEQUEUE> 
<DEFINE-ROUTINE QUEUED?> 
<DEFINE-ROUTINE QUEUE> 
<GLOBAL STATIONARY? <>> 
<GLOBAL STATIONARY-CNT <>> 
<GLOBAL CLOCK-HAND <>> 
<DEFINE-ROUTINE CLOCKER> 
<DEFINE-ROUTINE DEQUEUE-ALL> 
<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>)>>>
.V>> 
<DEFINE-ROUTINE PERFORM-PRSA> 
<DEFINE-ROUTINE NEW-VERB> 
<DEFINE-ROUTINE SWAP-VERB> 
<DEFINE-ROUTINE NEW-PRSO> 
<DEFINE-ROUTINE NEW-WINNER-PRSO> 
<DEFINE-ROUTINE REDIRECT> 
<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>>>)> 
<DEFINE-ROUTINE CREWMAN?> 
<DEFINE-ROUTINE WINDEF> 
<GLOBAL FONT-X 7> 
<GLOBAL FONT-Y 10> 
<DEFINE-ROUTINE C-PIXELS> 
<DEFINE-ROUTINE L-PIXELS> 
<DEFINE-ROUTINE CCURSET> 
<DEFINE-ROUTINE IN-SCENE?> 
<DEFINE-ROUTINE REPLACE-SYNONYM> 
<DEFINE-ROUTINE REPLACE-ADJECTIVE> 
<DEFINE-ROUTINE CURSOR-OFF> 
<DEFINE-ROUTINE CURSOR-ON> 
<END-SEGMENT>