**Intro** [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. 1. 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. [vetter_TriPeaks_feltAndCards_screenshot_741x416.jpg] [vetter_TriPeaks_helpWindow_screenshot_513x537.jpg] ---- [Jeff Smith] 2020-12-15 : Below is an online demo using [CloudTk]. This demo runs TriPeaks Solitaire in an Alpine Linux Docker Container. It is a 27.8MB image which is made up of Alpine Linux + tclkit + TriPeaks-Solitaire.kit + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories. <> <> ---- **Program** ====== ##+########################################################################## # # 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 [list BClick $cnum] } .c bind stock [list BClick stock] .c bind card_discard ShowGoodMoves .c bind card_discard 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 Help bind all Deal bind all {Deal 1} bind all {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** <> Games | Cardgames | Tcl/Tk games | Application