naz@hslrswi.UUCP (Norman H. Azadian) (12/06/90)
#klondike.icn 900720 NHA
#The Klondike version of Solitaire.
# Requires ANSI.SYS (or NANSI.SYS) screen driver and a 25-line display.
#
# TO FIX:
#
#
#
# TO DO:
#
# - Use space to step to next non-thumb move, and enter to do it ???
# - Implement an heuristic to discover optimal play strategy.
#
link kloncon #console I/O
link klonsub #general subroutines
record card(suit, rank) #suit is 1..4, rank is 1..13
# variables
global deckUp, deckDown, stackUp, stackDown #collections of card
global pile #ace piles - top rank only
global ops #list of all operations done
global debugging, automaticAce #command-line flags
global invisible, clicking #visual, audible feedback
global firstSeed, lastSeed #&random remembered
global totalGames, totalAces #ace pile statistics
# a u t o m a t i c 1
# Do 1 move, thumbing as necessary to achieve it.
# Fails if there is nothing useful left to do.
# This is an internal routine that doesn't worry at all about the user.
procedure automatic1 ()
local s, thumbCount
thumbCount := 0
while thumbCount <= ((*deckUp + *deckDown + 2) / 3) do {
if s := suggest() then {
push (ops, move ("M" || s || "0"))
thumbCount := 0
return;
} else { #no good move found -- thumb
if (*deckUp = 0) & (*deckDown = 0) then
fail #no cards left to thumb through
push (ops, s := thumb())
if 2 < *s then
return #must have turned up an Ace
thumbCount +:= 1
}
}
end #automatic1
# a u t o m a t i c
# Run the game, as far as possible, untouched by human hands
# This is an internal routine that only worries a little about the user.
# Returns when either there is nothing useful left to do or a key is struck.
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
automatic1 () | return
}
end #automatic
# u a u t o m a t i c
# Play this hand automatically, untouched by human hands.
# This is the fuction that interacts with the user.
procedure uautomatic ()
writes ("utomatic")
automatic()
if kbhit() then
if getch() == "\0" then getch()
end #uautomatic
# u c o n t i n u o u s
# Plays automatic games -- forever (or until any keystroke)
procedure ucontinuous()
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]
totalGames +:= 1
lastSeed := newGame()
}
end #ucontinuous
# u h e l p
# Provide command summary for user, plus statistics to date, if any.
procedure uhelp ()
write (VclearAll, Vnormal)
write ("Klondike version 1.41 901126 NHA\t\t", &version)
write ("\n\nThe following commands are available:\n")
write ("\t", Vbold, "^L\tre-draw", Vnormal, " screen")
write ("\t", Vbold, "A\tAutomatic", Vnormal, " mode -- plays 1 game by itself until any key is hit")
write ("\t", Vbold, "B\tBoss", Vnormal, " key for when you-know-who visits")
write ("\t", Vbold, "C\tContinuous", Vnormal, " mode -- plays games continuously until any key hit")
write ("\t", Vbold, "H,?\tHelp", Vnormal, ", this help screen")
write ("\t", Vbold, "M\tMove", Vnormal, " card (or stack) from Deck/Stack to Stack/Ace pile")
write ("\t", Vbold, "Q\tQuit", Vnormal, " this game")
write ("\t", Vbold, "S\tSuggest", Vnormal, " (another) possible move")
write ("\t", Vbold, "T\tThumb", Vnormal, " through the deck")
write ("\t", Vbold, "U\tUndo", Vnormal, " -- back up one move")
if \debugging then
write ("\t", Vbold, "Z\tDebug", Vnormal)
write ("\t", Vbold, "ESC\tEscape", Vnormal, " -- abort current command")
if totalGames ~= 0 then
write ("\n\ntotalGames = ", totalGames, " totalAces = ", totalAces,
" average = ", real(totalAces) / real(totalGames))
write ("\n\n", Vblink, "Press any key to resume game", Vnormal)
if getch() == "\0" then getch()
refreshScreen ()
end #uhelp
# u m o v e
# Move a card from deck to stack, or from stack to ace pile,
# or move a stack to another stack.
# Parameter is the source [1-7 or D] or &null to indicate that "M" was used
# and therefore source should be gathered from the keyboard.
# Fails if indicated move is not possible
# This is the routine that interacts with the user.
procedure umove (src)
local dst, c, op, moved
if \src then
writes ("\bMove ", Vbold, src)
else {
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, move("M" || src || dst || "0"))
end #umove
# s u g g e s t
# Find a (reasonable) possible move in this situation
# This is the internal routine.
procedure suggest ()
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 #suggest
# u 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 usuggest (another)
static suggestions, i
local s, ss
writes ("uggest")
if another = 0 then {
suggestions := [] #generate a new list of suggestions
every put (suggestions, suggest())
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 #usuggest
# u 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.
# If program termination is wished, that is done right here.
procedure uterminate (victory)
local s
if \victory then {
totalAces +:= 52
pile[1] := pile[2] := pile[3] := pile[4] := 0 #prevent victory loops
writeCursor (12, 22)
writes (Vbold, Vblink, "Congratulations -- You've WON !!!", Vnormal)
} else
writes ("uit")
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
if s ~== "N" then return complain ()
#program termination requested
writes ("\33[=7h", Vnormal) #set cursor wrap mode, normal attr
totalGames +:= 1
if /victory then
totalAces +:= pile[1] + pile[2] + pile[3] + pile[4]
write (VclearAll, "In ", totalGames, " games, you put ", totalAces,
" cards on the ace piles")
write ("average = ", real(totalAces) / real(totalGames), " per game")
exit ()
end #uterminate
# u d e b u g
# Additional commands to support the implementer.
procedure udebug ()
local s, d, c, name
if not \debugging then return complain()
writes ("\bDebug ")
until (s := getCmdChar ())
case s of {
ESC : fail
"A" : {
writes ("gain")
&random := lastSeed
writeCursor (23, 1)
write (Vbold, "&random set. Quit to play this game again.",
Vnormal, VclearEOL)
}
"D" : display()
"H"|"?" : {
writes (if s == "?" then "\bhelp" else "elp")
writeCursor (23, 1)
write (Vbold,
"Again, Dump, Options, Move, Peek{1-7UD}, Restore, Save, Toggle{ACT}.",
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 {
c := "123456789abcdef"[*stackUp[s]]
moveStack (s, d)
push (ops, "M" || s || d || c)
}
}
"O" : {
writes ("ptions")
writeCursor (23, 1)
write (Vbold,
if \automaticAce then "AutomaticAce " else " ",
if \clicking then "Clicking " else " ",
" &trace=", &trace,
" seeds=", firstSeed, ",", lastSeed, 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
if (d := restoreState(name)) then {
refreshScreen()
writeCursor (23, 1)
write (Vbold, "Restored position from file ", name,
" of ", d, Vnormal, VclearEOL)
} else {
writeCursor (23, 1)
write (Vblink, "Can't restore from file ", name, ".",
Vnormal, VclearEOL)
}
}
"S" : {
writes ("ave ")
until (s := getCmdChar ())
if s == ESC then fail
name := "klondike.sv" || s
writeCursor (23, 1)
if saveState (name) then
write (Vbold, "Position saved in file ",name,
Vnormal, VclearEOL)
else
write (Vblink, "Can't save in file ", name, ".",
Vnormal, VclearEOL)
}
"T" : {
writes ("oggle ")
until (s := getCmdChar ())
if s == ESC then fail
case s of {
"A" : automaticAce := if \automaticAce then &null
else 1
"C" : clicking := if \clicking then &null else 1
"T" : &trace := if &trace = 0 then -1 else 0
default : complain ()
} #case for Toggle
}
default : complain ()
} #case for Debug command
end #udebug
# u b o s s
# Cheese it, the Fuzz.
# Quick -- clear the screen and save the state in a file.
procedure uboss ()
writes ("oss")
writes ("\33[=7h", VclearAll, "C>") #set cursor-wrap mode, look innocent
saveState ("klondike.sav")
exit ()
end #uboss
# m a i n
procedure main (av)
local s, prevsCmd, maxGames
# set defaults
automaticAce := 1 # automatic ace handling
clicking := 1 # give audible feedback
debugging := &null # no debugging allowed
invisible := &null # let's see the action
maxGames := &null # interactive mode
&random := map (&clock, ":", "0") # randomize the seed
# deal with command-line parameters
while s := get (av) do
case map (s, &lcase, &ucase) of {
"-A" : automaticAce := &null #disable automatic ace handling
"-B" : maxGames := get (av) #batch mode, this many games
"-C" : clicking := &null #run silent
"-D" : debugging := 1 #grant all sorts of perqs
"-R" : &random := get (av) #unrandomize
default : {write ("klondike [-ACD] [-B gameCount] [-R randomSeed]")
stop("klondike: bogus option ", s) }
}
totalGames := totalAces := 0
if \maxGames then {
# In Batch mode there is absolutely no console I/O.
# The requested number of games is played
# and the average result is printed on the standard output.
invisible := 1
clicking := &null
totalGames := maxGames
while 0 <= (maxGames -:= 1) do {
newGame ()
while automatic1 () #don't allow user to interrupt
totalAces +:= pile[1] + pile[2] + pile[3] + pile[4]
}
write (real(totalAces) / real(totalGames))
exit ()
}
initConstants() #for console I/O
firstSeed := &random #initial seed
lastSeed := newGame ()
#if last game terminated via the Boss key, then restore it now
if restoreState ("klondike.sav") then {
refreshScreen ()
writeInfo ("Game restored")
close (open ("klondike.sav", "c")) #truncate boss save file
}
repeat { #game loop
prevsCmd := "x" #anything but "S"uggest
#respond to user input
repeat { #command loop
writeCursor (18, 65)
writes (VclearEOL || Vnormal || "> ") #clear command line
if pile[1] = pile[2] = pile[3] = pile[4] = 13 then
if uterminate (1) then break # VICTORY!
s := getCmdChar ()
writeInfo ("") #clear info line
writeCursor (18, 68)
case s of {
"?"|"H" : uhelp()
"1"|"2"|"3"|"4"|"5"|"6"|"7"|"D" :
if not umove(s) then complain()
"A" : uautomatic() #look Ma, no hands!
"B" : uboss() #bail out -- quick
"C" : ucontinuous() #no hands, forever
"M" : if not umove(&null) then complain()
"Q" : if uterminate(&null) then break #new game
"S" : usuggest (if s == prevsCmd then 1 else 0)
"T" : { writes("humb"); push(ops, thumb()) }
"U" : undo()
"Z" : udebug()
"\^L" : refreshScreen()
ESC : s #do nothing here
default : complain()
} #case
prevsCmd := s
} #repeat command
totalAces +:= pile[1] + pile[2] + pile[3] + pile[4]
totalGames +:= 1
lastSeed := newGame ()
} #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