Intro edit
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 [1]. 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 [2].HJG 2005-08-29 Factored out the card-images to card_img
uniquename 2013aug02This nice quality card game deserves images to indicate the windows that this code generates.
Program edit
##+##########################################################################
#
# 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 http://tcl.tk/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
# http://tcl.tk/starkits/patience.kit
source card_img.tcl
################################################################
DoDisplay
NewGame
