[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]
----
##+##########################################################################
#
# 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
----
[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 fun<<ction. 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]
----
!!!!!!
%| [Category Games] | [Tcl/Tk games] | [Category Application] |%
!!!!!!