http://tkgames.sf.net

#!/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 #

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References