naz@hslrswi.UUCP (Norman H. Azadian) (12/06/90)
#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