Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!sdd.hp.com!wuarchive!mit-eddie!bloom-beacon!eru!hagbard!sunic!mcsun!cernvax!chx400!hslrswi!naz
From: naz@hslrswi.UUCP (Norman H. Azadian)
Newsgroups: comp.lang.icon
Subject: klondike, version 1.41.  part 4/4
Message-ID: <1690@hslrswi.UUCP>
Date: 6 Dec 90 12:44:22 GMT
Organization: Hasler AG
Lines: 446


#klonsub.icn	901029	NHA
#subroutines for Klondike


#	d i e I f
# If the first argument succeeds, then write out the remaining args & die.
# Note that the remaining arguments must succeed.
procedure dieIf (failed, writeArgs[])
	every writes (&output, !writeArgs)
	write (&output)
	display ()
	every writes (&errout, !writeArgs)
	write (&errout)
	runerr (500)
end											#dieIf


#	f i t O n S t a c k
# Given a card and a stack number, fail unless card can be added to the stack.
# Note that we disallow putting an Ace on a stack, period.  This prevents
# ever building a stack with 13 cards, which we can't display in 25 rows.
procedure fitOnStack (c, n)
local top													#top card on stack
	if *stackUp[n] = 0  then  {
		dieIf (*stackDown[n] ~= 0, "Up empty, Down not")
		if c.rank ~= 13  then  fail			#only a king can go to empty stack
	} else {
		top := stackUp[n][-1]				#copy of top card
		if (c.rank ~= (top.rank - 1))  then  fail			#wrong rank
		if (c.suit < 3)  &  (top.suit < 3)  then  fail		#same color
		if (c.suit > 2)  &  (top.suit > 2)  then  fail		#same color
		if c.rank = 1  then  fail							#no ace on stack
		dieIf (*stackUp[n] >= 12, "stack too big")
	}
	return									#success
end											#fitOnStack


#	c h e c k 4 a c e
# Only has an effect when global automaticAce is set!
# Given a stack number, check for an ace as the top of stackUp[n].
# If present, move it over to it's ace pile, turn over the next card
# from stackDown, and check again.
# Must not be more than one up card in stack.
# Returns a string of the operations performed.
procedure check4ace (n)
local c, op
	op := ""
	if \automaticAce  then  {
		dieIf (1 < *stackUp[n])
		while 0 < *stackUp[n]  do  {
			c := stackUp[n][1]					#copy of (top = bottom) up card
			if c.rank = 1  then  {				#it's an ace!
				pop (stackUp[n])				#remove it from the stack
				pile[c.suit] := 1				#move to ace pile
				op ||:= c.suit
				push (stackUp[n], get(stackDown[n])) #turn over card underneath
				writeStack (n)
				writePile (c.suit)
				click ()
			} else
				break							#not an ace
		}
	}
	return op
end											#check4ace


#	m o v e S t a c k
# Move a stack to another stack, no questions asked.
# Updates video and audio.
# Returns any automatic ace operations that were done as a consequence.
##It would be nice to do this in a visually and audibly more satisfying way
procedure moveStack (src, dst)
	while put (stackUp[dst], get(stackUp[src]))
	put (stackUp[src], get(stackDown[src]))
	writeStack (src)
	writeStack (dst)
	click ()
	return  check4ace (src)
end											#moveStack


#	m o v e
# This is the internal move, taking a operation string.  No Thumbs allowed.
# Upon success it returns the (possibly modified) operation string.
procedure move (op)
local src, dst, c, moved
	dieIf (op[1] ~== "M", "op is ", op)
	src := op[2]
	dst := op[3]
	moved := 0
	if src == "D"  then  {
		c := deckUp[1]
		if dst == "A"  then  {				# Deck -> Ace
			if c.rank = (pile[c.suit] + 1)  then  {
				op[4] := c.suit				# Deck -> Ace:  fits - do it
				pile[c.suit] +:= 1
				writePile (c.suit)
				moved := 1
			} else
				fail						# Deck -> Ace:  doesn't fit
		} else  {							# Deck -> stack
			if fitOnStack (c, dst)  then {
				put (stackUp[dst], c)		# Deck -> stack:  fits - do it
				writeStack (dst)
				moved := 1
			} else
				fail						# Deck -> stack: doesn't fit
		}
		while moved ~= 0  do  {
			pop (deckUp)
			writeDeckUp ()					# Deck -> somewhere, with success
			click ()
			moved := 0
			if \automaticAce  then  {
				if (c := deckUp[1]).rank = 1  then  {	#automatic Ace handling
					pile[c.suit] := 1
					op ||:= c.suit
					writePile (c.suit)
					moved := 1
				}
			}
		}
	} else {
		if dst == "A"  then  {				# stack -> Ace
			c := stackUp[src][-1]			#copy of card on top of stack
			if c.rank = (pile[c.suit] + 1)  then  {
				op[4] := c.suit				# stack -> Ace:  fits - do it
				pile[c.suit] +:= 1
				pull (stackUp[src])
				writeStack (src)
				click ()
				writePile (c.suit)
				if *stackUp[src] = 0  then  {
					op[4] +:= 4				#mark this case for undo()
					put (stackUp[src], get(stackDown[src]))	#turn over a card
					writeStack (src)
					click ()
					op ||:= check4ace (src)
				}
			} else {
				fail						# stack -> Ace:  doesn't fit
			}
		} else {							# stack -> stack
			if fitOnStack (stackUp[src][1], dst)  then  {
											# stack -> stack:  fits - do it
				op[4] := "123456789abcdef"[*stackUp[src]]
				op ||:= moveStack (src, dst)
			} else
				fail						# stack -> stack:  doesn't fit
		}
	}
	return  op								#success
end											#move


#	t h u m b
# Move to next spot in deckDown
# Returns the operation performed (usually just "T3"), or fail if none possible.
procedure thumb ()
local c, op, moved
	if *deckDown = *deckUp = 0  then
		return complain()						#no cards left in the deck
	if *deckDown = 0  then
		while push (deckDown, pop(deckUp))
	op :=  "T"  ||  if *deckDown < 3  then  *deckDown  else  3
	push (deckUp, pop(deckDown))
	push (deckUp, pop(deckDown))
	push (deckUp, pop(deckDown))
	writeDeckDown ()
	moved := 1
	while moved ~= 0  do  {
		writeDeckUp ()
		click ()
		moved := 0
		if \automaticAce  then  {
			if deckUp[1].rank = 1  then  {
				c := pop (deckUp)
				pile[c.suit] := 1
				op ||:= c.suit
				writePile (c.suit)
				moved := 1
			}
		}
	}
	return op
end											#thumb


#	u n d o
# backup one move, including any automatic ace moves
procedure undo ()
local op, suit
	writes ("ndo")
	if op := pop (ops)  then  {
		writeInfo (op)
		# op looks like:  Msdixxx
		# where x is an [optional] number 1..4 of an ace pile
		# and s is either a stack number or "D"
		# and d is either "A" or a number 1..7 of a stack
		# and i is an extra piece of info which may be valid
		case op[1]  of   {
		"M"		:	{
					dieIf ((*op < 4) | ((/automaticAce) & (4 < *op)), op)
					if op[2] == "D"  then  {
						#Move cards from Ace piles to deck, starting at end
						while 4 < *op  do  {
							suit := op[-1]
							pile[suit] := 0
							writePile (suit)
							push (deckUp, card(suit,1))
							writeDeckUp ()
							click ()
							op[-1] := ""
						}
						if op[3] == "A"  then  {
							# unMove Deck to Ace op[4]
							suit := op[4]
							push (deckUp, card(suit,pile[suit]))
							pile[suit] -:= 1
							writePile (suit)
						} else {
							# unMove Deck to stack op[3]
							push (deckUp, pull(stackUp[op[3]]))
							writeStack (op[3])
						}
						writeDeckUp ()
					} else {
						#Move cards from Ace piles to stack, starting at end
						while 4 < *op  do  {
							suit := op[-1]
							pile[suit] := 0
							writePile (suit)
							dieIf (1 < *stackUp[op[2]])
							push (stackDown[op[2]], pull(stackUp[op[2]]))
							push (stackUp[op[2]], card(suit,1))
							writeStack (op[2])
							click ()
							op[-1] := ""
						}
						if op[3] == "A"  then  {
							# unMove stack op[2] to Ace pile op[4]
							suit := op[4]
							if 4 < suit  then  {
								suit -:= 4		#ace pile card was last on stack
								dieIf (1 < *stackUp[op[2]])
								push (stackDown[op[2]], pull(stackUp[op[2]]))
							}
							put (stackUp[op[2]], card(suit,pile[suit]))
							pile[suit] -:= 1
							writePile (suit)
							writeStack (op[2])
						} else {
							# unMove top op[4] cards on stack op[2]
							# to stack op[3]
							dieIf (1 < *stackUp[op[2]])
							push (stackDown[op[2]], pull(stackUp[op[2]]))
							every 1 to ("16r" || op[4])  do
								push (stackUp[op[2]], pull(stackUp[op[3]]))
							writeStack (op[3])
							writeStack (-op[2])
						}
					}
				}
		"T"		:	{
					dieIf ((/automaticAce) & (*op ~= 2))
					### op looks like:  Tcxx
					### where c is the number of cards thumbed (usually 3)
					### and x is an optional number 1..4 of an ace pile
					### There can be 0,1,2, or 3 of these x's.
					# move cards from Ace piles to deck, starting at end
					while 2 < *op  do  {
						suit := op[-1]
						pile[suit] := 0
						writePile (suit)
						push (deckUp, card(suit,1))
						writeDeckUp ()
						click ()
						op[-1] := ""
					}
					# then undo the Thumb operation itself
					dieIf (*deckUp = 0)
					every 1 to op[2]  do
						push (deckDown, pop(deckUp))
					if *deckUp = 0  then
						while push (deckUp, pop(deckDown))
					writeDeckUp ()
					writeDeckDown ()
				}
		default	:	stop ("Klondike: unknown operation `", op, "' in ops[]")
		}
		click ()
	} else {
		## Admittedly this is a bit of a kluge, but better than nothing ?
		if *deckDown = 0  then
			while push (deckDown, pop(deckUp))
		writeDeckUp ()
		writeDeckDown ()
		writeInfo ("Stack Empty")
	}

end											#undo


#	s h o w L i s t
# Display a list of cards at the current cursor position.
# Intended for debugging only .
procedure showList (lst)
local c
	every c := !lst  do
		writes (color[c.suit], "A23456789TJQK"[c.rank], suitID[c.suit],
				Vnormal, " ");
end											#showList


#	c a r d 2 s t r
# Given a list of card records, returns a string representation.
# Even an empty list results in a non-zero string length.
procedure card2str (lst)
local c, s
	s := "$"
	every c := !lst  do
		s ||:= string(c.suit) || "123456789abcd"[c.rank]
	return s
end											#card2str


#	s t r 2 c a r d
# Given a string [as generated by card2str()],
# return corresponding list of card records.
# Fails if the string is invalid.
procedure str2card (s)
local cc, i
	if s[i:=1] ~== "$"  then  fail
	cc := []
	while put (cc, card(s[i+:=1], integer("14r"||s[i+:=1])))
	return cc
end											#str2card


#	s a v e S t a t e
# Saves the current state in the named file, which is created/overwritten
# as necessary.
# Fails if the state was not successfully saved.
procedure saveState (filename)
local f, i
	(f := open (filename, "c"))  |  fail
	write (f, &dateline)
	write (f, if \automaticAce then 1 else 0)
	write (f, if \clicking     then 1 else 0)
	write (f, firstSeed)
	write (f, lastSeed)
	write (f, &random)
	every write (f, !pile)
	every write (f, card2str(!stackUp))
	every write (f, card2str(!stackDown))
	write (f, card2str(deckUp))
	write (f, card2str(deckDown))
	write (f, totalGames)
	write (f, totalAces)
	every write (f, !ops)
	return close (f)
end											#saveState


#	r e s t o r e S t a t e
# Restore game from the named file.
# Fails if the file isn't there, isn't readable, or isn't correct format.
# Otherwise returns date the file was last written.
# Note that we do not update the screen here !!
procedure restoreState (filename)
local f, date
	if not (f := open (filename, "r"))  then  fail
	if (not (date := read(f)))  |  (*date = 0)  then  fail
	automaticAce := if read (f) == "0"  then  &null  else  1
	clicking     := if read (f) == "0"  then  &null  else  1
	firstSeed    := read (f)
	lastSeed     := read (f)
	&random      := read (f)
	every ((!pile) := read(f))
	every ((!stackUp)   := str2card (read(f)))
	every ((!stackDown) := str2card (read(f)))
	deckUp   := str2card (read(f))
	deckDown := str2card (read(f))
	totalGames	:= read (f)
	totalAces	:= read (f)
	ops := []
	while push (ops, read (f))
	dieIf (not close (f), "can't close")
	return date
end											#restoreState


#	n e w G a m e
# Set up all the global variables for a new game.
# Returns the seed used to generate this game.
procedure newGame ()
local i, j, s, seed
	initScreen ()

	#initialize deck, stacks, piles
	ops       := []							#no operations done yet
	deckUp    := []							#deck in hand, face-up
	deckDown  := []							#deck in hand, face-down
	stackUp   := list(7, 0)					#columns on table, face up
	stackDown := list(7, 0)					#columns on table, face down
	pile      := list(4, 0)					#aces - only top rank stored
	every  i := 1 to 4  do
		every  j := 1 to 13  do
			put (deckDown, card(i, j))		#take cards out of the box

	seed := &random
	if not \invisible  then					#Vblink not defined in Batch mode
		writeInfo (Vblink || "Shuffling")
	every 1 to 100 do
		?deckDown :=: ?deckDown
	writeInfo ("")

	every !stackUp   := []
	every !stackDown := []
	every  i := 1 to 7  do  {
		push (stackUp[i], get(deckDown))
		writeStack (-i)
		click ()
		every  j := (i+1) to 7  do  {
			push (stackDown[j], get(deckDown))
			writeStack (-j)
			click ()
		}
###		writeStack (-i)						### this replaces 2 calls above
	}
	writeDeckDown()

	#handle any Aces which are showing
	every  i := 1 to 7  do
		if *(s := check4ace (i)) ~= 0  then
			push (ops, "M" || string(i) || "A" || string(integer(s) + 4))
	return seed
end											#newGame
-- 
PAPER:  Norman Azadian; Ascom AG; Belpstrasse 23; 3000 Berne 14; Switzerland
X.400:  naz@hslrswi.hasler
UUCP:   ...{uunet,ukc,mcvax,...}!cernvax!hslrswi!naz
VOICE:  +41 31 63 2178            BITNET: naz%hslrswi.UUCP@cernvax.BITNET


Brought to you by Super Global Mega Corp .com