##+##########################################################################
 #
 # tripeaks.tcl -- Plays the solitaire game of TriPeaks
 # by Keith Vetter, November 2004
 #
 package require Tk

 set S(title) TriPeaks

 ##+##########################################################################
 #
 # Init -- one time initialization
 #
 proc Init {} {
    global DECK SZ POS RANK PARENTS SONS S ANIM

    set S(score) 0
    set S(hide) 1

    set SZ(cw) [image width  ::img::back]
    set SZ(ch) [image height ::img::back]
    set SZ(ch2)  [expr {$SZ(ch) / 2}]
    set SZ(colw) [expr {1 + $SZ(cw) / 2}]
    set SZ(lm) 10
    set SZ(tm) 10
    set SZ(rowh) 40
    set SZ(bg) darkgreen

    # Make our deck of cards
    set DECK(cards) {}
    foreach suit {s d c h} {
        foreach v {a k q j t 9 8 7 6 5 4 3 2} {
            lappend DECK(cards) "$v$suit"
        }
    }

    # Who can play on whom
    set prev 2
    foreach v {a k q j t 9 8 7 6 5 4 3 2 a} {
        foreach suit1 {s d c h} {
            foreach suit2 {s d c h} {
                set RANK($v$suit1,$prev$suit2) 1
                set RANK($prev$suit1,$v$suit2) 1
            }
        }
        set prev $v
    }

    # Row/col for each visible card
    set aPOS {
         0 {0 3}   1 {0 9}   2 {0 15}  3 {1 2}   4 {1 4}   5 {1 8}   6 {1 10}
         7 {1 14}  8 {1 16}  9 {2 1}  10 {2 3}  11 {2 5}  12 {2 7}  13 {2 9}
        14 {2 11} 15 {2 13} 16 {2 15} 17 {2 17} 18 {3 0}  19 {3 2}  20 {3 4}
        21 {3 6}  22 {3 8}  23 {3 10} 24 {3 12} 25 {3 14} 26 {3 16} 27 {3 18}
    }
    array set POS $aPOS

    # Parents and sons of each card
    unset -nocomplain PARENTS
    unset -nocomplain SONS
    foreach {card .} $aPOS {
        set PARENTS($card) {- -}
        foreach {row col} $POS($card) break
        set n [lsearch $aPOS [list [incr row -1] [incr col -1]]]
        if {$n != -1} {lset PARENTS($card) 0 [lindex $aPOS [incr n -1]]}
        set n [lsearch $aPOS [list $row [incr col 2]]]
        if {$n != -1} {lset PARENTS($card) 1 [lindex $aPOS [incr n -1]]}
        foreach p $PARENTS($card) {
            if {$p eq "-"} continue
            lappend SONS($p) $card
        }
    }

    # Need back image w/ black edges for the stock pile
    catch {image delete ::img::back2}
    image create photo ::img::back2
    ::img::back2 copy ::img::back
    foreach {x0 y0 x1 y1} {2 0 69 1 1 1 "" "" 0 2 1 94 1 94 "" ""  2 95 69 96
        69 94 "" "" 70 2 71 94 69 1 "" ""} {
        eval ::img::back2 put black -to $x0 $y0 $x1 $y1
    }

    # Animation stuff
    set ANIM(cnt) 0
    set ANIM(aid) ""
    set ANIM(delay) 10
    set ANIM(nextStep) 4
    set ANIM(animation) 1
 }
 proc DoDisplay {} {
    wm title . $::S(title)
    DoMenus

    set w [expr {[lindex [Card2Pos 18] 0] + [lindex [Card2Pos 27] 0]}]
    set h [expr {[lindex [Card2Pos  0] 1] + [lindex [Card2Pos discard] 1]}]
    canvas .c -bg $::SZ(bg) -bd 0 -highlightthickness 0 -width $w -height $h
    pack .c -side top -fill both -expand 1
    for {set cnum 0} {$cnum < 28} {incr cnum} {
        .c bind card_$cnum <Button-1> [list BClick $cnum]
    }
    .c bind stock <Button-1> [list BClick stock]
    .c bind card_discard <Button-1> ShowGoodMoves
    .c bind card_discard <Button-3> ShowGoodMoves
    button .deal -text "Deal Next Hand" -font {Times 10 bold} -command Deal

    font create myFont -family Times -size 18
    option add *Label.font myFont
    option add *Label.foreground white
    option add *Label.background $::SZ(bg)

    frame .f -bg $::SZ(bg)
    label .f.lscore  -text "Score: "
    label .f.score   -textvariable S(score)
    label .f.lstreak -text "Streak: "
    label .f.streak  -textvariable S(streak)
    label .f.ldeck   -text "Cards Left: "
    label .f.deck    -textvariable S(left)
    grid  .f.lscore  .f.score -sticky w
    grid  .f.lstreak .f.streak -sticky w
    grid  .f.ldeck   .f.deck -sticky w
    place .f -in .c -x $::SZ(lm) -y 250

    label .bonus -textvariable S(bonus) -fg red -font {Times 24 bold}
    place .bonus -in .c -x 580 -y 280 -anchor c

    wm resizable . 0 0
 }
 proc DoMenus {} {
    menu .m -tearoff 0
    . configure -menu .m
    .m add cascade -menu .m.game -label "Game" -underline 0
    .m add cascade -menu .m.opts -label "Options" -underline 1
    .m add cascade -menu .m.help -label "Help" -underline 0

    menu .m.game -tearoff 0
    .m.game add command -label "Deal" -underline 0 -command Deal -accel "F2"
    .m.game add command -label "Reset" -underline 0 -command {Deal 1} \
        -accel "Shift+F2"
    .m.game add separator
    .m.game add command -label "Show All Moves" -underline 0 \
        -command ShowGoodMoves
    .m.game add separator
    .m.game add command -label "Exit" -command exit -underline 1

    menu .m.opts -tearoff 0
    .m.opts add checkbutton -label "Hide Cards" -underline 0 \
        -variable S(hide) -command ToggleHide
    .m.opts add checkbutton -label "Animation" -underline 0 \
        -variable ANIM(animation)

    menu .m.help -tearoff 0
    .m.help add command -label "Help" -command Help -accel "F1"
    .m.help add separator
    .m.help add command -label "About" -command About

    bind all <F1> Help
    bind all <F2> Deal
    bind all <Shift-F2> {Deal 1}
    bind all <Alt-c> {console show}
 }
 proc About {} {
    tk_messageBox -message "$::S(title)\nby Keith Vetter, November 2004" \
        -title "About $::S(title)"
 }
 ##+##########################################################################
 #
 # Card2Pos -- returns where a card should be placed on the canvas
 #
 proc Card2Pos {cnum} {
    global POS SZ

    if {$cnum eq "stock" || $cnum eq "discard"} {
        foreach {x y} [Card2Pos [expr {$cnum eq "stock" ? 21 : 23}]] break
        set y [expr {$y + 3*$SZ(tm) + $SZ(ch)}]
        return [list $x $y]
    }

    foreach {row col} $POS($cnum) break
    set x [expr {$SZ(lm) + $SZ(colw) * ($col + 1)}]
    set y [expr {$SZ(tm) + $SZ(rowh) * $row + $SZ(ch2)}]
    return [list $x $y]
 }
 ##+##########################################################################
 #
 # Deal -- deals a new hand
 #
 proc Deal {{reset 0}} {
    global DECK TABLEAU S
    if {$reset} {
        unset -nocomplain TABLEAU
        set S(score) 0
    }

    ShuffleCards
    set S(bonus) ""
    set S(gameover) 0

    foreach who [array names TABLEAU *,state] {
        if {$TABLEAU($who) != 2} {incr S(score) -5}
    }

    .c delete all
    DrawStockPile
    set xy [Card2Pos stock]
    for {set cnum 0} {$cnum < 28} {incr cnum} {
        set visible [expr {$cnum > 17}]
        set card [lindex $DECK(all) $cnum]

        set TABLEAU($cnum,state) $visible
        set TABLEAU($cnum,card) $card

        .c create image $xy -tag card_$cnum -image [Card2Image $card $visible]
        AddAnimation card_$cnum [Card2Pos $cnum]
    }
    RunAnimation
    WaitAnimation
    set DECK(discard) [lindex $DECK(all) 28]
    set DECK(stock)   [lrange $DECK(all) 29 end]

    DrawFromStock 0
 }
 ##+##########################################################################
 #
 # ShuffleCards -- shuffles the cards
 #
 proc ShuffleCards {} {
    global DECK

    set cnt 0
    foreach card $DECK(cards) {
        set z([expr {round(rand() * 10000)}].[incr cnt]) $card
    }
    set DECK(all) {}
    foreach card [lsort -real [array names z]] {
        lappend DECK(all) $z($card)
    }
    set DECK(stock) $DECK(all)
    set DECK(discard) {}
 }
 proc Card2Image {card reveal} {
    if {$::S(hide) && ! $reveal} { set card "back" } ;# Hidden -- show back
    set iname "::img::$card"
    return $iname
 }
 ##+##########################################################################
 #
 # ToggleHide -- toggle visibility of buried cards in the TriPeaks area
 #
 proc ToggleHide {} {
    global TABLEAU

    foreach who [array names TABLEAU *,state] {
        scan $who "%d" cnum
        if {$TABLEAU($who) != 0} continue
        .c itemconfig card_$cnum -image [Card2Image $TABLEAU($cnum,card) 0]
    }
 }
 ##+##########################################################################
 #
 # DrawStockPile -- draws the stock pile w/ its multiple cards
 #
 proc DrawStockPile {} {
    set n [llength $::DECK(stock)]
    set ::S(left) $n
    set ::S(streak) 0
    if {$n > 5} {set n 5}
    set have [llength [.c find withtag stock]]
    if {$have == $n} return

    .c delete stock
    foreach {x y} [Card2Pos stock] break
    for {set i 1} {$i <= $n} {incr i} {
        incr x -2
        incr y -2
        .c create image $x $y -tag stock -image ::img::back2
    }
 }
 ##+##########################################################################
 #
 # BClick -- handles button clicks on the cards
 #
 proc BClick {cnum} {
    global TABLEAU RANK DECK S

    if {$S(gameover)} return
    set S(bonus) ""
    if {$cnum eq "stock"} {
        DrawFromStock
        return
    }
    if {! $TABLEAU($cnum,state)} return
    if {! [info exists RANK($TABLEAU($cnum,card),$DECK(discard))]} return
    set S(moves) {}
    RemoveCard $cnum
 }
 ##+##########################################################################
 #
 # RemoveCard -- removes card from TriPeak area to discard pile
 #
 proc RemoveCard {cnum} {
    global TABLEAU DECK PARENTS SONS S

    incr S(streak)
    incr S(score) $S(streak)
    set TABLEAU($cnum,state) 2
    if {$cnum < 3} {                        ;# Cleared a peak
        incr S(score) 15
        set S(bonus) "BONUS: 15 points"
    }

    if {$TABLEAU(0,state) == 2 && $TABLEAU(1,state) == 2 &&
        $TABLEAU(2,state) == 2} {
        incr S(score) 15
        set S(bonus) "BONUS: 30 points"
    }
    OneAnimation card_$cnum [Card2Pos discard]
    set DECK(discard) $TABLEAU($cnum,card)

    foreach side {left right} {
        foreach {pa sib} [Sibling $cnum $side] break
        if {$pa eq "-"} continue
        if {$TABLEAU($sib,state) != 2} continue
        set TABLEAU($pa,state) 1
        .c itemconfig card_$pa -image [Card2Image $TABLEAU($pa,card) 1]
    }
    GameOver
 }
 ##+##########################################################################
 #
 # GameOver -- determines if there are no more legal moves
 #
 proc GameOver {} {
    global TABLEAU DECK S

    if {$TABLEAU(0,state) == 2 && $TABLEAU(1,state) == 2 &&
        $TABLEAU(2,state) == 2} {
    } else {
        if {[llength $DECK(stock)] > 0} return
        if {[FindAllMoves] ne {}} return
        set S(bonus) "No More Moves"
    }
    set S(gameover) 1
    .c create window 580 320 -window .deal -tag deal
    return 1
 }
 ##+##########################################################################
 #
 # FindAllMoves -- returns list of all legal moves
 #
 proc FindAllMoves {} {
    global TABLEAU DECK RANK

    set moves {}
    foreach who [lsort -dictionary [array names TABLEAU *,state]] {
        if {$TABLEAU($who) != 1} continue
        scan $who "%d" cnum

        if {[info exists RANK($TABLEAU($cnum,card),$DECK(discard))]} {
            lappend moves $cnum
        }
    }

    return $moves
 }
 ##+##########################################################################
 #
 # ShowGoodMoves -- highlights all available moves
 #
 proc ShowGoodMoves {} {
    global S
    if {$S(gameover)} return

    set moves [FindAllMoves]
    if {$moves eq {}} return

    foreach cnum $moves {
        set old($cnum) [.c itemcget card_$cnum -image]
        set new($cnum) ::img::anim
    }

    foreach _ {1 2} {
        foreach img {new old} {
            foreach cnum $moves {
                .c itemconfig card_$cnum -image [set [set img]($cnum)]
            }
            update
            after 300
        }
    }
 }
 ##+##########################################################################
 #
 # DrawFromStock -- draws card from the stock pile
 #
 proc DrawFromStock {{cost -5}} {
    global DECK S

    if {[llength $DECK(stock)] == 0} return
    set S(moves) {}
    incr S(score) $cost
    set DECK(discard) [lindex $DECK(stock) 0]
    set DECK(stock) [lrange $DECK(stock) 1 end]

    set xy [Card2Pos stock]
    .c create image $xy -tag tmp -image [Card2Image $DECK(discard) 1]
    OneAnimation tmp [Card2Pos discard]
    .c delete card_discard
    .c itemconfig tmp -tag card_discard

    DrawStockPile
    GameOver
 }
 ##+##########################################################################
 #
 # Sibling -- returns card number of sibling block our left or right parent
 #
 proc Sibling {cnum side} {
    global PARENTS SONS

    set idx [expr {$side eq "left" ? 0 : 1}]
    set pa [lindex $PARENTS($cnum) $idx]
    if {$pa eq "-"} {
        return [list "-" "-"]
    }
    set sib [lindex $SONS($pa) $idx]
    return [list $pa $sib]
 }
 ##+##########################################################################
 #
 # AddAnimation -- adds another task to our animation list
 #
 proc AddAnimation {tag xy1} {
    global ANIM

    set id [incr ANIM(cnt)]
    set S(step) 30

    foreach {x0 y0} [.c coords $tag] break
    foreach {x1 y1} $xy1 break
    set dx [expr {$x1 - $x0}]
    set dy [expr {$y1 - $y0}]
    set dist [expr {hypot($dx, $dy)}]
    set steps [expr {round($dist / $S(step))}]
    set dx [expr {$dx / $steps}]
    set dy [expr {$dy / $steps}]

    set ANIM(active,$id) [list $tag $steps $steps $dx $dy $x1 $y1]
    .c lower $tag                              ;# Hide it until animation
 }
 proc RunAnimation {} {
    global ANIM

    after cancel $ANIM(aid)
    set cnt 0
    foreach who [lsort -dictionary [array names ANIM active,*]] {
        foreach {tag steps tsteps dx dy x1 y1} $ANIM($who) break

        if {! $ANIM(animation)} {
            .c coords $tag $x1 $y1
            .c raise $tag
            unset ANIM($who)
            continue
        }

        .c move $tag $dx $dy
        if {$steps == $tsteps} {.c raise $tag}
        if {[incr steps -1] == 0} {          ;# Done
            unset ANIM($who)
            .c coords $tag $x1 $y1            ;# Fix up any round off error
        } else {
            lset ANIM($who) 1 $steps
            incr cnt
        }
        if {$steps > $ANIM(nextStep)} break
    }
    update

    if {$cnt} {
        set ANIM(aid) [after $ANIM(delay) RunAnimation]
    } else {
        set ANIM(done) 1
    }
 }
 proc WaitAnimation {} {
    if {$::ANIM(animation)} {
        vwait ::ANIM(done)
    }
 }
 proc OneAnimation {tag xy} {
    AddAnimation $tag $xy
    RunAnimation
    WaitAnimation
 }
 proc Help {} {
    catch {destroy .helper}
    toplevel .helper
    wm transient .helper .
    wm title .helper "$::S(title) Help"
    if {[regexp {(\+[0-9]+)(\+[0-9]+)$} [wm geom .] => wx wy]} {
        wm geom .helper "+[expr {$wx+35}]+[expr {$wy+35}]"
    }
    set w .helper.t
    scrollbar .helper.sb -command [list $w yview]
    text $w -wrap word -width 70 -height 29 -pady 10 \
        -yscrollcommand [list .helper.sb set]

    button .helper.quit -text Dismiss -command {catch {destroy .helper}}
    pack .helper.quit -side bottom -pady 10
    pack .helper.sb -side right -fill y
    pack $w -side left -fill both -expand 1

    $w tag config title -justify center -font {{Times Roman} 18 bold}
    $w tag config red -foreground red
    $w tag config header -font {{Times Roman} 12 bold} -lmargin1 5

    $w tag config n -lmargin1 5 -lmargin2 5
    set lm2 [expr {5 + [font measure [$w cget -font] " o "]}]
    $w tag config b -lmargin1 5 -lmargin2 $lm2

    $w insert end "$::S(title)" {title red} "\nby Keith Vetter\n" title
    $w insert end "\nOverview\n" header
    $w insert end "The goal of this solitaire game is to move all cards " n
    $w insert end "from the TriPeaks area to the discard pile using as " n
    $w insert end "few cards from the stock as possible.\n" n

    $w insert end "\nRules\n" header
    $w insert end " o You can remove a card from the TriPeaks area if it is one " b
    $w insert end "card higher or lower in rank than the top card in the " b
    $w insert end "discard pile. " b
    $w insert end "Nb. " {n red} "Aces are considered to be" b
    $w insert end "both one higher than kings and one lower than twos.\n" b
    $w insert end " o You can see all available moves by clicking on the " b
    $w insert end "discard pile.\n" b
    $w insert end " o At any time, you can move a card from the stock to the " b
    $w insert end "discard pile.\n" b

    $w insert end "\nScoring\n" header
    $w insert end " o Every card from the stock costs 5 points.\n" b
    $w insert end " o Every card moved from TriPeaks to the discard pile " b
    $w insert end "gets you points, starting with 1 point and increasing " b
    $w insert end "by 1 for each subsequent card. Drawing from the stock " b
    $w insert end "resets the scoring back to 1.\n" b
    $w insert end " o Clearing a peak earns 15 points.\n" b
    $w insert end " o Clearing all peaks earns another 15 points.\n" b
    $w insert end " o Dealing a new hand costs 5 points for every card " b
    $w insert end "still in the TriPeaks area.\n" b

    $w config -state disabled
 }
 ################################################################
 # Card images from Patience card game, see
 #   http://uebb.cs.tu-berlin.de/~krischan/patience/patience-english.html
 #   https://www.tcl-lang.org/starkits/patience.kit
 # (simple "source card_img.tcl" line has been replaced with a more complicated but friendlier one)
 if [catch {source card_img.tcl}] {
   puts "Card images are defined in a separate 'card_img.tcl' file that is supposed to be in the [pwd] directory but was not found. As of 2005-09-01, see https://wiki.tcl-lang.org/card_img for a copy."
 }
 ################################################################
 Init
 DoDisplay
 Deal