shogun/misc.zil

"MISC for
				 SHOGUN
	(c) Copyright 1988 Infocom, Inc. All Rights Reserved."

<BEGIN-SEGMENT 0>

<GLOBAL DEMO-VERSION? <>>	;"for swg"

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



;"former MAIN.ZIL stuff"

<GLOBAL P-WON <>>

<GLOBAL SCENE 0>

<ROUTINE SCENE-SELECT ("OPT" (FULL? <>) "AUX" TMP M WID WHICH)
	 <REPEAT ()
		 <SPLIT <- <WINGET ,S-FULL ,WHIGH>
			   <* <+ <GET ,PART-MENU ;.MEN 0> 1> ,FONT-Y>>>
		 <RESET-MARGIN>
		 <CLEAR ,S-TEXT>
		 <SCREEN ,S-TEXT>
		 <SET WHICH
		      <GET-FROM-MENU "You may choose to: "
				     ,PART-MENU
				     ,SCENE-SELECT-F
				     1>>
		 <COND (<EQUAL? .WHICH -1>
			<SET FULL? <NOT .FULL?>>)
		       (.WHICH <RTRUE>)>>>

<ROUTINE SCENE-SELECT-F (TMP M)
	 <COND (<EQUAL? .TMP 1>
		<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 ,LTABLE
	      <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
	  <LTABLE 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">>

<GLOBAL MACHINE <>>
<GLOBAL WIDTH 0>

<END-SEGMENT>

<BEGIN-SEGMENT STARTUP>

<ROUTINE GO () 
	 <MOUSE-LIMIT -1>
	 <SETG FG-COLOR <LOWCORE (CLRWRD 1)>>
	 <SETG BG-COLOR <LOWCORE (CLRWRD 0)>>
	 <SETG LIT T>
	 <SETG CLOCK-HAND <REST ,C-TABLE ,C-TABLELEN>>
	 <SETG MACHINE <LOWCORE INTID>>
	 <SETG PLAYER ,BLACKTHORNE>
	 <SETUP-FULL>
	 <TITLE-SCREEN>
	 <SETUP-DISPLAY>
	 <SCENE-SELECT>
	 <GOTO-SCENE ,SCENE <>>
	 <MAIN-LOOP>>

<END-SEGMENT>

<BEGIN-SEGMENT 0>

<CONSTANT S-FULL 7>

<ROUTINE SETUP-FULL ("AUX" (HIGH <LOWCORE VWRD>) (WIDE <LOWCORE HWRD>))
	 <WINDEF ,S-FULL 1 1 .HIGH .WIDE>>

<ROUTINE SETUP-DISPLAY ("AUX" X (HIGH <LOWCORE VWRD>) (WIDE <LOWCORE HWRD>))
	 <MOUSE-LIMIT -1>
	 <SETUP-FULL>
	 <SET X <WINGET ,S-TEXT ,WFSIZE>>
	 <SETG FONT-Y <HIGH-BYTE .X>>
	 <SETG FONT-X <LOW-BYTE .X>>
	 <SETUP-TEXT-AND-STATUS>
	 <SET WIDE <WINGET ,S-TEXT ,WWIDE>>
	 <MARGIN ,TEXT-MARGIN ,TEXT-MARGIN ,S-TEXT>
	 <SET WIDE <- .WIDE 4>>
	 <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>
	 <COLOR ,FG-COLOR ,BG-COLOR>
	 <SETUP-DISPLAY>
	 <COND (<NOT .NO-BORDER?> <DISPLAY-BORDER>)>
	 <INIT-STATUS-LINE T>
	 <COND (<HERE? ,MAZE>
		<DISPLAY-MAZE>)>>

<ROUTINE GOTO-SCENE (SC "OPT" (OSC ,SCENE))
	 <END-QUOTE>
	 <RESET-MARGIN>
	 <DEQUEUE-ALL>
	 <SETG SCENE .SC>
	 <SETG HERE <GET ,SCENE-LOCS ,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>>

;<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 (OSC ,SCENE))
	 <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 (<EQUAL? ,CLOCK-HAND .E>
			<SETG 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>)>
				      <SET OSC ,SCENE>
				      <COND (<SET TMP <APPLY .RTN>>
					     <SET FLG .TMP>)>
				      <COND (<AND <NOT .Q?>
						  <NOT
						   <ZERO?
						    <GET ,CLOCK-HAND
							 ,C-RTN>>>>
					     <SET Q? T>)>)>)>)>
		 <COND (<NOT <EQUAL? .OSC ,SCENE>> ;"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>>

<DEFMAC APPLE? ()
   '<EQUAL? ,MACHINE ,APPLE-2E ,APPLE-2C ,APPLE-2GS>>

<END-SEGMENT>