naz@hslrswi.UUCP (Norman H. Azadian) (10/02/90)
This is a card game, Solitaire to be precise, Klondike to be preciser.
I have built this mostly as a means of learning Icon. I can't claim
credit for the user interface. Some years ago I snatched a similar
(much faster) game built for PCs by Allyn Wade. I have added a few
features in my version. This one should work on any ANSI-compatible
terminal with 25 lines, but I don't have the opportunity to test that
here. It works OK on my AT clone.
I understand that in Los Vegas one can lose money with this game too.
One buys a deck of cards for $55, and then you get $5 back for each
card that you put in the Ace piles. Running my program for several
thousand games, I get an average of about 10.4 cards in the ace piles.
But the algorithm used (to date) is simplistic -- the goal for
future versions is to discover better algorithms so that I can get
rich quick in Los Vegas. :-)
I think this version basically works. There is probably a bug or two
left in Undo. Sorry, no documentation yet. I'm still trying to get
my head wrapped around this Icon concept of generators, so I'm sure
the code could be better. Bug fixes and suggestions for improvement
are welcome.
NHA
---
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
----------- cut here -------------- cut here -------------------- cut here ---
#klondike.icn 900720 NHA
#The Klondike version of Solitaire.
# Requires ANSI.SYS (or NANSI.SYS) screen driver and a 25-line display.
#
# TO FIX:
#
# - Undo is not 100%
#
#
# TO DO:
#
# - Implement an heuristic to discover optimal play strategy,
# with goal-directed evaluation and suchlike fancy stuff.
# The basic idea is to tailor find1() such that its first suggestion
# usually turns out to be the best one. Measure this by trying the
# entire tree of possibilities, recording what % of the time the
# first suggestion was actually the best one.
#
record card(suit, rank) #suit is 1..4, rank is 1..13
# constants
global suitID #suit identification chars
global isDOS # 1 when running under DOS
global monochrome # 1 when running Black&White
# Video control strings (ANSI.SYS)
global ESC
global Vnormal, Vreverse, Vblink, Vbold, VclearAll, VclearEOL
global Vred, Vblack #suit color strings
global color #list of suit color strings
# variables
global deckUp, deckDown, stackUp, stackDown #collections of card
global pile #ace piles - top rank only
global totalGames, totalAces #statistics
global debugging, automaticAce, shuffling #command-line flags
global clicking # 1 for audible feedback
global randomSeed #determinant for this game
global ops #list of all operations
# e r r o r
# Internal consistency check failed -- reveal all and die.
procedure error (x)
display ()
runerr (500, x)
end #error
# i n i t C o n s t a n t s
# Initialize the program "constants". These are actually variables that
# are set just once at the beginning of the world.
procedure initConstants ()
local i
#ensure that we are dealing with an ANSI-compatible screen
writes ("\33[6n") #request cursor position report
#NOTE that the first character to match should be an ESCape.
#Unfortunately, reads() seems to eat that character
if not match ("[", reads (&input, 8)) then
stop ("Klondike: requires ANSI.SYS screen driver")
isDOS := if find("MS-DOS", &host) then 1 else 0
if isDOS = 0 then
monochrome := 1
else {
i := ord (Peek([16r40, 16r49])) #BIOS display mode byte
case i of {
2 : monochrome := 1
3 : monochrome := 0
7 : monochrome := 1
default : stop ("Klondike: unknown display mode ", i)
}
}
ESC := "\33" #escape character
VclearAll := "\33[2J" #also homes cursor
VclearEOL := "\33[K"
Vnormal := "\33[0m"
Vbold := "\33[1m"
Vblink := "\33[5m"
Vreverse := "\33[7m"
if monochrome = 0 then {
Vred := "\33[0;47;31m" # "extra" 0 seems to be necessary
Vblack := "\33[0;47;30m"
} else {
Vred := Vnormal
Vblack := Vreverse
}
# Suits are: 1=Hearts, 2=Diamonds, 3=Clubs, 4=Spades
suitID := if isDOS ~= 0 then "\3\4\5\6" else "HDCS"
color := [Vred, Vred, Vblack, Vblack]
end #initConstants
# i n i t S c r e e n
# Initialize output and write the fixed parts of the screen.
# initConstants() must have been called earlier.
procedure initScreen ()
local i
if monochrome = 0 then writes ("\33[=3h") #25x80 color text mode
else writes ("\33[=2h") #25x80 B&W text mode
writes (VclearAll, "\33[=7l") #clear screen, prevent wrap
every i := 1 to 7 do
writeStackNumber (i, Vnormal)
every i := 2 to 25 do
writes ("\33[",i,";",64,"H\272") #vertical stripe
writes ("\33[2;64H\311\315\315\315\315SOLITAIRE\315\315\315\315")
end #initScreen
# w r i t e S t a c k N u m b e r
# Write the indicated stack number with the specified video attribute.
# Cursor position is preserved -- WARNING: THIS IS NOT NESTABLE.
procedure writeStackNumber (num, attr)
writes (ESC, "[s") #save cursor position
writeCursor (1, [2,11,20,29,38,47,56][num])
writes (attr, num, Vnormal)
writes (ESC, "[u") #restore cursor position
end #writeStackNumber
# w r i t e C u r s o r
# Position the cursor to row,col.
# Screen origin (top left corner) is row=1 and col=1.
procedure writeCursor (row, col)
writes ("\33[", row, ";", col, "H")
end #writeCursor
# w r i t e F r o n t
# Displays an image of the specified card fronts at the specified spot.
# WARNING: this eats the list that you provide -- pass a copy() if you care!!
# Top left corner of the first card will be placed at the specified position.
# Successive cards are displayed two rows higher (lower position on the screen).
# Cursor need not be in any particular position before this, and is left
# in a random position afterwards. Video is left normal (not reversed).
# Cards are 7 columns wide by 5 rows tall.
# With 25 rows, we can put 12 cards in a stack (assuming we start in row 2).
# But if there are 11 in the stack we can only display 4 rows of the top card.
# If there are 12 cards, we can only display 2 rows of the topmost card.
##We can only write a row at a time due to a problem with ANSI col 80 handling.
procedure writeFront (cardlist, row, col)
local suit, rank, card
while card := get(cardlist) do {
#first 2 rows of card
writeCursor (row+0, col);
writes (Vreverse, "\332\304\304\304\304\304\277")
writeCursor (row+1, col);
writes ("\263", color[card.suit], "A23456789TJQK"[card.rank],
suitID[card.suit], Vreverse, " \263")
if (*cardlist = 0) & (row < 24) then {
#next 2 rows of top card unless it's the 12th card on the stack
writeCursor (row+2, col);
writes (Vreverse, "\263 \263")
writeCursor (row+3, col);
writes ("\263 ", color[card.suit], "A23456789TJQK"[card.rank],
suitID[card.suit], Vreverse, "\263")
if row < 22 then {
#last row of card unless it's the 11th on the stack
writeCursor (row+4, col);
writes ("\300\304\304\304\304\304\331")
}
}
row +:= 2
}
writes (Vnormal)
end #writeFront
# w r i t e B a c k
# Puts an image of the back of a card at the specified spot on the screen.
# Except that this shows the back instead of the front of the card,
# this is identical to writeFront().
procedure writeBack (row, col)
static backLine
initial {
backLine := repl ("\260", 7)
}
writeCursor (row+0, col); writes (backLine)
writeCursor (row+1, col); writes (backLine)
writeCursor (row+2, col); writes (backLine)
writeCursor (row+3, col); writes (backLine)
writeCursor (row+4, col); writes (backLine)
end #writeBack
# w r i t e B l a n k
# Blanks a card-sized area at the specified spot on the screen.
# Except that this writes blanks instead of the back of a card,
# this is identical to writeBack().
procedure writeBlank (row, col)
static blankLine
initial {
blankLine := repl (" ", 7)
}
writeCursor (row+0, col); writes (blankLine)
writeCursor (row+1, col); writes (blankLine)
writeCursor (row+2, col); writes (blankLine)
writeCursor (row+3, col); writes (blankLine)
writeCursor (row+4, col); writes (blankLine)
end #writeBlank
# w r i t e S t a c k
# Display the specified stack. Left end is bottom of stackUp, top of stackDown.
# Stacks start in row 2, column1; with 2 columns between stacks.
# last[] holds, for each stack, the total number of visible cards
# on that stack as of the last time writeStack() was called. This allows
# us to simply draw (or erase) the cards that have been added (or subtracted).
# By special arrangement, this routine can be called with a negative stack
# number! This is a hint that our idea of what is on the display is actually
# wrong, and therefore the entire stack needs to be re-displayed. This can
# happen in two situations: 1) in refreshScreen(), the entire screen is cleared
# before calling writeStack(); 2) in undo() when undoing a move between
# stacks, the bottom card needs to be changed, although the normal algorithm
# would consider that it is already correctly displayed. Note that in neither
# case is the stack shrinking, therefore we don't need to worry about erasing
# any cards that were displayed last time.
procedure writeStack (n)
local row, col, s
static last, blankLine, firstRow, lastRow
initial {
last := [0,0,0,0,0,0,0]
blankLine := repl (" ", 7)
firstRow := [2,4,6,8,10,12,14,16,18,20,22,24] #first row of a card
lastRow := [6,8,10,12,14,16,18,20,22,24,25,25] #last row of a card
}
if n < 0 then {
n := -n
last[n] := 0 #force complete re-write
}
col := 1 + ((n -1) * 9) #leftmost column for this stack
if *stackUp[n] <= last[n] then {
#the stack just got smaller (or stayed the same)
#blank out two rows for each card that has been removed
row := lastRow[last[n]] #last row used by top card
while *stackUp[n] < last[n] do {
writeCursor (row-0, col); writes (blankLine)
writeCursor (row-1, col); writes (blankLine)
row -:= 2
last[n] -:= 1 #count and update simultaneously
}
if *stackUp[n] ~= last[n] then error (last[n])
#re-write new top card
if *stackUp[n] = 0 then
if *stackDown[n] = 0 then
writeBlank (2, col)
else
writeBack (2, col)
else
writeFront ([stackUp[n][-1]], firstRow[last[n]], col)
} else {
#the stack just got bigger -- display new cards
s := stackUp[n][last[n]-(*stackUp[n]):0]
writeFront (s, firstRow[last[n]+1], col)
last[n] := *stackUp[n] #remember how much is displayed
}
writeCursor (2, (7 + col))
writes (" 123456???"[1+*stackDown[n]]) #display the number of hidden cards
end #writeStack
# w r i t e P i l e
# Displays an image of the specified ace pile, face up (or blank if empty)
procedure writePile (n)
static pileRow, pileCol
initial {
pileRow := [3,3,9,9]
pileCol := [66,74,66,74]
}
if 0 = pile[n] then writeBlank (pileRow[n], pileCol[n])
else writeFront ([card(n,pile[n])], pileRow[n], pileCol[n])
end #writePile
# w r i t e D e c k D o w n
# Displays an image of deckDown (the face-down deck) in the proper spot.
procedure writeDeckDown ()
if 0 < *deckDown then
writeBack (21, 74)
else
writeBlank (21, 74)
writeCursor (20, 76)
writes (right(*deckDown, 2))
end #writeDeckDown
# w r i t e D e c k U p
# Displays an image of deckUp (the face-up deck) in the proper spot.
procedure writeDeckUp ()
if 0 < *deckUp then
writeFront ([deckUp[1]], 21, 66)
else
writeBlank (21, 66)
writeCursor (20, 68)
writes (right(*deckUp, 2))
end #writeDeckUp
# r e f r e s h S c r e e n
# Re-write entire screen.
procedure refreshScreen ()
local i
initScreen ()
every i := 1 to 7 do
writeStack (-i)
every i := 1 to 4 do
writePile (i)
writeDeckDown ()
writeDeckUp ()
end #refreshScreen
# w r i t e I n f o
# Displays a new short string (up to 12 printing characters) in the
# officially approved information area of the screen.
# An empty string results in clearing the area and restoring normal attributes.
procedure writeInfo (s)
writeCursor (16, 66)
writes (Vnormal, VclearEOL)
if *s ~= 0 then writes (s)
end #writeInfo
# c l i c k
# Make a quick sound to accompany card transfers
procedure click ()
local x
if (clicking ~= 0) & (isDOS ~= 0) then {
x := InPort (16r61)
OutPort (16r61, 3)
OutPort (16r61, x)
}
end #click
# g e t C m d C h a r
# Returns an upper-case command character, echoed to current cursor position.
# Fails if character wasn't "normal" and complaint was made.
# For ESC, abort information is written, and ESC is returned.
# Normal calling sequence (from within a command procedure) is thus:
# until (s := getCmdChar ())
# if s == ESC then fail
procedure getCmdChar ()
local s
s := getch () #get command character
if s == "\0" then { #non-ASCII character
getch () #discard keyboard scan code
complain ()
fail
}
s := map (s, &lcase, &ucase)
if s == ESC then
writeInfo (Vbold || "Cmd Aborted.")
else
writes (s) #echo the command character
return s
end #getCmdChar
# 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.
# onto a stack, this problem is avoided.
##This can certainly be done better...
procedure fitOnStack (c, n)
local top #top card on stack
if *stackUp[n] = 0 then {
if 0 < *stackDown[n] then stop ("fitOnStack(): 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 *stackUp[n] = 12 then fail #no room for ace
if c.rank = 1 then fail #no ace on stack
}
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.
# 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 ~= 0 then {
if 1 < *stackUp[n] then error (*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)
local i
every i := 1 to *stackUp[src] do
put (stackUp[dst], get(stackUp[src]))
put (stackUp[src], get(stackDown[src]))
writeStack (src)
writeStack (dst)
click ()
return check4ace (src)
end #moveStack
# a u t o m a t i c
# Run the game, as far as possible, untouched by human hands
procedure automatic ()
local s, thumbCount
thumbCount := 0
repeat {
if kbhit () then
return #stopped by human intervention
if pile[1] = pile[2] = pile[3] = pile[4] = 13 then
return #victory
if s := find1() then {
push (ops, move1 ("M" || s || "0"))
thumbCount := 0
} else { #no good move found -- thumb
if not (s := thumb()) then
return #no cards left to thumb through
push (ops, s)
thumbCount := if s == "T" then thumbCount + 1 else 0
if ((*deckUp + *deckDown + 2) / 3 + 1) < thumbCount then
return #end of the line
}
}
end #automatic
# c o n t i n u o u s
# Plays automatic games -- forever (or until any keystroke)
procedure continuous()
writes ("ontinuous")
repeat {
writeInfo (string(totalGames) || " " || string(totalAces))
automatic()
if kbhit() then {
if getch() == "\0" then #eat stopping char(s)
getch()
return
} else
totalAces +:= pile[1] + pile[2] + pile[3] + pile[4]
newGame()
}
end #continuous
# h e l p
# Provide information
procedure help ()
write (VclearAll, Vnormal)
write ("Klondike version 1.1 901002 NHA\t\t", &version)
write ("\n\nThe following commands are available:\n")
write ("\t^L\tre-draw screen")
write ("\tA\tAutomatic mode -- plays 1 game by itself until any key is hit")
write ("\tC\tContinuous mode -- plays games continuously until any key hit")
if debugging ~= 0 then
write ("\tD\tDebug")
write ("\tH,?\tHelp, this help screen")
write ("\tM\tMove card (or stack) from Deck/Stack to Stack/Ace pile")
write ("\tQ\tQuit this game")
write ("\tS\tSuggest (another) possible move")
write ("\tT\tThumb through the deck")
write ("\tU\tUndo -- back up one move")
write ("\tESC\tEscape -- abort current command")
write ("\n\ntotalGames = ", totalGames, " totalAces = ", totalAces)
write ("\n\nPress any key to resume game")
if getch() == "\0" then getch()
refreshScreen ()
end #help
# m o v e 1
# This is the internal move, taking a operation string. No Thumbs allowed.
# Upon success it returns the (possibly modified) operation string.
procedure move1 (op)
local src, dst, c, moved
if op[1] ~== "M" then error (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 ~= 0 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 {
op[4] := *stackUp[src] # stack -> stack: fits - do it
op ||:= moveStack (src, dst)
} else
fail # stack -> stack: doesn't fit
}
}
return op #success
end #move1
# m o v e
# Move a card from deck to stack, or from stack to ace pile,
# or move a stack to another stack.
# Fails if this is not possible
# This is the routine that interacts with the user.
procedure move ()
local src, dst, c, op, moved
writes ("ove " || Vbold);
until (src := getCmdChar ())
if src == ESC then return
if src == "D" then {
if *deckUp = 0 then fail
} else {
if not any ('1234567', src) then fail
if *stackUp[src] = 0 then fail
writeStackNumber (src, Vblink)
}
writes (Vnormal || " to " || Vbold)
until (dst := getCmdChar ())
if src ~== "D" then writeStackNumber (src, Vnormal)
if dst == ESC then return
if not any ('A1234567', dst) then fail
if dst == src then fail
return push (ops, move1("M" || src || dst || "0"))
end #move
# f i n d 1
# Find a (reasonable) possible move in this situation
procedure find1 ()
local i, j, k, c
#look at deckUp to see if the top card fits on a pile
if c := deckUp[1] then
if c.rank = (pile[c.suit] + 1) then
suspend "DA"
#look at deckUp to see if the top card fits on a stack
if c := deckUp[1] then
every i := 1 to 7 do
if fitOnStack (c, i) then
suspend "D" || string(i)
#look at each stack to see if top card can be put on ace pile
every i := 1 to 7 do
if c := stackUp[i][-1] then #top card
if c.rank = (pile[c.suit] + 1) then
suspend string(i) || "A"
#look at each stack to see if something can be (reasonably) moved
every i := 7 to 1 by -1 do
every j := 1 to 7 do
if fitOnStack (stackUp[i][1], j) then {
if (0 < *stackDown[i]) then
suspend 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 one of the following is true:
# 1) deckUp[1].rank = 13
# 2) there is a king with cards hidden beneath it
c := 0 #number of empty stacks
every k := 1 to 7 do
if *stackUp[k] = 0 then c +:= 1
if c = 0 then
if (deckUp[1].rank = 13) |
(every k := 1 to 7 do
if (stackUp[k][1].rank = 13) &
(0 < *stackDown[k]) then
break #success
)
then
suspend string(i) || string(j)
}
}
#punt
fail
end #find1
# s u g g e s t
# Suggest a (reasonable) possible move in this situation.
# Repeated invocations produce successive possibilities, until the
# only thing left to do is Thumb. After this, it cycles around to the start.
procedure suggest (another)
static suggestions, i
local s, ss
writes ("uggest")
if another = 0 then {
suggestions := [] #generate a new list of suggestions
every put (suggestions, find1())
i := 0
}
if ss := suggestions[i+:=1] then {
s := "Move " || if ss[1] == "A" then "Ace"
else if ss[1] == "D" then "Deck"
else ss[1]
s ||:= " to " || if ss[2] == "A" then "Ace" else ss[2]
writeInfo (s)
} else {
writeInfo ("Thumb")
i := 0
}
end #suggest
# t h u m b
# Move to next spot in deckDown
# Returns the operation performed (usually just "T"), or fail if none possible.
procedure thumb ()
local c, op, moved
if *deckDown = *deckUp = 0 then
return complain() #no cards left in the deck
op := "T"
if *deckDown = 0 then
while push (deckDown, pop(deckUp))
push (deckUp, get(deckDown))
push (deckUp, get(deckDown))
push (deckUp, get(deckDown))
moved := 1
writeDeckDown ()
while moved ~= 0 do {
writeDeckUp ()
click ()
moved := 0
if automaticAce ~= 0 then {
if (c := deckUp[1]).rank = 1 then {
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" : {
if (*op < 4) | ((automaticAce = 0) & (4 < *op)) then
error (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)
if 1 < *stackUp[op[2]] then error (*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
if 1 < *stackUp[op[2]] then
error (*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]
if 1 < *stackUp[op[2]] then error (*stackUp[op[2]])
push (stackDown[op[2]], pull(stackUp[op[2]]))
every 1 to op[4] do
push (stackUp[op[2]], pull(stackUp[op[3]]))
writeStack (op[3])
writeStack (-op[2])
}
}
}
"T" : {
if (automaticAce = 0) & (*op ~= 1) then error (op)
### op looks like: Txx
### where x is an optional number 1..4 of an ace pile
### There can be 0,1,2,3, or 4 of these x's.
# move cards from Ace piles to deck, starting at end
while 1 < *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
if *deckUp = 0 then
while push(deckUp, pop(deckDown))
else {
push (deckDown, pop(deckUp))
until (*deckUp % 3) = 0 do
push (deckDown, pop(deckUp))
}
writeDeckUp ()
writeDeckDown ()
}
default : stop ("Klondike: unknown operation `", op, "' in ops[]")
}
click ()
} else
writeInfo ("Stack Empty")
end #undo
# c o m p l a i n
# Let the boob know he done something wrong
procedure complain ()
local i, x
writeInfo (Vbold || "INVALID")
if isDOS ~= 0 then {
x := InPort (16r61)
every i := 1 to 22 do
OutPort (16r61, 3)
OutPort (16r61, x)
}
end #complain
# t e r m i n a t e
# Parameter should be non-zero if termination is due to complete success.
# Returns success to quit this game and start another.
# Returns failure to just continue this game.j
# If program termination is wished, that is done right here.
procedure terminate (victory)
local s, avg
if victory ~= 0 then {
writeCursor (12, 22)
writes (Vbold, "Congratulations -- You've WON !!!", Vnormal)
s := "Y"
} else {
writes ("uit? ")
until (s := getCmdChar ())
if s == ESC then fail #abort the quit command
}
if s == "Y" then {
writeInfo (Vbold || "Another game? ")
until (s := getCmdChar ())
if s == ESC then fail() #didn't really want to quit anyway
if s == "Y" then return #please start a new game
#program termination requested
writes ("\33[=7h", Vnormal) #set cursor wrap mode, normal attr
writeCursor (17, 1)
totalAces +:= pile[1] + pile[2] + pile[3] + pile[4]
if 1 < totalGames then {
avg := string (real(totalAces) / real(totalGames))
if 4 < *avg then avg := avg[1+:4]
write (VclearAll, "In ", totalGames, " games, you put ", totalAces,
" cards on the ace piles, for an average of ", avg, " per game")
} else
writes (VclearAll, "You put ", totalAces, " cards on the ace piles")
exit ()
} else
fail #oops! didn't really want to quit
end #terminate
# 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 i, c
every i := 1 to *lst do {
c := lst[i]
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.
# WARNING: this eats the list, so you might want to pass a copy().
# Intended for debugging only.
procedure card2str (ll)
local c, s
s := ""
while c := get(ll) 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
procedure str2card (s)
local cc, i
cc := []
i := 0
while put (cc, card(s[i+:=1], integer("14r"||s[i+:=1])))
return cc
end #str2card
# d e b u g
# Additional commands to support the implementer are done here.
procedure debug ()
local s, d, c, f, name
writes ("ebug ")
until (s := getCmdChar ())
case s of {
ESC : fail
"A" : {
writes ("gain")
&random := randomSeed
writeCursor (23, 1)
write (Vbold, "&random set. Quit to play this game again.",
Vnormal, VclearEOL)
}
"H"|"?" : {
writes (if s == "?" then "[help]" else "elp")
writeCursor (23, 1)
write (Vbold,
"Again, Options, Move, Peek{1-7UD}, Restore, Save, Toggle{ACDST}.",
Vnormal, VclearEOL)
}
"M" : {
writes ("ove ")
until (s := getCmdChar ()) #Source
if s == ESC then fail
if s == "A" then fail
until (d := getCmdChar ()) #Destination
if d == ESC then fail
if d == s then fail
if not any('1234567', d) then fail
if s == "D" then {
if *deckUp = 0 then fail
put (stackUp[d], get(deckUp))
writeDeckUp ()
writeStack (d)
push (ops, "MD" || d || "0")
} else {
moveStack (s, d)
push (ops, "M" || s || d || "0")
}
}
"O" : {
writes ("ptions")
writeCursor (23, 1)
write (Vbold,
"automaticAce=", automaticAce, " shuffling=", shuffling,
" random seed=", randomSeed, " clicking=", clicking, ".",
Vnormal, VclearEOL)
}
"P" : {
writes ("eek ")
until (s := getCmdChar ())
if s == ESC then fail
writeCursor (23, 1)
writes (VclearEOL, Vnormal)
if any('1234567', s) then
showList (stackDown[s])
else if s == "D" then
showList (deckDown)
else if s == "U" then
showList (deckUp)
else
complain ()
}
"R" : {
writes ("estore")
until (s := getCmdChar ())
if s == ESC then fail
name := "klondike.sv" || s
writeCursor (23, 1)
if not (f := open (name, "r")) then
write (Vbold, "Can't read file ", name, ".",
Vnormal, VclearEOL)
else {
write (Vbold, "Restoring position from file ", name,
Vnormal, VclearEOL)
automaticAce := read (f, automaticAce)
clicking := read (f)
randomSeed := read (f)
shuffling := read (f)
&random := read (f)
totalGames := read (f)
totalAces := read (f)
every c := 1 to 4 do
pile[c] := read (f)
every c := 1 to 7 do {
stackUp[c] := str2card (read(f))
stackDown[c] := str2card (read(f))
}
deckUp := str2card (read(f))
deckDown := str2card (read(f))
ops := []
while push (ops, read (f))
close (f) | stop ("Klondike: close failed")
refreshScreen()
}
}
"S" : {
writes ("ave ")
until (s := getCmdChar ())
if s == ESC then fail
name := "klondike.sv" || s
writeCursor (23, 1)
if not (f := open (name, "c")) then
write (Vbold, "Can't create file ", name, ".",
Vnormal, VclearEOL)
else {
write (f, automaticAce)
write (f, clicking)
write (f, randomSeed)
write (f, shuffling)
write (f, &random)
write (f, totalGames)
write (f, totalAces)
every c := 1 to 4 do
write (f, pile[c])
every c := 1 to 7 do {
write (f, card2str(copy(stackUp[c])))
write (f, card2str(copy(stackDown[c])))
}
write (f, card2str(copy(deckUp)))
write (f, card2str(copy(deckDown)))
while write (f, pull(ops))
close (f) | stop ("Klondike: close failed")
write (Vbold, "Position saved in file ",name,
Vnormal, VclearEOL)
}
}
"T" : {
writes ("oggle ")
until (s := getCmdChar ())
if s == ESC then fail
case s of {
"A" : automaticAce:= if automaticAce=0 then 1 else 0
"C" : clicking := if clicking = 0 then 1 else 0
"D" : debugging := if debugging = 0 then 1 else 0
"S" : shuffling := if shuffling = 0 then 1 else 0
"T" : &trace := if &trace = 0 then -1 else 0
default : complain ()
} #case for Toggle
}
default : complain ()
} #case for Debug command
end #debug
# n e w G a m e
# Set up all the global variables for a new game
procedure newGame ()
local i, j, s
totalGames +:= 1
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
if shuffling ~= 0 then {
writeInfo (Vblink || "Shuffling")
every 1 to 100 do
?deckDown :=: ?deckDown
writeInfo ("")
}
every i := 1 to 7 do {
stackDown[i] := []
stackUp[i] := []
}
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)
}
writeDeckDown()
every i := 1 to 7 do
if *(s := check4ace (i)) ~= 0 then
push (ops, "M" || string(i) || "A" || string(integer(s) + 4))
end #newGame
# m a i n
procedure main (av)
local s, prevsCmd
initConstants()
#deal with command-line parameters
debugging := 0 # default is no debugging allowed
clicking := 1 # audible feedback sometimes helps
automaticAce := 1 # default is automatic ace handling
shuffling := 1 # default is shuffle the deck
&random := map (&clock, ":", "0") # default is randomize the seed
while s := get (av) do
case map (s, &lcase, &ucase) of {
"-A" : automaticAce := 0 #disable automatic ace handling
"-C" : clicking := 0 #run silent
"-D" : debugging := 1 #grant all sorts of perqs
"-R" : &random := get (av) #unrandomize
"-S" : shuffling := 0 #don't shuffle the deck
default : { write ("klondike [-ACDS] [-R randomSeed]")
stop("klondike: bogus option ", s) }
}
randomSeed := &random #remember for debug()
totalGames := 0 #games played
totalAces := 0 #cards put on ace piles
repeat { #game loop
newGame()
prevsCmd := "x" #anything but "S"uggest
#respond to user input
repeat { #command loop
writeCursor (18, 66)
writes (VclearEOL || Vnormal || "> ") #clear command line
if pile[1] = pile[2] = pile[3] = pile[4] = 13 then
if terminate (1) then break # VICTORY!
s := getCmdChar ()
writeInfo ("") #clear info line
writeCursor (18, 69)
case s of {
"?" : help()
"A" : {
writes ("utomatic")
automatic() #look Ma, no hands!
if kbhit() then
if getch() == "\0" then getch()
}
"C" : continuous() #no hands, forever
"D" : if debugging = 0 then complain() else debug()
"H" : help()
"M" : if not move() then complain()
"Q" : if terminate(0) then break #new game
"S" : suggest (if s == prevsCmd then 1 else 0)
"T" : { writes ("humb"); push (ops, thumb()) }
"U" : undo()
"\14" : refreshScreen () #^L
ESC : s #do nothing
default : complain ()
} #case
prevsCmd := s
} #repeat command
totalAces +:= pile[1] + pile[2] + pile[3] + pile[4]
} #repeat game
end #main
--
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