1# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)
2
3package require Tk 8.3
4package require stooop
5
6
7::stooop::class pieBoxLabeler {
8
9    proc pieBoxLabeler {this canvas args} pieLabeler {$canvas $args} switched {
10        $args
11    } {
12        ::set ($this,array) [::stooop::new canvasLabelsArray $canvas]
13        switched::complete $this
14    }
15
16    proc ~pieBoxLabeler {this} {
17        ::stooop::delete $($this,array)
18    }
19
20    proc options {this} {
21        # font and justify options are used when creating a new canvas label
22        # justify option is used for both the labels array and the labels
23        return [list\
24            [list -font\
25                $pieLabeler::(default,font) $pieLabeler::(default,font)\
26            ]\
27            [list -justify left left]\
28            [list -offset 5 5]\
29            [list -xoffset 0 0]\
30        ]
31    }
32
33    foreach option {-font -justify -offset -xoffset} {
34        # no dynamic options allowed
35        proc set$option {this value} "
36            if {\$switched::(\$this,complete)} {
37                error {option $option cannot be set dynamically}
38            }
39        "
40    }
41
42    proc new {this slice args} {
43        # variable arguments are for the created canvas label object
44        ::set label [eval ::stooop::new canvasLabel\
45            $pieLabeler::($this,canvas) $args\
46            [list\
47                -justify $switched::($this,-justify)\
48                -font $switched::($this,-font) -selectrelief sunken\
49            ]\
50        ]
51        canvasLabelsArray::manage $($this,array) $label
52        # refresh our tags
53        $pieLabeler::($this,canvas) addtag pieLabeler($this)\
54            withtag canvasLabelsArray($($this,array))
55        # always append semi-column to label:
56        switched::configure $label -text [switched::cget $label -text]:
57        ::set ($this,selected,$label) 0
58        return $label
59    }
60
61    proc delete {this label} {
62        canvasLabelsArray::delete $($this,array) $label
63        unset ($this,selected,$label)
64    }
65
66    proc set {this label value} {
67        # update string part after last semi-column
68        regsub {:[^:]*$} [switched::cget $label -text] ": $value" text
69        switched::configure $label -text $text
70    }
71
72    proc label {this label args} {
73        ::set text [switched::cget $label -text]
74        if {[llength $args] == 0} {
75            regexp {^(.*):} $text dummy text
76            return $text
77        } else {                   ;# update string part before last semi-column
78            regsub {^.*:} $text [lindex $args 0]: text
79            switched::configure $label -text $text
80        }
81    }
82
83    proc labelBackground {this label args} {
84        if {[llength $args] == 0} {
85            return [switched::cget $label -background]
86        } else {
87            switched::configure $label -background [lindex $args 0]
88        }
89    }
90
91    proc labelTextBackground {this label args} {
92        if {[llength $args] == 0} {
93            return [switched::cget $label -textbackground]
94        } else {
95            switched::configure $label -textbackground [lindex $args 0]
96        }
97    }
98
99    proc selectState {this label {selected {}}} {
100        if {[string length $selected] == 0} {
101            # return current state if no argument
102            return $($this,selected,$label)
103        }
104        switched::configure $label -select $selected
105        ::set ($this,selected,$label) $selected
106    }
107
108    proc update {this left top right bottom} {
109        # whole pie coordinates, includings labeler labels
110        ::set canvas $pieLabeler::($this,canvas)
111        # first reposition labels array below pie graphics
112        ::set array $($this,array)
113        ::set width [expr {$right - $left}]
114        if {$width != [switched::cget $array -width]} {
115            switched::configure $array -width $width            ;# fit pie width
116        } else {
117            canvasLabelsArray::update $array
118        }
119        foreach {x y} [$canvas coords canvasLabelsArray($array)] {}
120        $canvas move canvasLabelsArray($array) [expr {$left - $x}]\
121            [expr {$bottom - [canvasLabelsArray::height $array] - $y}]
122    }
123
124    proc room {this arrayName} {
125        upvar 1 $arrayName data
126
127        ::set data(left) 0                        ;# no room taken around slices
128        ::set data(right) 0
129        ::set data(top) 0
130        ::set box\
131            [$pieLabeler::($this,canvas) bbox canvasLabelsArray($($this,array))]
132        if {[llength $box] == 0} {                              ;# no labels yet
133            ::set data(bottom) 0
134        } else {                    ;# room taken by all labels including offset
135            ::set data(bottom) [expr {\
136                [lindex $box 3] - [lindex $box 1] + $switched::($this,-offset)\
137            }]
138        }
139    }
140
141}
142