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.
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.
##+##########################################################################
#
# 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://mini.net/sdarchive/patience.kit
source card_img.tcl
################################################################
Init
DoDisplay
Dealwilldye 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. :-)