naz@hslrswi.hasler.ascom.ch (Norman H. Azadian) (04/21/91)
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# klonsub.icn
# This archive created: Sun Apr 21 15:04:30 1991
# By: Norman H. Azadian (Hasler AG)
export PATH; PATH=/bin:$PATH
echo shar: extracting "'klonsub.icn'" '(14804 characters)'
if test -f 'klonsub.icn'
then
echo shar: will not over-write existing file "'klonsub.icn'"
else
cat << \SHAR_EOF > 'klonsub.icn'
#klonsub.icn 901029 NHA
#some 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[])
writeCursor (1, 20)
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)
if *stackUp[n] = 0 then {
dieIf (*stackDown[n] ~= 0, "Up empty, Down not")
(c.rank = 13) | fail #only a king can go to empty stack
} else {
(c.rank = (stackUp[n][-1].rank - 1)) | fail #top wrong rank
(color[c.suit] == color[stackUp[n][-1].suit]) & fail #top same color
(c.rank = 1) & fail #no aces on stak
dieIf (*stackUp[n] >= 12, "stack too big")
}
return #success
end #fitOnStack
# s u g g e s t
# Suggest a(nother) possible (useful) move in this situation.
# Suspends with an operation string for the suggested move.
# Fails if there is none and you should Thumb.
# This internal routine is currently the heart and soul of all program play.
procedure suggest ()
local i, j, k
# look at deckUp to see if the top card fits on an ace pile
(deckUp[1].rank = (pile[deckUp[1].suit] + 1)) & suspend "MDA"
# look at deckUp to see if the top card fits on a stack
every (fitOnStack (deckUp[1], i := 1 to 7)) do suspend "MD" || string(i)
# look at each stack to see if top card can be put on an ace pile
every (stackUp[i := 1 to 7][-1].rank = pile[stackUp[i][-1].suit] + 1) do
suspend "M" || string(i) || "A"
# look at each stack to see if one can be (usefully) moved to another
every fitOnStack (stackUp[i := 7 to 1 by -1][1], j := 1 to 7) do
if 0 < *stackDown[i] then
suspend "M" || string(i) || string(j)
else
# possibility, but since there are no cards hidden under
# this pile, we reject it UNLESS there are no empty slots
# AND at least one of the following is true:
# (1) deckUp[1].rank = 13
# (2) there is a king with cards hidden beneath it
if not (*stackUp[1 to 7] = 0) then
if deckUp[1].rank = 13 then
suspend "M" || string(i) || string(j) #(1)
else
# only suspend once, no matter how many kings there are
if ( (stackUp[k := 1 to 7][1].rank = 13) &
(0 < *stackDown[k]) ) then
suspend "M" || string(i) || string(j) #(2)
# punt (Thumb)
fail
end #suggest
# 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 stackUp[n][1].rank = 1 do {
op ||:= (c := pop (stackUp[n])).suit #remove ace from the stack
writeStack (n)
pile[c.suit] := 1 #move to ace pile
writePile (c.suit)
click ()
if push (stackUp[n], get(stackDown[n])) then { #turn over card
writeStack (n)
click ()
}
}
}
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)
# move up cards from src stack to dst stack
while put (stackUp[dst], get(stackUp[src]))
writeStack (src)
writeStack (dst)
click ()
# turn over new card (if any) on src stack
put (stackUp[src], get(stackDown[src])) | return "" #empty stackDown
writeStack (src)
click ()
return check4ace (src)
end #moveStack
# m o v e 1
# This is the internal move, taking an operation string. No Thumbs allowed.
# Upon success it returns the (possibly modified) operation string.
# There's some redundant code here, but it makes the action look better
# (at least on slow machines).
procedure move1 (op)
local src, dst, c
dieIf ((op[1] ~== "M"), op)
src := op[2]
dst := op[3]
if src == "D" then { # Deck -> somewhere
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
pop (deckUp)
writeDeckUp ()
pile[c.suit] +:= 1
writePile (c.suit)
} else {
fail # Deck -> Ace: doesn't fit
}
} else { # Deck -> stack
if fitOnStack (c, dst) then {
pop (deckUp) # Deck -> stack: fits - do it
writeDeckUp ()
put (stackUp[dst], c)
writeStack (dst)
} else {
fail # Deck -> stack: doesn't fit
}
}
click ()
if \automaticAce then {
while deckUp[1].rank = 1 do {
op ||:= (c := pop(deckUp)).suit
writeDeckUp ()
pile[c.suit] := 1
writePile (c.suit)
click ()
}
}
} else { # stack -> somewhere
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
pull (stackUp[src])
writeStack (src)
pile[c.suit] +:= 1
writePile (c.suit)
click ()
if 0 = *stackUp[src] then {
op[4] +:= 4 #mark this case for undo()
put (stackUp[src], get(stackDown[src])) #turn over a card
writeStack (src)
if 0 < *stackUp[src] then {
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 #move1
# 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
((*deckDown) = (*deckUp) = 0) & (complain(), fail) #no cards left
if 0 = *deckDown then { #no cards left in hand
while push (deckDown, pop(deckUp)) #pick up (and turn) the face-up deck
writeDeckUp () #show the (empty) deck on table
writeDeckDown () #show the face-down deck [in hand]
click ()
}
op := ( "T" || ((*deckDown >= 3) | *deckDown) )
every | push (deckUp, pop(deckDown)) \ 3
writeDeckDown ()
writeDeckUp ()
click ()
if \automaticAce then {
while deckUp[1].rank = 1 do {
op ||:= (c := pop (deckUp)).suit
writeDeckUp ()
pile[c.suit] := 1
writePile (c.suit)
click ()
}
}
return op
end #thumb
# u n d o
# Backup one move, including any automatic ace moves
# This is the internal routine.
procedure undo ()
local op, suit
if op := pop (ops) then {
writeInfo (expandOp(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 is only occasionally used
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]], op)
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]
if 4 < (suit := op[4]) then {
suit -:= 4 #ace pile card was last on stack
dieIf (1 < *stackUp[op[2]], op)
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]], op)
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)
## 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 (0 = *deckUp)
every 1 to op[2] do
push (deckDown, pop(deckUp))
if 0 = *deckUp then
while push (deckUp, pop(deckDown))
writeDeckUp ()
writeDeckDown ()
}
default : runerr (500, op)
}
click ()
} else {
## Admittedly this is a bit of a kluge, but better than nothing ?
(0 = *deckDown) & while push (deckDown, pop(deckUp))
writeDeckUp ()
writeDeckDown ()
complain ("At Beginning")
}
return
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
output (color[c.suit], rankID[c.rank], suitID[c.suit], Vnormal, " ")
return
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
(s[i:=1] == "$") | 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.
# Obviously the ordering here must exactly match that in restoreState().
procedure saveState (filename)
local f, i
(f := open ((directory || filename), "c")) | fail
write (f, &dateline)
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, totalWins)
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 !!
# Obviously the ordering here must exactly match that in saveState().
procedure restoreState (filename)
local f, date
(f := open ((directory || filename), "r")) | fail
(25 < *(date := read(f))) | fail
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)
totalWins := read (f)
totalAces := read (f)
ops := []
while push (ops, read (f))
dieIf (not close (f), f)
return date
end #restoreState
# i n i t V a r i a b l e s
# Initialize the various lists so that everyone can reference them.
procedure initVariables ()
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 put (deckDown, card(1 to 4, 1 to 13)) #take cards out of the box
return
end #initVariables
# 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 ()
initVariables () #reset everything to ground zero
writeInfo (Vblink || "Shuffling")
seed := &random
every | (?deckDown :=: ?deckDown) \ 123
writeInfo ("")
every !stackUp := []
every !stackDown := []
every push(stackUp[i := 1 to 7], get(deckDown)) do {
writeStack (-i)
click ()
every push (stackDown[j := i+1 to 7], get(deckDown)) do {
writeStack (-j)
click ()
}
### writeStack (-i) ### this could replace 2 calls above
}
writeDeckDown(1)
#handle any Aces which are showing
every *(s := check4ace (i := 1 to 7)) ~= 0 do
push (ops, "M" || string(i) || "A" || string(integer(s) + 4))
return seed
end #newGame
# e x p a n d O p
# Given an operation string, return an expanded human-readable equivalent.
procedure expandOp (op)
static opChars
local s
initial {
opChars := table("oops!")
opChars["A"] := Vbold || "A" || Vnormal || "ce"
opChars["D"] := Vbold || "D" || Vnormal || "eck"
every opChars[s := !"1234567"] := Vbold || s || Vnormal
}
# This slightly more efficient scheme assumes op[1] is 1st char of result
return (Vbold || op[1] || Vnormal ||
case op[1] of {
"M" : ( "ove " || opChars[op[2]] || " to " || opChars[op[3]] )
"Q" : "uit"
"T" : "humb"
default : runerr (500, op)
})
end #expandOp
SHAR_EOF
if test 14804 -ne "`wc -c < 'klonsub.icn'`"
then
echo shar: error transmitting "'klonsub.icn'" '(should have been 14804 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0
--
PAPER: Norman Azadian; Ascom AG; Belpstrasse 23; 3000 Berne 14; Switzerland
INTERNET: naz%hslrswi.uucp@uunet.uu.net
UUCP: ...{uunet,ukc,mcvax,...}!chx400!hslrswi!naz
VOICE: +41 31 63 2178 BITNET: naz%hslrswi.UUCP@cernvax.BITNET