Version 11 of A little Yahtzee game

Updated 2012-11-22 02:22:40 by pooryorick

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