[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 Help bind all StartGame bind all {console show} bind all Undo bind . {Auto 1} bind . {Auto R} bind . {Auto End} bind . {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 [list Click $row $col] .c bind c$row,$col [list Hint $row $col] #.c bind g$row,$col [list Hint2 $row $col] .c bind g$row,$col [list Hint2 $row $col double] .c bind g$row,$col [list Hint2 $row $col] bind all [list Hint3 down] bind all [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 ---- [Category Games]