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
}
}
# 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