HJG This is
Montana Solitaire from Keith Vetter, with an added AutoPlayer, and some tweaks to fit the display better on a 1024x768 screen.
To save space, the common card images from
card_img are used.
KPV Just curious, have you tried different strategies or noticed one being better than another? Ultimately, just how much skill is there and how much is it just mechanical?
HJG: it is a really simple, purely mechanical strategy:
- If one of the first columns has a gap, put the Deuce from the rightmost column there
- Check if a card can be played to its correct, final position (and do it).
- Otherwise: Select the rightmost playable card
There are some simple improvements / heuristics I can think of, e.g.:
- when selecting a deuce, look for cards that are already in place:
gap xx 4h yy zz ...
should get the two of hearts, thus saving one move.
- Avoid moving kings to the left, i.e. lower priority of such moves
- Ditto: avoid vacating a position at the right of a king as long as possible
A more complex improvement: simulate all possible plays until the next redeal, building a tree of moves and note for each of these sequences of play how many cards are in their final position. Then select the best of these. This amounts to a complete enumeration, but I think the tree would be small enough to be feasible.
But, for testing such things, it would be nice to have selectable seed for the random numbers, and a dump-routine for the card-positions (logging), and record/replay of moves, etc. But that would need lots of additional code, and I wanted this version to get out as soon as possible :-)
##+##########################################################################
#
# Montana -- plays Montana solitaire
# by Keith Vetter, April 2006 / May 2006
# 2006-04-30 HaJo Gurt: Resize+wm geom, card_img.tcl
# 2006-05-01 HaJo Gurt: Find2, Print
# 2006-05-02 HaJo Gurt: Autoplay1
# 2006-05-03 HaJo Gurt: update to KPV 2005-05-01, F1, focus -force, Auto
# TODO: AutoPlay2
package require Tk
array set S {title "Montana Solitaire"
auto 0 delay 500
lm 10 bm 10 tm 70
padx 5 pady 5 color green4 gcolor cyan gwidth 6}
wm title . $S(title)
wm geom . 1000x552+8+16
proc DoDisplay {} {
global S
if {! [catch {package require tile 0.7.2}]} {
namespace import -force ::ttk::button
namespace import -force ::ttk::scrollbar
}
eval destroy [winfo child .]
DoMenus
canvas .c -width $S(w) -height $S(h) -bg $S(color) -highlightthickness 0
frame .bottom -bd 2 -relief ridge
label .lmoves -text "Moves:" -anchor e
.lmoves configure -font "[font actual [.lmoves cget -font]] -weight bold"
option add *Label.font [.lmoves cget -font]
label .vmoves -textvariable ::STATS(moves) -anchor e
label .lgood -text "Good:" -anchor e
label .vgood -textvariable ::STATS(good) -anchor e
label .lredeals -text "Redeals:" -anchor e
label .vredeals -textvariable ::STATS(redeals) -anchor e
grid .lgood .vgood -in .bottom -sticky ew
grid .lmoves .vmoves -in .bottom -sticky ew
grid .lredeals .vredeals -in .bottom -sticky ew
grid columnconfigure .bottom 2 -weight 1
pack .c -side top -fill both -expand 1
pack .bottom -side top -fill x
bind all <Key-F1> Help
bind all <Key-F2> StartGame
bind all <Key-F3> {console show}
bind all <Control-z> Undo
bind . <Key-1> {Auto 1}
bind . <Key-2> {Auto R}
bind . <Key-3> {Auto End}
bind . <Key-0> {Auto Off}
.c create text [expr {$S(w)/2}] 0 -text $S(title) -fill red \
-font {Times 42 bold} -anchor n -tag title
GetCardPlacement
focus -force .
}
##+##########################################################################
#
# DoMenus -- isn't installing menus really verbose and clunky?
#
proc DoMenus {} {
option add *Menu.tearOff 0
. config -menu [menu .menu]
menu .menu.game
.menu add cascade -label "Game" -underline 0 -menu .menu.game
.menu.game add command -label "New Game" -underline 0 -command StartGame \
-accelerator "F2"
.menu.game add command -label "Restart" -underline 0 -command [list StartGame 1]
.menu.game add separator
.menu.game add command -label "Undo" -underline 0 -command Undo \
-accelerator "Ctrl-Z"
.menu.game add separator
.menu.game add command -label "Exit" -underline 1 -command exit
menu .menu.help
.menu add cascade -label "Help" -underline 0 -menu .menu.help
.menu.help add command -label "Help" -underline 0 -command Help
.menu.help add command -label "About" -underline 0 -command About
.menu.help add separator
.menu.help add command -label "Autoplay 1 move" -underline 9 -command {Auto 1}
.menu.help add command -label "Autoplay 2 until Redeal" -underline 9 -command {Auto R}
.menu.help add command -label "Autoplay 3 to end" -underline 9 -command {Auto End}
.menu.help add separator
.menu.help add command -label "Autoplay 0ff" -underline 9 -command {Auto Off}
}
####+####1####+####2####+####3####+####4####+####5####+####6####+####7####+####8
#
# GetCardPlacement -- sets up board with lots of empty tagged items
#
proc GetCardPlacement {} {
global S
for {set idx 0} {$idx < 52} {incr idx} {
set row [expr {$idx / 13}]
set col [expr {$idx % 13}]
set x [expr {$S(lm) + $col * ($S(cw)+$S(padx))}]
set y [expr {$S(tm) + $row * ($S(ch)+$S(pady))}]
set x1 [expr {$x+$S(cw)}]
set y1 [expr {$y+$S(ch)}]
.c create line $x $y $x1 $y $x1 $y1 $x $y1 $x $y $x1 $y -fill {} \
-tag [list m m$row,$col] -width $S(gwidth) -joinstyle miter
incr x1 -1
.c create rect $x $y $x1 $y1 -tag g$row,$col -fill $S(color) \
-outline $S(color)
.c create image $x $y -tag c$row,$col -anchor nw
.c bind c$row,$col <Button-1> [list Click $row $col]
.c bind c$row,$col <Button-3> [list Hint $row $col]
#.c bind g$row,$col <Button-1> [list Hint2 $row $col]
.c bind g$row,$col <Double-Button-1> [list Hint2 $row $col double]
.c bind g$row,$col <Button-3> [list Hint2 $row $col]
bind all <ButtonPress-2> [list Hint3 down]
bind all <ButtonRelease-2> [list Hint3 up]
}
}
##+##########################################################################
#
# Click -- handles moving a card after clicking on it
#
proc Click {row col} {
global B
.c delete flash
set card $B($row,$col)
if {$card eq "gap"} return ;# Be safe, shouldn't happen
if {$card eq "X" } return ;# Be safe, shouldn't happen
set pred [CardPredecessor $card]
if {! [string match "2?" $card]} {
foreach {r c} $B(r,$pred) break
incr c
} else {
set c 0
for {set r 0} {$r < 3} {incr r} {
if {$B($r,$c) eq "gap"} break
}
}
if {$B($r,$c) eq "gap"} {
lappend B(undo) [list $row $col $r $c]
.menu.game entryconfig "Undo" -state normal
incr ::STATS(moves)
MoveCardToGap $row $col $r $c
} else {
Flash bad $row $col
}
}
##+##########################################################################
#
# Flash -- temporarily highlights a card for either bad move or hint
#
proc Flash {how args} {
array set delays {bad 300 good 1000 all 15000}
array set clr {bad red good magenta all yellow}
foreach aid [after info] { after cancel $aid }
.c delete flash
foreach {row col} $args {
foreach {x0 y0 x1 y1} [.c bbox c$row,$col] break
.c create line $x0 $y0 $x1 $y0 $x1 $y1 $x0 $y1 $x0 $y0 $x1 $y0 \
-tag flash -width 7 -fill $clr($how) -capstyle round
if {$how eq "bad"} {
.c create line $x0 $y0 $x1 $y1 -tag flash -width 10 -fill $clr($how)
.c create line $x0 $y1 $x1 $y0 -tag flash -width 10 -fill $clr($how)
}
}
after $delays($how) .c delete flash
}
##+##########################################################################
#
# CanMove -- returns true if a valid move still exists
#
proc CanMove {} {
global B
foreach gap $B(gaps) {
foreach {row col} $gap break
if {$col == 0} { return 1 }
set left $B($row,[expr {$col-1}])
if {$left eq "gap"} continue
if {! [string match "k?" $left]} { return 1 }
}
return 0
}
##+##########################################################################
#
# MoveCardToGap -- moves card from row/col to the gap at r/c
#
proc MoveCardToGap {row col r c} {
global B
set card $B($row,$col)
set B($row,$col) "gap"
set B($r,$c) $card
set B(r,$card) [list $r $c]
set n [lsearch $B(gaps) [list $r $c]]
lset B(gaps) $n [list $row $col]
.c itemconfig c$r,$c -image ::img::$card
.c itemconfig c$row,$col -image {}
EndTurn
}
##+##########################################################################
#
# EndTurn -- Handles end-of-turn logic
#
proc EndTurn {} {
HighlightGood
set ::STATS(good) [llength [FindGood]]
if {[CanMove]} return
if {$::STATS(good) == 48} {
set ::S(auto) 0
Print "Finished: $::STATS(moves) moves, $::STATS(redeals) redeals.\n\n"
tk_messageBox -title $::S(title) -message "You Won!"
} else {
if {$::S(auto) == 2} { set ::S(auto) 0 }
Print "Redeal\n"
tk_messageBox -title $::S(title) -message "No more moves.\n\nRedeal"
Redeal
}
}
##+##########################################################################
#
# HighlightGood -- highlight all cards in their proper position
#
proc HighlightGood {} {
global B
.c itemconfig m -fill {}
foreach card [FindGood] {
foreach {row col} $B(r,$card) break
.c itemconfig m$row,$col -fill $::S(gcolor)
}
}
##+##########################################################################
#
# FindGood -- finds all cards that are in their proper position
#
proc FindGood {} {
global B
set pos {2 3 4 5 6 7 8 9 t j q k}
set good {}
for {set row 0} {$row < 4} {incr row} {
set head $B($row,0)
if {! [string match "2?" $head]} continue
set hsuit [string index $head 1]
for {set col 0} {$col < 13} {incr col} {
foreach {pip suit} [split $B($row,$col) ""] break
if {$suit ne $hsuit} break
if {$pip ne [lindex $pos $col]} break
lappend good $B($row,$col)
}
}
return $good
}
##+##########################################################################
#
# About -- tell something about us
#
proc About {} {
set txt "$::S(title)\n\nby Keith Vetter\nApril, 2006"
append txt "\n\nAutoplay by HaJo Gurt"
tk_messageBox -icon info -message $txt -title "About $::S(title)"
}
##+##########################################################################
#
# Help -- a simple help screen
#
proc Help {} {
catch {destroy .help}
toplevel .help
wm title .help "$::S(title) Help"
#wm geom .help "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"
set t .help.t
text $t -relief raised -wrap word -width 70 -height 30 \
-padx 10 -pady 10 -cursor {} -yscrollcommand {.help.sb set}
scrollbar .help.sb -orient vertical -command [list $t yview]
button .help.dismiss -text Dismiss -command {destroy .help}
pack .help.dismiss -side bottom -pady 10
pack .help.sb -side right -fill y
pack $t -side top -expand 1 -fill both
set bold "[font actual [$t cget -font]] -weight bold"
set italic "[font actual [$t cget -font]] -slant italic"
$t tag config title -justify center -foregr red -font "Times 20 bold"
$t tag configure title2 -justify center -font "Times 12 bold"
$t tag configure header -font $bold
$t tag configure n -lmargin1 10 -lmargin2 10
$t tag configure bullet -lmargin1 20 -lmargin2 30
$t insert end "$::S(title)\n" title
$t insert end "by Keith Vetter\n\n" title2
$t insert end "$::S(title) is a simple solitaire game that goes by "
$t insert end "a variety of names including \x22Gaps\x22, \x22Rangoon\x22, "
$t insert end "\"BlueMoon\", \x22Station\x22 and \x22Montana Aces\x22.\n\n"
$t insert end "Tableau\n" header
$t insert end "At the start of the game, all 52 cards are shuffled and "
$t insert end "dealt face up in four rows of thirteen cards. The four aces "
$t insert end "are removed creating four gaps.\n\n"
$t insert end "Object\n" header
$t insert end "The objective is to rearrange the cards so that each row "
$t insert end "contains the cards of a single suit ordered from deuce to "
$t insert end "king. (The last column in each row will contain a gap "
$t insert end "instead of the ace.)\n\n"
$t insert end "The Play\n" header
$t insert end "If a gap appears in the first column, you can move any "
$t insert end "deuce to that position. If a gap appears elsewhere, you "
$t insert end "move there only the card with same suit and one higher "
$t insert end "rank than the card to the left of the gap. For example, "
$t insert end "if the 5 of Hearts appears to the left of a gap, you "
$t insert end "can move the 6 of Hearts to that gap. If the card to "
$t insert end "the left of the gap is a King or another gap, you cannot "
$t insert end "move any card to that gap.\n\n"
$t insert end "Whenever you move a card, you'll fill one gap, but create "
$t insert end "a new one.\n\n"
$t insert end "Mechanics\n" header
$t insert end "o Click on a card to move it to a gap (if legal)\n" bullet
$t insert end "o Right-click on card to highlight its predecessor\n" bullet
$t insert end "o Right-click on a gap to highlight legal move\n" bullet
$t insert end "o Double-click on a gap to fill gap\n" bullet
$t insert end "o Hold middle-button down to highlight all legal moves\n" bullet
$t insert end "\n"
$t insert end "Redeal\n" header
$t insert end "If no move is possible, a redeal occurs automatically. "
$t insert end "All cards which are not in their correct positions are "
$t insert end "picked up, shuffled and redealt. Again the four aces are "
$t insert end "removed creating four gaps.\n\n"
$t insert end "See Also\n" header
$t insert end "For more details about all the different variants in "
$t insert end "family of solitaire games, see "
$t insert end "http://web.inter.nl.net/hcc/Rudy.Muller/ranrules.html\n\n"
$t insert end "Autoplay\n" header
$t insert end "Key 1: make a single automatic move,\n"
$t insert end "Key 2: autoplay until next redeal,\n"
$t insert end "Key 3: autoplay until end of game.\n"
$t insert end "Key 0: Stop autoplay.\n\n"
$t config -state disabled
focus -force .help.dismiss
}
##+##########################################################################
#
# MakeCards -- makes a deck and cards
#
proc MakeCards {} {
global S
set S(deck) {}
foreach suit {s d c h} {
foreach pip {a 2 3 4 5 6 7 8 9 t j q k} {
lappend S(deck) "$pip$suit"
}
}
if {[info commands ::img::as] eq ""} {
if {! [file exists cimages.tcl]} {
wm withdraw .
set emsg "Error: missing card images\n\n"
tk_messageBox -icon error -message $emsg \
-title "$S(title) Error"
exit
}
source cimages.tcl
}
set S(cw) [image width ::img::as]
set S(ch) [image height ::img::as]
set S(w) [expr {2*$S(lm) + 13*$S(cw) + 12*$S(padx)}]
set S(h) [expr { $S(tm) + 4*$S(ch) + 3*$S(pady) + $S(bm)}]
}
##+##########################################################################
#
# Shuffle -- Shuffles a list
#
proc Shuffle { l } {
set len [llength $l]
set len2 $len
for {set i 0} {$i < $len-1} {incr i} {
set n [expr {int($i + $len2 * rand())}]
incr len2 -1
# Swap elements at i & n
set temp [lindex $l $i]
lset l $i [lindex $l $n]
lset l $n $temp
}
return $l
}
##+##########################################################################
#
# StartGame -- starts a new game
#
proc StartGame {{noShuffle 0}} {
global S B STATS
array unset STATS
array set STATS {moves 0 redeals 0 good 0}
array unset B
array set B {0,13 X 1,13 X 2,13 X 3,13 X 4,0 X} ;# Sentinels
.menu.game entryconfig "Undo" -state disabled
if {! $noShuffle} {
set S(cards) [Shuffle $S(deck)]
}
# Deal all the cards
for {set idx 0} {$idx < 52} {incr idx} {
set row [expr {$idx / 13}]
set col [expr {$idx % 13}]
set card [lindex $S(cards) $idx]
if {[string match "a?" $card]} { ;# Ace, leave a gap
set B($row,$col) "gap"
lappend B(gaps) [list $row $col]
.c itemconfig c$row,$col -image {}
} else {
set B($row,$col) $card
set B(r,$card) [list $row $col]
.c itemconfig c$row,$col -image ::img::$B($row,$col)
}
}
Print "New Game"
EndTurn
}
##+##########################################################################
#
# CardPredecessor -- returns previous card in sequence
#
proc CardPredecessor {card} {
set n [lsearch $::S(deck) $card]
return [lindex $::S(deck) [expr {$n-1}]]
}
##+##########################################################################
#
# CardSuccessor -- returns next card in sequence
#
proc CardSuccessor {card} {
set n [lsearch $::S(deck) $card]
return [lindex $::S(deck) [expr {$n+1}]]
}
##+##########################################################################
#
# Redeal -- deals out all cards that are not in their proper position
#
proc Redeal {} {
global S B
incr ::STATS(redeals)
set good [FindGood]
set bad {} ;# All the cards to deal
set cells $B(gaps) ;# Where to deal to
foreach card $S(deck) {
if {[lsearch $good $card] > -1} continue
lappend bad $card
catch {lappend cells $B(r,$card)}
}
set B(undo) {}
.menu.game entryconfig "Undo" -state disabled
while {1} {
set B(gaps) {}
set cards [Shuffle $bad]
foreach card $cards cell $cells {
foreach {row col} $cell break
if {[string match "a?" $card]} { ;# Ace, leave a gap
set B($row,$col) "gap"
lappend B(gaps) [list $row $col]
.c itemconfig c$row,$col -image {}
} else {
set B($row,$col) $card
set B(r,$card) [list $row $col]
.c itemconfig c$row,$col -image ::img::$B($row,$col)
}
}
if {[CanMove]} break
}
EndTurn
}
##+##########################################################################
proc Undo {} {
global B
if {$B(undo) eq {}} return
foreach {r c row col} [lindex $B(undo) end] break
set B(undo) [lrange $B(undo) 0 end-1]
MoveCardToGap $row $col $r $c
incr ::STATS(moves)
if {$B(undo) eq {}} {
.menu.game entryconfig "Undo" -state disabled
}
}
##+##########################################################################
#
# Hint -- shows predecessor for a given card
#
proc Hint {row col} {
global B
set pred [CardPredecessor $B($row,$col)]
if {! [info exists B(r,$pred)]} return
foreach {r c} $B(r,$pred) break
Flash good $r $c
}
##+##########################################################################
#
# Hint2 -- shows which card goes into a gap
#
proc Hint2 {row col {how single}} {
global B
if {$B($row,$col) ne "gap"} return
incr col -1
if {$col < 0} return
set card $B($row,$col)
if {$card eq "gap"} return
if {[string match "k?" $card]} return
set succ [CardSuccessor $card]
if {! [info exists B(r,$succ)]} return
if {$how eq "single"} {
eval Flash good $B(r,$succ)
} else { ;# Double click--do actual move
.c delete flash
eval Click $B(r,$succ)
}
}
##+##########################################################################
#
proc Hint3 {updown} {
global B
if {$updown eq "up"} {
Flash all ;# Turn off highlighting
return
}
set moves {}
foreach pos $B(gaps) {
foreach {row col} $pos break
if {$col == 0} { ;# Empty in left column
foreach card {2h 2c 2d 2s} {
foreach {row col} $B(r,$card) break
if {$col > 0} {
lappend moves $row $col
}
}
continue
}
incr col -1
if {$col < 0} continue
set card $B($row,$col)
if {$card eq "gap"} continue ;# Left is gap
if {[string match "k?" $card]} continue ;# Left is a king
set succ [CardSuccessor $card]
if {! [info exists B(r,$succ)]} continue ;# Shouldn't happen
eval lappend moves $B(r,$succ)
}
eval Flash all $moves
}
################################################################
# Card images from Patience card game, see
# http://uebb.cs.tu-berlin.de/~krischan/patience/patience-english.html
# http://www.tcl.tk/starkits/patience.kit
if { [catch { source card_img.tcl }]} {
wm withdraw .
tk_messageBox -icon error -title "$S(title) Error" \
-message "File with cardimages not found: card_img.tcl"
exit
}
####+####1####+####2####+####3####+####4####+####5####+####6####+####7####+
proc Print { x } {
#: Debug-Log : Output to console
#puts $x
}
proc Auto {Mode} {
#: Start/Stop autoplay
global S
switch -- $Mode {
"1" {AutoPlay1}
"2" {AutoPlay2}
"R" {set S(auto) 2; AutoPlay1}
"End" {set S(auto) 3; AutoPlay1}
"Off" {set S(auto) 0; foreach a [after info] {after cancel $a} }
}
Print "Auto=$S(auto)"
}
proc Find2 {} {
#: Find rightmost 2-card ("Deuce")
global B
set col9 -1
foreach card { 2h 2d 2c 2s } {
foreach {row col} $B(r,$card) break
if {$col>$col9} {
set c9 $card
set col9 $col
set row9 $row
}
}
return [list $c9 $row9 $col9 ]
}
proc AutoPlay1 {} {
#: Play one automatic move, use Strategy #1:
#
# Simple Strategy:
# 1: See if a card can be played to its correct position
# 1b: If first column has a gap, put Deuce from the rightmost column there
# 2: Otherwise: Select the rightmost playable card
#
global B S STATS
if { $STATS(good) >= 48 } return
#set txt "$STATS(moves) - AutoPlay:"
set good [FindGood]
set col9 -1
foreach gap $B(gaps) {
foreach {row col} $gap break
if {$col == 0} {
foreach {card r c} [Find2] break
#append txt "\n $row $col ! $card $r $c"
Print "Auto: $card $r $c --> $row $col"
Click $r $c
break
}
set left $B($row,[expr {$col-1}])
if { $left eq "gap" } { continue }
if { [string match "k?" $left] } { continue }
#append txt "\n $row $col"
if {$col>$col9} {
set col9 $col
set row9 $row
}
if { [lsearch $good $left] > -1} { ;# append txt " G"
Print "Auto: xx --> $row9 $col9"
Hint2 $row $col double
set col -1
break
}
}
if {$col > 0} {
#append txt "\n ==> $row9 $col9"
Print "Auto: $row9 $col9"
Hint2 $row9 $col9 double
}
#tk_messageBox -icon info -title "Auto1" -message $txt
if {$S(auto) > 0} {
after $S(delay) AutoPlay1
}
}
proc AutoPlay2 {} {
#: Play one automatic move, use Strategy #2
# TODO
}
####+####1####+####2####+####3####+####4####+####5####+####6####+####7####+
MakeCards
DoDisplay
StartGame
return
Comments edit
[tony] - 2014-07-13 00:04:39Creating a tree with all possible plays is a big task. I tried it once for a Montana game I wrote for the Mac. I got a better clue on the Internet which got me just creating random moves over and over until no more moves were possible. Repeating this process would often find a solution in under 10s.
I like the auto player heuristic, I might try it out on games I know to have a solution from my own code. Note that the code I wrote would allow moves of a 2 to a new row, not sure if this is really totally right.
