[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 improvements I can think of, e.g.:

   * a simple improvement: 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
   * Avoid moving card to the right of a king

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.

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

  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"} {
        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 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://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 : Output 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, 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

----
[Category Games]