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:
# klondike.icn
# This archive created: Sun Apr 21 15:03:59 1991
# By: Norman H. Azadian (Hasler AG)
export PATH; PATH=/bin:$PATH
echo shar: extracting "'klondike.icn'" '(19820 characters)'
if test -f 'klondike.icn'
then
echo shar: will not over-write existing file "'klondike.icn'"
else
cat << \SHAR_EOF > 'klondike.icn'
#klondike.icn 901207 NHA
#The Klondike version of Solitaire; main program and command routines.
#
# TO FIX:
#
#
# TO DO:
#
# - Add a "cheated" flag ??
# - Find a better way to determine isPC.
# - Implement an heuristic to discover optimal play
#
link kloncon #klondike console I/O subroutines
link klonstr #klondike strategy subroutines
link klonsub #klondike miscellaneous subroutines
record card(suit, rank) #suit is 1..4, rank is 1..13
# v a r i a b l e s
# lists of record card
global deckUp #face Up portion of deck (stock)
global deckDown #face Down portion of deck
global stackUp #list of face Up cards per stack
global stackDown #list of face Down cards per stack
# others
global pile #ace piles - top rank only
global ops #list of all operations ever done
global isDOS, isPC # "state of our world" flags
global debugging, automaticAce #command-line flags
global invisible, isQuiet # for visual and audible feedback
global strategy #strategy to use for automatic play
global directory, phraseFile #pathnames
global firstSeed, lastSeed #&random remembered
global totalGames, totalAces, totalWins #ace pile statistics
# u h e l p
# Provide command summary for user, plus statistics to date, if any.
procedure uhelp ()
local row, info
static helpInfo
initial {
helpInfo := [
["A", "Automatic", " mode -- finish out this game on automatic pilot"],
["B", "Boss", " key for when you-know-who visits"],
["C","Continuous"," mode -- play games continuously until interrupted"],
["F", "Find", " (next) useful move to do"],
["H,?", "Help", ", this help screen"],
["M", "Move", " card (or stack) from Deck/Stack to Stack/Ace pile"],
["Q", "Quit", " this game"],
["S", "Suggest", " (another) possible move"],
["T", "Thumb", " through the deck"],
["U", "Undo", " -- back up one move"],
["Z", "Debug", ""],
["^L", "re-draw", " screen"],
["ESC", "Escape", " -- abort current command"]
]
}
output (VclearAll, Vnormal)
output ("Klondike version 3.01 910330 NHA\t\t", &version)
outputAt (4, 4, "The following commands are available:")
row := 6
every info := !helpInfo do
if (\debugging) | (info[1] ~== "Z") then {
outputAt (row, 8, Vbold, info[1])
outputAt (row, 16, info[2], Vnormal, info[3])
row +:= 1
}
if 0 < totalGames then
writeAt (21, 1, "totalGames = ", totalGames,
" totalWins = ", totalWins,
" totalAces = ", totalAces,
" average = ",
left (string(real(totalAces) / real(totalGames)), 6) )
outputAt (24, 20, Vblink, "Press any key to resume game", Vnormal)
(getch() == "\0") & getch() #wait for a keystroke & swallow it
refreshScreen ()
return
end #uhelp
# f i n d 1
# Find the best move, thumbing as necessary to achieve it.
# Return the operation string for that move.
# Fails if there is nothing useful left to do.
# When Thumbing, fails upon second occurrence of *deckDown = 0.
# This is an internal routine but it does keep the user informed.
# Note that if automaticAce is set, any Ace uncovered whilst thumbing
# will be automatically moved and the search will continue.
procedure find1 ()
local emptySeen, s
repeat {
/emptySeen := (*deckDown = 0)
(s := suggest()) & return (s || "0") #good move found
((*deckUp + *deckDown) = 0) & fail #no cards to thumb through
writeInfo (Vbold || "T" || Vnormal || "humb")
push (ops, thumb())
(\emptySeen) & (*deckDown = 0) & fail #no point Thumbing forever
}
end #find1
# u f i n d
# Thumb as necessary until a reasonable move appears, then stop and suggest it.
# When nothing is left to do, suggest "Quit".
# When invoked twice in a row, again will be non-null and we should take the
# previous suggestion and find the next.
# Returns success to request termination.
# Note that the suggestion is not necessarily the "best" suggestion.
# Note that if automaticAce is set, an uncovered Ace will be automatically
# moved and the search will continue. It does not count as a move.
procedure ufind (again)
static lastOp
local s
if \again then
if lastOp == "Q" then { #pretend he typed "Q" instead of "F"
output (VbackSpace, Vbold, "Q", Vnormal)
return uterminate () #Th.th.th.that's all, folks!
} else {
writes ("ind")
writeInfo ("") #clear prevs suggestion
s := expandOp (lastOp) #build suggestion
# show previous suggestion as current command
outputAt (17, 65, "> ", left (s, 14 + countControls(s)))
push (ops, move1(lastOp)) | runerr (500, lastOp) #execute it
outputAt (17, 65, VclearEOL,Vnormal, "> F") #go find next suggestion
}
writes ("ind")
writeInfo ( expandOp (lastOp := (find1() | "Q") ) ) #suggest (next) move
fail #do NOT request a new game
end #ufind
# 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.
# "another" is non-null when this command was also the previous command.
# Suggestions are given in essentially random order, and thumbing is
# suggested only as a last resort.
procedure usuggest (another)
static suggestions, i
writes ("uggest")
if /another then { #prev command was NOT Suggest
suggestions := [] #generate a new list of suggestions
every put ( suggestions, suggest() )
i := 0
}
return writeInfo ( expandOp (suggestions[i+:=1] | "T") )
end #usuggest
# 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 but it keeps the user informed.
# Returns total ace cards promoted when there is nothing useful left to do.
# Returns with failure when the user interrupts the proceedings.
procedure automatic ()
local op
repeat {
userInterrupt() & fail #interrupted
(!pile < 13) | return 52 #victory
if not writeInfo ( expandOp ( op := findBest() ) ) then
return (pile[1] + pile[2] + pile[3] + pile[4]) #no moves left
push (ops, move1 (op)) | runerr (500, op)
}
end #automatic
# u a u t o m a t i c
# Play this hand automatically, untouched by human hands.
# This is the command fuction that interacts with the user.
procedure uautomatic ()
writes ("utomatic")
writeInfo (if automatic() then "" else "Interrupted")
return
end #uautomatic
# u c o n t i n u o u s
# Plays automatic games -- forever (or until user interrupts)
procedure ucontinuous()
writes ("ontinuous")
repeat {
writeCursor (16, 65) #between Info line and Command line
writes (center ((string(totalGames) || " " || string(totalAces)), 16))
(totalAces +:= automatic()) | (writeInfo ("Interrupted"), break)
totalGames +:= 1
(!pile < 13) | (totalWins +:= 1)
lastSeed := newGame()
writeAt (17, 65, "> Continuous")
}
return
end #ucontinuous
# 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]; else &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, col
if \src then
output (VbackSpace, "Move ", Vbold, src)
else {
output ("ove ", Vbold);
until (src := getCmdChar ())
(src == ESC) & return
}
col := 73
if src == "D" then {
(*deckUp = 0) & fail
output (Vnormal, "eck")
col +:= 3
} else {
any ('1234567', src) | fail
(*stackUp[src] = 0) & fail
writeStackNumber (src, Vblink)
writeCursor (17, col)
}
output (Vnormal, " to ", Vbold)
until (dst := getCmdChar ())
col +:= 5
if src ~== "D" then {
writeStackNumber (src, Vnormal)
writeCursor (17, col)
}
(dst == ESC) & return
any ('A1234567', dst) | fail
(dst == src) & fail
(dst == "A") & (src ~== "D") & output (Vnormal, "ce")
return push (ops, move1("M" || src || dst || "0"))
end #umove
# u u n d o
# backup one move, including any automatic ace moves
procedure uundo ()
writes ("ndo")
undo()
return
end #uundo
# u d e b u g
# Additional commands to support the implementer.
procedure udebug ()
local s, d, name
(\debugging) | return complain()
output (VbackSpace, "Debug ")
until (s := getCmdChar ())
case s of {
ESC : fail #debug command aborted
"A" : { #play this game again
writes ("gain")
&random := lastSeed
outputAt (22, 1, Vbold,
"&random set. Quit to play this game again.",
Vnormal, VclearEOL)
}
"D" : display() #dump ICON state
"H"|"?" : {
output (if s == "?" then (VbackSpace || "help") else "elp")
outputAt (22, 1, Vbold,
"Again, Dump, Options, Move, Peek{1-7UD}, Restore, Save, Toggle{AQT}.",
Vnormal, VclearEOL)
}
"M" : { #move, without legality checking
writes ("ove ")
until (s := getCmdChar ()) #Source
(s == ESC) & fail
(s == "A") & fail
until (d := getCmdChar ()) #Destination
(d == ESC) & fail
(d == s) & fail
any('1234567', d) | fail
if s == "D" then {
(*deckUp = 0) & fail
put (stackUp[d], get(deckUp))
writeDeckUp ()
writeStack (d)
push (ops, "MD" || d || "0")
} else {
moveStack (s, d)
push (ops, "M" || s || d || "123456789abcdef"[*stackUp[s]])
}
}
"O" : { #show command-line options
writes ("ptions")
outputAt (22, 1, Vbold,
if \automaticAce then "AutomaticAce " else "",
if 0 < *directory then ("-D"||directory||" ") else "",
if \phraseFile then ("-P"||phraseFile||" ") else "",
if \isQuiet then "Quiet " else "",
("-S" || strategy), Vnormal, VclearEOL)
outputAt (23, 1, Vbold, "&trace=", &trace,
" firstSeed=", firstSeed, " lastSeed=", lastSeed,
Vnormal, VclearEOL)
}
"P" : { #look at hidden cards
writes ("eek ")
until (s := getCmdChar ())
(s == ESC) & fail
outputAt (22, 1, 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" : { #restore current state from a file
writes ("estore")
until (s := getCmdChar ())
(s == ESC) & fail
name := "klondike.sv" || s
if (d := restoreState(name)) then {
refreshScreen()
outputAt (22, 1, Vbold, "Restored position from file ",
directory || name, " of ", d, Vnormal,VclearEOL)
} else {
outputAt (22, 1, Vblink, "Can't restore from file ",
directory || name, Vnormal, VclearEOL)
}
}
"S" : { #save current state to a file
writes ("ave ")
until (s := getCmdChar ())
(s == ESC) & fail
name := "klondike.sv" || s
writeCursor (22, 1)
if saveState (name) then
output (Vbold, "Position saved in file ",
directory || name, Vnormal, VclearEOL)
else
output (Vblink, "Can't save in file ",
directory || name, Vnormal, VclearEOL)
}
"T" : { #toggle a command-line flag
writes ("oggle ")
until (s := getCmdChar ())
(s == ESC) & fail
case s of {
"A" : automaticAce := if \automaticAce then &null
else 1
"Q" : isQuiet := if \isQuiet then &null else 1
"T" : &trace := if &trace = 0 then -1 else 0
default : complain ()
} #case for Toggle
}
default : complain ()
} #case for Debug command
return
end #udebug
# u b o s s
# Cheese it, the Fuzz.
# Quick -- clear the screen and save the position in a file.
procedure uboss ()
writes ("oss") # "consistency is the hobgoblin of small minds"
terminateScreen () #put screen in the correct state
writes ("C>") #look innocent
saveState ("klondike.sav")
exit ()
end #uboss
# w r i t e S t a t i s t i c s
# Using the global counter variables, compute & write out some elementary stats.
# These are written to stderr so as not to mess up any batch file which might
# be collecting statistics whilst running klondike in -Batch mode.
# Note that write() is kosher here since this should only be called after
# terminate() has been called to restore the screen to its original state.
procedure writeStatistics ()
if 1 < totalGames then {
write (&errout, "In ", totalGames, " games you put ", totalAces,
" cards on the ace piles.")
if 0 < totalAces then
write (&errout,
"Average ", real(totalAces) / real(totalGames),
" cards on the ace piles per game.")
if 0 < totalWins then
write (&errout,
"You won ", totalWins, " (",
left((totalWins * 100.) / totalGames, 4),
"%) of those games.")
write (&errout,
"Average ", real(&time) / totalGames / 1000,
" seconds per game.")
} else {
write (&errout,
"In 1 game you put ", totalAces, " cards on the ace piles.")
write (&errout, "Total time was ", real(&time) / 1000, " seconds.")
}
write (&errout, "Initial random seed was ", firstSeed)
return
end #writeStatistics
# u t e r m i n a t e
# 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 ()
local s
if (!pile < 13) then
writes ("uit")
else
outputAt (12, 22, Vbold, Vblink, "Congratulations -- You've WON !!!",
Vnormal)
writeInfo (Vbold || "Another game? ")
until (s := getCmdChar ())
case s of {
ESC : fail #didn't really want to quit after all
"Y" : return #please start a new game
"N" : { #program termination requested
totalGames +:= 1
every totalAces +:= !pile
(!pile < 13) | (totalWins +:= 1)
terminateScreen ()
writeStatistics ()
exit ()
}
default : {complain(); fail} #continue playing this game
}
runerr (500, s)
end #uterminate
# d o B a t c h
# Plays the requested number of games in batch mode.
# Returns three-element list of results.
# If the number of games to play is 0 or negative, then plays until interrupted.
procedure doBatch (gamesToPlay)
local games, wins, aces
games := wins := aces := 0
repeat {
newGame ()
if aces +:= automatic() then {
(!pile < 13) | (wins +:= 1)
((games +:= 1) = gamesToPlay) & break
} else
break #interrupted from keyboard
}
return [games, wins, aces]
end #doBatch
# u b a t c h
# Plays the requested number of games (0 => infinity) in batch mode.
# Results are reported after every interval (0 => only at end) games.
# Statistics are output when done or interrupted, whichever comes first.
procedure ubatch (gamesToPlay, interval)
local veryFirstSeed, stat
isQuiet := invisible := 1
veryFirstSeed := &random #remember the initial random seed
(interval = 0) & (interval := gamesToPlay)
repeat {
(0 < gamesToPlay) & (interval >:= gamesToPlay)
firstSeed := &random #random seed for first game this set
stat := doBatch (interval)
write (firstSeed, "\t", stat[1], "\t", stat[2], "\t", stat[3])
totalGames +:= stat[1]
totalWins +:= stat[2]
totalAces +:= stat[3]
(stat[1] ~= interval) & break #interrupted by user
(0 = (gamesToPlay -:= interval)) & break
}
firstSeed := veryFirstSeed #required for writeStatistics()
writeStatistics ()
exit ()
end #ubatch
# m a i n
procedure main (av)
local s, prevsCmd, batchMode, reportInterval, again, termtype
# initialize
isDOS := find("MS-DOS", &host) #probably a reasonable assumption
isPC := isDOS #really a pretty poor assumption
totalGames:=totalAces:=totalWins := 0 #statistics
# set defaults
findBest("") # set global variable strategy
automaticAce := 1 # automatic ace handling
debugging := &null # no debugging allowed
directory := "" # use current directory
invisible := &null # let's see the action
batchMode := &null # interactive mode
reportInterval := 0 # report only at end of batch mode
phraseFile := &null # use all built-in phrases
isQuiet := &null # make clicks & beeps if possible
termtype := if \isPC then "pc" else "mono"
&random := map (&clock, ":", "7") # randomize the seed
# deal with command-line parameters
reverse(getenv("KLONDIKE")) ? #pre-pend env var words to cmd line
while tab(upto(~" \t\v\f\r\n")) do
push (av, reverse(tab(many(~" \t\v\f\r\n"))))
while s := get (av) do
case s[1:3] of {
"-A" | "-a" : automaticAce :=if \automaticAce then &null else 1
"-B" | "-b" : batchMode := (integer(s[3:0]) | 0)
"-D" | "-d" : directory := if *s < 3 then
getenv ("HOME" | "ROOTDIR")
else
s[3:0]
"-I" | "-i" : reportInterval := (integer(s[3:0]) | 1)
"-P" | "-p" : phraseFile := s[3:0]
"-Q" | "-q" : isQuiet := if \isQuiet then &null else 1
"-R" | "-r" : &random := integer (s[3:0])
"-S" | "-s" : findBest (s[3:0]) #check & store strategy
"-T" | "-t" : termtype := s[3:0]
"-Z" | "-z" : debugging := if \debugging then &null else 1
default : {
# screen mode not yet initialized, so write() is OK
write ("klondike [-AQZ] [-B[count]] [-D[dir]] [-I[interval]]")
write (" [-P[file]] [-Rseed] [-Sstrategy] [-T[term]]")
# screen mode not yet initialized, so stop() is OK
stop ("klondike: bogus option ", s)
}
}
# initializations which use command-line parameters
(map(termtype, &lcase, &ucase) == "PC") & isPC := 1
initConstants (termtype) #need updated termtype from cmdline
initVariables () #establish all the lists and such
# when defined, batchMode is the number of games to play; 0 => infinity.
ubatch (\batchMode, reportInterval) #conditional call of no return
# Establish the directory for file I/O; with a trailing "/" if non-empty.
# It is only used directly in the open() and remove() calls.
(0 < *directory) & (directory := trim(directory, '/\\') || "/")
# If last game was terminated via the Boss key then restore it now,
# otherwise start up a new game.
if restoreState ("klondike.sav") then {
refreshScreen ()
writeInfo ("Game restored")
remove (directory || "klondike.sav")
} else {
firstSeed := &random #random seed for first game
lastSeed := newGame () #start a new game, stashing seed
}
repeat { #game loop
prevsCmd := "-none-"
repeat { #command loop
outputAt (17, 65, VclearEOL, Vnormal, "> ") #clear command line
until (s := getCmdChar ())
again := (if s == prevsCmd then s else &null)
writeInfo ("") #clear info line
writeCursor (17, 68) #just after cmd char
case s of {
"?"|"H" : uhelp()
"1"|"2"|"3"|"4"|"5"|"6"|"7"|"D" : #short-cut for Move
umove (s) | complain ()
"A" : uautomatic() #look Ma, no hands!
"B" : uboss() #bail out quick
"C" : ucontinuous() #no hands, forever
"F" : ufind (again) & break #new game
"M" : umove (&null) | complain ()
"Q" : uterminate () & break #new game
"S" : usuggest (again)
"T" : { writes("humb"); push(ops, thumb()) }
"U" : uundo()
"Z" : udebug()
"\^L" : refreshScreen()
ESC : s #do nothing here
default : complain()
} #case
prevsCmd := s
(!pile < 13) | (uterminate () & break) # VICTORY!
} #repeat command
totalGames +:= 1
every totalAces +:= !pile
(!pile < 13) | (totalWins +:= 1)
lastSeed := newGame ()
} #repeat game
end #main
SHAR_EOF
if test 19820 -ne "`wc -c < 'klondike.icn'`"
then
echo shar: error transmitting "'klondike.icn'" '(should have been 19820 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