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