sr.mud

<SETG SAVSTR <ISTRING 5>>

<SETG SAVE-VERSION -1>

<GDECL (SAVE-VERSION) FIX (SRUV) <UVECTOR [REST FIX]>>

;"CONSTANTS FOR SAVE-RESTORE UVECTOR"

<MSETG OBJSVLN 3600>

;"Length of ROOMS block"

<MSETG RMSVLN 2000>

;"Length of DEMONS block"

<MSETG DMNSVLN 225>

;"Length of <HOBJS <robber>> block"

<MSETG HOBJSVLN 17>

;"Starting offset of CLOCKER slots"

<MSETG CEVSVOFF 20>

;"Length of CEVENT slots (33 CEVENTS x 3 slots)"

<MSETG CEVSVLN 99>

;"Length of ACTORs block"

<SETG ACTSVLN 122>

;"Length of WINNER block"

<MSETG WSVLN 22>

;"Length of MONAD GVAL block"

<MSETG MGSVLN 125>

;"Length of ROOM GVAL block"

<MSETG RMGSVLN 15>

;"Length of OBJECT GVAL block"

<MSETG OBJGSVLN 10>

;"# of slots for OBJECTs"

<MSETG PUZSVLN 164>

<MSETG SAVLENGTH
       <+ 1 ,OBJSVLN ,RMSVLN ,DMNSVLN ,ACTSVLN ,MGSVLN ,RMGSVLN ,OBJGSVLN ,PUZSVLN>>

<MSETG ORECLN 12>

;"# of slots for ROOMs"

<MSETG RRECLN 8>

;"# of slots for CEVENT"

<MSETG CRECLN 3>

;"Names of slots to be saved from OBJECTS"

<PSETG OSNAMES
       '![OID OCAN OFLAGS OROOM ORAND OFVAL OSIZE OCAPAC OLINT OMATCH
	  OSTRENGTH!]>

;"Types of these slots (rested once)"

<PSETG OSTYPES '![OBJECT FIX ROOM FIX FIX FIX FIX FIX FIX FIX!]>

;"Names of slots to be saved from ROOMS"

<PSETG RSNAMES '![RID RVARS RBITS RRAND RVAL!]>

;"Types of these slots (rested once)"

<PSETG RSTYPES '![FIX WORD FIX FIX!]>

;"Names of slots to be saved from CEVENTS"

<PSETG CSNAMES '![CID CTICK CFLAG!]>

;"Types of these slots"

<PSETG CSTYPES '![FIX FIX!]>

<GDECL (OSNAMES RSNAMES CSNAMES OSTYPES RSTYPES CSTYPES) <UVECTOR [REST ATOM]>>

<DEFINE POS (OBJ LST "AUX" M)
    #DECL ((OBJ) ANY (LST) LIST (M) <OR FALSE LIST>)
    <AND <SET M <MEMQ .OBJ .LST>>
	 <+ 1 <- <LENGTH .LST> <LENGTH .M>>>>>

 ; "Get the FIX code for any item."
<GDECL (CLOCKER) HACK (CLOCK-CALLERS) LIST (ACTORS) <LIST [REST ADV]>>

<DEFINE SCODE (ITM "AUX" RI) 
	#DECL ((ITM) ANY (RI) <VECTOR FIX CEVENT>)
	<COND (<==? .ITM T> 10223616)
	      (<NOT .ITM> 2883584)
	      (<TYPE? .ITM ADV> 0)
	      (<TYPE? .ITM ATOM PSTRING> <ATMFIX .ITM>)
	      (<==? <PRIMTYPE .ITM> WORD> <CHTYPE .ITM FIX>)
	      (<TYPE? .ITM ROOM> <ATMFIX <RID .ITM>>)
	      (<TYPE? .ITM OBJECT> <ATMFIX <OID .ITM>>)
	      (<DECL? .ITM '<VECTOR FIX CEVENT>>
	       <SET RI .ITM>
	       <PUTBITS <PUTBITS 3145728
				 <BITS 18 0>
				 <POS <2 .RI> <HOBJS ,CLOCKER>>>
			<BITS 9 9>
			<1 .RI>>)
	      (5505024)>>

;"Get an object from any FIX code (inverse of SCODE)"

<DEFINE SDECODE (FX TYP "AUX" ATM)
    #DECL ((FX) FIX (TYP) ATOM (ATM) <OR ATOM FALSE>)
    <COND (<==? .FX *47000000*>)
	  (<==? .FX *13000000*> <>)
	  (<==? .FX *25000000*> #FALSE (1))
 	  (<==? <GETBITS .FX <BITS 18 18>> #WORD *14*>
	   <VECTOR <CHTYPE <GETBITS .FX <BITS 9 9>> FIX>
		   <NTH <HOBJS ,CLOCKER> <CHTYPE <GETBITS .FX <BITS 9 0>> FIX>>>)
	  (<==? .TYP OBJECT>
	   <COND (<0? .FX> <>)
		 (<FIND-OBJ <FIXSTR .FX>>)>)
	  (<==? .TYP ROOM>
	   <COND (<0? .FX> <>)
		 (<NOT <PLOOKUP <FIXSTR .FX> ,ROOM-POBL>>
		  <FIND-ROOM "FCHMP">)
		 (<FIND-ROOM <FIXSTR .FX>>)>)
	  (<==? .TYP CEVENT>
	   <COND (<0? .FX> <>)
		 (<SET ATM <LOOKUP <FIXSTR .FX> <GET INITIAL OBLIST>>>
		  ,.ATM)>)
	  (<CHTYPE .FX .TYP>)>>

; "Save elements from a list of items:
	Arg 1: The code UVECTOR
	Arg 2: The list of items (e.g. ,ROOMS ,OBJECTS)
	Arg 3: Number of elements to REST off Arg 1 when finished
	Arg 4: A UVECTOR of offsets for each item to be saved
	Arg 5: The number of slots to be used for each item in the UVECTOR"

<DEFINE UNSAVORY-CODE (SU L OFF NUVEC RECLEN "AUX" (NU .SU))
    #DECL ((L) LIST (OFF RECLEN) FIX (SU NU) <UVECTOR [REST FIX]>
	   (NUVEC) <UVECTOR [REST ATOM]>)
    <MAPF <>
	<FUNCTION (ITM "AUX" (U .NU))
	    #DECL ((ITM) <PRIMTYPE VECTOR> (U) <UVECTOR [REST FIX]>)
	    <MAPF <>
		<FUNCTION (SLT "AUX" VAL)
		    #DECL ((SLT) ATOM (VAL) ANY)
		    <SET VAL <SRGET .ITM .SLT>>
		    <PUT .U
			 1
			 <SCODE .VAL>>
		    <SET U <REST .U 1>>>
		.NUVEC>
	    <SET NU <REST .NU .RECLEN>>>
	.L>
    <REST .SU .OFF>>

; "Restore elements from an object
	Arg 1: The code UVECTOR
	Arg 2: The object
	Arg 3: A UVECTOR of offsets into the object
	Arg 4: A UVECTOR of types for these offsets (ATOMs)"

<DEFINE UNRESTFUL-CODE (U OBJ NUVEC TUVEC "AUX" M) 
	#DECL ((U) <UVECTOR [REST FIX]> (TUVEC NUVEC) <UVECTOR [REST ATOM]>
	       (OBJ) <PRIMTYPE VECTOR> (M) <OR FALSE <VECTOR OBJECT ATOM ATOM>>)
	<MAPF <>
	      <FUNCTION (SLT TYP "AUX" TMP) 
		      #DECL ((SLT TYP) ATOM)
		      <COND (<OR <SET TMP <SDECODE <1 .U> .TYP>> <EMPTY? .TMP>>
			     <SRPUT .OBJ .SLT .TMP>)>
		      <SET U <REST .U 1>>>
	      .NUVEC
	      .TUVEC>>

<DEFINE SRGET (OBJ SLT "AUX" HOW) 
	#DECL ((OBJ) <PRIMTYPE VECTOR> (SLT) ATOM (HOW) APPLICABLE)
	<COND (<AND <GASSIGNED? .SLT>
		    <TYPE? <SET HOW ,.SLT> FIX>>
	       <NTH .OBJ .HOW>)
	      (<==? .SLT OID>
	       <OID .OBJ>)
	      (<OGET .OBJ .SLT>)>>

<DEFINE SRPUT (OBJ SLT VAL "AUX" HOW M) 
	#DECL ((OBJ) <PRIMTYPE VECTOR> (SLT) ATOM (VAL) ANY (HOW) APPLICABLE
	       (M) <OR FALSE <VECTOR OBJECT ATOM ATOM>>)
	<COND (<SET M <MEMQ .OBJ ,OFIXUPS>>
	       <COND (<==? <2 .M> .SLT> <SET SLT <3 .M>>)>)>
	<COND (<AND <GASSIGNED? .SLT>
		    <TYPE? <SET HOW ,.SLT> FIX>>
	       <PUT .OBJ .HOW .VAL>)
	      (<OPUT .OBJ .SLT .VAL>)>>

;
"Save GVALs
	Arg 1: The code UVECTOR
	Arg 2: A UVECTOR of ATOMS (which must have GVALs!
	Arg 3: Number of times to rest UVECTOR when done"

<DEFINE SAVE-GVAL (V GV RST)
    #DECL ((V) <UVECTOR [REST FIX]> (GV) <UVECTOR [REST ATOM]> (RST) FIX)
    <MAPR <>
	<FUNCTION (ATMS VEC)
	    #DECL ((ATMS) <UVECTOR [REST ATOM]> (VEC) <UVECTOR [REST FIX]>)
	    <PUT .VEC 1 <SCODE <GVAL <1 .ATMS>>>>>
	.GV
	.V>
    <REST .V .RST>>

; "Restore GVALs
	Args 1-3: As above
	Arg 4: The type (ATOM) to restore"

<DEFINE REST-GVAL (V GV RST TYP)
    #DECL ((V) <UVECTOR [REST FIX]> (GV) <UVECTOR [REST ATOM]> (RST) FIX (TYP) ATOM)
    <MAPF <>
	<FUNCTION (ATM VAL)
	    #DECL ((ATM) ATOM (VAL) FIX)
	    <SETG .ATM <SDECODE .VAL .TYP>>>
	.GV
	.V>
    <REST .V .RST>>

; "Restore a LIST of OBJECTs
	Arg 1: The code UVECTOR 
	Stops when a 0 is encountered"

<DEFINE REST-LIST (V)
    #DECL ((V) <UVECTOR [REST FIX]>)
    <MAPF ,LIST
	<FUNCTION (X)
	    #DECL ((X) FIX)
	    <COND (<0? .X> <MAPSTOP>)
		  (<SDECODE .X OBJECT>)>>
	.V>>

; "Restore ROOMS/OBJECTS
	Arg 1: The code UVECTOR
	Arg 2: A UVECTOR of offsets into the objects (FIX)
	Arg 3: A UVECTOR of types of the offsets (ATOM)
	Arg 4: The length of each record
	Arg 5: OBJECT/ROOM flag
	Gets the item (ROOM or OBJECT) from the ID slot and then
	calls UNRESTFUL-CODE to fill the elements (note that this
	function is called with names = <REST ,xSNAMES>
  	This function also fixes up OCONTENTS and OROOM slots."

<DEFINE REST-ITEMS (V NAMES TYPES RECLEN TYPE "AUX" D C) 
   #DECL ((V) <UVECTOR [REST FIX]> (TYPES NAMES) <UVECTOR [REST ATOM]>
	  (RECLEN) FIX (TYPE) ATOM (C) <OR FALSE <PRIMTYPE VECTOR>>
	  (D) <OR FALSE DOOR>)
   <REPEAT (OBJ)
	   #DECL ((OBJ) <OR FALSE <PRIMTYPE VECTOR>>)
	   <COND
	    (<SET OBJ <SDECODE <1 .V> .TYPE>>
	     <UNRESTFUL-CODE <REST .V> .OBJ .NAMES .TYPES>
	     <COND (<==? .TYPE OBJECT>
		    <COND (<SET C <OCAN .OBJ>>
			   <PUT .C ,OCONTENTS (.OBJ !<OCONTENTS .C>)>)
			  (<SET C <OROOM .OBJ>>
			   <PUT .C ,ROBJS (.OBJ !<ROBJS .C>)>
			   <COND (<AND <TRNN .OBJ ,DOORBIT>
				       <SET D <FIND-DOOR .C .OBJ>>>
				  <SET C <GET-DOOR-ROOM .C .D>>
				  <PUT .C ,ROBJS (.OBJ !<ROBJS .C>)>)>)>)>
	     <SET V <REST .V .RECLEN>>)
	    (<RETURN>)>>>

<DEFINE GET-SRUV ()
    <COND (<GASSIGNED? SRUV>
	   <MAPR <>
		 <FUNCTION (X) #DECL ((X) <UVECTOR [REST FIX]>)
			   <PUT .X 1 0>>
		 ,SRUV>
	   ,SRUV)
	  (<BLOAT <+ ,SAVLENGTH 2>>
	   <SETG SRUV <IUVECTOR ,SAVLENGTH 0>>)>>

; "Save the game -- linear sequence of calls to above"

<DEFINE SAVE-GAME (CH "AUX" V VV (C ,CLOCKER) (H ,ROBBER-DEMON)) 
	#DECL ((V VV) <UVECTOR [REST FIX]> (C H) HACK (CH) CHANNEL)
	<SET V <GET-SRUV>>					 ;"Save objects"
	<PUT .V 1 ,SAVE-VERSION>
	<SET V <REST .V>>
	<SET V <UNSAVORY-CODE .V ,OBJECTS ,OBJSVLN ,OSNAMES ,ORECLN>>
								   ;"Save rooms"
	<SET V <UNSAVORY-CODE .V ,ROOMS ,RMSVLN ,RSNAMES ,RRECLN>>
							  ;"Save robber's booty"
	<SET VV <UNSAVORY-CODE .V <HOBJS .H> ,HOBJSVLN '![OID] 1>>
							    ;"Save robber stuff"
	<PUT .VV 1 <SCODE <1 <HROOMS .H>>>>
	<PUT .VV 2 <SCODE <HROOM .H>>>
	<PUT .VV 3 <SCODE <HFLAG .H>>>
	<PUT .VV 4 <COND (<HACTION .H> 1)
			 (0)>>
	<PUT .VV 5 <COND (<HACTION ,SWORD-DEMON> 1)
			 (0)>>
	;"Save clocker"
	<SET VV
	     <UNSAVORY-CODE <REST .VV 5> <HOBJS .C> ,CEVSVLN ,CSNAMES ,CRECLN>>
	<SET V <SET VV <REST .V ,DMNSVLN>>>			 ;"Save winners"
	<MAPF <> <FUNCTION (X) <SET VV <WINSAVE .VV .X>>> ,ACTORS>
	<SET V <REST .V ,ACTSVLN>>	     ;"Save GVALs (MONAD, ROOM, OBJECT)"
	<SET V <SAVE-GVAL .V ,MGVALS ,MGSVLN>>
	<SET V <SAVE-GVAL .V ,RMGVALS ,RMGSVLN>>
	<SET V <SAVE-GVAL .V ,OBJGVALS ,OBJGSVLN>>
	<SAVE-PUZZLE .V>
	<PRINTB <TOP .V> .CH>
	<CLOSE .CH>
	"DONE">

<DEFINE SAVE-PUZZLE (U "AUX" (BUCK 1))
	#DECL ((U) <UVECTOR [REST FIX]> (BUCK) FIX)
	<COND (<==? <LENGTH <TOP .U>> ,SAVLENGTH>
	       <PUT ,CPOBJS ,CPHERE <ROBJS <SFIND-ROOM "CP">>>
	       <SUBSTRUC ,CPUVEC 0 64 .U>
	       <SET U <REST .U 64>>
	       <MAPF <>
		     <FUNCTION (LST)
			       #DECL ((LST) LIST)
			       <MAPF <>
				     <FUNCTION (OBJ)
					       #DECL ((OBJ) OBJECT)
					       <PUT .U 1 <SCODE .OBJ>>
					       <PUT .U 2 .BUCK>
					       <SET U <REST .U 2>>>
				     .LST>
			       <SET BUCK <+ .BUCK 1>>>
		     ,CPOBJS>)>>

<DEFINE RESTORE-PUZZLE (U "AUX" (OBJS ,CPOBJS) WHR)
	#DECL ((U) <UVECTOR [REST FIX]> (OBJS) <UVECTOR [REST LIST]> (WHR) FIX)
	<COND (<==? <LENGTH <TOP .U>> ,SAVLENGTH>
	       <SUBSTRUC .U 0 64 ,CPUVEC>
	       <SET U <REST .U 64>>
	       <MAPR <>
		     <FUNCTION (UVC)
			       #DECL ((UVC) <UVECTOR [REST LIST]>)
			       <PUT .UVC 1 '()>>
		     .OBJS>
	       <REPEAT ()
		     <COND (<0? <1 .U>>
			    <RETURN>)
			   (<PUT .OBJS
				 <SET WHR <2 .U>>
				 (<SDECODE <1 .U> OBJECT> !<NTH .OBJS .WHR>)>)>
		     <SET U <REST .U 2>>>
	       <OR <0? ,CPHERE>
		   <PUT <SFIND-ROOM "CP"> ,ROBJS <NTH ,CPOBJS ,CPHERE>>>)>>

<DEFINE WINSAVE (V W) 
	#DECL ((V) <UVECTOR [REST FIX]> (W) ADV)
	<PUT .V 1 <SCODE <AROOM .W>>>
	<PUT .V 2 <SCODE <ASCORE .W>>>
	<PUT .V 3 <SCODE <AVEHICLE .W>>>
	<PUT .V 4 <SCODE <AOBJ .W>>>
	<PUT .V 5 <SCODE <ASTRENGTH .W>>>
	<UNSAVORY-CODE <REST .V 5> <AOBJS .W> ,WSVLN '![OID!] 1>>

<DEFINE RESTORE-GAME RG (CH "AUX" V VV (H ,ROBBER-DEMON) (C ,CLOCKER)
		      (CSNAMES ,CSNAMES) (CSTYPES ,CSTYPES) (CNT 2))
    #DECL ((CH) CHANNEL (V VV) <UVECTOR [REST FIX]> (C H) HACK
	   (CSNAMES CSTYPES) UVECTOR (CNT) FIX (RG) ACTIVATION)
    <SET V <GET-SRUV>>
    <COND (<READB .V .CH>
	   <COND (<N==? <1 .V> ,SAVE-VERSION>
		  <TELL
		   "ERROR--Save file is incompatible with this version of Dungeon.">
		  <CLOSE .CH>
		  <RETURN <> .RG>)>
	   <SET V <REST .V>>
	   <CLOSE .CH>
	   ; "Clear slots"
	   <MAPF <> <FUNCTION (X) #DECL ((X) OBJECT) <PUT .X ,OCONTENTS ()>> ,OBJECTS>
	   <MAPF <> <FUNCTION (X) #DECL ((X) ROOM) <PUT .X ,ROBJS ()>> ,ROOMS>
    	   ; "Retrieve clocker first!"
	   <PUT .C ,HOBJS
	     <MAPR ,LIST
	       <FUNCTION (UV "AUX" CV)
		 #DECL ((UV) UVECTOR (CV) <OR FALSE CEVENT>)
	         <COND (<0? <SET CNT <MOD <+ .CNT 1> 3>>>
			<COND (<SET CV <SDECODE <1 .UV> CEVENT>>
			       <UNRESTFUL-CODE <REST .UV> .CV
					       <REST .CSNAMES> .CSTYPES>
			       <MAPRET .CV>)
			      (<MAPSTOP>)>)
		       (<MAPRET>)>>
	       <REST .V <+ ,OBJSVLN ,RMSVLN ,HOBJSVLN 5>>>>
	   ; "Get objects"
	   <REST-ITEMS .V <REST ,OSNAMES> ,OSTYPES ,ORECLN OBJECT>
	   ; "Get rooms"
	   <REST-ITEMS <SET V <REST .V ,OBJSVLN>> <REST ,RSNAMES> ,RSTYPES ,RRECLN ROOM>
	   ; "Get robber"
	   <PUT .H ,HOBJS <REST-LIST <SET V <REST .V ,RMSVLN>>>>
	   <SET VV <REST .V ,HOBJSVLN>>
	   <PUT .H ,HROOMS <MEMQ <SDECODE <1 .VV> ROOM> ,ROOMS>>
	   <PUT .H ,HROOM <SDECODE <2 .VV> ROOM>>
	   <PUT .H ,HFLAG <SDECODE <3 .VV> FIX>>
	   <COND (<1? <4 .VV>>
		  <PUT .H ,HACTION <COND (<TYPE? ,ROBBER NOFFSET> ,ROBBER)
					 (ROBBER)>>)
		 (T <PUT .H ,HACTION <>>)>
	   <COND (<1? <5 .VV>>
		  <PUT ,SWORD-DEMON ,HACTION <COND (<TYPE? ,SWORD-GLOW NOFFSET>
						    ,SWORD-GLOW)
						   (SWORD-GLOW)>>)>
	   <SET V <SET VV <REST .V ,DMNSVLN>>>
	   ; "Get winner"
	   <MAPF <> <FUNCTION (X) #DECL ((X) ADV) <SET VV <WINREST .VV .X>>> ,ACTORS>
	   <SET V <REST .V ,ACTSVLN>>
	   ; "Get GVALS"
	   <SET V <REST-GVAL .V ,MGVALS ,MGSVLN FIX>>
	   <SET V <REST-GVAL .V ,RMGVALS ,RMGSVLN ROOM>>
	   <SET V <REST-GVAL .V  ,OBJGVALS ,OBJGSVLN OBJECT>>
	   <RESTORE-PUZZLE .V>
	   "DONE")>>
	  
<DEFINE WINREST (V W "AUX" T) 
	#DECL ((V) <UVECTOR [REST FIX]> (W) ADV (T) OBJECT)
	<PUT .W ,AROOM <SDECODE <1 .V> ROOM>>
	<PUT .W ,ASCORE <SDECODE <2 .V> FIX>>
	<PUT .W ,AVEHICLE <SDECODE <3 .V> OBJECT>>
	<PUT .W ,AOBJ <OPUT <SET T <SDECODE <4 .V> OBJECT>> OACTOR .W>>
	<PUT .W ,ASTRENGTH <SDECODE <5 .V> FIX>>
	<PUT .W ,AOBJS <REST-LIST <SET V <REST .V 5>>>>
	<REST .V ,WSVLN>>

<GDECL (OFIXUPS) <VECTOR [REST OBJECT ATOM ATOM]>>