[2139] | 1 | # ---------------------------------------------------------------------- |
---|
| 2 | # COMPONENT: legend - show a legend of color/line samples |
---|
| 3 | # |
---|
| 4 | # This widget acts as a legend for the differences view. It manages |
---|
| 5 | # a series of samples, each with a block or line sample and a label. |
---|
| 6 | # ====================================================================== |
---|
| 7 | # AUTHOR: Michael McLennan, Purdue University |
---|
| 8 | # Copyright (c) 2010-2011 Purdue Research Foundation |
---|
| 9 | # |
---|
| 10 | # See the file "license.terms" for information on usage and |
---|
| 11 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 12 | # ====================================================================== |
---|
| 13 | package require Itk |
---|
| 14 | |
---|
| 15 | namespace eval Rappture::Tester { # forward declaration } |
---|
| 16 | |
---|
| 17 | option add *Legend.font {Arial -12} widgetDefault |
---|
| 18 | option add *Legend.padX 12 widgetDefault |
---|
| 19 | |
---|
| 20 | itcl::class Rappture::Tester::LegendEntry { |
---|
| 21 | public variable title "" |
---|
| 22 | public variable shape "box" { |
---|
| 23 | if {[lsearch {box line} $shape] < 0} { |
---|
| 24 | error "bad value \"$shape\": should be box, line" |
---|
| 25 | } |
---|
| 26 | } |
---|
| 27 | public variable color "" |
---|
| 28 | public variable state "normal" { |
---|
| 29 | if {[lsearch {normal disabled} $state] < 0} { |
---|
| 30 | error "bad value \"$state\": should be normal, disabled" |
---|
| 31 | } |
---|
| 32 | } |
---|
| 33 | public variable anchor "w" { |
---|
| 34 | if {[lsearch {e w} $anchor] < 0} { |
---|
| 35 | error "bad value \"$anchor\": should be e, w" |
---|
| 36 | } |
---|
| 37 | } |
---|
| 38 | |
---|
| 39 | constructor {args} { eval configure $args } |
---|
| 40 | } |
---|
| 41 | |
---|
| 42 | itcl::class Rappture::Tester::Legend { |
---|
| 43 | inherit itk::Widget |
---|
| 44 | |
---|
| 45 | itk_option define -font font Font "" |
---|
| 46 | itk_option define -padx padX PadX 1 |
---|
| 47 | |
---|
| 48 | constructor {args} { # defined later } |
---|
| 49 | destructor { # defined later } |
---|
| 50 | |
---|
| 51 | public method insert {pos args} |
---|
| 52 | public method delete {from {to ""}} |
---|
| 53 | public method itemconfigure {what args} |
---|
| 54 | public method size {} { return [llength $_entries] } |
---|
| 55 | public method get {pos args} |
---|
| 56 | |
---|
| 57 | protected method _redraw {} |
---|
| 58 | |
---|
| 59 | private variable _dispatcher "" ;# dispatcher for !events |
---|
| 60 | private variable _entries "" ;# list of status entries |
---|
| 61 | } |
---|
| 62 | |
---|
| 63 | # ---------------------------------------------------------------------- |
---|
| 64 | # CONSTRUCTOR |
---|
| 65 | # ---------------------------------------------------------------------- |
---|
| 66 | itcl::body Rappture::Tester::Legend::constructor {args} { |
---|
| 67 | Rappture::dispatcher _dispatcher |
---|
| 68 | $_dispatcher register !redraw |
---|
| 69 | $_dispatcher dispatch $this !redraw "[itcl::code $this _redraw]; list" |
---|
| 70 | |
---|
| 71 | itk_component add area { |
---|
| 72 | canvas $itk_interior.area -relief flat |
---|
| 73 | } |
---|
| 74 | pack $itk_component(area) -expand yes -fill both |
---|
| 75 | |
---|
| 76 | bind $itk_component(hull) <Configure> \ |
---|
| 77 | [list $_dispatcher event -idle !redraw] |
---|
| 78 | |
---|
| 79 | eval itk_initialize $args |
---|
| 80 | } |
---|
| 81 | |
---|
| 82 | itk::usual Legend { |
---|
| 83 | keep -background -foreground -cursor -font |
---|
| 84 | } |
---|
| 85 | |
---|
| 86 | # ---------------------------------------------------------------------- |
---|
| 87 | # DESTRUCTOR |
---|
| 88 | # ---------------------------------------------------------------------- |
---|
| 89 | itcl::body Rappture::Tester::Legend::destructor {} { |
---|
| 90 | delete 0 end |
---|
| 91 | } |
---|
| 92 | |
---|
| 93 | # ---------------------------------------------------------------------- |
---|
| 94 | # USAGE: insert <pos> ?-option value -option value ...? |
---|
| 95 | # |
---|
| 96 | # Inserts a new entry into the legend at the given <pos>. The options |
---|
| 97 | # are those recognized by a LegendEntry object. |
---|
| 98 | # ---------------------------------------------------------------------- |
---|
| 99 | itcl::body Rappture::Tester::Legend::insert {pos args} { |
---|
| 100 | set entry [eval Rappture::Tester::LegendEntry #auto $args] |
---|
| 101 | set _entries [linsert $_entries $pos $entry] |
---|
| 102 | $_dispatcher event -idle !redraw |
---|
| 103 | } |
---|
| 104 | |
---|
| 105 | # ---------------------------------------------------------------------- |
---|
| 106 | # USAGE: delete <pos> ?<toPos>? |
---|
| 107 | # |
---|
| 108 | # Deletes a single entry or a range of entries from the legend |
---|
| 109 | # displayed in this widget. |
---|
| 110 | # ---------------------------------------------------------------------- |
---|
| 111 | itcl::body Rappture::Tester::Legend::delete {pos {to ""}} { |
---|
| 112 | if {$to eq ""} { |
---|
| 113 | set to $pos |
---|
| 114 | } |
---|
| 115 | foreach obj [lrange $_entries $pos $to] { |
---|
| 116 | itcl::delete object $obj |
---|
| 117 | } |
---|
| 118 | set _entries [lreplace $_entries $pos $to] |
---|
| 119 | $_dispatcher event -idle !redraw |
---|
| 120 | } |
---|
| 121 | |
---|
| 122 | # ---------------------------------------------------------------------- |
---|
| 123 | # USAGE: itemconfigure <what> ?-option? ?value -option value ...? |
---|
| 124 | # |
---|
| 125 | # Changes the options of a particular entry. The <what> can be the |
---|
| 126 | # -title of the entry, or an integer index. The options are those |
---|
| 127 | # recognized by a LegendEntry object. |
---|
| 128 | # ---------------------------------------------------------------------- |
---|
| 129 | itcl::body Rappture::Tester::Legend::itemconfigure {what args} { |
---|
| 130 | # first, see if the <what> parameter matches a title |
---|
| 131 | set obj "" |
---|
| 132 | foreach entry $_entries { |
---|
| 133 | if {[$entry cget -title] eq $what} { |
---|
| 134 | set obj $entry |
---|
| 135 | break |
---|
| 136 | } |
---|
| 137 | } |
---|
| 138 | |
---|
| 139 | # if not, see if it's an integer index |
---|
| 140 | if {$obj eq "" && [string is integer -strict $what]} { |
---|
| 141 | set obj [lindex $_entries $what] |
---|
| 142 | } |
---|
| 143 | |
---|
| 144 | if {$obj eq ""} { |
---|
| 145 | error "bad option \"$what\": should be entry title or integer index" |
---|
| 146 | } |
---|
| 147 | |
---|
| 148 | # if this is a query operation, return the info |
---|
| 149 | if {[llength $args] < 2} { |
---|
| 150 | return [eval $obj configure $args] |
---|
| 151 | } |
---|
| 152 | |
---|
| 153 | # configure the entry and then schedule a redraw to show the change |
---|
| 154 | eval $obj configure $args |
---|
| 155 | $_dispatcher event -idle !redraw |
---|
| 156 | } |
---|
| 157 | |
---|
| 158 | # ---------------------------------------------------------------------- |
---|
| 159 | # USAGE: get <pos> ?-key? |
---|
| 160 | # |
---|
| 161 | # Queries information about a particular entry at index <pos>. With |
---|
| 162 | # no extra args, it returns a list of "-key value -key value ..." |
---|
| 163 | # representing all of the data about that entry. Otherwise, the value |
---|
| 164 | # for a particular -key can be requested. |
---|
| 165 | # ---------------------------------------------------------------------- |
---|
| 166 | itcl::body Rappture::Tester::Legend::get {pos {option ""}} { |
---|
| 167 | set obj [lindex $_entries $pos] |
---|
| 168 | if {$obj eq ""} { |
---|
| 169 | return "" |
---|
| 170 | } |
---|
| 171 | if {$option eq ""} { |
---|
| 172 | set vlist "" |
---|
| 173 | foreach opt [$obj configure] { |
---|
| 174 | lappend vlist [lindex $opt 0] [lindex $opt end] |
---|
| 175 | } |
---|
| 176 | return $vlist |
---|
| 177 | } |
---|
| 178 | return [$obj cget $option] |
---|
| 179 | } |
---|
| 180 | |
---|
| 181 | # ---------------------------------------------------------------------- |
---|
| 182 | # USAGE: _redraw |
---|
| 183 | # |
---|
| 184 | # Used internally to update the detailed list of items maintained |
---|
| 185 | # by this widget. |
---|
| 186 | # ---------------------------------------------------------------------- |
---|
| 187 | itcl::body Rappture::Tester::Legend::_redraw {} { |
---|
| 188 | set c $itk_component(area) |
---|
| 189 | set w [winfo width $c] |
---|
| 190 | set ymid [expr {[winfo height $c]/2}] |
---|
| 191 | set padx $itk_option(-padx) |
---|
| 192 | set fn $itk_option(-font) |
---|
| 193 | set ssize [expr {[font metrics $fn -linespace]-2}] |
---|
| 194 | |
---|
| 195 | $c delete all |
---|
| 196 | |
---|
| 197 | # left/right edges of the drawing area |
---|
| 198 | set x0 2 |
---|
| 199 | set x1 [expr {[winfo width $c]-2}] |
---|
| 200 | |
---|
| 201 | # overall label on the left |
---|
| 202 | set id [$c create text $x0 $ymid -anchor w -text "Legend:" -font $fn] |
---|
| 203 | foreach {bx0 by0 bx1 by1} [$c bbox $id] break |
---|
| 204 | set x0 [expr {$x0 + $bx1-$bx0 + $padx}] |
---|
| 205 | |
---|
| 206 | foreach obj $_entries { |
---|
| 207 | if {[$obj cget -state] eq "disabled" || [$obj cget -title] eq "" |
---|
| 208 | || [$obj cget -color] eq ""} { |
---|
| 209 | continue |
---|
| 210 | } |
---|
| 211 | |
---|
| 212 | set labelw [font measure $fn [$obj cget -title]] |
---|
| 213 | set entryw [expr {$labelw + $ssize + 3}] |
---|
| 214 | |
---|
| 215 | switch -- [$obj cget -anchor] { |
---|
| 216 | w { |
---|
| 217 | set xpos $x0 |
---|
| 218 | set x0 [expr {$x0 + $entryw + $padx}] |
---|
| 219 | } |
---|
| 220 | e { |
---|
| 221 | set xpos [expr {$x1 - $entryw}] |
---|
| 222 | set x1 [expr {$x1 - $entryw - $padx}] |
---|
| 223 | } |
---|
| 224 | } |
---|
| 225 | |
---|
| 226 | switch -- [$obj cget -shape] { |
---|
| 227 | box { |
---|
| 228 | # draw the box style |
---|
| 229 | $c create rectangle \ |
---|
| 230 | $xpos [expr {$ymid-$ssize/2}] \ |
---|
| 231 | [expr {$xpos+$ssize}] [expr {$ymid+$ssize/2}] \ |
---|
| 232 | -outline black -fill [$obj cget -color] |
---|
| 233 | } |
---|
| 234 | line { |
---|
| 235 | # draw the line style |
---|
| 236 | $c create line $xpos $ymid [expr {$xpos+$ssize}] $ymid \ |
---|
| 237 | -width 2 -fill [$obj cget -color] |
---|
| 238 | } |
---|
| 239 | } |
---|
| 240 | set xpos [expr {$xpos+$ssize+3}] |
---|
| 241 | |
---|
| 242 | $c create text $xpos $ymid -anchor w -text [$obj cget -title] -font $fn |
---|
| 243 | |
---|
| 244 | if {$x0 >= $x1} break |
---|
| 245 | } |
---|
| 246 | |
---|
| 247 | # fix the requested size for the widget based on the layout |
---|
| 248 | $c configure -width [expr {$x0 + [winfo width $c]-$x1}] |
---|
| 249 | } |
---|
| 250 | |
---|
| 251 | # ---------------------------------------------------------------------- |
---|
| 252 | # CONFIGURATION OPTIONS |
---|
| 253 | # ---------------------------------------------------------------------- |
---|
| 254 | itcl::configbody Rappture::Tester::Legend::font { |
---|
| 255 | set lineh [font metrics $itk_option(-font) -linespace] |
---|
| 256 | $itk_component(area) configure -height [expr {$lineh+4}] |
---|
| 257 | $_dispatcher event -idle !redraw |
---|
| 258 | } |
---|