| 1 | # -*- mode: tcl; indent-tabs-mode: nil -*- |
|---|
| 2 | # ---------------------------------------------------------------------- |
|---|
| 3 | # COMPONENT: ProbDistEditor - probability distribution editor |
|---|
| 4 | # |
|---|
| 5 | # This widget displays a probability distribution and lets the user |
|---|
| 6 | # edit it in various flavors. |
|---|
| 7 | # ====================================================================== |
|---|
| 8 | # AUTHOR: Michael McLennan, Purdue University |
|---|
| 9 | # Copyright (c) 2004-2010 Purdue University |
|---|
| 10 | # |
|---|
| 11 | # See the file "license.terms" for information on usage and |
|---|
| 12 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|---|
| 13 | # ====================================================================== |
|---|
| 14 | package require Itk |
|---|
| 15 | package require BLT |
|---|
| 16 | |
|---|
| 17 | option add *ProbDistEditor.fillColor blue widgetDefault |
|---|
| 18 | option add *ProbDistEditor*Entry.background white widgetDefault |
|---|
| 19 | option add *ProbDistEditor*Entry.width 10 widgetDefault |
|---|
| 20 | |
|---|
| 21 | itcl::class Rappture::ProbDistEditor { |
|---|
| 22 | inherit itk::Widget |
|---|
| 23 | |
|---|
| 24 | itk_option define -fillcolor fillColor FillColor "" |
|---|
| 25 | |
|---|
| 26 | constructor {args} { |
|---|
| 27 | # defined below |
|---|
| 28 | } |
|---|
| 29 | public method value {{newval ""}} |
|---|
| 30 | public method mode {{newval ""}} |
|---|
| 31 | public method reset {} |
|---|
| 32 | |
|---|
| 33 | protected method _redraw {} |
|---|
| 34 | protected method _axisLabels {which graph val} |
|---|
| 35 | protected method _apply {op {widget ""}} |
|---|
| 36 | |
|---|
| 37 | protected variable _dispatcher ""; # dispatcher for !events |
|---|
| 38 | protected variable _mode ""; # type of distribution function |
|---|
| 39 | protected variable _value; # data values for mode-detail |
|---|
| 40 | protected variable _uvalue; # data values for mode-detail with units |
|---|
| 41 | protected variable _umin; # minimum allowed value for tool with units |
|---|
| 42 | protected variable _umax; # maximum allowed value for tool with units |
|---|
| 43 | protected variable _units; # units for min and max |
|---|
| 44 | } |
|---|
| 45 | |
|---|
| 46 | itk::usual ProbDistEditor { |
|---|
| 47 | keep -cursor -font -foreground -background |
|---|
| 48 | keep -fillcolor |
|---|
| 49 | } |
|---|
| 50 | |
|---|
| 51 | # ---------------------------------------------------------------------- |
|---|
| 52 | # CONSTRUCTOR |
|---|
| 53 | # ---------------------------------------------------------------------- |
|---|
| 54 | itcl::body Rappture::ProbDistEditor::constructor {min max units default} { |
|---|
| 55 | # create a dispatcher for events |
|---|
| 56 | #puts "PDE::constructor $min $max $default" |
|---|
| 57 | |
|---|
| 58 | # These are the tool min and max values. May be empty. |
|---|
| 59 | set _umin $min |
|---|
| 60 | set _umax $max |
|---|
| 61 | set _units $units |
|---|
| 62 | set _uvalue(central) $default |
|---|
| 63 | |
|---|
| 64 | Rappture::dispatcher _dispatcher |
|---|
| 65 | $_dispatcher register !redraw |
|---|
| 66 | $_dispatcher dispatch $this !redraw "[itcl::code $this _redraw]; list" |
|---|
| 67 | |
|---|
| 68 | itk_component add vals { |
|---|
| 69 | frame $itk_interior.vals |
|---|
| 70 | } |
|---|
| 71 | pack $itk_component(vals) -side left -fill both -padx {0 10} |
|---|
| 72 | # |
|---|
| 73 | # EXACT value options |
|---|
| 74 | # |
|---|
| 75 | itk_component add exactvals { |
|---|
| 76 | frame $itk_component(vals).exact |
|---|
| 77 | } |
|---|
| 78 | itk_component add evl { |
|---|
| 79 | label $itk_component(exactvals).l -text "Value:" |
|---|
| 80 | } |
|---|
| 81 | entry $itk_component(exactvals).val |
|---|
| 82 | _apply bindings $itk_component(exactvals).val |
|---|
| 83 | grid $itk_component(evl) -row 0 -column 0 -sticky e |
|---|
| 84 | grid $itk_component(exactvals).val -row 0 -column 1 -sticky ew -pady 2 |
|---|
| 85 | grid rowconfigure $itk_component(exactvals) 1 -weight 1 |
|---|
| 86 | # |
|---|
| 87 | # UNIFORM value options |
|---|
| 88 | # |
|---|
| 89 | itk_component add uniformvals { |
|---|
| 90 | frame $itk_component(vals).uniform |
|---|
| 91 | } |
|---|
| 92 | itk_component add uvl0 { |
|---|
| 93 | label $itk_component(uniformvals).l0 -text "Minimum:" |
|---|
| 94 | } |
|---|
| 95 | entry $itk_component(uniformvals).min |
|---|
| 96 | _apply bindings $itk_component(uniformvals).min |
|---|
| 97 | grid $itk_component(uvl0) -row 0 -column 0 -sticky e |
|---|
| 98 | grid $itk_component(uniformvals).min -row 0 -column 1 -sticky ew -pady 2 |
|---|
| 99 | |
|---|
| 100 | itk_component add uvl1 { |
|---|
| 101 | label $itk_component(uniformvals).l1 -text "Maximum:" |
|---|
| 102 | } |
|---|
| 103 | entry $itk_component(uniformvals).max |
|---|
| 104 | _apply bindings $itk_component(uniformvals).max |
|---|
| 105 | grid $itk_component(uvl1) -row 1 -column 0 -sticky e |
|---|
| 106 | grid $itk_component(uniformvals).max -row 1 -column 1 -sticky ew -pady 2 |
|---|
| 107 | grid rowconfigure $itk_component(uniformvals) 2 -weight 1 |
|---|
| 108 | |
|---|
| 109 | # |
|---|
| 110 | # GAUSSIAN value options |
|---|
| 111 | # |
|---|
| 112 | itk_component add gaussianvals { |
|---|
| 113 | frame $itk_component(vals).gaussian |
|---|
| 114 | } |
|---|
| 115 | itk_component add gvlm { |
|---|
| 116 | label $itk_component(gaussianvals).lm -text "Mean:" |
|---|
| 117 | } |
|---|
| 118 | entry $itk_component(gaussianvals).mean |
|---|
| 119 | _apply bindings $itk_component(gaussianvals).mean |
|---|
| 120 | grid $itk_component(gvlm) -row 0 -column 0 -sticky e |
|---|
| 121 | grid $itk_component(gaussianvals).mean -row 0 -column 1 -sticky ew -pady 2 |
|---|
| 122 | |
|---|
| 123 | itk_component add gvls { |
|---|
| 124 | label $itk_component(gaussianvals).ls -text "Std Deviation:" |
|---|
| 125 | } |
|---|
| 126 | entry $itk_component(gaussianvals).stddev |
|---|
| 127 | _apply bindings $itk_component(gaussianvals).stddev |
|---|
| 128 | grid $itk_component(gvls) -row 1 -column 0 -sticky e |
|---|
| 129 | grid $itk_component(gaussianvals).stddev -row 1 -column 1 -sticky ew -pady 2 |
|---|
| 130 | |
|---|
| 131 | itk_component add gvl0 { |
|---|
| 132 | label $itk_component(gaussianvals).l0 -text "Minimum:" -state disabled |
|---|
| 133 | } |
|---|
| 134 | entry $itk_component(gaussianvals).min -state readonly |
|---|
| 135 | _apply bindings $itk_component(gaussianvals).min |
|---|
| 136 | grid $itk_component(gvl0) -row 2 -column 0 -sticky e |
|---|
| 137 | grid $itk_component(gaussianvals).min -row 2 -column 1 -sticky ew -pady 2 |
|---|
| 138 | |
|---|
| 139 | itk_component add gvl1 { |
|---|
| 140 | label $itk_component(gaussianvals).l1 -text "Maximum:" -state disabled |
|---|
| 141 | } |
|---|
| 142 | entry $itk_component(gaussianvals).max -state readonly |
|---|
| 143 | _apply bindings $itk_component(gaussianvals).max |
|---|
| 144 | grid $itk_component(gvl1) -row 3 -column 0 -sticky e |
|---|
| 145 | grid $itk_component(gaussianvals).max -row 3 -column 1 -sticky ew -pady 2 |
|---|
| 146 | grid rowconfigure $itk_component(gaussianvals) 4 -weight 1 |
|---|
| 147 | |
|---|
| 148 | # |
|---|
| 149 | # Preview graph to display probability density function |
|---|
| 150 | # |
|---|
| 151 | itk_component add graph { |
|---|
| 152 | blt::graph $itk_interior.graph -width 2i -height 1i \ |
|---|
| 153 | -plotborderwidth 1 -plotrelief solid -plotpadx 0 -plotpady 0 \ |
|---|
| 154 | -highlightthickness 0 |
|---|
| 155 | } { |
|---|
| 156 | keep -background -foreground -cursor -font |
|---|
| 157 | } |
|---|
| 158 | pack $itk_component(graph) -expand yes -fill both |
|---|
| 159 | |
|---|
| 160 | $itk_component(graph) xaxis configure -ticklength 4 \ |
|---|
| 161 | -command [itcl::code $this _axisLabels xaxis] |
|---|
| 162 | $itk_component(graph) yaxis configure -ticklength 4 \ |
|---|
| 163 | -title "PDF" -command [itcl::code $this _axisLabels yaxis] |
|---|
| 164 | $itk_component(graph) grid off |
|---|
| 165 | $itk_component(graph) legend configure -hide yes |
|---|
| 166 | |
|---|
| 167 | # start in exact mode with default values |
|---|
| 168 | mode "exact" |
|---|
| 169 | |
|---|
| 170 | eval itk_initialize |
|---|
| 171 | |
|---|
| 172 | # |
|---|
| 173 | # Figure out a good size for all panels of options and for the |
|---|
| 174 | # overall widget. |
|---|
| 175 | # |
|---|
| 176 | update idletasks |
|---|
| 177 | set maxw 0 |
|---|
| 178 | set maxh 0 |
|---|
| 179 | foreach panel {exact uniform gaussian} { |
|---|
| 180 | set w [winfo reqwidth $itk_component(${panel}vals)] |
|---|
| 181 | if {$w > $maxw} { set maxw $w } |
|---|
| 182 | set h [winfo reqheight $itk_component(${panel}vals)] |
|---|
| 183 | if {$h > $maxh} { set maxh $h } |
|---|
| 184 | } |
|---|
| 185 | |
|---|
| 186 | pack propagate $itk_component(vals) off |
|---|
| 187 | $itk_component(vals) configure -width $maxw -height $maxh |
|---|
| 188 | } |
|---|
| 189 | |
|---|
| 190 | # ---------------------------------------------------------------------- |
|---|
| 191 | # USAGE: value ?<setValue>? |
|---|
| 192 | # |
|---|
| 193 | # With no arguments, this returns the current value within the widget |
|---|
| 194 | # as a list of key/value pairs: |
|---|
| 195 | # mode gaussian mean xxx stddev xxx min xxx max xxx |
|---|
| 196 | # |
|---|
| 197 | # Each value always has a "mode" that indicates its type, and other |
|---|
| 198 | # values to characterize the type. |
|---|
| 199 | # |
|---|
| 200 | # If the value is specified, then it is interpreted as the sort of |
|---|
| 201 | # value that is passed back, but used to set the value. |
|---|
| 202 | # ---------------------------------------------------------------------- |
|---|
| 203 | itcl::body Rappture::ProbDistEditor::value {{newval ""}} { |
|---|
| 204 | # puts "PDE::value $newval" |
|---|
| 205 | |
|---|
| 206 | #FIXME: _value has numerical values _uvalue has value with units |
|---|
| 207 | if {"" == $newval} { |
|---|
| 208 | catch {_apply finalize} ;# apply any outstanding changes |
|---|
| 209 | |
|---|
| 210 | switch -- $_mode { |
|---|
| 211 | exact { |
|---|
| 212 | return $_uvalue(central) |
|---|
| 213 | } |
|---|
| 214 | uniform { |
|---|
| 215 | return [list uniform $_uvalue(min) $_uvalue(max)] |
|---|
| 216 | } |
|---|
| 217 | gaussian { |
|---|
| 218 | return [list gaussian $_uvalue(central) $_uvalue(stddev)] |
|---|
| 219 | } |
|---|
| 220 | default { |
|---|
| 221 | error "don't know how to format value for $_mode" |
|---|
| 222 | } |
|---|
| 223 | } |
|---|
| 224 | } |
|---|
| 225 | |
|---|
| 226 | set newmode [lindex $newval 0] |
|---|
| 227 | switch -- $newmode { |
|---|
| 228 | uniform { |
|---|
| 229 | foreach {utmp(min) utmp(max)} [lrange $newval 1 2] break |
|---|
| 230 | if {[catch {Rappture::Units::convert $utmp(min) -units off} tmp(min)]} { |
|---|
| 231 | set tmp(min) $utmp(min) |
|---|
| 232 | } |
|---|
| 233 | if {[catch {Rappture::Units::convert $utmp(max) -units off} tmp(max)]} { |
|---|
| 234 | set tmp(max) $utmp(max) |
|---|
| 235 | } |
|---|
| 236 | } |
|---|
| 237 | gaussian { |
|---|
| 238 | foreach {utmp(central) utmp(stddev)} [lrange $newval 1 2] break |
|---|
| 239 | if {[catch {Rappture::Units::convert $utmp(central) -units off} tmp(central)]} { |
|---|
| 240 | set tmp(central) $utmp(central) |
|---|
| 241 | } |
|---|
| 242 | if {[catch {Rappture::Units::convert $utmp(stddev) -units off} tmp(stddev)]} { |
|---|
| 243 | set tmp(stddev) $utmp(stddev) |
|---|
| 244 | } |
|---|
| 245 | set units [Rappture::Units::Search::for $utmp(central)] |
|---|
| 246 | if {"" != $_umin} { |
|---|
| 247 | if {"" != $units} { |
|---|
| 248 | set tmp(min) [Rappture::Units::convert $_umin -to $units -context $units -units off] |
|---|
| 249 | } else { |
|---|
| 250 | set tmp(min) $_umin |
|---|
| 251 | } |
|---|
| 252 | } |
|---|
| 253 | if {"" != $_umax} { |
|---|
| 254 | if {"" != $units} { |
|---|
| 255 | set tmp(max) [Rappture::Units::convert $_umax -to $units -context $units -units off] |
|---|
| 256 | } else { |
|---|
| 257 | set tmp(max) $_umax |
|---|
| 258 | } |
|---|
| 259 | } |
|---|
| 260 | } |
|---|
| 261 | exact { |
|---|
| 262 | set utmp(central) [lindex $newval 1] |
|---|
| 263 | if {[catch {Rappture::Units::convert $utmp(central) -units off} tmp(central)]} { |
|---|
| 264 | set tmp(central) $utmp(central) |
|---|
| 265 | } |
|---|
| 266 | } |
|---|
| 267 | default { |
|---|
| 268 | set newmode exact |
|---|
| 269 | set utmp(central) [lindex $newval 0] |
|---|
| 270 | if {[catch {Rappture::Units::convert $utmp(central) -units off} tmp(central)]} { |
|---|
| 271 | set tmp(central) $utmp(central) |
|---|
| 272 | } |
|---|
| 273 | } |
|---|
| 274 | } |
|---|
| 275 | array set _value [array get tmp] |
|---|
| 276 | array set _uvalue [array get utmp] |
|---|
| 277 | mode $newmode ;# assign this mode and copy in values for editing |
|---|
| 278 | } |
|---|
| 279 | |
|---|
| 280 | # ---------------------------------------------------------------------- |
|---|
| 281 | # USAGE: mode ?<setMode>? |
|---|
| 282 | # |
|---|
| 283 | # With no arguments, this returns a list of allowed distribution |
|---|
| 284 | # modes. Otherwise, the value sets the mode of the distribution and |
|---|
| 285 | # loads default or previous values for the distribution. Note that |
|---|
| 286 | # the mode is also reported as part of the "value" returned from |
|---|
| 287 | # this widget. |
|---|
| 288 | # ---------------------------------------------------------------------- |
|---|
| 289 | itcl::body Rappture::ProbDistEditor::mode {{newval ""}} { |
|---|
| 290 | # puts "PDE::mode mode=$newval min=$_umin max=$_umax units=$_units" |
|---|
| 291 | |
|---|
| 292 | set modes {exact uniform gaussian custom} |
|---|
| 293 | if {"" == $newval} { |
|---|
| 294 | return $modes |
|---|
| 295 | } |
|---|
| 296 | |
|---|
| 297 | set check 0 |
|---|
| 298 | if {$newval == "check"} { |
|---|
| 299 | set newval $_mode |
|---|
| 300 | set check 1 |
|---|
| 301 | } |
|---|
| 302 | |
|---|
| 303 | if {[lsearch $modes $newval] < 0} { |
|---|
| 304 | error "bad value \"$newval\": should be [join $modes {, }]" |
|---|
| 305 | } |
|---|
| 306 | |
|---|
| 307 | # discard units from tool min/max |
|---|
| 308 | if {$_units == ""} { |
|---|
| 309 | set min $_umin |
|---|
| 310 | set max $_umax |
|---|
| 311 | } else { |
|---|
| 312 | if {$_umin == ""} { |
|---|
| 313 | set min "" |
|---|
| 314 | } else { |
|---|
| 315 | set min [Rappture::Units::convert $_umin -context $_units -units off] |
|---|
| 316 | } |
|---|
| 317 | if {$_umax == ""} { |
|---|
| 318 | set max "" |
|---|
| 319 | } else { |
|---|
| 320 | set max [Rappture::Units::convert $_umax -context $_units -units off] |
|---|
| 321 | } |
|---|
| 322 | } |
|---|
| 323 | |
|---|
| 324 | # The mode was changed by the user. Pick reasonable values. |
|---|
| 325 | switch -- $newval { |
|---|
| 326 | exact { |
|---|
| 327 | if {![info exists _value(central)]} { |
|---|
| 328 | if {$min != "" && $max != ""} { |
|---|
| 329 | set _value(central) [expr {0.5*($max + $min)}] |
|---|
| 330 | } else { |
|---|
| 331 | set _value(central) 0.5 |
|---|
| 332 | } |
|---|
| 333 | set _uvalue(central) $_value(central)$_units |
|---|
| 334 | } |
|---|
| 335 | } |
|---|
| 336 | uniform { |
|---|
| 337 | if {![info exists _value(min)] || ![info exists _value(max)]} { |
|---|
| 338 | set _value(max) [expr $_value(central) * 1.1] |
|---|
| 339 | set _value(min) [expr $_value(central) * 0.9] |
|---|
| 340 | if {$_value(central) == 0.0} { |
|---|
| 341 | set _value(max) 1.0 |
|---|
| 342 | } |
|---|
| 343 | if {$min != ""} { |
|---|
| 344 | if {$_value(min) < $min} { |
|---|
| 345 | set $_value(min) $min |
|---|
| 346 | } |
|---|
| 347 | } |
|---|
| 348 | if {$max != ""} { |
|---|
| 349 | if {$_value(max) > $max} { |
|---|
| 350 | set $_value(max) $max |
|---|
| 351 | } |
|---|
| 352 | } |
|---|
| 353 | set _uvalue(min) $_value(min)$_units |
|---|
| 354 | set _uvalue(max) $_value(max)$_units |
|---|
| 355 | } |
|---|
| 356 | } |
|---|
| 357 | gaussian { |
|---|
| 358 | #puts "GAUSSIAN min=$min max=$max" |
|---|
| 359 | if {![info exists _value(central)]} { |
|---|
| 360 | if {[info exists _value(min)] && [info exists _value(max)]} { |
|---|
| 361 | set _value(central) [expr {0.5*($_value(max) + $_value(min))}] |
|---|
| 362 | } else { |
|---|
| 363 | set _value(central) [expr {0.5*($max + $min)}] |
|---|
| 364 | } |
|---|
| 365 | } |
|---|
| 366 | #puts "central=$_value(central)" |
|---|
| 367 | if {![info exists _value(stddev)]} { |
|---|
| 368 | set _value(stddev) [expr $_value(central) * 0.10] |
|---|
| 369 | } |
|---|
| 370 | if {$_value(stddev) <= 0} { |
|---|
| 371 | set _value(stddev) 1.0 |
|---|
| 372 | } |
|---|
| 373 | #puts "stddev=$_value(stddev)" |
|---|
| 374 | # lower bound is -3 deviations or tool min |
|---|
| 375 | set trunc [expr {$_value(central) - 3*$_value(stddev)}] |
|---|
| 376 | if {$min == "" || $trunc > $min} { |
|---|
| 377 | set _value(min) $trunc |
|---|
| 378 | } else { |
|---|
| 379 | set _value(min) $min |
|---|
| 380 | } |
|---|
| 381 | |
|---|
| 382 | # upper bound is +3 deviations or tool max |
|---|
| 383 | set trunc [expr {$_value(central) + 3*$_value(stddev)}] |
|---|
| 384 | if {$max == "" || $trunc < $max} { |
|---|
| 385 | set _value(max) $trunc |
|---|
| 386 | } else { |
|---|
| 387 | set _value(max) $max |
|---|
| 388 | } |
|---|
| 389 | |
|---|
| 390 | set _uvalue(min) $_value(min)$_units |
|---|
| 391 | set _uvalue(max) $_value(max)$_units |
|---|
| 392 | set _uvalue(central) $_value(central)$_units |
|---|
| 393 | set _uvalue(stddev) $_value(stddev)$_units |
|---|
| 394 | } |
|---|
| 395 | } |
|---|
| 396 | |
|---|
| 397 | if {$check == 1} { |
|---|
| 398 | return |
|---|
| 399 | } |
|---|
| 400 | # pop up the panel of editing options for this mode |
|---|
| 401 | foreach w [pack slaves $itk_component(vals)] { |
|---|
| 402 | pack forget $w |
|---|
| 403 | } |
|---|
| 404 | pack $itk_component(${newval}vals) -expand yes -fill both |
|---|
| 405 | |
|---|
| 406 | switch -- $newval { |
|---|
| 407 | exact { |
|---|
| 408 | $itk_component(exactvals).val delete 0 end |
|---|
| 409 | $itk_component(exactvals).val insert end $_uvalue(central) |
|---|
| 410 | focus $itk_component(exactvals).val |
|---|
| 411 | } |
|---|
| 412 | uniform { |
|---|
| 413 | $itk_component(uniformvals).min delete 0 end |
|---|
| 414 | $itk_component(uniformvals).min insert end $_uvalue(min) |
|---|
| 415 | $itk_component(uniformvals).max delete 0 end |
|---|
| 416 | $itk_component(uniformvals).max insert end $_uvalue(max) |
|---|
| 417 | focus $itk_component(uniformvals).min |
|---|
| 418 | } |
|---|
| 419 | gaussian { |
|---|
| 420 | $itk_component(gaussianvals).mean delete 0 end |
|---|
| 421 | $itk_component(gaussianvals).mean insert end $_uvalue(central) |
|---|
| 422 | $itk_component(gaussianvals).stddev delete 0 end |
|---|
| 423 | $itk_component(gaussianvals).stddev insert end $_uvalue(stddev) |
|---|
| 424 | |
|---|
| 425 | $itk_component(gaussianvals).min configure -state normal |
|---|
| 426 | $itk_component(gaussianvals).min delete 0 end |
|---|
| 427 | $itk_component(gaussianvals).min insert end $_uvalue(min) |
|---|
| 428 | $itk_component(gaussianvals).min configure -state readonly |
|---|
| 429 | |
|---|
| 430 | $itk_component(gaussianvals).max configure -state normal |
|---|
| 431 | $itk_component(gaussianvals).max delete 0 end |
|---|
| 432 | $itk_component(gaussianvals).max insert end $_uvalue(max) |
|---|
| 433 | $itk_component(gaussianvals).max configure -state readonly |
|---|
| 434 | |
|---|
| 435 | focus $itk_component(gaussianvals).mean |
|---|
| 436 | } |
|---|
| 437 | } |
|---|
| 438 | |
|---|
| 439 | set _mode $newval |
|---|
| 440 | $_dispatcher event -idle !redraw |
|---|
| 441 | } |
|---|
| 442 | |
|---|
| 443 | # ---------------------------------------------------------------------- |
|---|
| 444 | # USAGE: reset |
|---|
| 445 | # |
|---|
| 446 | # Clears all value information so that the next value application |
|---|
| 447 | # starts from scratch. Without a reset, the widget carries information |
|---|
| 448 | # like the "central" value, in case the user changes modes and then |
|---|
| 449 | # changes back. Reset discards that info and starts fresh. |
|---|
| 450 | # ---------------------------------------------------------------------- |
|---|
| 451 | itcl::body Rappture::ProbDistEditor::reset {} { |
|---|
| 452 | set _mode "" |
|---|
| 453 | catch {unset _value} |
|---|
| 454 | catch {unset _uvalue} |
|---|
| 455 | $_dispatcher event -idle !redraw |
|---|
| 456 | } |
|---|
| 457 | |
|---|
| 458 | # ---------------------------------------------------------------------- |
|---|
| 459 | # USAGE: _redraw |
|---|
| 460 | # |
|---|
| 461 | # Used internally to reconfigure the graph to display the current |
|---|
| 462 | # distribution plot. |
|---|
| 463 | # ---------------------------------------------------------------------- |
|---|
| 464 | itcl::body Rappture::ProbDistEditor::_redraw {} { |
|---|
| 465 | #puts "PDE::_redraw" |
|---|
| 466 | |
|---|
| 467 | set g $itk_component(graph) |
|---|
| 468 | eval $g element delete [$g element names] |
|---|
| 469 | eval $g mark delete [$g mark names] |
|---|
| 470 | switch -- $_mode { |
|---|
| 471 | exact { |
|---|
| 472 | $g xaxis configure -majorticks {} -min 0 -max 1 -stepsize 0.1 |
|---|
| 473 | $g yaxis configure -min 0 -max 1 |
|---|
| 474 | $g element create delta \ |
|---|
| 475 | -xdata {0 0.48 0.49 0.50 0.51 0.52 1} \ |
|---|
| 476 | -ydata {0 0 0.05 0.93 0.05 0 0} \ |
|---|
| 477 | -color $itk_option(-foreground) -symbol "" \ |
|---|
| 478 | -areaforeground $itk_option(-fillcolor) -areapattern solid |
|---|
| 479 | # $g marker create image -anchor nw -coords {0.5 0.95} \ |
|---|
| 480 | -xoffset -6 -yoffset -3 -image [Rappture::icon delta] |
|---|
| 481 | } |
|---|
| 482 | uniform { |
|---|
| 483 | $g xaxis configure -majorticks {} -min 0 -max 1 -stepsize 0.1 |
|---|
| 484 | $g yaxis configure -min 0 -max 1 |
|---|
| 485 | |
|---|
| 486 | # uniform distribution throughout |
|---|
| 487 | $g element create uniform \ |
|---|
| 488 | -xdata {-0.1 -0.1 1.1 1.1} -ydata {-0.1 0.5 0.5 -0.1} \ |
|---|
| 489 | -color $itk_option(-foreground) -symbol "" \ |
|---|
| 490 | -areaforeground $itk_option(-fillcolor) -areapattern solid |
|---|
| 491 | |
|---|
| 492 | # left/right limits |
|---|
| 493 | $g marker create polygon \ |
|---|
| 494 | -coords {-0.1 -0.1 0.1 -0.1 0.1 1.1 -0.1 1.1} \ |
|---|
| 495 | -outline gray -linewidth 1 -fill gray -stipple gray25 |
|---|
| 496 | $g marker create polygon \ |
|---|
| 497 | -coords {1.1 -0.1 0.9 -0.1 0.9 1.1 1.1 1.1} \ |
|---|
| 498 | -outline gray -linewidth 1 -fill gray -stipple gray25 |
|---|
| 499 | } |
|---|
| 500 | gaussian { |
|---|
| 501 | #puts "min=$_value(min) max=$_value(max)" |
|---|
| 502 | #puts "mean=$_value(central) dev=$_value(stddev)" |
|---|
| 503 | |
|---|
| 504 | set min $_value(min) |
|---|
| 505 | set max $_value(max) |
|---|
| 506 | set dx [expr {$max - $min}] |
|---|
| 507 | set realmin [expr {$min - 0.1 * $dx}] |
|---|
| 508 | set realmax [expr {$max + 0.1 * $dx}] |
|---|
| 509 | set mean $_value(central) |
|---|
| 510 | set sig2 [expr {$_value(stddev) * $_value(stddev)}] |
|---|
| 511 | $g xaxis configure -min $realmin -max $realmax \ |
|---|
| 512 | -majorticks [list $min $mean $max] |
|---|
| 513 | $g yaxis configure -min 0 -max 1.1 |
|---|
| 514 | set xdata "" |
|---|
| 515 | set ydata "" |
|---|
| 516 | for {set n 0} {$n <= 50} {incr n} { |
|---|
| 517 | set x [expr {($realmax - $realmin) / 50.0 * $n + $realmin}] |
|---|
| 518 | lappend xdata $x |
|---|
| 519 | set expon [expr {-0.5 * ($x - $mean) * ($x - $mean) / $sig2}] |
|---|
| 520 | if {$expon < -200} { |
|---|
| 521 | lappend ydata 0.0 |
|---|
| 522 | } else { |
|---|
| 523 | lappend ydata [expr {exp($expon)}] |
|---|
| 524 | } |
|---|
| 525 | } |
|---|
| 526 | $g element create bellcurve \ |
|---|
| 527 | -xdata $xdata -ydata $ydata \ |
|---|
| 528 | -color $itk_option(-foreground) -symbol "" \ |
|---|
| 529 | -areaforeground $itk_option(-fillcolor) -areapattern solid |
|---|
| 530 | |
|---|
| 531 | # left/right limits |
|---|
| 532 | set x0m [expr {$min - 0.2 * $dx}] |
|---|
| 533 | set x0 $min |
|---|
| 534 | set x1 $max |
|---|
| 535 | set x1p [expr {$max + 0.2 * $dx}] |
|---|
| 536 | $g marker create polygon \ |
|---|
| 537 | -coords [list $x0m -0.1 $x0 -0.1 $x0 1.2 $x0m 1.2] \ |
|---|
| 538 | -outline gray -linewidth 1 -fill gray -stipple gray25 |
|---|
| 539 | $g marker create polygon \ |
|---|
| 540 | -coords [list $x1p -0.1 $x1 -0.1 $x1 1.2 $x1p 1.2] \ |
|---|
| 541 | -outline gray -linewidth 1 -fill gray -stipple gray25 |
|---|
| 542 | |
|---|
| 543 | # lines for standard deviation |
|---|
| 544 | set x0 [expr {$_value(central)-$_value(stddev)}] |
|---|
| 545 | set x1 [expr {$_value(central)+$_value(stddev)}] |
|---|
| 546 | $g marker create line \ |
|---|
| 547 | -coords [list $x0 -0.1 $x0 1.2] -linewidth 1 \ |
|---|
| 548 | -outline gray -dashes 2 |
|---|
| 549 | $g marker create line \ |
|---|
| 550 | -coords [list $x1 -0.1 $x1 1.2] -linewidth 1 \ |
|---|
| 551 | -outline gray -dashes 2 |
|---|
| 552 | } |
|---|
| 553 | custom { |
|---|
| 554 | } |
|---|
| 555 | default { |
|---|
| 556 | error "don't know how to redraw for mode \"$_mode\"" |
|---|
| 557 | } |
|---|
| 558 | } |
|---|
| 559 | } |
|---|
| 560 | |
|---|
| 561 | # ---------------------------------------------------------------------- |
|---|
| 562 | # USAGE: _axisLabels <which> <graph> <val> |
|---|
| 563 | # |
|---|
| 564 | # Used internally to generate axis labels for the x- and y-axes of |
|---|
| 565 | # the graph. The y-axis doesn't usually have labels since the values |
|---|
| 566 | # aren't meaningful. The x-axis should show values according to the |
|---|
| 567 | # current mode of input. |
|---|
| 568 | # ---------------------------------------------------------------------- |
|---|
| 569 | itcl::body Rappture::ProbDistEditor::_axisLabels {which graph val} { |
|---|
| 570 | switch -- $which { |
|---|
| 571 | xaxis { |
|---|
| 572 | switch -- $_mode { |
|---|
| 573 | exact { |
|---|
| 574 | if {$val == 0.5} { |
|---|
| 575 | return $_value(central) |
|---|
| 576 | } |
|---|
| 577 | return "" |
|---|
| 578 | } |
|---|
| 579 | uniform { |
|---|
| 580 | if {$val == 0.1} { |
|---|
| 581 | return [expr {$_value(min) < $_value(max) |
|---|
| 582 | ? $_value(min) : $_value(max)}] |
|---|
| 583 | } elseif {$val == 0.9} { |
|---|
| 584 | return [expr {$_value(min) > $_value(max) |
|---|
| 585 | ? $_value(min) : $_value(max)}] |
|---|
| 586 | } |
|---|
| 587 | return "" |
|---|
| 588 | } |
|---|
| 589 | gaussian { |
|---|
| 590 | return $val |
|---|
| 591 | } |
|---|
| 592 | } |
|---|
| 593 | } |
|---|
| 594 | yaxis { |
|---|
| 595 | return "" ;# no labels for y-axis values |
|---|
| 596 | } |
|---|
| 597 | } |
|---|
| 598 | } |
|---|
| 599 | |
|---|
| 600 | # ---------------------------------------------------------------------- |
|---|
| 601 | # USAGE: _apply bindings <widget> |
|---|
| 602 | # USAGE: _apply value <widget> |
|---|
| 603 | # USAGE: _apply finalize |
|---|
| 604 | # |
|---|
| 605 | # Called automatically whenever a value is edited to check/apply the |
|---|
| 606 | # value and redraw the PDF plot. If the value is bad, then it is |
|---|
| 607 | # reloaded for editing. Otherwise, it is applied. |
|---|
| 608 | # ---------------------------------------------------------------------- |
|---|
| 609 | itcl::body Rappture::ProbDistEditor::_apply {op {widget ""}} { |
|---|
| 610 | #puts "PDE::_apply $op $widget" |
|---|
| 611 | if {$op != "bindings"} { |
|---|
| 612 | # need this for value/finalize |
|---|
| 613 | array set w2uvalue [list \ |
|---|
| 614 | $itk_component(exactvals).val _uvalue(central) \ |
|---|
| 615 | $itk_component(uniformvals).min _uvalue(min) \ |
|---|
| 616 | $itk_component(uniformvals).max _uvalue(max) \ |
|---|
| 617 | $itk_component(gaussianvals).mean _uvalue(central) \ |
|---|
| 618 | $itk_component(gaussianvals).stddev _uvalue(stddev) \ |
|---|
| 619 | $itk_component(gaussianvals).min _uvalue(min) \ |
|---|
| 620 | $itk_component(gaussianvals).max _uvalue(max) \ |
|---|
| 621 | ] |
|---|
| 622 | array set w2value [list \ |
|---|
| 623 | $itk_component(exactvals).val _value(central) \ |
|---|
| 624 | $itk_component(uniformvals).min _value(min) \ |
|---|
| 625 | $itk_component(uniformvals).max _value(max) \ |
|---|
| 626 | $itk_component(gaussianvals).mean _value(central) \ |
|---|
| 627 | $itk_component(gaussianvals).stddev _value(stddev) \ |
|---|
| 628 | $itk_component(gaussianvals).min _value(min) \ |
|---|
| 629 | $itk_component(gaussianvals).max _value(max) \ |
|---|
| 630 | ] |
|---|
| 631 | } |
|---|
| 632 | |
|---|
| 633 | if {$op == "finalize"} { |
|---|
| 634 | # one of our widgets has focus? |
|---|
| 635 | set widget [focus] |
|---|
| 636 | if {![info exists w2value($widget)]} { |
|---|
| 637 | # nope -- nevermind, nothing to do |
|---|
| 638 | return |
|---|
| 639 | } |
|---|
| 640 | # yes -- continue onward trying to finalize the value in that widget |
|---|
| 641 | set op "value" |
|---|
| 642 | } |
|---|
| 643 | |
|---|
| 644 | switch -- $op { |
|---|
| 645 | bindings { |
|---|
| 646 | bind $widget <KeyPress-Tab> [itcl::code $this _apply value %W] |
|---|
| 647 | bind $widget <KeyPress-Return> [itcl::code $this _apply value %W] |
|---|
| 648 | bind $widget <FocusOut> [itcl::code $this _apply value %W] |
|---|
| 649 | } |
|---|
| 650 | value { |
|---|
| 651 | set var $w2value($widget) |
|---|
| 652 | set uvar $w2uvalue($widget) |
|---|
| 653 | if {$_units == ""} { |
|---|
| 654 | set newval [$widget get] |
|---|
| 655 | } else { |
|---|
| 656 | set newval [Rappture::Units::convert [$widget get] -context $_units] |
|---|
| 657 | } |
|---|
| 658 | set itk $itk_component(gaussianvals).stddev |
|---|
| 659 | if {$widget != $itk && [catch {Rappture::Units::mcheck_range $newval $_umin $_umax $_units} err]} { |
|---|
| 660 | # oops! value is bad -- edit again |
|---|
| 661 | bell |
|---|
| 662 | Rappture::Tooltip::cue $widget $err |
|---|
| 663 | $widget delete 0 end |
|---|
| 664 | $widget insert end [set $var] |
|---|
| 665 | $widget select from 0 |
|---|
| 666 | $widget select to end |
|---|
| 667 | focus $widget |
|---|
| 668 | return -code break ;# stop other bindings like tab-traversal |
|---|
| 669 | } |
|---|
| 670 | $widget delete 0 end |
|---|
| 671 | $widget insert end $newval |
|---|
| 672 | set $uvar $newval |
|---|
| 673 | |
|---|
| 674 | #if {$widget == $itk_component(gaussianvals).mean} { |
|---|
| 675 | # need new min and max |
|---|
| 676 | #set $_uvalue(min) |
|---|
| 677 | #set $_uvalue(max) ... |
|---|
| 678 | #} |
|---|
| 679 | |
|---|
| 680 | if {[catch {Rappture::Units::convert $newval -units off} nvar]} { |
|---|
| 681 | set nvar $newval |
|---|
| 682 | } |
|---|
| 683 | set $var $nvar |
|---|
| 684 | |
|---|
| 685 | mode check |
|---|
| 686 | $_dispatcher event -idle !redraw |
|---|
| 687 | } |
|---|
| 688 | default { |
|---|
| 689 | error "bad option \"$opt\": should be bindings, value" |
|---|
| 690 | } |
|---|
| 691 | } |
|---|
| 692 | } |
|---|
| 693 | |
|---|
| 694 | # ---------------------------------------------------------------------- |
|---|
| 695 | # CONFIGURATION OPTION: -fillcolor |
|---|
| 696 | # ---------------------------------------------------------------------- |
|---|
| 697 | itcl::configbody Rappture::ProbDistEditor::fillcolor { |
|---|
| 698 | $_dispatcher event -idle !redraw |
|---|
| 699 | } |
|---|
