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 ====================== I've made quite a few constructive changes to this program , but haven't updated the widget below. You'll find the new game (tkyahtzee) at http://tkgames.sf.net stevenaaus, jan, 2006. ===================== 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 [list dieEnter $w $n] bind $w [list dieLeave $w $n] bind $w [list dieDown $w $n] bind $w [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 } } # 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 [list scoreEnter %W $i $pname $vname] bind $w.s$i [list scoreLeave %W $i $pname $vname] bind $w.s$i [list scoreDown %W $i $pname $vname] bind $w.s$i \ [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]