1# $Id: pie.tcl,v 2.25 2006/01/27 19:05:52 andreas_kupries Exp $
2
3package require Tk 8.3
4package require stooop
5
6
7::stooop::class pie {
8    set (colors) [list\
9        #7FFFFF #FFFF7F #FF7F7F #7FFF7F #7F7FFF #FFBF00 #BFBFBF #FF7FFF #FFFFFF\
10    ]
11}
12
13proc pie::pie {this canvas x y args} switched {$args} {
14    # note: all pie elements are tagged with pie($this)
15    set ($this,canvas) $canvas
16    set ($this,colorIndex) 0
17    set ($this,slices) {}
18    # use an empty image as an origin marker with only 2 coordinates
19    set ($this,origin) [$canvas create image $x $y -tags pie($this)]
20    switched::complete $this
21    # wait till all options have been set for initial configuration
22    complete $this
23}
24
25proc pie::~pie {this} {
26    if {[info exists ($this,title)]} {                    ;# title may not exist
27        $($this,canvas) delete $($this,title)
28    }
29    ::stooop::delete $($this,labeler)
30    eval ::stooop::delete $($this,slices) $($this,backgroundSlice)
31    if {[info exists ($this,selector)]} {              ;# selector may not exist
32        ::stooop::delete $($this,selector)
33    }
34    $($this,canvas) delete $($this,origin)
35}
36
37proc pie::options {this} {
38    # force height, thickness title font and width options so that corresponding
39    # members are properly initialized
40    return [list\
41        [list -autoupdate 1 1]\
42        [list -background {} {}]\
43        [list -colors $(colors) $(colors)]\
44        [list -height 200]\
45        [list -labeler 0 0]\
46        [list -selectable 0 0]\
47        [list -thickness 0]\
48        [list -title {} {}]\
49        [list -titlefont {Helvetica -12 bold} {Helvetica -12 bold}]\
50        [list -titleoffset 2 2]\
51        [list -width 200]\
52    ]
53}
54
55proc pie::set-autoupdate {this value} {}
56
57# no dynamic options allowed: see complete
58foreach option {\
59    -background -colors -labeler -selectable -title -titlefont -titleoffset\
60} {
61    proc pie::set$option {this value} "
62        if {\$switched::(\$this,complete)} {
63            error {option $option cannot be set dynamically}
64        }
65    "
66}
67
68proc pie::set-thickness {this value} {
69    if {$switched::($this,complete)} {
70        error {option -thickness cannot be set dynamically}
71    }
72    # convert to pixels
73    set ($this,thickness) [winfo fpixels $($this,canvas) $value]
74}
75
76# size is first converted to pixels, then 1 pixel is subtracted since slice size
77# is half the pie size and pie center takes 1 pixel
78proc pie::set-height {this value} {
79    # value is height is slices height not counting thickness
80    set ($this,height) [expr {[winfo fpixels $($this,canvas) $value] - 1}]
81    if {$switched::($this,complete)} {
82        update $this
83    } else {      ;# keep track of initial value for latter scaling calculations
84        set ($this,initialHeight) $($this,height)
85    }
86}
87proc pie::set-width {this value} {
88    set ($this,width) [expr {[winfo fpixels $($this,canvas) $value] - 1}]
89    if {$switched::($this,complete)} {
90        update $this
91    } else {      ;# keep track of initial value for latter scaling calculations
92        set ($this,initialWidth) $($this,width)
93    }
94}
95
96proc pie::complete {this} {                          ;# no user slices exist yet
97    set canvas $($this,canvas)
98
99    if {$switched::($this,-labeler) == 0} {
100        # use default labeler if user defined none
101        set ($this,labeler) [::stooop::new pieBoxLabeler $canvas]
102    } else {                                         ;# use user defined labeler
103        set ($this,labeler) $switched::($this,-labeler)
104    }
105    $canvas addtag pie($this) withtag pieLabeler($($this,labeler))
106    if {[string length $switched::($this,-background)] == 0} {
107        set bottomColor {}
108    } else {
109        set bottomColor [darken $switched::($this,-background) 60]
110    }
111    set slice [::stooop::new slice\
112        $canvas [expr {$($this,initialWidth) / 2}]\
113        [expr {$($this,initialHeight) / 2}]\
114        -startandextent {90 360} -height $($this,thickness)\
115        -topcolor $switched::($this,-background) -bottomcolor $bottomColor\
116    ]
117    $canvas addtag pie($this) withtag slice($slice)
118    $canvas addtag pieSlices($this) withtag slice($slice)
119    set ($this,backgroundSlice) $slice
120    if {[string length $switched::($this,-title)] == 0} {
121        set ($this,titleRoom) 0
122    } else {
123        set ($this,title) [$canvas create text 0 0\
124            -anchor n -text $switched::($this,-title)\
125            -font $switched::($this,-titlefont) -tags pie($this)\
126        ]
127        set ($this,titleRoom) [expr {\
128            [font metrics $switched::($this,-titlefont) -ascent] +\
129            [winfo fpixels $canvas $switched::($this,-titleoffset)]\
130        }]
131    }
132    update $this
133}
134
135proc pie::newSlice {this {text {}} {color {}}} {
136    set canvas $($this,canvas)
137
138    # calculate start radian for new slice
139    # (slices grow clockwise from 12 o'clock)
140    set start 90
141    foreach slice $($this,slices) {
142        set start [expr {$start - $slice::($slice,extent)}]
143    }
144    if {[string length $color] == 0} {
145        # get a new color
146        set color [lindex $switched::($this,-colors) $($this,colorIndex)]
147        set ($this,colorIndex) [expr {\
148            ($($this,colorIndex) + 1) % [llength $switched::($this,-colors)]\
149        }]                                              ;# circle through colors
150    }
151    # darken slice top color by 40% to obtain bottom color, as it is done for
152    # Tk buttons shadow, for example
153    set slice [::stooop::new slice\
154        $canvas [expr {$($this,initialWidth) / 2}]\
155        [expr {$($this,initialHeight) / 2}] -startandextent "$start 0"\
156        -height $($this,thickness) -topcolor $color\
157        -bottomcolor [darken $color 60]\
158    ]
159    # place slice at other slices position in case pie was moved
160    eval $canvas move slice($slice) [$canvas coords pieSlices($this)]
161    $canvas addtag pie($this) withtag slice($slice)
162    $canvas addtag pieSlices($this) withtag slice($slice)
163    lappend ($this,slices) $slice
164    if {[string length $text] == 0} {     ;# generate label text if not provided
165        set text "slice [llength $($this,slices)]"
166    }
167    set labeler $($this,labeler)
168    set label [pieLabeler::new $labeler $slice -text $text -background $color]
169    set ($this,sliceLabel,$slice) $label
170    # update tags which canvas does not automatically do
171    $canvas addtag pie($this) withtag pieLabeler($labeler)
172    update $this
173    if {$switched::($this,-selectable)} {
174        # toggle select state at every button release
175        if {![info exists ($this,selector)]} {   ;# create selector if necessary
176            set ($this,selector) [::stooop::new objectSelector\
177                -selectcommand "pie::setLabelsState $this"\
178            ]
179        }
180        set selector $($this,selector)
181        selector::add $selector $label
182        $canvas bind canvasLabel($label) <ButtonPress-1>\
183            "pie::buttonPress $selector $label"
184        $canvas bind slice($slice) <ButtonPress-1>\
185            "selector::select $selector $label"
186        $canvas bind canvasLabel($label) <Control-ButtonPress-1>\
187            "selector::toggle $selector $label"
188        $canvas bind slice($slice) <Control-ButtonPress-1>\
189            "selector::toggle $selector $label"
190        $canvas bind canvasLabel($label) <Shift-ButtonPress-1>\
191            "selector::extend $selector $label"
192        $canvas bind slice($slice) <Shift-ButtonPress-1>\
193            "selector::extend $selector $label"
194        $canvas bind canvasLabel($label) <ButtonRelease-1>\
195            "pie::buttonRelease $selector $label 0"
196        $canvas bind slice($slice) <ButtonRelease-1>\
197            "pie::buttonRelease $selector $label 0"
198        $canvas bind canvasLabel($label) <Control-ButtonRelease-1>\
199            "pie::buttonRelease $selector $label 1"
200        $canvas bind slice($slice) <Control-ButtonRelease-1>\
201            "pie::buttonRelease $selector $label 1"
202        $canvas bind canvasLabel($label) <Shift-ButtonRelease-1>\
203            "pie::buttonRelease $selector $label 1"
204        $canvas bind slice($slice) <Shift-ButtonRelease-1>\
205            "pie::buttonRelease $selector $label 1"
206    }
207    return $slice
208}
209
210proc pie::deleteSlice {this slice} {
211    set index [lsearch -exact $($this,slices) $slice]
212    if {$index < 0} {
213        error "invalid slice $slice for pie $this"
214    }
215    set ($this,slices) [lreplace $($this,slices) $index $index]
216    set extent $slice::($slice,extent)
217    ::stooop::delete $slice
218    foreach following [lrange $($this,slices) $index end] {
219        # rotate the following slices counterclockwise
220        slice::rotate $following $extent
221    }
222    # finally delete label last so that other labels may eventually be
223    # repositionned according to remaining slices placement
224    pieLabeler::delete $($this,labeler) $($this,sliceLabel,$slice)
225    if {$switched::($this,-selectable)} {
226        selector::remove $($this,selector) $($this,sliceLabel,$slice)
227    }
228    unset ($this,sliceLabel,$slice)
229    update $this
230}
231
232proc pie::sizeSlice {this slice unitShare {valueToDisplay {}}} {
233    set index [lsearch -exact $($this,slices) $slice]
234    if {$index < 0} {
235        error "invalid slice $slice for pie $this"
236    }
237    # cannot display slices that occupy more than whole pie and less than zero
238    set newExtent [expr {[maximum [minimum $unitShare 1] 0] * 360}]
239    set growth [expr {$newExtent - $slice::($slice,extent)}]
240    switched::configure $slice -startandextent\
241        "[expr {$slice::($slice,start) - $growth}] $newExtent" ;# grow clockwise
242    if {[string length $valueToDisplay] > 0} {
243        # update label after slice for it may need slice latest configuration
244        pieLabeler::set $($this,labeler) $($this,sliceLabel,$slice)\
245            $valueToDisplay
246    } else {
247        pieLabeler::set $($this,labeler) $($this,sliceLabel,$slice) $unitShare
248    }
249    set value [expr {-1 * $growth}]         ;# finally move the following slices
250    foreach slice [lrange $($this,slices) [incr index] end] {
251        slice::rotate $slice $value
252    }
253    if {$switched::($this,-autoupdate)} {
254        # since label was changed, labeler may need to reorganize labels,
255        # for example
256        update $this
257    }
258}
259
260proc pie::labelSlice {this slice text} {
261    pieLabeler::label $($this,labeler) $($this,sliceLabel,$slice) $text
262    update $this                ;# necessary if number of lines in label changes
263}
264
265proc pie::sliceLabelTag {this slice} {
266    return canvasLabel($($this,sliceLabel,$slice))
267}
268
269proc pie::setSliceBackground {this slice color} {
270    switched::configure $slice -topcolor $color -bottomcolor [darken $color 60]
271    pieLabeler::labelBackground $($this,labeler) $($this,sliceLabel,$slice)\
272        $color
273}
274
275proc pie::setSliceLabelBackground {this slice color} {
276    pieLabeler::labelTextBackground $($this,labeler) $($this,sliceLabel,$slice)\
277        $color
278}
279
280proc pie::selectedSlices {this} {  ;# return a list of currently selected slices
281    set list {}
282    foreach slice $($this,slices) {
283        if {[pieLabeler::selectState $($this,labeler)\
284            $($this,sliceLabel,$slice)\
285        ]} {
286            lappend list $slice
287        }
288    }
289    return $list
290}
291
292proc pie::setLabelsState {this labels selected} {
293    set labeler $($this,labeler)
294    foreach label $labels {
295        pieLabeler::selectState $labeler $label $selected
296    }
297}
298
299proc pie::currentSlice {this} {
300    # return current slice (slice or its label under the mouse cursor) if any
301    set tags [$($this,canvas) gettags current]
302    if {\
303        ([scan $tags slice(%u) slice] > 0) &&\
304        ($slice != $($this,backgroundSlice))\
305    } {                                               ;# ignore background slice
306        return $slice                                     ;# found current slice
307    }
308    if {[scan $tags canvasLabel(%u) label] > 0} {
309        foreach slice $($this,slices) {
310            if {$($this,sliceLabel,$slice) == $label} {
311                return $slice              ;# slice is current through its label
312            }
313        }
314    }
315    return 0                                                 ;# no current slice
316}
317
318proc pie::update {this} {
319    # place and scale slices along and with labels array in its current
320    # configuration
321    set canvas $($this,canvas)
322    # retrieve current pie coordinates
323    foreach {x y} [$canvas coords $($this,origin)] {}
324    set right [expr {$x + $($this,width)}]
325    set bottom [expr {$y + $($this,height)}]
326    # update labels so that the room that they take can be exactly calculated:
327    pieLabeler::update $($this,labeler) $x $y $right $bottom
328    pieLabeler::room $($this,labeler) room      ;# take labels room into account
329    # move slices in order to leave room for labels
330    foreach {xSlices ySlices} [$canvas coords pieSlices($this)] {}
331    $canvas move pieSlices($this) [expr {$x + $room(left) - $xSlices}]\
332        [expr {$y + $room(top) + $($this,titleRoom) - $ySlices}]
333    set scale [list\
334        [expr {\
335            ($($this,width) - $room(left) - $room(right)) /\
336            $($this,initialWidth)\
337        }]\
338        [expr {\
339            (\
340                $($this,height) - $room(top) - $room(bottom) -\
341                $($this,titleRoom)\
342            ) / ($($this,initialHeight) + $($this,thickness))\
343        }]\
344    ]
345    # update scale of background slice
346    switched::configure $($this,backgroundSlice) -scale $scale
347    foreach slice $($this,slices) {
348        switched::configure $slice -scale $scale             ;# and other slices
349    }
350    # some labelers place labels around slices
351    pieLabeler::updateSlices $($this,labeler) $x $y $right $bottom
352    if {$($this,titleRoom) > 0} {                                ;# title exists
353        # place text above pie and centered
354        $canvas coords $($this,title) [expr {$x + ($($this,width) / 2)}] $y
355    }
356}
357
358proc pie::buttonPress {selector label} {
359    foreach selected [selector::selected $selector] {
360        # in an already selected label, do not change selection
361        if {$selected == $label} return
362    }
363    selector::select $selector $label
364}
365
366proc pie::buttonRelease {selector label extended} {
367    # extended means that there is an extended selection in process
368    if {$extended} return
369    set list [selector::selected $selector]
370    if {[llength $list] <= 1} {
371        return                ;# nothing to do if there is no multiple selection
372    }
373    foreach selected $list {
374        if {$selected == $label} {               ;# in an already selected label
375            selector::select $selector $label     ;# set selection to sole label
376            return
377        }
378    }
379}
380
381::stooop::class pie {                       ;# define various utility procedures
382    proc maximum {a b} {return [expr {$a > $b? $a: $b}]}
383    proc minimum {a b} {return [expr {$a < $b? $a: $b}]}
384
385    catch ::tk::Darken                                  ;# force package loading
386    if {[llength [info procs ::tk::Darken]] > 0} {                     ;# Tk 8.4
387        proc darken {color percent} {::tk::Darken $color $percent}
388    } else {
389        proc darken {color percent} {::tkDarken $color $percent}
390    }
391}
392