Updated 2018-09-20 23:52:04 by jdc

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
#!/bin/sh
# the next line restarts using tclsh \
exec wish "$0" "$@"


package require Tk

set data(version) 1.2.4
set data(name) TkYahtzee
set data(date) 26/10/2008
set data(web) http://tkgames.sf.net

set rcfile "~/.tkyahtzeerc"

# 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  Yahtzees} extra {100  points  each}}
    {}
    {{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 dieBackGround
    global dieSelected

    canvas $w -width 50 -height 50 -relief flat -borderwidth 2 -background $dieBackGround
    bind $w <Enter> "dieEnter $w $n"
    bind $w <Leave> "dieLeave $w $n"
    bind $w <Button-1> "diePressInit $w $n"
    bind $w <ButtonRelease-1> "diePress $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.
# (colors were prev: \#ff5f5f , \#bfbfbf (skyblue,skyblue3))

# lavenderblush3 mistyrose3 \#bfbfbf
set dieBackGround lavenderblush3
set dieColor(0) skyblue
set dieColor(1) skyblue3
set dieColor(2) skyblue
set dieColor(3) skyblue3
set dieColor(4) skyblue
set dieColor(5) $dieBackGround

# 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 dieColor 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 diePressInit {w n} {
    # S.A. $w configure -relief sunken
}

proc diePress {w n} {
    global dieCurrent dieSelected dieActive dieNumPressed roll dieBackGround

    # S.A. $w configure -relief raised
    if {!$dieActive($n) || $roll == 3} return
    if { [string match $w $dieCurrent] } {
        set dieSelected($n) [expr { !$dieSelected($n) }]
        if {$dieSelected($n)} {
            incr dieNumPressed
            .action configure -state normal
            $w configure -background tan ;# lightgreen
        } else {
            incr dieNumPressed -1
            if {$dieNumPressed == 0} {.action configure -state disabled}
            $w configure -background $dieBackGround
        }
    }
}

# 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 dieNumPressed roll dieBackGround
    set scoreActive 0
    set dieNumPressed 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 $dieBackGround
    }
    .action configure -text "R o l l  1" -command {set roll 1 ; doroll} -state normal -padx 60
}

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

proc doroll {} {
    global scoreActive dieSelected dieNumPressed roll

    set scoreActive 0

    .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
        }
        set dieNumPressed 0
        .action configure -text "R o l l  [expr $roll + 1]" -command "incr roll ; doroll"
    } else {
        .action configure -text "S c o r e" -state disabled
    }
    set scoreActive 1
}

# Display the score card

proc scorecard w {
    global scorecard tcl_patchLevel
    frame $w -relief flat -borderwidth 2 ;# raised, no pad - S.A.

    if {[string match 8.5* $tcl_patchLevel]} {
      grid columnconfigure $w 0 -weight 1 -pad 18
      grid columnconfigure $w 1 -weight 1 -pad 22
      grid columnconfigure $w 2 -weight 1 -pad 10
      # grid rowconfigure $w all -minsize 2 ... makes no diff S.A.
    } else {
      grid columnconfigure $w 1 -weight 1
      grid columnconfigure $w 2 -weight 1
    }

    set i 0
    set RELIEF groove ;# S.A.
    set FONT {8x13}
    foreach line $scorecard {
        if {[llength $line] == 0} {
            frame $w.sep$i -relief flat -height 1 -background yellow
            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 $RELIEF -font $FONT -borderwidth 2 -anchor w
            label $w.t$i -text $title -relief $RELIEF -font $FONT -borderwidth 2 -anchor w
            label $w.d$i -text $desc -relief $RELIEF -font $FONT -borderwidth 2 -anchor w
            label $w.s$i -relief $RELIEF -font $FONT -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
            grid $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 score tempScore tempBG scoreCurrentWin

    set scoreCurrentWin $w
    set tempBG [$w cget -background]
    if {$scoreActive == 0} return
    if { [string compare $score($vname) {}] } return

    # \#ffff7f was the orig color S.A.

    $w configure -textvariable tempScore -background yellow3 ;#rosybrown, yellow3, khaki

    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
}

proc endGame {} {
    global score rcfile env highscores username tcl_platform

    set highscores {}

    ### read in file if it exists
    if {[file readable $rcfile ]} {
        set fid [open $rcfile r]
        while {![eof $fid]} {
            gets $fid line
            if {[string is integer [lindex $line 0]] && "$line" != ""} {
                lappend highscores $line
            }
        }
        close $fid
    }

    if {[lindex [lindex $highscores end] 0] < $score(total) \
        || [llength $highscores] < 14 } {
        ### new high score

        # get a name

        if {![info exists username]} {
            if { $tcl_platform(platform) == "unix" } {
                set username $env(USER)
            } else {
                set username $env(USERNAME)
            }
        }
        set username [getName $username]
        destroy .name

        # sort them and keep only best 15

        set newentry "[format "%3i" $score(total)] [format "%-15s" $username] [clock format [clock seconds] -format %d/%m/%y]"
        lappend highscores $newentry
        set highscores [lrange [lsort -integer -index 0 -decreasing $highscores] 0 13]

        ### write highscores

        set fid [open $rcfile w]
        foreach line $highscores {
            puts $fid "$line"
        }
        close $fid

        showScores $newentry
    }

    .action configure -text "N e w  G a m e" -command newGame -padx 31 -state normal
}

proc getName {default} {
    global result

    initSubWindow .name "High Score" 1

    message .name.msg -text "Please enter a name" -aspect 1000

    entry .name.entry -textvariable name
        .name.entry delete 0 end
        .name.entry insert 0 $default
        .name.entry icursor end
        raise .name
        focus .name.entry
        update
        bind .name.entry <Return> {set result $name}
    button .name.button -text ok -command {set  result $name} -pady .7 -activebackground lightgoldenrodyellow

    pack .name.msg .name.entry -side top -fill x
    pack .name.entry -pady 5 -padx 10
    pack .name.button -side bottom

    center .name
    wm deiconify .name
    update
    tkwait variable result
    return [string range $result 0 14]
}


proc initSubWindow {w title transient} {

  # Initilaises a toplevel window offscreen and withdrawn
  # (to allow the user to pack it before centering and being drawn)

  # I tried to use bind <FocusIn|Enter> to raise the window,
  # but using "grab" stops this command taking effect.
  # Additionally, using grab is the only way I know of to disable menus

  catch {destroy $w}
  toplevel $w
  wm title $w $title
  wm withdraw $w
  wm geometry $w +2000+2000

  if {$transient} {
    wm transient $w .

    bind . <FocusIn> "raise $w ; focus -force $w"
  }
  wm protocol $w WM_DELETE_WINDOW "closeSubWindow $w"

}

proc grabSubWindow {w} {

  # There is an obscure bug in the grab code that means grab shouldn't be used till window
  # is drawn, so put grab here

  global data

  if { $data(platform) == "unix"} {
    grab set $w
  }
}

proc closeSubWindow {w} {
  bind . <FocusIn> ""
  grab release $w
  destroy $w
}

proc closeDialog {w {cmd ""}} {

  closeSubWindow $w
  .c configure -state normal
  if { $cmd != "" } {
       uplevel #0 $cmd
     }
}

proc center {win} {
  # Center window $win on the screen

  set w [winfo reqwidth $win]
  set h [winfo reqheight $win]
  set parent [winfo parent $win]

  if {"$parent" == "" } {
    set sh [winfo screenheight $win]
    set sw [winfo screenwidth $win]
    set reqX [expr {($sw-$w)/2}]
    set reqY [expr {($sh-$h)/2}]
  } else {
    scan [wm geometry $parent] "%dx%d+%d+%d" a b c d
    set reqX [expr $c + ($a-$w)/2]
    set reqY [expr $d + ($b-$h)/2]
  }
  if {$reqX < 0} {set reqX 0}
  if {$reqY < 0} {set reqY 0}

  wm geometry $win +$reqX+$reqY
  update idletasks
  return;
}

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

proc showScores {{newentry {}}} {

    global rcfile tcl_platform

    initSubWindow .scores  "High Scores" 1

    text .scores.t -relief groove -spacing1 3 -back grey80 -height 15 
    .scores.t tag configure center -justify center 
    .scores.t tag configure hilight -background gainsboro -justify center

    .scores.t insert end "High Scores\n" center

    if {[file readable $rcfile]} {
        set fid [open $rcfile r]
        while {![eof $fid]} {
            gets $fid line
            if {$line != {} && $line == $newentry} {
                .scores.t insert end "$line\n" hilight
            } else {
                .scores.t insert end "$line\n" center
            }
        }
           close $fid
    }
    
    button .scores.b -text ok -command {closeSubWindow .scores} -pady .7 -activebackground lightgoldenrodyellow
    
    # gates is a piece of shit
    if { $tcl_platform(platform) != "unix" } {
        .scores.t configure -font {courier 9}
        .scores.b configure -font {Arial 9} -padx 15 -pady .5
    }

    pack .scores.t -padx 5 -pady 2
    pack .scores.b -side bottom

    # centre the help window before enabling

    update
    scan [wm geometry .] "%dx%d+%d+%d" e f g h
    set x [expr $g+30]
    set y [expr $h+60]
    wm geometry .scores "250x305+$x+$y"
    wm state .scores normal
    update
}


proc initHelp {} {

  global help data tcl_patchLevel

  # basically each help text ("k") is just a list of {text format text format ....}
  # where format is the text "tag" that determines any special formatting

  foreach {i j k} {

    0 TkYahtzee {
{Yahtzee is game played with 5 dice.  You roll them - up to 3 times - trying to
get patterns which match the entries in the score card.

After the first roll, only unwanted dies are rolled a second and third time,
trying to get the best score.  You must then select one entry to score against
before starting the next round.

The game is over and a score tallied after all the entries are full.

A bonus of 35 points is gained if the upper score card sub-total is 63 or
greater.

Extra Yahtzees score a 100 point Bonus (though this is not official rules).} {} \n\n {}
}

    1 Changes {
{1.2.4 Bug with destroying the highscore window - fixed. 07/10/08. Help menu up/down key bindings 26/11/08} indent \n\n {}

{1.2.3 Restructured 'help' and 'about' widgets, adding a 'changes' widget 10/11/07} indent \n\n {}

{1.2.2 Changed around a few colours, and the fonts for wish8.5, 22/07/07} indent \n\n {}

{1.2.1 Added a high score widget, overhauled buttons, added menus, removed message widget , fixed up win fonts, added help dialogs, removed the 1,2,...17 column from the scorecard  18/01/06} indent \n\n {}

{1.01 Moved button close to dice, sanity checked the colour scheme 14/11/05} indent \n\n {}

{- Downloaded Kevin's yahtzee from www.tcl.tk} indent
}

    2 About {}
} {
      set help($i) ""
      set help(title,$i) "$j"
      set help(text,$i) "$k"
  }

  # end foreach

  set help(text,2) [list "$data(name) $data(version) ($data(date)) copyright Steven A. Released under the GPL v2. Available at $data(web).\n\n" {} "Based on: Yahtzee, downloaded from www.tcl.tk, written by Kevin Kenny.\n\n" {} "Tcl Version $tcl_patchLevel.\n" {} ]

}

proc showHelp {{topic 0}} {

  global p help data

  set w .help

  if { [winfo exists $w] } {
    showHelpTopic  $w $topic
    wm deiconify $w
    raise $w
    focus $w
    return
  }

  initSubWindow $w "$data(name) - Help" 0

  pack [listbox $w.l -activestyle none -selectmode single -font $data(font_default) -width 12] \
    -expand 0 -fill y -side left -anchor nw
  bind $w.l <<ListboxSelect>> "showHelpTopic $w"
  pack [text $w.t -width 30 -height 25 -yscrollcommand "$w.s set" \
                  -wrap word -font $data(font_default) -padx 5 -pady 8] \
        -expand 1 -fill both -side left -anchor nw
  $w.t tag configure "title" -font $data(font_large) -justify center
  $w.t tag configure "indent" -lmargin2 15
  $w.t tag configure "indent2" -lmargin1 8 -lmargin2 20
  $w.t tag configure "italic" -font "[font actual [$w.t cget -font]] -slant italic"
  $w.t tag configure "link" -font "[font actual [$w.t cget -font]] -underline 1" \
                            -foreground blue 
  $w.t tag bind link <Enter> "%W configure -cursor hand2"
  $w.t tag bind link <Leave> "%W configure -cursor {}"
  pack [scrollbar $w.s -command "$w.t yview"] -fill y -side left -anchor ne

  # populate list, show index topic
  foreach x [lsort [array names help -regexp {^[0-9]+$}]] {
    $w.l insert end $help(title,$x)
    $w.t tag bind goto$x <Button-1> "showHelpTopic $w $x"
  }

  bind $w <KeyPress-q> "destroy $w"
  # there's a minor unresolved issue with wish8.5 and focus
  bind $w <KeyPress-Up> "$w.t yview scroll -1 unit"
  bind $w <KeyPress-Down> "$w.t yview scroll +1 unit"
  bind $w <KeyPress-Prior> "$w.t yview scroll -1 page"
  bind $w <KeyPress-Next> "$w.t yview scroll +1 page"
  focus $w
  update
  center $w
  wm deiconify $w
  showHelpTopic $w $topic
  $w.t configure -state disabled
}

proc showHelpTopic {w {topic {}}} {

  global help

  # show a specific help topic in the window
  # $w is toplevel, $w.t is the text frame

  if { $topic != {}} {
    $w.l selection clear 0 end
    $w.l selection set $topic
    $w.l activate $topic
  }

  $w.t configure -state normal
  $w.t delete 1.0 end
  set helpFile [$w.l curselection]
  $w.t insert end $help(title,$helpFile) title
  $w.t image create end -image ::img::logo -align center -padx 20
  $w.t insert end "\n\n"
  foreach {text tags} $help(text,$helpFile) {
    $w.t insert end $text $tags
  }
  $w.t configure -state disabled

}

proc exitYahtzee {} {
    exit
}


# main #


. configure -menu [menu .m -tearoff 0]

.m add cascade -label "Game" -underline 0 -menu [menu .m.g -tearoff 0]
    .m.g add command -label "New Game" -underline 0 -command newGame
    .m.g add command -label "High Scores" -underline 0 -command showScores
    .m.g add command -label "Quit" -underline 1 -command exitYahtzee

# .m add cascade -label "Options"  -underline 0 -menu [menu .m.o  -tearoff 0]
#    .m.o add command -label "Background Colour" -underline 0 -command showColor

.m add cascade -label "Help"  -underline 0 -menu [menu .m.help -tearoff 0]
  .m.help add command -label "Help"  -command showHelp -underline 0
  .m.help add command -label "Changes" -command {showHelp 1} -underline 0
  .m.help add command -label "About" -command {showHelp 2} -underline 0

# used by new help widgets

set data(font_default)   {Arial -16}
set data(font_medium) {Arial -18}
set data(font_large) {Arial -20}


catch {wm title . "$data(name) $data(version)"}
catch {wm minsize . 300 500}

grid columnconfigure . 0 -weight 1
grid columnconfigure . 2 -weight 1

grid [scorecard .score] - - -

set FONT {8x13bold}

grid [frame .padding] - - - -sticky ew -pady 3 ;#  padding S.A.


grid [label .dummy -text {}  -padx 16 ] \
     [button .action -text {} -padx 60 -pady 5 ] \
     [label .diff -textvariable score(difference) -padx 16] \

if { $tcl_platform(platform) == "unix" } {
    .action configure -font {Arial 20}
} else {
    .action configure -font {Arial 10}
}

#     [button .button -image im1 -fg "lightslategray" -borderwidth 1 -padx 5 -pady 5 -activeforeground lightslategray -activebackground grey82 ] 


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
}

# set window state and prime the random number generator

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

image create photo ::img::logo -data {
R0lGODlhQABAAOf/AAABAAgLBw0PDBIUERgZFxsdGh4gHiIkISYoJSssKi4w
LTI0MTY3NTg6OD0+PEFCQEVGRElLSElKU05MT0xOS0tPUUtRSFBOUk1RU1BS
T1BRWVNRVVZQWk5aP1FZRFRVU1JYT1VYSldVWVZYVVRXZVRZW1dYYVpYXFdc
U1pXZlVdWVhcalphTF1aalpeYF5cYF1kOFxeW11gUl5eZ19hXl1jWmJfY2Nh
ZWJkYV9jcWVicmJmaGRlbmZoZWtlb2lnamVrYWZqeGpraWxpeW9pdGtsdWxu
a2trgG9tcWpth2p5UG9xbm1xdHBxenN1cnhyfXZ0eHZzgnZ3dXh6d3x6fnl5
jnd7iXx+e3x8hn56lnuAgoB+gn+BfoCAioOBhYKEgX+DkX+CnYSAnISGg4OD
mISFjn+GmoiGioaIhYeJhoaGm4SHooaLjYmLiH2Qj42Lj4uNio2JmoOPnIyO
i42JpYuLoYmNnIyNloiMp4uQkoWRno6QjZKQlJCSj42RoJKOq5CQppOQoI2R
rIuTp5KUkZKTnZSWk5aSr5OYm42ZppWVq5CYrJeZloufnpaZqJiXrpmbmJuY
qZqapJidoJudmZqasJ6coJyem5SgrZ2fnJ2cs5ygsJilpaCftqGjoKOfsKGh
q5uoqKSmo6Slr6iktaOntpyssqmnq6amvKWqraiqp6ustamtvKqvsa6rvK2v
rKysw7GzsK6ywbSwwbKyvLGxx7Wzt7S2s7S1v7O3x7e5trm2x7e4wrq4vLm7
uL25y7u8xry+u7q+zcC+wr/Bvr+/1sLEwcDFyMbDx8PEzsXHxMjE1sfJxsXK
zcjJ08vJzcvNys3PzNDN0svQ0s7P2dHN39DSz9LU0dXT19XR49TW09TU39LX
2dbY1dnW29zV4dXa3Nnb19rc2d3a39vd2tze293f3N7g3d/h3tzi5OLg5ODi
3+Lk4ebj6OTm4+Ln6ubo5efp5unr5+rs6evu6u7s8O3v7O3y9fDy7/L18fXz
9/b49PT5/Pn79/z++////yH5BAEKAP8ALAAAAABAAEAAAAj+AP8JHEiwoMGD
CBMqXMiwocOHECNKnEixosWLGDNq3Mixo8ePIC1yMhWqkRtHlUJirPUtW7Vl
xWqVwrSpk6aUKh1WgqWunz9+/vDVG/ctWS5XnSopEsRUUM6Dj3Z5u6fPn1V9
WO/Va5cOHDVnyXbNIqVJ0dOBh6Tay6dvn1Wr+PLlqzdvnrpefc7YQias7Nl/
qKilg9fOHlas+PTVo1d3HrY3DhiwaeaN1aOnf0i1U2crEzF4+/r10ye3Xr14
8/DdEiGAAAND6nhdVvlHFjV3aSIwuDCsHta5i+PRxYfMBoEECahAS4YTJB1X
1M4h+2DAAIJX8vaRtneasLpw2t7+MCCg4Ay2Z5XwhKwkDZ46TwwMJGBgC95a
usLhIfPEiNktKg7Y4Ik51HRSB0WYHHLIIokYRIcm2LQDzzinJCBAAlI8Yxpw
8MSjjRQECADFMOP48kw452jzCSASDVLJLMk8s8sndBBkRifAtIMOPOc8hoQX
yKjDDjx0wQMPPsP4cNwDe4SjjjrjOMkKixAdUkou0qRDIC+kKDKIQHKUgow8
T6IzDjLBKFPOk+7MQ2Q8+TCDBAEIHECFNeucE+U4s5gFUSe/cMNOmeokg0ok
Dd4hyS7qlLPmOoS5h8456tTj3nnPvPGAfFdg81044awjWxYNlaIJLN4YyeM5
4aCjzjX+uzxihhl+0OKekyiC+qST6sCjixQRWGILHwzYcAquUaKDzCakLlQK
K8KME+mT1JYzDjbIuIIHHqjoyus4n34nTzlvJGDAA20g0wsy0aiDzbVPOqNJ
GAoJU8os36jzjjzusRPqmqCCA440pAASCTbdhNNNwgmH42k48GCzxQEHGCCE
MfF8Vw6ooJ5zTSn0ImRvMemkZo+R8Rj5JMC7PrPiiVFSG6XC4KLDhwMJEGBD
fZR6i0043rhCxkFyAALLN1XhY088Eho5pHvqaKNNOT2SEggwvEIM5Xdcz9ML
Eq0JESSo3iS8azi0qGFQJaQk044+VCmN3zN82CCFJ9Hg6qT+NqvEYcvPxLyx
hSjacByONc8wY8sZb9gSjjlcq+ONw04CE0gSAz3SSS7f1OOWPonNE0/Kp1Aw
nw2W4Poz2nGAgo0xX0QmRC9PnueLLbG8osorJiKDDTZ5Y9OzOsdIcsRAisCy
TVVVBWWPPfOcRggDBRyggA0/h2uLH4FgYwkEIU5winvR9MKfJeifcooou98y
DDLQPBPNz8+AcrxAgOSSjlv+JK3Y6PYYhhAIQMAJZO9a6xiGJLowjC0gxwAf
GB82fIE+SGSCEoYgBB/48AY+7GEPfIDEKVRhC2L0whL3+4cidtEeejAPdNAT
TjiGcYYfSAESoFqdOqRhiSgMQzz+rnlDNK6hi1NkAn1I5IMhDNGHOWxwDm9o
gwc3CIYgDAQQvJBGrwwDOqFYSmXKsEUvPLWxqJVjGqPggS1O4QUbjGGMvRCF
JTIBCUrMYQo4sIEQvMAHOLQhimf4QiCp0IQhDGEggpiFNMLxDGyYwx6JgV6k
4OEmMoFqZtpAhiV0cIppTBAb0NCFJ+aIRClMgAEJcEAM+sDBP7YhkF5oAg9y
QJD8YeMalDjDsezDHaZRK3LeGoYq8pADSyjDSNg44REpwQhLvIECrknAARjw
Biim4QzX5EITdDCDguCBFs84BQMQ8AFLqKMd7RhdyuDBDoA5yRvIsIUc3+CD
OwzDXbr+UMUy0ceIPWzAAAc43R7ecM1rUgEJ3TQIHnAxDD4QUAFC8NSTVLUr
qEXDGKqwBCMIwQYedMEW0RjGKUjJiCVagg9QmMADJmCDKQz0lWM46A5WcJA6
7KKh8knAB6yhK2qxc1fW6MUp+KBBPpwBCVBgRC8ycQlLNLWZGyQEHM4ABSl8
4Q0EDeQWEKoChNSBFtKwxXh09jCzQWxQ6oDGK9oABz4wAhKGoOoMfnQGEDaT
EZSABCOmaAg+zOGaaDjDFnzgghIkhA6ymF/dpGAJVq2OV1ELhiVs4IAPXAGl
UuACF4SwAxvY4AY/8AERnvAELzBug37F6iup8IMPLOQ5WrT+hi1M9KlrUS4c
yBAFF8z1gCUsYQIspcIHMrCBE2xABBzQARB6AAQhCAGpUKACFbbwBSn84ASu
VUgYVgGNNVEKHdqAEq4+dQtLUAE5J/iBA+RDARswgAEZsMEIMDCQ5WZAAxzg
AA5w0AMjCOEGJ6AAQ2BruNv+bHXe6Ezd9kiFOjkgAuZK5QtGkAGFAKEDPZgA
BQTMEDGw4hlc8xbX3BOlW4xUg4Z4wwtE8IIXIIcBE9jABejLETGUYhiTi9Lk
PBUNMbYLG7E44hEJ8QYp+PcGD3AAcCdggRB0ZA11cIXvvOWwV/TACado1xoh
YQlK8GEMUoCCEH6w4gwA1wMfycL5Glb4MHWgoxdCAEAAPvAKdpS3qZfggxee
m8cRbEACEYCBSsSghk8M42fwsIVxCgCBM9xFjs2cgxSEkMcPcAC4Z8mCGCRh
i2eYIxggco0X2GE+jTpTCDaIgQgyAIIK/+UfWYgDKZ6hyXFOgBHq0IUluGyI
PdtABBeQAAtePZAjHOEOWbQEY9tlYi4zggox0MAFJkBsgxyhC5YYxjN4qo3O
WMITb0CCBkZQbYQMAQt86IUWwxHHvSIBBzJwcrkPogMddOEUyAhHec+wBA7I
QAnzVogJeFAGkZaBBygIeENM4AMoQMEHCoeICWwQ8Ypb/OIYz7jGN87xcgcE
ADs=}

initHelp
newGame
bind . <F1> showHelp
bind . <KeyPress-q> {destroy . ; exit 0}
bind . <KeyPress-i> {wm iconify .}

# end #