Keith Vetter 2003-04-25: I realized that over my 20+ years of programming that I've written hundreds of games but never a playing card game (actually I once wrote in Lisp an expert system that plays the game of canasta but that only played one hand and had no UI).
So here's my first card--it plays the game Scat, also known as 31, Ride the Bus and Blitz [L1 ]. The object of the game is to collect cards in one�s hand totaling as close to 31 as possible in the same suit. It uses the GPL card images found in Playing Card Images. (No longer true, see below.)
The code for playing the computer hands is pretty simple and could easily be improved (see routines PickupOrKnock and WhichDiscard), but it plays well enough to be enjoyable.
KBK - There appears to be a small bug in the scoring. A player who draws to 31 after another player has knocked does not score a Blitz.
KPV - That's just how I learned to play. If you want to change it, just edit the two lines that have the comment ;# Blitz? on them to remove the knocking test.
KBK - I'd have just have gone and fixed it, except that it appeared to be intentional. It does contradict what the cited Web page says, though.
KPV - okay, I've changed it so that it complies with what the web sites says the rules should be.
KPV May 2, 2003 - I've updated the code to no longer use the viral GPL card images but rather to use card images extracted from the Patience Starkit [L2 ].
HJG 2005-08-29 Factored out the card-images to card_img
uniquename 2013aug02
This nice quality card game deserves images to indicate the windows that this code generates.
Jeff Smith 2020-11-11 : Below is an online demo using CloudTk. This demo runs "scat" in an Alpine Linux Docker Container. It is a 27.5MB image which is made up of Alpine Linux + tclkit + scat.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.
By clicking on the "V" in the upper left corner you can access other demos.
##+########################################################################## # # Scat.tcl -- plays the card game of Scat (aka 31, Ride the Bus and Blitz) # by Keith Vetter, April 2003 # for detailed rules, see http://www.pagat.com/draw/scat.html # Card images from https://www.tcl-lang.org/starkits/patience.kit package require Tk set S(title) "Scat" set S(step) 1 ;# Animation distance per step set S(delay) 0 ;# Time between animation moves set S(pause) 1 ;# Pause between players set S(margin) 5 set S(cs) 2 ;# Card spacing set ROUND(state) 0 set ROUND(turn) w array set GAME {next,w n next,n e next,e s next,s w} array set GAME {name,w West name,n North name,e East name,s South} proc DoDisplay {} { global S wm title . $S(title) pack [frame .ctrl -relief ridge -bd 2 -padx 5 -pady 5] \ -side right -fill both -ipady 5 pack [frame .screen -bd 2 -relief raised] -side top -fill both -expand 1 canvas .c -relief raised -borderwidth 0 -height 500 -width 500 \ -scrollregion {-250 -250 250 250} -bg green4 label .msg -textvariable S(msg) -bd 2 -bg white -relief ridge pack .msg -in .screen -side bottom -fill both pack .c -in .screen -side top -fill both -expand 1 button .b1 option add *Button.font "[font actual [.b1 cget -font]] -weight bold" destroy .b1 button .knock -text Knock -command [list UserMove knock] -padx 10 bind all <Alt-c> {console show} DoCtrlFrame update GetCardPositions bind .c <Configure> {ReCenter %W %h %w} trace variable ::ROUND w Tracer } proc DoCtrlFrame {} { frame .sframe -bd 2 -relief sunken label .player -text Player .player configure -font "[font actual [.player cget -font]] -weight bold" label .lives -text Lives -font [.player cget -font] grid .player .lives -in .sframe -row 1 -sticky ew foreach who {s w n e} { label .l$who -text "$::GAME(name,$who)" -bd 0 label .s$who -textvariable GAME(lives,$who) -bd 0 grid .l$who .s$who -in .sframe -sticky ew } button .new -text "New Game" -command NewGame button .help -text Help -command Help bind .help <3> [list ShowCards 2] button .about -text About -command \ [list tk_messageBox -message "$::S(title)\nby Keith Vetter, April 2003"] grid .sframe -in .ctrl -row 1 -sticky ew grid rowconfigure .ctrl 20 -minsize 20 grid .new -in .ctrl -row 21 -sticky ew grid rowconfigure .ctrl 50 -weight 1 grid .help -in .ctrl -row 100 -sticky ew grid .about -in .ctrl -sticky ew } ##+########################################################################## # GetCardPositions -- Where cards are placed on the canvas # proc GetCardPositions {} { global S GAME foreach suit {s d c h} { foreach v {a k q j t 9 8 7 6 5 4 3 2} { lappend S(cards) "$v$suit" } } set img [Card2Image b 0] set S(cw) [image width $img] set S(ch) [image height $img] .c delete card bknock txt foreach {x0 y0 x1 y1} [.c cget -scrollregion] break set yn [expr {$y0 + $S(margin) + $S(ch) / 2.0}] set ys [expr {$y1 - $S(margin) - $S(ch) / 2.0}] set xw [expr {$x0 + $S(margin) + $S(cw) / 2.0}] set xe [expr {$x1 - $S(margin) - $S(cw) / 2.0}] set x [expr {-$S(cw) - $S(cs)}] ;# For n and s set y [expr {-$S(ch) - $S(cs)}] ;# For e and w foreach i {0 1 2 3} { set xx [expr {$x + $i * ($S(cw) + $S(cs))}] .c create image $xx $yn -anchor c -tag [list card n$i] .c create image $xx $ys -anchor c -tag [list card s$i] set yy [expr {$y + $i* ($S(ch) + $S(cs))}] .c create image $xw $yy -anchor c -tag [list card w$i] .c create image $xe $yy -anchor c -tag [list card e$i] } # Player names set x [expr {-1.5 * $S(cw) - 5 * $S(cs)}] .c create text $x [expr {$y1 - $S(margin)}] -anchor se -tag txt \ -text $GAME(name,s) -fill white -font bold .c create text $x [expr {$y0 + $S(margin)}] -anchor ne -tag txt \ -text $GAME(name,n) -fill white -font bold set y [expr {-1.5 * $S(ch) - 5 * $S(cs)}] .c create text $xw $y -anchor s -text $GAME(name,w) -fill white -font bold \ -tag txt .c create text $xe $y -anchor s -text $GAME(name,e) -fill white -font bold \ -tag txt # Position discard and stock set x [expr {($S(cw) + $S(cs)) / -2.0}] .c create image $x 0 -anchor c -tag [list card discard] set x [expr {round($x + $S(cw) + $S(cs))}] foreach i {3 2 1} { set xx [expr {$x + $i * 2}] .c create image $xx 0 -anchor c -tag [list card stock$i stocks] } .c create image $x 0 -anchor c -tag [list card stock stocks] # KNOCK message set y [expr {-$S(ch)/2.0 - 20}] .c create text 0 $y -anchor s -tag knock -font {{Times Roman} 24 bold} \ -fill red # KNOCK button set y [expr {$ys - $S(ch) / 2.0 - 10}] .c create window 0 $y -anchor s -tag bknock -window {} foreach who [list s0 s1 s2 s3 stock discard] { .c bind $who <Button-1> [list UserMove $who] } } ##+########################################################################## # # Card2Image -- returns the image name for a card--the back of the card # if the card should not be revealed. # proc Card2Image {card reveal} { if {$card == ""} {return {}} ;# No card -- show nothing if {! $reveal} { set card "back" } ;# Hidden card -- show back set iname "::img::$card" return $iname } ##+########################################################################## # # Recenter -- keeps 0,0 at the center of the canvas during resizing # proc ReCenter {W h w} { ;# Called by configure event set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}] $W config -scrollregion [list -$w2 -$h2 $w2 $h2] GetCardPositions ;# Reposition everything ShowCards } ##+########################################################################## # # NewGame -- starts a new game # proc NewGame {} { global ROUND GAME S destroy .score set S(animate) 0 ;# End any animation set ROUND(dealer) n set GAME(who) {s w n e} ;# Who's still playing foreach who $GAME(who) { set GAME(lives,$who) 3 } .c itemconfig win -text "" PlayOneRound $GAME(who) } proc PlayOneRound {who} { global ROUND PUBLIC set ROUND(who) $who ;# Who's playing set ROUND(dealer) [GetNextPlayer $ROUND(dealer)] set ROUND(turn) [GetNextPlayer $ROUND(dealer)] set ROUND(state) 0 ;# Pickup or discard state set ROUND(knock) 0 ;# No one's knocking yet set ROUND(blitz) 0 ;# No one's blitz yet catch {unset PUBLIC} set PUBLIC(dealer) $ROUND(dealer) .c itemconfig knock -text "" ShuffleCards Deal $ROUND(who) ShowCards set n [CheckForBlitz] if {! $n} ComputerMove } proc EndOfGame {} { .c itemconfig stocks -image {} .c itemconfig discard -image {} .c itemconfig knock -text "" set msg " $::GAME(name,$::ROUND(who)) Wins! " set ::S(msg) "" set w .score destroy $w toplevel $w wm transient $w . wm title $w "" if {[regexp {(\+[0-9]+)(\+[0-9]+)$} [wm geom .] => wx wy]} { wm geom $w "+[expr {$wx+150}]+[expr {$wy+150}]" } label $w.l -text $msg -font {{Times Roman} 24 bold} -fg red button $w.ok -text "OK" -command [list destroy $w] grid $w.l -row 1 grid $w.ok -pady 10 -ipadx 25 tkwait window $w NewGame } proc EndOfRound {} { global ROUND GAME S ShowCards 1 ;# Show all the cards set players $ROUND(who) set losers [FindLosers] ;# Who lost this round # Now adjust score foreach who $losers { incr GAME(lives,$who) -1 if {$who == $ROUND(knock)} { ;# Knocker w/ low score set n [incr GAME(lives,$who) -1] } if {$GAME(lives,$who) <= 0} { ;# Out of the game set GAME(lives,$who) "out" set n [lsearch $ROUND(who) $who] set ROUND(who) [lreplace $ROUND(who) $n $n] } } set w .score destroy $w toplevel $w wm transient .score . wm title $w "Score" if {[regexp {(\+[0-9]+)(\+[0-9]+)$} [wm geom .] => wx wy]} { wm geom $w "+[expr {$wx+150}]+[expr {$wy+150}]" } set font {Helvetica 10 bold} label $w.b -text "BLITZ!" -font {Helvetica 14 bold} -fg red label $w.p -text "Points" -font $font label $w.l -text "Lives" -font $font if {$ROUND(blitz) != 0} { grid $w.b - - -row 0 } grid x $w.p $w.l -row 1 -sticky ew foreach who $players { set fg [$w.p cget -fg] if {[lsearch $losers $who] > -1} {set fg red} label $w.l$who -text " $GAME(name,$who)" -font $font -fg $fg -bd 0 label $w.p$who -text $ROUND(score,$who) -font $font -fg $fg -bd 0 label $w.s$who -text $GAME(lives,$who) -font $font -fg $fg -bd 0 grid $w.l$who $w.p$who $w.s$who } label $w.msg -text " Losers are displayed in red." -font $font button $w.ok -text "OK" -command [list destroy $w] grid columnconfigure $w 0 -minsize 10 grid rowconfigure $w 20 -minsize 20 grid $w.msg - - -row 21 grid $w.ok - - -pady 10 -ipadx 25 set S(msg) "" tkwait window $w if {[llength $ROUND(who)] > 1} { PlayOneRound $ROUND(who) } else { EndOfGame } } proc ShuffleCards {} { global S CARD set cnt 0 foreach card $S(cards) { set z([expr {round(rand() * 10000)}].[incr cnt]) $card } set CARD(deck) {} foreach card [lsort -real [array names z]] { lappend CARD(deck) $z($card) } } ##+########################################################################## # # DealACard -- pops the next card off the deck # proc DealACard {} { global CARD set card [lindex $CARD(deck) 0] set CARD(deck) [lrange $CARD(deck) 1 end] return $card } proc Deal {who} { global CARD set CARD(w) [set CARD(n) [set CARD(e) [set CARD(s) {}]]] foreach _ {0 1 2} { foreach w $who { lappend CARD($w) [DealACard] } } foreach who {w n e s} { SortHand $who } set CARD(discard) [DealACard] } proc SortHand {who} { global CARD set CARD($who) [lsort -command SortHandCmd $CARD($who)] } proc SortHandCmd {c1 c2} { global S set p1 [lsearch $S(cards) $c1] set p2 [lsearch $S(cards) $c2] return [expr {$p1 - $p2}] } proc ShowCards {{reveal 0}} { ShowHand s 1 ;# Always reveal foreach who {w n e} { ShowHand $who $reveal } ShowStock if {$reveal > 1} { ;# Cheat .c itemconfig stock -image [Card2Image [lindex $::CARD(deck) 0] 1] } } proc ShowHand {who {show 0}} { SortHand $who foreach n {0 1 2 3} { .c itemconfig $who$n -image [Card2Image [lindex $::CARD($who) $n] $show] } } proc ShowStock {} { .c itemconfig discard -image [Card2Image [lindex $::CARD(discard) end] 1] set img [Card2Image back 0] .c itemconfig stock -image $img foreach i {1 2 3} { .c itemconfig stock$i -image $img } } proc Pickup {who whence} { global CARD if {$whence == "stock"} { set card [DealACard] lappend CARD($who) $card if {$who != "s"} {set card back} lappend ::PUBLIC($::ROUND(turn)) ? } else { set card [lindex $CARD(discard) end] lappend CARD($who) $card set CARD(discard) [lrange $CARD(discard) 0 end-1] ShowStock lappend ::PUBLIC($::ROUND(turn)) $card } # Figure out where we should put the card set from ${who}3 if {$who == "s"} { SortHand $who set from $who[lsearch $CARD($who) $card] } AnimateCard $whence $from $card ShowHand $who [string match s $who] } proc Discard {who which} { global CARD set card [lindex $CARD($who) $which] ;# Card to discard lappend ::PUBLIC($::ROUND(turn)) $card lappend CARD(discard) $card set CARD($who) [lreplace $CARD($who) $which $which] if {$who != "s"} {set from ${who}3} {set from $who$which} ShowHand $who [string match s $who] AnimateCard $from discard $card ShowStock } ##+########################################################################## # # UserMove -- handles the user's (south's) turn # proc UserMove {who} { global ROUND if {$ROUND(turn) != "s"} return ;# Not our turn Busy 1 while {1} { if {$ROUND(state) == 0} { ;# Knock or pickup card step .c itemconfig bknock -window {} if {$who == "knock"} { ;# Knocking KnockOrBlitz $ROUND(turn) knock lappend ::PUBLIC($ROUND(turn)) knock set ROUND(state) 0 set ROUND(turn) [GetNextPlayer $ROUND(turn)] after 1 ComputerMove break } if {$who != "discard" && $who != "stock"} break set ROUND(state) 1 Pickup s $who } else { ;# Discard step if {$who == "discard" || $who == "stock"} break foreach {_ idx} [split $who ""] break ;# Which card to discard Discard s $idx if {[ScoreHand $ROUND(turn)] == 31} { ;# BLITZ? KnockOrBlitz $ROUND(turn) blitz EndOfRound break } set ROUND(state) 0 set ROUND(turn) [GetNextPlayer $ROUND(turn)] after 1 ComputerMove } break } Busy 0 } proc Busy {onoff} { if {$onoff} { .new config -state disabled } else { .new config -state normal } } proc KnockOrBlitz {who what} { global ROUND GAME set ROUND($what) $who set msg "" foreach w $who { append msg "$::GAME(name,$w) " } if {[llength $who] == 1} { if {$what == "knock"} {set what knocks} {set what blitzes} } append msg $what .c itemconfig knock -text $msg } proc Tracer {var1 var2 op} { global ROUND GAME S if {$ROUND(state) == 0} { ;# Start of a new turn if {$ROUND(turn) == "s"} { set S(msg) "Your turn: pickup a card." } else { set S(msg) "Waiting for $GAME(name,$ROUND(turn)) to go." } } elseif {$ROUND(turn) == "s" && $ROUND(state) == 1} { set S(msg) "Discard." } } proc AnimateCard {from to card} { global S set S(animate) 1 ;# We're animating foreach {x0 y0} [.c coords $from] break foreach {x1 y1} [.c coords $to] break set dx [expr {$x1 - $x0}] set dy [expr {$y1 - $y0}] set dist [expr {sqrt($dx*$dx + $dy*$dy)}] set dx [expr {$S(step) * $dx / $dist}] set dy [expr {$S(step) * $dy / $dist}] .c create image $x0 $y0 -tag animate -image [Card2Image $card 1] for {set i 0} {$i < $dist} {incr i $S(step)} { if {! $S(animate)} break .c move animate $dx $dy update if {$S(delay) > 0} { after $S(delay) } } set S(animate) 0 .c delete animate } proc GetNextPlayer {who} { global GAME ROUND while {1} { set who $GAME(next,$who) if {[lsearch $ROUND(who) $who] > -1} { return $who } } } proc SumHand {who {extraCard {}}} { global CARD GAME set max 0 array set V {sum,s 0 sum,d 0 sum,c 0 sum,h 0 cards,s {} cards,d {} cards,c {} cards,h {}} foreach card [concat $CARD($who) $extraCard] { foreach {v s} [split $card ""] break if {$v == "a"} {set v 11} if {[string first $v "kqjt"] > -1} {set v 10} incr V(sum,$s) $v if {$V(sum,$s) > $max} {set max $V(sum,$s); set msuit $s} lappend V(cards,$s) $card } set V(max,sum) $max set V(max,suit) $msuit return [array get V] } proc ScoreHand {who} { array set V [SumHand $who] return $V(max,sum) } proc CheckForBlitz {} { set blitzers {} foreach who $::ROUND(who) { set v [ScoreHand $who] if {$v == 31} {lappend blitzers $who} } if {$blitzers == {}} {return 0} KnockOrBlitz $blitzers blitz EndOfRound return 1 } proc FindLosers {} { global ROUND foreach who $ROUND(who) { ;# Get all the scores set v [ScoreHand $who] lappend score($v) $who set ROUND(score,$who) $v } if {$ROUND(blitz) != 0} { ;# Blitz victory set losers $ROUND(who) foreach blitzer $ROUND(blitz) { set n [lsearch $losers $blitzer] set losers [lreplace $losers $n $n] } return $losers } set min [lindex [lsort -integer [array names score]] 0] set losers $score($min) if {[llength $losers] > 1} { set n [lsearch $losers $ROUND(knock)] ;# Did knocker lose in a tie??? set losers [lreplace $losers $n $n] ;# Remove knocker from list } return $losers } proc ComputerMove {} { global ROUND foreach a [after info] {after cancel $a} ;# Just be safe # Is this round over??? if {$ROUND(state) == 0 && $ROUND(turn) == $ROUND(knock)} { EndOfRound return } # Is it the user's turn if {$ROUND(turn) == "s"} { if {$ROUND(state) == 0 && $ROUND(knock) == 0} { .c itemconfig bknock -window .knock } return } set delay 1 if {$ROUND(state) == 0} { ;# Knock or pickup set move [PickupOrKnock $ROUND(turn)] if {$move == "knock"} { set ROUND(state) 2 KnockOrBlitz $ROUND(turn) knock lappend ::PUBLIC($ROUND(turn)) knock } else { set ROUND(state) 1 Pickup $ROUND(turn) $move } } elseif {$ROUND(state) == 1} { ;# Which card to discard set idx [WhichDiscard $ROUND(turn)] set ROUND(state) 2 ::Discard $ROUND(turn) $idx } elseif {$ROUND(state) == 2} { ;# End of turn if {[ScoreHand $ROUND(turn)] == 31} { ;# BLITZ? KnockOrBlitz $ROUND(turn) blitz EndOfRound return } set ROUND(turn) [GetNextPlayer $ROUND(turn)] set ROUND(state) 0 if {$ROUND(turn) != "s"} { set delay 500 } } after $delay ComputerMove } ##+########################################################################## # # PickupOrKnock -- figures out if the computer player should knock, pickup # from the discard pile or from the stock pile. # proc PickupOrKnock {who} { global CARD ROUND set PUBLIC(hand) $CARD($who) ;# All info known to $who array set V [SumHand $who] # 1) KNOCK if hand better than 21 # ...except if discard is much better??? if {$V(max,sum) > 21 && $ROUND(knock) == 0} { return knock } # What is the discard card set card [lindex $CARD(discard) end] foreach {v s} [split $card ""] break # 2) Don't pickup if < 6 if {$v < 6} { return stock } # 3) if card improves hand then pick it up array set VV [SumHand $who $card] if {$VV(max,sum) > $V(max,sum)} {return discard} return stock } ##+########################################################################## # # WhichDiscard -- Figure out which card the computer player should discard # proc WhichDiscard {who} { global CARD PUBLIC set PUBLIC(hand) $CARD($who) ;# All info known to $who array set V [SumHand $who] set min 100 ;# Get min card in min suit foreach suit {s d c h} { set v $V(sum,$suit) if {$v == 0} continue if {$v < $min} { set min $v set card [lindex $V(cards,$suit) end] } } set idx [lsearch $CARD($who) $card] return $idx } 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 text $w -wrap word -width 70 -height 29 -pady 10 button .helper.quit -text Dismiss -command {catch {destroy .helper}} pack .helper.quit -side bottom pack $w -side top -fill both -expand 1 $w tag config title -justify center -font {{Times Roman} 18 bold} $w tag config header -font "[font actual [$w cget -font]] -weight bold" \ -lmargin1 5 ;# -rmargin 5 -spacing3 1 $w tag config n -lmargin1 5 -lmargin2 5 ;# -rmargin 5 $w insert end "$::S(title)\nby Keith Vetter\n" title $w insert end "\nIntroduction" header $w insert end "This card game goes by several names including 31, " n $w insert end "Scat and Blitz. " n $w insert end "It uses a standard 52 card deck, with aces worth 11, " n $w insert end "face cards worth 10, and all other cards worth their " n $w insert end "pip value.\n\n" n $w insert end "Object" header $w insert end "The object of the game is to collect cards in one�s " n $w insert end "hand totaling as close to 31 as possible in the same " n $w insert end "suit.\n\n" n $w insert end "Play" header $w insert end "The player to the dealer's left begins and the turn " n $w insert end "passes clockwise around the table. A normal turn consists " n $w insert end "drawing a card from the stock or discard pile, then " n $w insert end "discarding one card to the discard pile.\n\n" n $w insert end "Knocking" header $w insert end "If at the start of your turn you think that your hand " n $w insert end "is not the lowest you can KNOCK instead of drawing. " n $w insert end "Each other player gets one final turn. Then, all the " n $w insert end "hands are revealed and scored.\n\n" n $w insert end "Scoring" header $w insert end "The player with the lowest hand loses a life. If there " n $w insert end "is a tie, then all of those players lose a life, except " n $w insert end "the knocker. If the knocker has the lowest hand, he loses " n $w insert end "2 lives.\n\n" $w insert end "Blitz" header $w insert end "A blitz is when a player gets a hand totalling 31, and " n $w insert end "all other players lose a life.\n\n" n $w config -state disabled } ################################################################ # Card images from Patience card game, see # http://uebb.cs.tu-berlin.de/~krischan/patience/patience-english.html # https://www.tcl-lang.org/starkits/patience.kit source card_img.tcl ################################################################ DoDisplay NewGame