Intro edit

http://tkgames.sourceforge.net/

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.

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

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References