Version 2 of A little Yahtzee game

Updated 2005-03-23 03:44:20

When Richard posted a little Pachisi game here, it reminded me that I had this dusty piece of code sitting on the shelf.

Because it predates Tcl 8.0, it doesn't use bindtags or namespaces. I've updated it to use Tcl's random number generator, but found it necessary to add post-sampling using a different congruence in order to avoid patterns in the numbers.

KBK 6 October 2000


Wow, what are the odds? I pasted this into a console, played the game, and immediately got a yatzee. Well, ok, it actually took two rolls rather than one. Maybe I should buy a lottery ticket today :-)

(time passes)

Hmmm. Must be a bug. I've gotten three yahtzee's with 4's and one with 2's in the same game. Sure wish that happened when I played for real...

Still, it's a nice little game. Amazing how much you can do with just a few lines of tcl.

-- Bryan Oakley 6 October 2000


There was a problem with seeding the pseudo-random number generator. I hope it's fixed now.

KBK 6 October 2000


 # Table defining the score card.
 # The table is a list of lists.  The elements of the sublists are:
 #  0 - Title of the row.  If missing, the row is blank.
 #  1 - Name of a global variable holding the score for this row.
 #  2 - Value of the row.
 #  3 - Procedure that scores the row.  If missing, the player cannot
 #      mouse on the row to enter a score.

 set scorecard {
     {{1's} count1 {Sum of 1's} {count 1}}
     {{2's} count2 {Sum of 2's} {count 2}}
     {{3's} count3 {Sum of 3's} {count 3}}
     {{4's} count4 {Sum of 4's} {count 4}}
     {{5's} count5 {Sum of 5's} {count 5}}
     {{6's} count6 {Sum of 6's} {count 6}}
     {}
     {{Subtotal} subtotal {Add 1's ... 6's}}
     {{Bonus if >= 63} bonus {35 points}}
     {}
     {{3 of a kind} kind3 {Sum of dice} {kind 3}}
     {{4 of a kind} kind4 {Sum of dice} {kind 4}}
     {{Full house} fullhouse {25 points} fullhouse}
     {{Sm. straight} smstraight {30 points} smstraight}
     {{Lg. straight} lgstraight {40 points} lgstraight}
     {{Yahtzee} yahtzee {50 points} yahtzee}
     {{Chance} chance {Sum of dice} chance}
     {}
     {{Extra Yahtzee's} extra {100 points per chip}}
     {}
     {{Grand total} total {Add lines 7-16}}
 }

 # Initialize random number generator

 proc random_init { seed } {
     global rand
     expr { srand($seed) }
     for {set i 0} {$i < 100} {incr i} {
         set rand($i) [expr { rand() }]
     }
     set rand(x) [expr { int( 233280. * rand()) }]
     return
 }

 # Pull a random integer in a given range. Use sampling driven by
 # a second PRNG to try to increase the number of planes on which
 # N consecutive random numbers fall.

 proc randint { range } {
     global rand
     if ![info exists rand] {
         random_init 0
     }
     set rand(x) [expr { ( 9301 * $rand(x) + 49297 ) % 233280}]
     set ind [expr { $rand(x) * 100 / 233280 }]
     set newrand $rand($ind)
     set rand($ind) [expr { rand() }]
     return [expr { int( $range * $newrand ) }]
 }

 # Make a die.  $w is the canvas, $n is the die number

 proc die {w n} {
     global dieActive
     global dieSelected
     canvas $w -width 50 -height 50 -relief raised -borderwidth 2 \
         -background \#bfbfbf
     bind $w <Enter> [list dieEnter $w $n]
     bind $w <Leave> [list dieLeave $w $n]
     bind $w <Button-1> [list dieDown $w $n]
     bind $w <ButtonRelease-1> [list dieUp $w $n]
     set dieActive($n) 1
     set dieSelected($n) 0
     return $w
 }

 # Dice change colors as they roll.  This is the table of colors they
 # take on.

 set dieColor(0) \#ff5f5f
 set dieColor(1) \#bfbfbf
 set dieColor(2) \#ff5f5f
 set dieColor(3) \#bfbfbf
 set dieColor(4) \#ff5f5f
 set dieColor(5) \#bfbfbf

 # Roll die whose canvas is $w, whose die number is $n, and which
 # has bounced $times times

 proc dieRoll {w n {times 0}} {
     global dieSelected
     global dieColor
     global dieValue
     if { !$dieSelected($n) } return
     if {$times == 0} {
         catch {unset dieValue($n)}
     }
     $w configure -background $dieColor($times)
     $w delete all
     set v [expr { [randint 6] + 1 }]
     if {$v % 2} {
         $w create oval 20 20 30 30 -fill black
     }
     if {$v >= 2} {
         $w create oval 5 5 15 15  -fill black
         $w create oval 35 35 45 45 -fill black
     }
     if {$v >= 4} {
         $w create oval 5 35 15 45 -fill black
         $w create oval 35 5 45 15 -fill black
     }
     if {$v >= 6} {
         $w create oval 5 20 15 30 -fill black
         $w create oval 35 20 45 30 -fill black
     }
     incr times
     if {$times > 5} {
         set dieValue($n) $v
     } else {
         after [expr { 50 * $times + [randint 150] }] dieRoll $w $n $times
     }fffffff
 }

 # Mouse into a die

 proc dieEnter {w n} {
     global dieCurrent
     set dieCurrent $w
 }

 # Mouse out of a die

 proc dieLeave {w n} {
     global dieCurrent
     set dieCurrent {}
 }

 # Button down in a die

 proc dieDown {w n} {
     $w configure -relief sunken
 }

 # Button up in a die

 proc dieUp {w n} {
     global dieCurrent
     global dieSelected
     global dieActive
     $w configure -relief raised
     if {!$dieActive($n)} return
     if { [string match $w $dieCurrent] } {
         set dieSelected($n) [expr { !$dieSelected($n) }]
         if {$dieSelected($n)} {
             $w configure -background \#7fffff
         } else {
             $w configure -background \#bfbfbf
         }
     }
 }

 # Is a die active? -- that is, is it listening to mouse clicks?

 proc dieActive {n v} {
     global dieActive
     set dieActive($n) $v
 }

 # Is a die selected for reroll?

 proc dieSelected {n v} {
     global dieSelected
     set dieSelected($n) $v
 }

 # Wait for a die to settle down

 proc dieWait {n} {
     global dieValue
     if { ![info exists dieValue($n)] } {
         vwait dieValue($n)
     }
 }

 # Make an initial die roll

 proc initroll {} {
     global scoreActive
     set scoreActive 0
     for {set n 1} {$n <= 5} {incr n} {
         dieActive $n 0
         dieSelected $n 1
         .dice.d$n delete all
         .dice.d$n configure -background \#bfbfbf
         .action configure -text "Roll!" -command {doroll 1} \
             -state normal
         .message configure -text {
 Press `Roll!' to roll the dice.}
     }
 }

 # Make a die roll.  $roll is 1, 2, or 3

 proc doroll {roll} {
     global scoreActive
     global dieSelected
     set scoreActive 0
     set someDieSelected 0
     for {set n 1} {$n <= 5} {incr n} {
         if { $dieSelected($n) } {
             set someDieSelected 1
             break
         }
     }
     if { !$someDieSelected } return
     .action configure -state disabled
     for {set n 1} {$n <= 5} {incr n} {
         dieRoll .dice.d$n $n 0
     }
     for {set n 1} {$n <= 5} {incr n} {
         dieWait $n
     }
     if {$roll < 3} {
         for {set n 1} {$n <= 5} {incr n} {
             dieActive $n 1
             dieSelected $n 0
         }
         incr roll
         .action configure -text "Roll $roll" \
             -command [list doroll $roll] \
             -state normal
         .message configure -text {Select dice to reroll, and press `Roll!', or
 select a line of the scorecard.} 

     } else {
         .action configure -text "Score" -state disabled
         .message configure -text {
 Select a line of the scorecard.} 

     }
     set scoreActive 1
 }

 # Display the score card

 proc scorecard w {
     global scorecard
     frame $w -relief raised -borderwidth 2
     grid columnconfigure $w 1 -weight 1
     grid columnconfigure $w 2 -weight 1
     set i 0
     foreach line $scorecard {
         if {[llength $line] == 0} {
             frame $w.sep$i -relief flat -height 2 -background black
             grid $w.sep$i - - - -sticky ew
         } else {
             incr i
             set title [lindex $line 0]
             set vname [lindex $line 1]
             set desc [lindex $line 2]
             set pname [lindex $line 3]
             label $w.n$i -text $i -relief sunken -borderwidth 2 \
                 -anchor w
             label $w.t$i -text $title -relief sunken -borderwidth 2 \
                 -anchor w
             label $w.d$i -text $desc -relief sunken -borderwidth 2 \
                 -anchor w
             label $w.s$i -relief sunken -borderwidth 2 -anchor e \
                 -width 3 -textvariable score($vname)
             bind $w.s$i <Enter> [list scoreEnter %W $i $pname $vname]
             bind $w.s$i <Leave> [list scoreLeave %W $i $pname $vname]
             bind $w.s$i <Button-1> [list scoreDown %W $i $pname $vname]
             bind $w.s$i <ButtonRelease-1> \
                 [list scoreUp %W $i $pname $vname]
             grid $w.n$i $w.t$i $w.d$i $w.s$i -sticky ew
         }
     }
     return $w

 } 

 # Enter a cell on the score card

 proc scoreEnter {w line pname vname} {
     global scoreActive
     global score
     global tempScore
     global tempBG
     global scoreCurrentWin
     set scoreCurrentWin $w
     set tempBG [$w cget -background]
     if {$scoreActive == 0} return
     if { [string compare $score($vname) {}] } return
     $w configure -textvariable tempScore -background \#ffff7f
     diceCount
     set tempScore [eval $pname]
 }

 # Leave a cell in the score card

 proc scoreLeave {w line pname vname} {
     global scoreActive
     global score
     global tempBG
     global scoreCurrentWin
     set scoreCurrentWin {}
     if {$scoreActive == 0} return
     if { [string compare $score($vname) {}] } return
     $w configure -textvariable score($vname) -background $tempBG
     catch {unset tempScore}
 }

 # Button press on a cell in the score card

 proc scoreDown {w line pname vname} {
     global scoreActive
     global score
     if {$scoreActive == 0} return
     if { [string compare $score($vname) {}] } return
 }

 # Button release on a cell in the score card -- score the roll.

 proc scoreUp {w line pname vname} {
     global scoreActive
     global score
     global scoreCurrentWin
     global tempScore
     global tempBG
     global linesUsed
     if {$scoreActive == 0} return
     if { ![info exists tempScore] } return
     if { [string compare $score($vname) {}] } return
     if { [string compare $w $scoreCurrentWin] } return
     $w configure -textvariable score($vname) -background $tempBG
     set score($vname) [eval $pname 1]
     unset tempScore
     if {[incr linesUsed] >= 13} {
         endGame
     } else {
         initroll
     }
 }

 # Count the number of 1's, 2's, etc... rolled

 proc diceCount {} {
     global dieValue
     global dieCount
     global dieTotal
     set dieTotal 0
     for {set d 1} {$d <= 6} {incr d} {
         set dieCount($d) 0
     }
     for {set n 1} {$n <= 5} {incr n} {
         incr dieCount($dieValue($n))
         incr dieTotal $dieValue($n)
     }
 }

 # Score up 1's, 2's etc.

 proc count {d {done 0}} {
     global dieCount
     global score
     set c [expr { $dieCount($d)*$d }]
     if {$done} {
         incr score(subtotal) $c
         incr score(total) $c
         incr score(difference) [expr { $c-3*$d }]
         if {$score(subtotal) >= 63 && $score(bonus) == 0} {
             set score(bonus) 35
             incr score(total) 35
         }
         checkXtra
     }
     return $c
 }

 # Score 3-of-a-kind, 4-of-a-kind

 proc kind {need {done 0}} {
     global score
     global dieCount
     global dieTotal
     set rv 0
     for {set d 1} {$d <= 6} {incr d} {
         if {$dieCount($d) >= $need} {
             set rv $dieTotal
         }
     }
     if {$done} {
         incr score(total) $rv
         checkXtra
     }
     return $rv
 }

 # Score full house

 proc fullhouse {{done 0}} {
     global dieCount
     global score
     for {set n 1} {$n <= 5} {incr n} {
         set have($n) 0
     }
     for {set d 1} {$d <= 6} {incr d} {
         set have($dieCount($d)) 1
     }
     if {$have(5) || ($have(2) && $have(3))} {
         set rv 25
     } else {
         set rv 0
     }
     if {$done} {
         incr score(total) $rv
         checkXtra
     }
     return $rv
 }

 # Score chance

 proc chance {{done 0}} {
     global score
     global dieTotal
     if {$done} {
         incr score(total) $dieTotal
         checkXtra
     }
     return $dieTotal
 }

 # Score small-straight

 proc smstraight {{done 0}} {
     global dieCount
     global score
     set rv 0
     if {$dieCount(3) && $dieCount(4)} {
         if {$dieCount(1) && $dieCount(2) \
                 || $dieCount(2) && $dieCount(5) \
                 || $dieCount(5) && $dieCount(6)} {
             set rv 30
         }
     }
     set x [isyahtzee]
     if {$x \
             && [string compare $score(count$x) {}] \
             && [string match $score(yahtzee) 50]} {
         set rv 30
     }
     if { $done } {
         incr score(total) $rv
         checkXtra
     }
     return $rv
 }

 # Score large-straight

 proc lgstraight {{done 0}} {
     global dieCount
     global score
     set rv 0
     if {$dieCount(2) && $dieCount(3) && $dieCount(4) && $dieCount(5)} {
         if {$dieCount(1) || $dieCount(6)} {
             set rv 40
         }
     }
     set x [isyahtzee]
     if {$x \
             && [string compare $score(count$x) {}] \
             && [string match $score(yahtzee) 50]} {
         set rv 40
     }
     if { $done } {
         incr score(total) $rv
         checkXtra
     }
     return $rv
 }

 # Score yahtzee

 proc yahtzee {{done 0}} {
     global score
     if { [isyahtzee] } {
         set rv 50
     } else {
         set rv 0
     }
     if {$done} {
         incr score(total) $rv
     }
     return $rv
 }

 # Check for an extra yahtzee

 proc checkXtra {} {
     global score
     if {[string match $score(yahtzee) 50] && [isyahtzee]} {
         incr score(extra) 100
         incr score(total) 100
     }
 }

 # Check if this roll is a yahtzee

 proc isyahtzee {} {
     global dieCount
     for {set d 1} {$d <= 6} {incr d} {
         if {$dieCount($d) == 5} {
             return $d
         }
     }
     return 0
 }

 # End game

 proc endGame {} {
     .action configure -text "Game Over" -command newGame -state disabled
     .message configure -text {Press `New Game' to play
 again, or `Quit' to exit.}
 }

 # New game

 proc newGame {} {
     global scorecard
     global score
     global linesUsed
     initroll
     set linesUsed 0
     foreach line $scorecard {
         set vname [lindex $line 1]
         set score($vname) {}
     }
     set score(subtotal) 0
     set score(difference) 0
     set score(total) 0
     set score(bonus) 0
     set score(extra) 0
     set scoreCurrentWin {}
 }

 # Make the user interface

 catch {wm title . Yahtzee}
 catch {wm minsize . 300 500}
 set fn helvetica
 grid columnconfigure . 0 -weight 1
 grid columnconfigure . 2 -weight 1
 grid [frame .dice] - - - -sticky ew -pady 10
 for {set n 1} {$n <= 5} {incr n} {
     grid columnconfigure .dice $n -weight 1
     grid [die .dice.d$n $n] -row 1 -column $n
 }
 grid [scorecard .score] - - -
 grid [button .action -background \#bfbfbf -width 8] \
     [button .newgame -command newGame \
          -text "New Game" -background \#7fffff -width 8] \
     [button .quit -command exit \
          -text "Quit" -background \#ff5f5f -width 8] \
     [label .diff -textvariable score(difference)] \
     -pady 10

 grid [label .message] - - - -sticky ew

 # Set window state and prime the random number generator

 set dieCurrent {}
 set scoreCurrentWin {}
 random_init [clock seconds]

 # Launch the game

 newGame

 console show

Category Games