Updated 2015-06-25 11:44:24 by MiHa

Intro edit

Keith Vetter 2004-11-29 : When I upgraded my computer recently, I lost my copy of Microsoft's Windows Entertainment Pack. This is/was a set of games written way back in 1991 for an early version of Windows. My original disks are long lost.

So I thought I'd recreate one of those games, namely the solitaire game called TriPeaks. The rules for playing are described in the game's Help section.

The code for the game is fairly small, but it uses the card images I first got for Scat and subsequently used by Once In A Lifetime and Spider Solitaire, so the size is relatively big.

Steven, 2008-04-24, I wrote my own tk tripeaks (well, mostly ;>). http://tkgames.sourceforge.net/

HJG 2005-08-29 Factored out the card-images to card_img

KPV Are you really sure that factoring out the card images is a good thing? I don't think the benefit of this factoring outweighs the hastle of forcing people wanting to try out the game from having to go to multiple pages (I know that I more often than not just give up on wiki pages that require me to get more code elsewhere--I like being able to cut-and-paste the code and having it work.)

HJG The cardimages are about 60 kb, for wiki-pages this is quite a lot. When moved to a separate page, this part does not need to be down&uploaded with each bit of discussion. And it also makes those other cardgames shorter.

KPV I disagree, I think this is a false saving.

Now the user experience for trying out this game is wretched. Pretend you're a new user of tcl and you decide to try out this game: first you'll try to cut-and-paste the code from this page (or if you're a bit more sophisticated you'll use wish-reaper). But when you run the code you just get a horrid message box saying "Error in startup script". At that point, most people will just give up, but the intrepid user will open up the source code only to find an unhelpful comment about the card images coming from some starkit. Then if he still cares, the user will go back to the wiki page, dig through all the comments to find the one on where the images are now and still do a 60K download.

And the benefit for this user? If at some later point he downloads one of the five other games which use these card images he'll save himself 60K in the download (provided he downloads to the same directory he was in before). WOW

(Yes, there may still be some people using browsers which can't handle >32K edit boxes but those people aren't the ones editing these pages.)

aa - The card pictures are used in several programs. I think it's perfectly appropriate to separate them into a separate file for that reason alone. But the big bonus is that it gets them out of the way of the actual program code, which is what makes the game what it is. If you don't like the "Error in startup script" dialog (and who would?), don't just complain that it's horrid. Account for the error condition and give a useful message instead, so that the less intrepid user will know what to do.

LV Two other solutions would be to

  1. create starpacks containing the games; in that way, users don't have the worry of figuring out how to get a clean download of the script from this page (which can be tricky for a casual user), let alone have to figure out how to find, download, and install activetcl or some other distribution for their system, other code required, etc.
  2. add the games, etc. to http://tclapps.sf.net/ . tclapps is a collection of games, utilities, etc. that one can download as a group of amusing items.

willdye This is an excellent little game. Thank you for posting it. On my personal copy, I added a little 'cheat' to help me learn how to play. I have it automatically show me the valid moves after every discard or stock draw. I don't think this change would be a good idea for the normal game, but perhaps it could be an option for an "tutorial" game setting.

One possible bug: I found that if animation is turned on, and I make a move while the animation for showing possible moves is still running, then future animation to show possible moves will no longer function. I suspect the use of 'update' -- see Update considered harmful. Unfortunately, I don't have the time right now to confirm my suspicions and post a fix, because I spent too much of my free time for the evening playing this game. :-)

uniquename 2013aug02

Like 'willdye' says above, this is an excellent little game ... and as such, it deserves a couple of images to show what the code above creates.


Program edit

 ##+##########################################################################
 #
 # 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
 #   http://www.tcl.tk/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 http://wiki.tcl.tk/card_img for a copy."
 }
 ################################################################
 Init
 DoDisplay
 Deal

Comments edit