Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!wuarchive!mit-eddie!bloom-beacon!eru!hagbard!sunic!mcsun!cernvax!chx400!hslrswi!naz From: naz@hslrswi.UUCP (Norman H. Azadian) Newsgroups: comp.lang.icon Subject: klondike, version 1.41. part 2/4 Message-ID: <1688@hslrswi.UUCP> Date: 6 Dec 90 12:42:14 GMT Organization: Hasler AG Lines: 492 #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 Brought to you by Super Global Mega Corp .com