##+##########################################################################
 #
 # Dice -- draws nice looking dice
 # by Keith Vetter, Oct 20, 2006
 #
 # Three functions:
 #  ::Dice::DrawDie -- draws one die
 #  ::Dice::DrawStack -- draw many dice in stacks of four
 #  ::Dice::Size -- gets or sets the size of one edge of a die
 #
 namespace eval ::Dice {
    variable S                                  ;# Size information
    variable D                                  ;# Side color darkening
    variable F                                  ;# Face information
    variable PIPS                               ;# Pip orientation
    variable PPIP                               ;# Pip placement on face

    array set S {sz 50 dx 15 dy 10 notch .2}
    array set D {t 90 l 70 r 40 c4 80 c2 40 c6 100 c0 15} ;# Darkness factor
    array set F {r {0,a 1,b 1,a 2,b 2,c 6,a 6,c 0,c}
        t {6,a 2,c 2,a 3,b 3,a 4,b 4,c 6,b} l {0,c 6,c 6,b 4,c 4,a 5,b 5,a 0,b}
        c0 {0,a 0,c 0,b} c2 {2,a 2,c 2,b} c4 {4,a 4,c 4,b} c6 {6,a 6,b 6,c}
        R {0 1 2 6} T {6 2 3 4} L {0 6 4 5}}
   array set PIPS {1 {2 3 5 4 2} 2 {1 4 6 3 1} 3 {1 2 6 5 1}
        4 {1 5 6 2 1} 5 {1 3 6 4 1} 6 {2 4 5 3 2}}
    array set PPIP {1 {1} 2 {0 2} 3 {0 1 2} 4 {0 2 3 4}
        5 {0 1 2 3 4} 6 {0 2 3 4 5 6}}
 }
 ##+##########################################################################
 #
 # ::Dice::DrawDie -- draws 1 die
 #    w -- canvas widget
 #    x,y -- canvas location
 #    pip -- number on top of the die
 #    clr -- color for the die
 #    shadow -- size of shadow (0 is no shadow)
 #    tag -- tag to apply to all pieces of the die
 #
 proc ::Dice::DrawDie {w x y pip clr shadow tag} {
    variable S
    variable F
    variable D
    variable PIPS

    set l $S(sz)                                ;# Size of one edge
    set dx [expr {$S(dx)*$l/hypot($S(dx),$S(dy))}] ;# Scale to cube size
    set dy [expr {$S(dy)*$l/hypot($S(dx),$S(dy))}]

    set V(r) [list $dx -$dy]                    ;# Edge vectors
    set V(l) [list -$dx -$dy]
    set V(u) [list 0 -$l]
    set V(rr) [list $l 0]

    # Compute all vertices (both actual corners and notches on the corner)
    set P(0) [list $x $y]                       ;# Bottom middle vertex
    set s1 $S(notch) ; set s2 [expr {1 - $s1}]  ;# Corner notch
    set vtx [list 1 0 r 1  2 1 u 1  3 2 l 1  5 0 l 1  4 5 u 1  6 0 u 1 \
               0,a 0 r $s1  0,b 0 l $s1  0,c 0 u $s1  1,a 1 u $s1  1,b 0 r $s2 \
               2,a 2 l $s1  2,b 1 u $s2  2,c 6 r $s2  3,a 4 r $s2  3,b 2 l $s2 \
               4,a 5 u $s2  4,b 4 r $s1  4,c 6 l $s2  5,a 0 l $s2  5,b 5 u $s1 \
               6,a 6 r $s1  6,b 6 l $s1  6,c 0 u $s2]
    foreach {who from dir sc} $vtx {
        set P($who) [::Dice::_VAdd $P($from) $V($dir) $sc]
    }

    # Compute all faces
    foreach f [array names F] {
        set XY($f) {}
        foreach vtx $F($f) { set XY($f) [concat $XY($f) $P($vtx)]}
    }

    # Draw shadow if needed
    if {$shadow > 0} {
        set p0 $P(0,b)
        set p1 [::Dice::_VAdd $p0 $V(rr) $shadow]
        set p2 [::Dice::_VAdd $p1 $V(r)]
        set p3 [::Dice::_VAdd $p2 $V(l)]
        set p4 [::Dice::_VAdd $p3 $V(rr) -$shadow]
        set xy [concat $p0 $p0 $p1 $p2 $p3 $p4]
        .c create poly $xy -tag $tag -smooth 1
    }
    # Draw all the faces
    foreach f {r t l c0 c2 c4 c6} {
        set clr2 [::tk::Darken $clr $D($f)]
        .c create poly $XY($f) -fill $clr2 -width 0 -outline $clr2 -tag $tag
    }

    # Draw pips on the three visible faces, pick random orientation
    set n [expr {int(rand()*4)}]
    set n 0
    set pips [concat $pip [lrange $PIPS($pip) $n [expr {$n+1}]]]
    foreach n $pips f {T L R} {
        ::Dice::_DrawPip $w $n $XY($f) $D([string tolower $f]) $tag
    }
 }
 ##+##########################################################################
 #
 # ::Dice::DrawStack -- draw many dice in stacks of 4
 #    w -- canvas widget
 #    x,y -- canvas location
 #    cnt -- how many dice in stack
 #    pip -- number on top of the die
 #    clr -- color of the die
 #    tag -- tag to apply to all pieces of the die
 #
 proc ::Dice::DrawStack {w x y cnt pip clr tag} {
    variable S
    set dy [expr {int(round($S(sz) * -1.1))}]
    set dx2 [expr {int(round($S(sz) * 1.1))}]   ;# Multiple stack offset
    set dy2 [expr {int(round($S(sz) * .6))}]

    set numCols [expr {($cnt+3) / 4}]
    set x [expr {$x - ($numCols-1)*$dx2}]
    set y [expr {$y - ($numCols-1)*$dy2}]

    while {$cnt > 0} {                          ;# Multiple columns
        set n [expr {$cnt > 4 ? ($cnt % 4) : $cnt}]
        if {$n == 0} {set n 4}
        incr cnt -$n

        set yy $y
        for {set i 0} {$i < $n} {incr i} {
            set shadow [expr {($i == 0 && $cnt == 0) ? (1 + ($n-1)*.3) : 0}]
            ::Dice::DrawDie $w $x $yy $pip $clr $shadow $tag
            incr yy $dy
        }
        incr x $dx2
        incr y $dy2
    }
 }
 ##+##########################################################################
 #
 # ::Dice::Size -- gets or sets the size of one edge of a die
 #
 proc ::Dice::Size {args} {
    if {[llength $args] > 1} {
        error "wrong \# args: should be \"::Dice::Size ?newValue?\""
    }
    if {[llength $args] == 1} {
        set value [lindex $args 0]
        if {! [string is double -strict $value]} {
            error "expected number but got \"$value\""
        }
        set ::Dice::S(sz) $value
    }
    return $::Dice::S(sz)
 }
 ##+##########################################################################
 #
 # ::Dice::_DrawPip -- draws pips on a one face
 #
 proc ::Dice::_DrawPip {w num xy perc tag} {
    variable PPIP

    set clr [::tk::Darken white $perc]
    foreach {x0 y0 x1 y1 x2 y2 x3 y3} $xy break
    set D1 [::Dice::_VAdd [list $x2 $y2] [list $x0 $y0] -1]
    set D2 [::Dice::_VAdd [list $x3 $y3] [list $x1 $y1] -1]

    set V(0) [::Dice::_VAdd [list $x0 $y0] $D1 .25]
    set V(1) [::Dice::_VAdd [list $x0 $y0] $D1 .5]
    set V(2) [::Dice::_VAdd [list $x0 $y0] $D1 .75]
    set V(3) [::Dice::_VAdd [list $x1 $y1] $D2 .25]
    set V(4) [::Dice::_VAdd [list $x1 $y1] $D2 .75]

    set D3 [::Dice::_VAdd $V(2) $V(4) -1]
    set V(5) [::Dice::_VAdd $V(4) $D3 .5]
    set V(6) [::Dice::_VAdd $V(0) $D3 .5]

    set sc [expr {$num == 1 ? .2 : .1}]         ;# Single pip is bigger
    foreach v $PPIP($num) {
        set xy [::Dice::_MakeRhombus $V($v) $D1 $D2 $sc]
        $w create poly $xy -fill $clr -tag $tag -smooth 1
    }
 }
 ##+##########################################################################
 #
 # ::Dice::_MakeRhombus -- returns 4 corners of a rhombus at PP given
 #  two diagonals vectors with a scaling factor.
 #
 proc ::Dice::_MakeRhombus {PP D1 D2 sc} {
    set p [::Dice::_VAdd $PP $D1 $sc]
    set q [::Dice::_VAdd $PP $D2 $sc]
    set r [::Dice::_VAdd $PP $D1 -$sc]
    set s [::Dice::_VAdd $PP $D2 -$sc]
    set xy [concat $p $q $r $s]
    return $xy
 }
 ##+##########################################################################
 #
 # ::Dice::_VAdd -- adds two vectors, possibly scaling the second one
 #
 proc ::Dice::_VAdd {P V {sc 1}} {
    foreach {x y} $P {dx dy} $V break
    return [list [expr {$x+$sc*$dx}] [expr {$y+$sc*$dy}]]
 }

 ################################################################
 #
 # DEMO
 #
 package require Tk
 if {! [catch {package require tile}]} {
    interp alias {} scale {} ::ttk::scale
 }

 proc Demo {{newSize ""}} {
    if {$newSize ne ""} {::Dice::Size $newSize}
    .c delete all
    RowOfDiceTest 125 0
    RowOfDiceTest 250 1
    StackedDiceTest 550
 }

 proc RowOfDiceTest {y shadows} {
    set x 50
    set pips 0
    foreach clr $::colors {
        if {[incr pips] > 6} {set pips 1}
        ::Dice::DrawDie .c $x $y $pips $clr $shadows a
        incr x 150
    }
 }
 proc StackedDiceTest {y} {
    for {set i 1} {$i <= 8} {incr i} {
        set xx [expr {50 + ($i-1)*150}]
        set clr [lindex $::colors [expr {$i-1}]]
        set pip [expr {1+($i%6)}]
        ::Dice::DrawStack .c $xx $y $i $pip $clr x
    }
 }

 ################################################################

 wm title . "Drawing Dice"
 set colors {red yellow green cyan blue deeppink orange \#00FA9A}

 canvas .c -width 1250 -height 600 -bd 2 -highlightthickness 0 -relief ridge
 pack   .c -fill both -expand 1 -side top
 scale  .sc -from 10 -to 50 -command Demo -orient h
 .sc set $::Dice::S(sz)
 pack .sc -side bottom -pady 10 -before .c

 Demo
 return