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.
##+##########################################################################
#
# 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
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 AutoPlay1
.menu.help add command -label "Autoplay 2" -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}
}
##+##########################################################################
#
# 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"} {
MoveCardToGap $row $col $r $c
lappend B(undo) [list $row $col $r $c]
.menu.game entryconfig "Undo" -state normal
incr ::STATS(moves)
} 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 are 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://mini.net/sdarchive/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 to console
#puts $x
}
proc Auto {Mode} {
#: Start/Stop autoplay
global S
switch -- $Mode {
"1" {AutoPlay1}
"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
#
# 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
}
}
####+####1####+####2####+####3####+####4####+####5####+####6####+####7####+
MakeCards
DoDisplay
StartGame
return