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