########################################################################
#
# Radial Hierarchical Pareto
#

namespace eval redialHeirPareto {
    option add *RedialHeirPareto.size                        400
    option add *RedialHeirPareto.core                        20
    option add *RedialHeirPareto.maxLevels                   10

    option add *RedialHeirPareto.relief                      flat
    option add *RedialHeirPareto.borderWidth                 0

    option add *RedialHeirPareto.Canvas.width                200m
    option add *RedialHeirPareto.Canvas.height               200m
    option add *RedialHeirPareto.Canvas.background           gray
    option add *RedialHeirPareto.Canvas.foreground           black
    option add *RedialHeirPareto.Canvas.highlightThickness   0
    option add *RedialHeirPareto.Canvas.borderWidth          1
    option add *RedialHeirPareto.Canvas.relief               raised
}

proc redialHeirPareto::constructor { widget top hTreeName } {
        upvar      $hTreeName hTree
        
        frame $widget -class RedialHeirPareto
        canvas [set c $widget.canvas]
        pack $c -fill both -expand true
        
        option add ${widget}.hTreeName $hTreeName
        
        set size    [option get $widget size      RedialHeirPareto]
        set numLvls [option get $widget maxLevels RedialHeirPareto]
        set cH      [option get $widget core      RedialHeirPareto]

        set dH [expr ($size / 2.0 - $cH)/$numLvls]
        set mx $size
        set my $size

        # draw the hierarchies
        for {set h [expr $cH + $dH]} {$h <= $size / 2.0} {set h [expr $h + $dH]} {
                $c create oval \
                        [expr $mx - $h] [expr $my - $h] [expr $mx + $h] [expr $my + $h] \
                        -outline black 
        }
        
        # obtain the layout for each cell
        set objs [calcObjLayout $hTree]

        # now draw them
        foreach sl [lsort -index 1 -decreasing -integer $objs] {
                lassign $sl name lvl startAngle arcAngle val
                # first calc the box:
                set r [expr $cH + $lvl*$dH]
                set x0 [expr $mx - $r]
                set y0 [expr $my - $r]
                set x1 [expr $mx + $r]
                set y1 [expr $mx + $r]

                set color [getColor $arcAngle]
                set id [$c create arc $x0 $y0 $x1 $y1 \
                                          -start $startAngle -extent $arcAngle \
                                          -style pieslice -outline blue -fill $color]
                
                cballoon $c $id "$name $val"
        }

        # draw middle cicrle
        $c create oval \
                [expr $mx - $cH] [expr $my - $cH] [expr $mx + $cH] [expr $my + $cH] \
                -outline black -fill black
        
        $c create text $mx $my -anchor center -justify center -text $top -fill yellow        

        bind $c <2> [bind Text <2>]
        bind $c <B2-Motion> [bind Text <B2-Motion>]
        fit $c

        frame [set help $widget.help]
        label $help.l -text "Use: button-1 to show object properties and button-2 to drag"
        pack $help.l -fill both -expand true 
        pack $help -fill both -expand true -side bottom
        
        return $widget
}

# This needs more work as it has bugs if run within the <Configure>
# event. Does not maximize to full window.
proc redialHeirPareto::fit {c} {
        set bbox [$c bbox all]
        lassign $bbox x0 y0 x1 y1
        set mx [expr ($x1 + $x0)/2]
        set my [expr ($y1 + $y0)/2]
        set dx [expr $x1 - $x0]
        set dy [expr $y1 - $y0]
        set w  [$c cget -width]
        set h  [$c cget -height]
        $c xview moveto 0
        $c yview moveto 0
#        $c configure -scrollregion [list 0 0 $w $h]
#        set vw [lindex [$c xview] 1]
#        set vh [lindex [$c yview] 1]
#        if {$vw != 0 && $vh != 0} {
#                set w [expr $w*$vw]
#                set h [expr $h*$vh]
#   }
        $c scale all [expr 1.0*$mx*$w/$dx] [expr 1.0*$my*$h / $dy] [expr 1.0*$w / $dx] [expr 1.0*$h / $dy]
}

proc redialHeirPareto::getColor {arcAngle} {
        set color [format "#%02x%02x%02x" 255 [expr 255-int(255*($arcAngle/360))] 0]
}

# Calculate the allocated start stop angle for each object
# The result is a list of {key lvl startAngle stopAngle}
proc redialHeirPareto::calcObjLayout {hTree {startAngle 0} {stopAngle 359} {lvl 1} } {
        set res {} 
        lassign $hTree top sum children

        if {![llength $children]} {return ""}

        set anglePerUnit [expr 1.0*($stopAngle - $startAngle) / $sum]
        set angle $startAngle

        foreach child [lsort -decreasing -index 1 -real $children] {
                lassign $child name val
                set endAngle [expr $angle + $anglePerUnit * $val]
                set a1 [expr $anglePerUnit * $val]
                lappend res [list $name $lvl $angle $a1 $val]
                append res " " [calcObjLayout $child $angle $endAngle [expr $lvl + 1]]
                set angle $endAngle
        }
        return $res
}

proc redialHeirPareto::cballoon {w tag text} {
        $w bind $tag <ButtonPress-1> [list redialHeirPareto::cballoon_disp $w $text]
        $w bind all  <ButtonRelease-1> [list after 1 $w delete cballoon]
}

proc redialHeirPareto::cballoon_disp {w text} {
        lassign [$w bbox current] - - x y
        if [info exists y] {
                set id [$w create text $x $y -text $text -tag cballoon]
                lassign [$w bbox $id] x0 y0 x1 y1
                $w create rect $x0 $y0 $x1 $y1 -fill lightyellow -tag cballoon
                $w raise $id
        }
}