(FILECREATED "15-Jan-86 23:32:05" {ERIS}<LISPUSERS>KOTO>SOLITAIRE.;5 23494  

      changes to:  (VARS SOLITAIRECOMS)
		   (FNS SOLO DEALDECK NXTCARD CARDIMAGE COUNTCARDS GOODMOVE? MOVESSS CARDNAME 
			CREATEHAND CREATESTACK STACKLOC POSTVALUE)
		   (MACROS KINGP)

      previous date: "15-Dec-85 22:01:18" {ERIS}<LISPUSERS>KOTO>SOLITAIRE.;3)


(* Copyright (c) 1982, 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT SOLITAIRECOMS)

(RPAQQ SOLITAIRECOMS [(FNS SOLO SOLITAIRE)
	(FNS CARDIMAGE COUNTCARDS CREATEHAND CREATESTACK DEALDECK FLIPSTACK GETCARD GOODMOVE? HTOS? 
	     MOVECARD DOMOVE MOVEHS MOVES MOVES1 UPCARD MOVESSS NXTCARD PUSHCARD POSTVALUE 
	     SEARCHSTACKS SHOWCARDSTACK SHUFFLEDECK STACKLOC STOS? TOPSUITSTACK)
	(FNS HIST ARRAYMAX)
	(DECLARE: DONTCOPY (FNS SHOWCONFIG PRINTCARDSTACK CARDNAME))
	(DECLARE: EVAL@COMPILE DONTCOPY (MACROS BOTTOM KINGP STACK TOP)
		  (RECORDS CARD CARDSTACK)
		  (CONSTANTS (Spades 0)
			     (Clubs 1)
			     (Diamonds 2)
			     (Hearts 3)
			     (CostOfDeck 50)
			     (PayForCard 5)
			     (NStacks 7)
			     (NSuits 4)
			     (CardsPerSuit 13)
			     (TotalCards 52))
		  (CONSTANTS (BACKSHADE 52275)
			     (BetweenStacks 2)
			     (Overlap .667)
			     (CardWidth 30)
			     (CardHeight 45))
		  (GLOBALVARS HAND STACKS SUITSTACKS DECK SOLORESULTS)
		  (GLOBALVARS MaxCardMove WaitBetweenMoves))
	(INITRECORDS CARD CARDSTACK)
	(BITMAPS SpadesBits ClubsBits DiamondsBits HeartsBits 10Bits)
	(INITVARS (MaxCardMove 8)
		  (WaitBetweenMoves 10)
		  (DECK)
		  (SOLORESULTS))
	(ADDVARS (IDLE.FUNCTIONS ("Solitaire" (QUOTE SOLO])
(DEFINEQ

(SOLO
  [LAMBDA (W)                                                (* bas: "15-Jan-86 23:31")
    (if (AND (BOUNDP (QUOTE SOLORESULTS))
		 (ARRAYP SOLORESULTS))
      else (SETQ SOLORESULTS (ARRAY (ADD1 TotalCards)
					  (QUOTE FIXP)
					  0 0)))
    (if (WINDOWP W)
      else (SETQ W (CREATEW [GETREGION (CONSTANT (ITIMES (IPLUS BetweenStacks
									      (ITIMES NStacks
											(ADD1
											  
										    BetweenStacks)))
								     CardWidth))
					       (CONSTANT (ITIMES CardHeight
								     (IPLUS 5 (FTIMES 
										     CardsPerSuit 
											  Overlap]
				  "Just waiting Patiently..."))
	     (DSPTEXTURE 1088 W)
	     (DSPFONT (FONTCREATE (QUOTE HELVETICA)
				      18)
			W))
    (bind X
       do (SETQ X (SOLITAIRE W))
	    (DISMISS 1500)
	    (SETA SOLORESULTS X (ADD1 (ELT SOLORESULTS X)))
	    (HIST SOLORESULTS W "Number of cards up")
	    (DISMISS 1500])

(SOLITAIRE
  [LAMBDA (SOLOW REPLAY)                                     (* bas: "15-Dec-85 21:33")
    (DECLARE (SPECVARS SOLOW))
    (CLEARW SOLOW)
    (DEALDECK REPLAY)
    (PROG ((GAMEVALUE (IMINUS CostOfDeck)))
	    (DECLARE (SPECVARS GAMEVALUE))
	    (POSTVALUE GAMEVALUE)
	    (while (OR [for I from NStacks to 1 by -1 thereis
								   (MOVES (STACK I)
									    (STOS? (STACK I]
			   (MOVESSS HAND)
			   (MOVEHS HAND (HTOS? HAND))
			   (for I to NStacks thereis (MOVESSS (STACK I)))
			   (FLIPSTACK HAND))
	       do (DISMISS WaitBetweenMoves)))
    (COUNTCARDS])
)
(DEFINEQ

(CARDIMAGE
  [LAMBDA (C)                                                (* bas: "15-Jan-86 21:37")
    (PROG [(BM (BITMAPCREATE CardWidth CardHeight))
	     (SUITBM (SELECTQ (fetch SUIT of C)
				(0 SpadesBits)
				(1 ClubsBits)
				(2 DiamondsBits)
				(3 HeartsBits)
				(SHOULDNT)))
	     (RANKBM (if (EQ 10 (fetch (CARD RANK) of C))
			 then 10Bits
		       else (GETCHARBITMAP (SELECTQ (fetch (CARD RANK) of C)
							  (13 (CHARCODE K))
							  (12 (CHARCODE Q))
							  (11 (CHARCODE J))
							  (IPLUS (fetch (CARD RANK) of C)
								   (CHARCODE 0)))
					       (FONTCREATE (QUOTE HELVETICA)
							     18]
	    (BLTSHADE BLACKSHADE BM 0 0 CardWidth CardHeight (QUOTE REPLACE))
	    (BLTSHADE WHITESHADE BM 1 1 (IDIFFERENCE CardWidth 2)
			(IDIFFERENCE CardHeight 2)
			(QUOTE REPLACE))
	    (BITBLT SUITBM 0 0 BM 2 32 NIL NIL (QUOTE INPUT)
		      (QUOTE REPLACE))
	    (BITBLT RANKBM 0 0 BM (IQUOTIENT (IDIFFERENCE CardWidth (fetch BITMAPWIDTH
									     of RANKBM))
						 2)
		      (IQUOTIENT (IDIFFERENCE CardHeight (fetch BITMAPHEIGHT of RANKBM))
				   2)
		      NIL NIL (QUOTE INPUT)
		      (QUOTE REPLACE))
	    (BITBLT SUITBM 0 0 BM 17 3 NIL NIL (QUOTE INPUT)
		      (QUOTE REPLACE))
	    (RETURN BM])

(COUNTCARDS
  [LAMBDA NIL                                                (* bas: "15-Jan-86 21:37")
    (for S from Spades to Hearts sum (fetch (CARD RANK) of (TOPSUITSTACK S])

(CREATEHAND
  [LAMBDA (F)                                                (* bas: "15-Jan-86 23:25")
    (FLIPSTACK (SHOWCARDSTACK (create CARDSTACK
					    FACEUP _ NIL
					    FACEDOWN _(for I from F to TotalCards
							 collect (GETCARD I))
					    CSX _(fetch CSX of (STACK 1))
					    CSY _(FIX (FTIMES CardHeight .6))
					    XO _(FIX (FTIMES CardWidth Overlap))
					    YO _ 0])

(CREATESTACK
  [LAMBDA (N)                                                (* bas: "15-Jan-86 23:00")
    (FLIPSTACK (SHOWCARDSTACK (create CARDSTACK
					    FACEUP _ NIL
					    FACEDOWN _(for I
							 from (ADD1 (IQUOTIENT
									  (ITIMES N (SUB1 N))
									  2))
							 as J to N collect (GETCARD I))
					    CSX _(STACKLOC N NStacks)
					    CSY _(ITIMES CardHeight (IPLUS 2 (FTIMES 
										     CardsPerSuit 
											  Overlap)))
					    XO _ 0
					    YO _(FIX (FTIMES CardHeight (FMINUS Overlap])

(DEALDECK
  [LAMBDA (REDEAL)                                           (* bas: "11-Jan-86 20:14")
    (OR (AND REDEAL (ARRAYP DECK))
	  (SHUFFLEDECK))
    (SETQ SUITSTACKS (ARRAY NSuits (QUOTE POINTER)
				(create CARD
					  RANK _ 0)
				0))
    (SETQ STACKS (ARRAY NStacks (QUOTE POINTER)))
    (for I to NStacks do (SETA STACKS I (CREATESTACK I)))
    (SETQ HAND (CREATEHAND (CONSTANT (ADD1 (IQUOTIENT (ITIMES NStacks (ADD1 NStacks))
								2])

(FLIPSTACK
  [LAMBDA (H)                                                (* bas: "29-JUL-82 15:07")
    (if (fetch FACEDOWN of H)
	then (PUSHCARD H (NXTCARD H))
	     H
      else NIL])

(GETCARD
  [LAMBDA (I)                                                (* bas: "30-JUL-82 19:04")
    (PROG ((C (ELT DECK I)))
          (if (fetch FACE of C)
	    else (replace FACE of C with (CARDIMAGE C))
		 (replace SAV of C with (BITMAPCREATE CardWidth CardHeight)))
          (replace CX of C with (replace CY of C with NIL))
          (RETURN C])

(GOODMOVE?
  [LAMBDA (TOP BOT)                                          (* bas: "15-Jan-86 21:38")
    (if TOP
	then (AND (EQ (fetch (CARD RANK) of TOP)
			    (ADD1 (fetch (CARD RANK) of BOT)))
		      (NEQ (fetch (CARD COLOR) of TOP)
			     (fetch (CARD COLOR) of BOT)))
      else (KINGP BOT])

(HTOS?
  [LAMBDA (H)                                                (* bas: "30-JUL-82 19:30")
    (if (TOP H)
	then (SEARCHSTACKS (TOP H])

(MOVECARD
  [LAMBDA (C X Y)                                            (* lmm " 6-Aug-85 00:04")
    (if (fetch CX of C)
	then (DOMOVE (fetch FACE of C)
		     (fetch CX of C)
		     (fetch CY of C)
		     X Y (fetch SAV of C))
      else (BITBLT SOLOW X Y (fetch SAV of C)
		   NIL NIL NIL NIL (QUOTE INPUT)
		   (QUOTE REPLACE))
	   (BITBLT (fetch FACE of C)
		   NIL NIL SOLOW X Y NIL NIL (QUOTE INPUT)
		   (QUOTE REPLACE)))
    (replace CX of C with X)
    (replace CY of C with Y)
    C])

(DOMOVE
  [LAMBDA (IMAGE LEFT BOTTOM NX NY SAVE)                     (* lmm " 6-Aug-85 00:04")
    (PROG (N YWP YFP XWP XFP)
          (SETQ N (IQUOTIENT (IPLUS (IMAX (ABS (IDIFFERENCE NX LEFT))
					  (ABS (IDIFFERENCE NY BOTTOM)))
				    (SUB1 MaxCardMove))
			     MaxCardMove))                   (* Number of steps)
          (SETQ XWP (IQUOTIENT (IDIFFERENCE NX LEFT)
			       N))
          (SETQ XFP (IREMAINDER (IDIFFERENCE NX LEFT)
				N))
          (SETQ YWP (IQUOTIENT (IDIFFERENCE NY BOTTOM)
			       N))
          (SETQ YFP (IREMAINDER (IDIFFERENCE NY BOTTOM)
				N))
          (bind OLDLEFT OLDLOW (XFC _ 0)
		(YFC _ 0) until (AND (EQ LEFT NX)
				     (EQ BOTTOM NY))
	     do (SETQ OLDLEFT LEFT)
		(SETQ OLDLOW BOTTOM)
		[add LEFT XWP (PROG1 (IQUOTIENT (add XFC XFP)
						N)
				     (SETQ XFC (IREMAINDER XFC N]
		[add BOTTOM YWP (PROG1 (IQUOTIENT (add YFC YFP)
						  N)
				       (SETQ YFC (IREMAINDER YFC N]
		(BITBLT SAVE 0 0 SOLOW OLDLEFT OLDLOW CardWidth CardHeight (QUOTE INPUT)
			(QUOTE REPLACE))
		(BITBLT SOLOW LEFT BOTTOM SAVE 0 0 CardWidth CardHeight (QUOTE INPUT)
			(QUOTE REPLACE))
		(BITBLT IMAGE 0 0 SOLOW LEFT BOTTOM CardWidth CardHeight (QUOTE INPUT)
			(QUOTE REPLACE])

(MOVEHS
  [LAMBDA (H SN)                                             (* bas: "30-JUL-82 19:30")
    (if SN
	then (PUSHCARD SN (pop (fetch FACEUP of H)))
	     (OR (TOP H)
		 (FLIPSTACK H))
	     SN])

(MOVES
  [LAMBDA (S1 S2)                                            (* bas: "30-JUL-82 12:47")
    (if S2
	then (MOVES1 (fetch FACEUP of S1)
		     NIL S2)
	     (replace FACEUP of S1 with NIL)
	     (FLIPSTACK S1)
	     S2])

(MOVES1
  [LAMBDA (L P S2)                                           (* bas: "30-JUL-82 19:12")
    (if L
	then (MOVES1 (CDR L)
		     (CAR L)
		     S2)
	     (UPCARD (CAR L)
		     P)
	     (PUSHCARD S2 (CAR L])

(UPCARD
  [LAMBDA (X Y)                                              (* lmm " 6-Aug-85 00:04")
                                                             (* Brings up X image which is assumed to be overlapped 
							     by Y image. Assumes YOFFSET only)
    (if Y
	then (PROG [(DY (IDIFFERENCE (fetch CY of X)
				     (fetch CY of Y]
	           (BITBLT (fetch SAV of X)
			   0 0 (fetch SAV of Y)
			   0 DY CardWidth (IDIFFERENCE CardHeight DY)
			   (QUOTE INPUT)
			   (QUOTE REPLACE))
	           (BITBLT SOLOW (fetch CX of X)
			   (fetch CY of X)
			   (fetch SAV of X)
			   0 0 CardWidth (IDIFFERENCE CardHeight DY)
			   (QUOTE INPUT)
			   (QUOTE REPLACE))
	           (BITBLT (fetch FACE of X)
			   0 0 SOLOW (fetch CX of X)
			   (fetch CY of X)
			   CardWidth
			   (IDIFFERENCE CardHeight DY)
			   (QUOTE INPUT)
			   (QUOTE REPLACE])

(MOVESSS
  [LAMBDA (S)                                                (* bas: "15-Jan-86 23:23")
    (PROG (STS (TS (TOP S)))
	    (DECLARE (USEDFREE GAMEVALUE))
	    (AND TS [EQ (fetch (CARD RANK) of TS)
			    (ADD1 (fetch (CARD RANK) of (TOPSUITSTACK (SETQ STS
										(fetch SUIT
										   of TS]
		   (PROGN [SETA SUITSTACKS STS (MOVECARD (pop (fetch FACEUP of S))
							       (STACKLOC (ADD1 STS)
									   NSuits)
							       (IPLUS (fetch CSY
									   of (STACK NStacks))
									(FTIMES CardHeight 1.5]
			    (OR (TOP S)
				  (FLIPSTACK S))
			    (POSTVALUE (add GAMEVALUE PayForCard))
			    (RETURN T])

(NXTCARD
  [LAMBDA (S)                                                (* bas: "15-Jan-86 21:44")
    (PROG1 (pop (fetch FACEDOWN of S))
	     (if (fetch FACEDOWN of S)
	       else                                        (* Last card up, replace surface of card table and 
							     adjust saved image for possibly overlapping exposed 
							     card in the pile)
		      (BLTSHADE (DSPTEXTURE NIL SOLOW)
				  SOLOW
				  (fetch CSX of S)
				  [IPLUS (fetch CSY of S)
					   (if (OR (NULL (fetch FACEUP of S))
						       (ZEROP (fetch YO of S)))
					       then 0
					     else (IPLUS CardHeight (fetch YO of S]
				  (if (OR (NULL (fetch FACEUP of S))
					      (ZEROP (fetch XO of S)))
				      then CardWidth
				    else (fetch XO of S))
				  (if (OR (NULL (fetch FACEUP of S))
					      (ZEROP (fetch YO of S)))
				      then CardHeight
				    else (IMINUS (fetch YO of S)))
				  (QUOTE REPLACE))
		      (if (fetch FACEUP of S)
			  then (BLTSHADE (DSPTEXTURE NIL SOLOW)
					     (fetch SAV of (BOTTOM S))
					     0
					     (IMINUS (fetch YO of S))
					     (IDIFFERENCE CardWidth (fetch XO of S))
					     CardHeight
					     (QUOTE REPLACE])

(PUSHCARD
  [LAMBDA (S C)                                              (* bas: "30-JUL-82 14:37")
    [MOVECARD C (IPLUS (fetch XO of S)
		       (if (fetch FACEUP of S)
			   then (fetch CX of (CAR (fetch FACEUP of S)))
			 else (fetch CSX of S)))
	      (IPLUS (fetch YO of S)
		     (if (fetch FACEUP of S)
			 then (fetch CY of (CAR (fetch FACEUP of S)))
		       else (fetch CSY of S]
    (push (fetch FACEUP of S)
	  C])

(POSTVALUE
  [LAMBDA (V)                                                (* bas: "15-Jan-86 23:25")
    (MOVETO (CONSTANT (FIX (FTIMES 25 Overlap CardWidth)))
	      CardHeight SOLOW)
    (DSPFONT (FONTCREATE (QUOTE HELVETICA)
			     18)
	       SOLOW)
    (BLTSHADE (DSPTEXTURE NIL SOLOW)
		SOLOW
		(DSPXPOSITION NIL SOLOW)
		(IDIFFERENCE (DSPYPOSITION NIL SOLOW)
			       (FONTPROP (DSPFONT NIL SOLOW)
					   (QUOTE DESCENT)))
		1000
		(FONTPROP (DSPFONT NIL SOLOW)
			    (QUOTE HEIGHT))
		(QUOTE REPLACE))
    (DSPOPERATION (PROG1 (DSPOPERATION (QUOTE PAINT)
					     SOLOW)
			     (if (ILESSP V 0)
				 then (printout SOLOW "Down by $" (IMINUS V)
						  "   ")
			       elseif (ZEROP V)
				 then (printout SOLOW "Dead even!   ")
			       else (printout SOLOW "Ahead by $" V "   ")))
		    SOLOW])

(SEARCHSTACKS
  [LAMBDA (K)                                                (* bas: "30-JUL-82 19:19")
    (for I to NStacks when (GOODMOVE? (TOP (STACK I))
				      K)
       do (RETURN (STACK I])

(SHOWCARDSTACK
  [LAMBDA (S)                                                (* lmm " 6-Aug-85 00:04")
    (if (fetch FACEDOWN of S)
	then (BITBLT NIL NIL NIL SOLOW (fetch CSX of S)
		     (fetch CSY of S)
		     CardWidth CardHeight (QUOTE TEXTURE)
		     (QUOTE REPLACE)
		     BLACKSHADE)
	     (BITBLT NIL NIL NIL SOLOW (ADD1 (fetch CSX of S))
		     (ADD1 (fetch CSY of S))
		     (IDIFFERENCE CardWidth 2)
		     (IDIFFERENCE CardHeight 2)
		     (QUOTE TEXTURE)
		     (QUOTE REPLACE)
		     BACKSHADE))
    S])

(SHUFFLEDECK
  [LAMBDA NIL                                                (* bas: "30-JUL-82 14:08")
    [if (AND (BOUNDP (QUOTE DECK))
	     (ARRAYP DECK))
      else (SETQ DECK (ARRAY TotalCards (QUOTE POINTER)))
	   (bind (I _ 0) for S from Spades to Hearts
	      do (for R to CardsPerSuit do (SETA DECK (add I 1)
						 (create CARD
							 SUIT _ S
							 RANK _ R]
    (bind Y for I to TotalCards do (SETQ Y (RAND 1 TotalCards))
				   (SETA DECK I (PROG1 (ELT DECK Y)
						       (SETA DECK Y (ELT DECK I])

(STACKLOC
  [LAMBDA (I N)                                              (* bas: "15-Jan-86 22:21")
    (IPLUS [ITIMES I (FIXR (FQUOTIENT (IDIFFERENCE (WINDOWPROP SOLOW (QUOTE WIDTH))
							     (ITIMES N CardWidth))
					      (ADD1 N]
	     (ITIMES CardWidth (SUB1 I])

(STOS?
  [LAMBDA (SN)                                              (* bas: " 7-JAN-81 22:01")
    (AND (fetch FACEUP of SN)
	 [OR (fetch FACEDOWN of SN)
	     (NOT (KINGP (BOTTOM SN]
	 (SEARCHSTACKS (BOTTOM SN])

(TOPSUITSTACK
  [LAMBDA (I)                                               (* bas: " 4-JAN-81 01:39")
    (ELT SUITSTACKS I])
)
(DEFINEQ

(HIST
  [LAMBDA (A W L)                                            (* bas: "15-Dec-85 20:22")
    (PROG ((WH (WINDOWPROP W (QUOTE HEIGHT)))
	     (WW (WINDOWPROP W (QUOTE WIDTH)))
	     (HM NIL)
	     (VM (IPLUS (FONTPROP (DSPFONT NIL W)
				      (QUOTE HEIGHT))
			  4)))
	    (SETQ HM VM)                                   (* Margins could be different eg if Y labels were 
							     used)
	    (BLTSHADE WHITESHADE W 0 0 WW WH (QUOTE REPLACE))
	    [PROG [(HS (IQUOTIENT (IDIFFERENCE WW (ITIMES HM 2))
				      (ARRAYSIZE A)))
		     (VS (FQUOTIENT (IDIFFERENCE WH (ITIMES VM 2))
				      (ARRAYMAX A]
		    (for I from (ARRAYORIG A) to (IPLUS (ARRAYSIZE A)
								  (ARRAYORIG A)
								  -1)
		       do (BLTSHADE GRAYSHADE W (IPLUS HM (ITIMES I HS))
					VM HS (FIX (FTIMES VS (ELT A I)))
					(QUOTE REPLACE]
	    (DRAWLINE HM VM (IDIFFERENCE WW HM)
			VM 2 (QUOTE REPLACE)
			W)
	    (DRAWLINE HM VM HM (IDIFFERENCE WH VM)
			2
			(QUOTE REPLACE)
			W)
	    (MOVETO (IDIFFERENCE (IDIFFERENCE WW HM)
				     (STRINGWIDTH L (DSPFONT NIL W)))
		      (IPLUS (FONTPROP (DSPFONT NIL W)
					   (QUOTE DESCENT))
			       2)
		      W)
	    (PRIN1 L W])

(ARRAYMAX
  [LAMBDA (A)                                                (* bas: " 5-AUG-82 14:59")
    (bind (M _ 0) for I from (ARRAYORIG A) to (IPLUS (ARRAYSIZE A)
						     (ARRAYORIG A)
						     -1)
       when (LESSP M (ELT A I)) do (SETQ M (ELT A I)) finally (RETURN M])
)
(DECLARE: DONTCOPY 
(DEFINEQ

(SHOWCONFIG
  [LAMBDA NIL                                                (* bas: "30-JUL-82 19:20")
    (printout NIL "Suits: " 10)
    (for I from Spades to Hearts do (printout NIL (CARDNAME (TOPSUITSTACK I))
					      ,))
    (TERPRI)
    (for I to NStacks do (PRINTCARDSTACK (STACK I)
					 (CONCAT "Stack " I)))
    (PRINTCARDSTACK HAND "Hand"])

(PRINTCARDSTACK
  [LAMBDA (X S)                                              (* bas: " 6-JAN-81 16:47")
    (printout NIL S ":" 10 .I2 (LENGTH (fetch FACEDOWN X))
	      " down. Up: ")
    (for J in (fetch FACEUP of X) do (printout NIL (CARDNAME J)
					       ,))
    (TERPRI])

(CARDNAME
  [LAMBDA (C)                                                (* bas: "15-Jan-86 21:40")
    (if (ZEROP (fetch (CARD RANK) of C))
	then "None"
      else (PACK (LIST (SELECTQ (fetch (CARD SUIT) of C)
					(0 (QUOTE S))
					(1 (QUOTE C))
					(2 (QUOTE D))
					(3 (QUOTE H))
					(SHOULDNT))
			     (SELECTQ (fetch (CARD RANK) of C)
					(1 (QUOTE A))
					(11 (QUOTE J))
					(12 (QUOTE Q))
					(13 (QUOTE K))
					(fetch (CARD RANK) of C])
)
)
(DECLARE: EVAL@COMPILE DONTCOPY 
(DECLARE: EVAL@COMPILE 
[PUTPROPS BOTTOM MACRO ((S)
	   (CAR (LAST (fetch FACEUP of S]
[PUTPROPS KINGP MACRO ((C)
	   (EQ CardsPerSuit (fetch (CARD RANK)
				   of C]
(PUTPROPS STACK MACRO ((N)
	   (ELT STACKS N)))
[PUTPROPS TOP MACRO ((S)
	   (CAR (fetch FACEUP of S]
)

[DECLARE: EVAL@COMPILE 

(DATATYPE CARD (SUIT RANK FACE SAV CX CY)
		 (ACCESSFNS CARD (COLOR (ILESSP (fetch SUIT of DATUM)
						    Diamonds))))

(RECORD CARDSTACK (FACEUP FACEDOWN CSX CSY XO YO))
]
(/DECLAREDATATYPE (QUOTE CARD)
		  (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER))
		  (QUOTE ((CARD 0 POINTER)
			  (CARD 2 POINTER)
			  (CARD 4 POINTER)
			  (CARD 6 POINTER)
			  (CARD 8 POINTER)
			  (CARD 10 POINTER)))
		  (QUOTE 12))

(DECLARE: EVAL@COMPILE 

(RPAQQ Spades 0)

(RPAQQ Clubs 1)

(RPAQQ Diamonds 2)

(RPAQQ Hearts 3)

(RPAQQ CostOfDeck 50)

(RPAQQ PayForCard 5)

(RPAQQ NStacks 7)

(RPAQQ NSuits 4)

(RPAQQ CardsPerSuit 13)

(RPAQQ TotalCards 52)

(CONSTANTS (Spades 0)
	   (Clubs 1)
	   (Diamonds 2)
	   (Hearts 3)
	   (CostOfDeck 50)
	   (PayForCard 5)
	   (NStacks 7)
	   (NSuits 4)
	   (CardsPerSuit 13)
	   (TotalCards 52))
)

(DECLARE: EVAL@COMPILE 

(RPAQQ BACKSHADE 52275)

(RPAQQ BetweenStacks 2)

(RPAQQ Overlap .667)

(RPAQQ CardWidth 30)

(RPAQQ CardHeight 45)

(CONSTANTS (BACKSHADE 52275)
	   (BetweenStacks 2)
	   (Overlap .667)
	   (CardWidth 30)
	   (CardHeight 45))
)

(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS HAND STACKS SUITSTACKS DECK SOLORESULTS)
)

(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS MaxCardMove WaitBetweenMoves)
)
)
(/DECLAREDATATYPE (QUOTE CARD)
		  (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER))
		  (QUOTE ((CARD 0 POINTER)
			  (CARD 2 POINTER)
			  (CARD 4 POINTER)
			  (CARD 6 POINTER)
			  (CARD 8 POINTER)
			  (CARD 10 POINTER)))
		  (QUOTE 12))

(RPAQ SpadesBits (READBITMAP))
(11 11
"@D@@"
"@N@@"
"AO@@"
"COH@"
"GOL@"
"GOL@"
"GOL@"
"COH@"
"@D@@"
"AO@@"
"COH@")

(RPAQ ClubsBits (READBITMAP))
(11 11
"@D@@"
"@N@@"
"AO@@"
"@N@@"
"BDH@"
"GEL@"
"OON@"
"GEL@"
"BDH@"
"@N@@"
"COH@")

(RPAQ DiamondsBits (READBITMAP))
(11 11
"@D@@"
"@N@@"
"AK@@"
"CAH@"
"F@L@"
"L@F@"
"F@L@"
"CAH@"
"AK@@"
"@N@@"
"@D@@")

(RPAQ HeartsBits (READBITMAP))
(11 11
"@@@@"
"CAH@"
"GKL@"
"DND@"
"D@D@"
"F@L@"
"CAH@"
"AK@@"
"@N@@"
"@D@@"
"@@@@")

(RPAQ 10Bits (READBITMAP))
(20 18
"@@@@@@@@"
"@F@GL@@@"
"@N@ON@@@"
"GNALG@@@"
"GNAHC@@@"
"@FAHC@@@"
"@FAHC@@@"
"@FAHC@@@"
"@FAHC@@@"
"@FAHC@@@"
"@FAHC@@@"
"@FALG@@@"
"@F@ON@@@"
"@F@GL@@@"
"@@@@@@@@"
"@@@@@@@@"
"@@@@@@@@"
"@@@@@@@@")

(RPAQ? MaxCardMove 8)

(RPAQ? WaitBetweenMoves 10)

(RPAQ? DECK )

(RPAQ? SOLORESULTS )

(ADDTOVAR IDLE.FUNCTIONS ("Solitaire" (QUOTE SOLO)))
(PUTPROPS SOLITAIRE COPYRIGHT ("Xerox Corporation" 1982 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1624 3406 (SOLO 1634 . 2699) (SOLITAIRE 2701 . 3404)) (3407 17559 (CARDIMAGE 3417 . 
4854) (COUNTCARDS 4856 . 5068) (CREATEHAND 5070 . 5525) (CREATESTACK 5527 . 6136) (DEALDECK 6138 . 
6687) (FLIPSTACK 6689 . 6909) (GETCARD 6911 . 7339) (GOODMOVE? 7341 . 7706) (HTOS? 7708 . 7867) (
MOVECARD 7869 . 8491) (DOMOVE 8493 . 9921) (MOVEHS 9923 . 10158) (MOVES 10160 . 10429) (MOVES1 10431
 . 10672) (UPCARD 10674 . 11691) (MOVESSS 11693 . 12456) (NXTCARD 12458 . 13928) (PUSHCARD 13930 . 
14484) (POSTVALUE 14486 . 15427) (SEARCHSTACKS 15429 . 15654) (SHOWCARDSTACK 15656 . 16269) (
SHUFFLEDECK 16271 . 16859) (STACKLOC 16861 . 17182) (STOS? 17184 . 17423) (TOPSUITSTACK 17425 . 17557)
) (17560 19275 (HIST 17570 . 18957) (ARRAYMAX 18959 . 19273)) (19296 20605 (SHOWCONFIG 19306 . 19716) 
(PRINTCARDSTACK 19718 . 20040) (CARDNAME 20042 . 20603)))))
STOP
