source: trunk/gui/scripts/resultset.tcl @ 13

Last change on this file since 13 was 13, checked in by mmc, 19 years ago

Many improvements, including a new energy level viewer
for Huckel-IV. Added support for a new <boolean> type.
Fixed the cloud/field stuff so that when a cloud is 1D,
it reverts to BLT vectors so it will plot correctly.
Fixed the install script to work better on Windows.

File size: 22.6 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: ResultSet - controls for a collection of related results
3#
4#  This widget stores a collection of results that all represent
5#  the same quantity, but for various ranges of input values.
6#  It also manages the controls to select and visualize the data.
7# ======================================================================
8#  AUTHOR:  Michael McLennan, Purdue University
9#  Copyright (c) 2004-2005
10#  Purdue Research Foundation, West Lafayette, IN
11# ======================================================================
12package require Itk
13
14option add *ResultSet.width 4i widgetDefault
15option add *ResultSet.height 4i widgetDefault
16option add *ResultSet.colors {blue magenta} widgetDefault
17option add *ResultSet.toggleBackground gray widgetDefault
18option add *ResultSet.toggleForeground white widgetDefault
19option add *ResultSet.textFont \
20    -*-helvetica-medium-r-normal-*-*-120-* widgetDefault
21option add *ResultSet.boldFont \
22    -*-helvetica-bold-r-normal-*-*-120-* widgetDefault
23
24itcl::class Rappture::ResultSet {
25    inherit itk::Widget
26
27    itk_option define -colors colors Colors ""
28    itk_option define -togglebackground toggleBackground Background ""
29    itk_option define -toggleforeground toggleForeground Foreground ""
30    itk_option define -textfont textFont Font ""
31    itk_option define -boldfont boldFont Font ""
32    itk_option define -clearcommand clearCommand ClearCommand ""
33    itk_option define -settingscommand settingsCommand SettingsCommand ""
34    itk_option define -promptcommand promptCommand PromptCommand ""
35
36    constructor {args} { # defined below }
37    destructor { # defined below }
38
39    public method add {xmlobj}
40    public method clear {}
41    public method contains {xmlobj}
42    public method size {{what -results}}
43
44    protected method _doClear {}
45    protected method _doSettings {{cmd ""}}
46    protected method _fixControls {args}
47    protected method _fixSettings {args}
48    protected method _doPrompt {state}
49    protected method _toggleAll {path widget}
50
51    private variable _dispatcher ""  ;# dispatchers for !events
52    private variable _results ""     ;# tuple of known results
53    private variable _recent ""      ;# most recent result in _results
54    private variable _plotall ""     ;# column with "All" active
55    private variable _col2widget     ;# maps column name => control widget
56    private variable _spectrum ""    ;# color spectrum for "All" active
57    private variable _counter 0      ;# counter for unique control names
58}
59                                                                               
60itk::usual ResultSet {
61    keep -background -foreground -cursor -font
62}
63
64# ----------------------------------------------------------------------
65# CONSTRUCTOR
66# ----------------------------------------------------------------------
67itcl::body Rappture::ResultSet::constructor {args} {
68    option add hull.width hull.height
69    pack propagate $itk_component(hull) no
70
71    # create a dispatcher for events
72    Rappture::dispatcher _dispatcher
73    $_dispatcher register !fixcntls
74    $_dispatcher dispatch $this !fixcntls \
75        [itcl::code $this _fixControls]
76    $_dispatcher register !settings
77    $_dispatcher dispatch $this !settings \
78        [itcl::code $this _fixSettings]
79
80    # create a list of tuples for data
81    set _results [Rappture::Tuples ::#auto]
82    $_results column insert end -name xmlobj -label "top-level XML object"
83
84
85    itk_component add cntls {
86        frame $itk_interior.cntls
87    }
88    pack $itk_component(cntls) -fill x
89
90    itk_component add clear {
91        button $itk_component(cntls).clear -text "Clear" -state disabled \
92            -relief flat -overrelief raised \
93            -command [itcl::code $this _doClear]
94    }
95    pack $itk_component(clear) -side right
96    Rappture::Tooltip::for $itk_component(clear) \
97        "Clears all results collected so far."
98
99    itk_component add status {
100        label $itk_component(cntls).status -anchor w -text "No results"
101    }
102    pack $itk_component(status) -side left -expand yes -fill x
103
104    itk_component add scroller {
105        Rappture::Scroller $itk_interior.scroller \
106            -xscrollmode off -yscrollmode auto -height 1i
107    }
108    pack $itk_component(scroller) -expand yes -fill both
109
110    eval itk_initialize $args
111
112    # color spectrum for plotting "All" results
113    set c1 [lindex $itk_option(-colors) 0]
114    set c0 [lindex $itk_option(-colors) 1]
115    if {"" == $c0} { set c0 #d9d9d9 }
116    set _spectrum [Rappture::Spectrum ::#auto [list 0 $c0 1 $c1]]
117}
118
119# ----------------------------------------------------------------------
120# DESTRUCTOR
121# ----------------------------------------------------------------------
122itcl::body Rappture::ResultSet::destructor {} {
123    itcl::delete object $_results
124    itcl::delete object $_spectrum
125}
126
127# ----------------------------------------------------------------------
128# USAGE: add <xmlobj>
129#
130# Adds a new result to this result set.  Scans through all existing
131# results to look for a difference compared to previous results.
132# Returns the index of this new result to the caller.  The various
133# data objects for this result set should be added to their result
134# viewers at the same index.
135# ----------------------------------------------------------------------
136itcl::body Rappture::ResultSet::add {xmlobj} {
137    # make sure we fix up controls at some point
138    $_dispatcher event -idle !fixcntls
139
140    #
141    # If this is the first result, then there are no diffs.
142    # Add it right in.
143    #
144    set xmlobj0 [$_results get -format xmlobj end]
145    if {"" == $xmlobj0} {
146        # first element -- always add
147        $_results insert end [list $xmlobj]
148        set _recent $xmlobj
149        $itk_component(status) configure -text "1 result"
150        $itk_component(clear) configure -state normal
151        return 0
152    }
153
154    #
155    # Compare this new object against the last XML object in the
156    # results set.  If it has a difference, make sure that there
157    # is a column to represent the quantity with the difference.
158    #
159    foreach {op vpath oldval newval} [$xmlobj0 diff $xmlobj] {
160        if {[$xmlobj get $vpath.about.diffs] == "ignore"} {
161            continue
162        }
163        if {$op == "+" || $op == "-"} {
164            # ignore differences where parameters come and go
165            # such differences make it hard to work controls
166            continue
167        }
168        if {[$_results column names $vpath] == ""} {
169            # no column for this quantity yet
170            $_results column insert end -name $vpath -default $oldval
171        }
172    }
173
174    # build a tuple for this new object
175    set cols ""
176    set tuple ""
177    foreach col [lrange [$_results column names] 1 end] {
178        lappend cols $col
179        set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0]
180        lappend tuple $raw  ;# use the "raw" (user-readable) label
181    }
182
183    # find a matching tuple? then replace it -- only need one
184    if {[llength $cols] > 0} {
185        set ilist [$_results find -format $cols -- $tuple]
186    } else {
187        set ilist 0  ;# no diffs -- must match first entry
188    }
189
190    # add all remaining columns for this new entry
191    set tuple [linsert $tuple 0 $xmlobj]
192
193    if {[llength $ilist] > 0} {
194        if {[llength $ilist] > 1} {
195            error "why so many matching results?"
196        }
197
198        # overwrite the first matching entry
199        set index [lindex $ilist 0]
200        $_results put $index $tuple
201        set _recent $xmlobj
202    } else {
203        set index [$_results size]
204        $_results insert end $tuple
205        set _recent $xmlobj
206    }
207
208    if {[$_results size] == 1} {
209        $itk_component(status) configure -text "1 result"
210    } else {
211        $itk_component(status) configure -text "[$_results size] results"
212    }
213    $itk_component(clear) configure -state normal
214
215    return $index
216}
217
218# ----------------------------------------------------------------------
219# USAGE: clear
220#
221# Clears all results in this result set.
222# ----------------------------------------------------------------------
223itcl::body Rappture::ResultSet::clear {} {
224    _doSettings
225
226    # delete all adjuster controls
227    set f [$itk_component(scroller) contents frame]
228    foreach w [winfo children $f] {
229        destroy $w
230    }
231    catch {unset _col2widget}
232    set _plotall ""
233    set _counter 0
234
235    # don't need to scroll adjustor controls right now
236    $itk_component(scroller) configure -yscrollmode off
237
238    # clear out all results
239    $_results delete 0 end
240    eval $_results column delete [lrange [$_results column names] 1 end]
241    set _recent ""
242
243    # update status and Clear button
244    $itk_component(status) configure -text "No results"
245    $itk_component(clear) configure -state disabled
246    $_dispatcher event -idle !fixcntls
247}
248
249# ----------------------------------------------------------------------
250# USAGE: contains <xmlobj>
251#
252# Checks to see if the given <xmlobj> is already represented by
253# some result in this result set.  This comes in handy when checking
254# to see if an input case is already covered.
255#
256# Returns 1 if the result set already contains this result, and
257# 0 otherwise.
258# ----------------------------------------------------------------------
259itcl::body Rappture::ResultSet::contains {xmlobj} {
260    # no results? then this must be new
261    if {[$_results size] == 0} {
262        return 0
263    }
264
265    #
266    # Compare this new object against the last XML object in the
267    # results set.  If it has a difference, make sure that there
268    # is a column to represent the quantity with the difference.
269    #
270    set xmlobj0 [$_results get -format xmlobj end]
271    foreach {op vpath oldval newval} [$xmlobj0 diff $xmlobj] {
272        if {[$xmlobj get $vpath.about.diffs] == "ignore"} {
273            continue
274        }
275        if {$op == "+" || $op == "-"} {
276            # ignore differences where parameters come and go
277            # such differences make it hard to work controls
278            continue
279        }
280        if {[$_results column names $vpath] == ""} {
281            # no column for this quantity yet
282            return 0
283        }
284    }
285
286    #
287    # If we got this far, then look through existing results for
288    # matching tuples, then check each one for diffs.
289    #
290    set format ""
291    set tuple ""
292    foreach col [lrange [$_results column names] 1 end] {
293        lappend format $col
294        set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0]
295        lappend tuple $raw  ;# use the "raw" (user-readable) label
296    }
297    if {[llength $format] > 0} {
298        set ilist [$_results find -format $format -- $tuple]
299    } else {
300        set ilist 0  ;# no diffs -- must match first entry
301    }
302
303    foreach i $ilist {
304        set xmlobj0 [$_results get -format xmlobj $i]
305        set diffs [$xmlobj0 diff $xmlobj]
306        if {[llength $diffs] == 0} {
307            # no diffs -- already contained here
308            return 1
309        }
310    }
311
312    # must be some differences
313    return 0
314}
315
316
317# ----------------------------------------------------------------------
318# USAGE: size ?-results|-controls?
319#
320# Returns the number of results or the number of controls in this
321# result set.
322# ----------------------------------------------------------------------
323itcl::body Rappture::ResultSet::size {{what -results}} {
324    switch -- $what {
325        -results {
326            return [$_results size]
327        }
328        -controls {
329            return [array size _col2widget]
330        }
331        default {
332            error "bad option \"$what\": should be -results or -controls"
333        }
334    }
335}
336
337# ----------------------------------------------------------------------
338# USAGE: _doClear
339#
340# Invoked automatically when the user presses the Clear button.
341# Invokes the -clearcommand to clear all data from this resultset
342# and all other resultsets in an Analyzer.
343# ----------------------------------------------------------------------
344itcl::body Rappture::ResultSet::_doClear {} {
345    if {[string length $itk_option(-clearcommand)] > 0} {
346        uplevel #0 $itk_option(-clearcommand)
347    }
348}
349
350# ----------------------------------------------------------------------
351# USAGE: _doSettings ?<command>?
352#
353# Used internally whenever the result selection changes to invoke
354# the -settingscommand.  This will notify some external widget, which
355# with perform the plotting action specified in the <command>.
356# ----------------------------------------------------------------------
357itcl::body Rappture::ResultSet::_doSettings {{cmd ""}} {
358    if {[string length $itk_option(-settingscommand)] > 0} {
359        uplevel #0 $itk_option(-settingscommand) $cmd
360    }
361}
362
363# ----------------------------------------------------------------------
364# USAGE: _fixControls ?<eventArgs...>?
365#
366# Called automatically at the idle point after one or more results
367# have been added to this result set.  Scans through all existing
368# data and updates controls used to select the data.
369# ----------------------------------------------------------------------
370itcl::body Rappture::ResultSet::_fixControls {args} {
371    set f [$itk_component(scroller) contents frame]
372    grid columnconfigure $f 1 -weight 1
373
374    if {[$_results size] == 0} {
375        return
376    }
377
378    #
379    # Scan through all columns in the data and create any
380    # controls that just appeared.
381    #
382    foreach col [lrange [$_results column names] 1 end] {
383        set xmlobj [$_results get -format xmlobj 0]
384
385        #
386        # If this column doesn't have a control yet, then
387        # create one.
388        #
389        if {![info exists _col2widget($col)]} {
390            # add an "All" button to plot all results
391            label $f.all$_counter -text "All" -padx 8 \
392                -borderwidth 1 -relief raised -font $itk_option(-textfont)
393            grid $f.all$_counter -row $_counter -column 0 \
394                -padx 8 -pady 2 -sticky nsew
395            Rappture::Tooltip::for $f.all$_counter "Plot all values for this quantity"
396
397            bind $f.all$_counter <ButtonPress> \
398                [itcl::code $this _toggleAll $col $f.all$_counter]
399
400            # search for the first XML object with this element defined
401            foreach xmlobj [$_results get -format xmlobj] {
402                set str [$xmlobj get $col.about.label]
403                if {"" == $str} {
404                    set str [$xmlobj element -as id $col]
405                }
406                if {"" != $str} {
407                    break
408                }
409            }
410
411            if {"" != $str} {
412                set w $f.label$_counter
413                label $w -text $str -anchor w -font $itk_option(-boldfont)
414                grid $w -row $_counter -column 1 -sticky w
415
416                grid $f.all$_counter -rowspan 2
417                Rappture::Tooltip::for $f.all$_counter "Plot all values for $str"
418                incr _counter
419            }
420
421            set w $f.cntl$_counter
422            Rappture::Radiodial $w \
423                -activelinecolor [lindex $itk_option(-colors) 0]
424            grid $w -row $_counter -column 1 -sticky ew
425            bind $w <<Value>> \
426                [itcl::code $_dispatcher event -after 100 !settings]
427            set _col2widget($col) $w
428
429            incr _counter
430            grid rowconfigure $f $_counter -minsize 4
431            incr _counter
432
433            $itk_component(scroller) configure -yscrollmode auto
434
435            # let clients know that a new control appeared
436            # so they can fix the overall size accordingly
437            event generate $itk_component(hull) <<Control>>
438        }
439
440        #
441        # Determine the unique values for this column and load
442        # them into the control.
443        #
444        catch {unset values}
445        set havenums 1
446        set vlist ""
447        foreach rec [$_results get -format [list xmlobj $col]] {
448            set xo [lindex $rec 0]
449            set v [lindex $rec 1]
450
451            if {![info exists values($v)]} {
452                lappend vlist $v
453                foreach {raw norm} [Rappture::LibraryObj::value $xo $col] break
454                set values($v) $norm
455
456                if {$havenums && ![string is double $norm]} {
457                    set havenums 0
458                }
459            }
460        }
461
462        if {!$havenums} {
463            # don't have normalized nums? then sort and create nums
464            catch {unset values}
465
466            set n 0
467            foreach v [lsort $vlist] {
468                set values($v) [incr n]
469            }
470        }
471
472        # load the results into the control
473        set w $_col2widget($col)
474        $w clear
475        foreach v [array names values] {
476            $w add $v $values($v)
477        }
478    }
479
480    #
481    # Set all controls to the settings of the most recent
482    # addition.
483    #
484    if {"" != $_recent} {
485        foreach col [array names _col2widget] {
486            set raw [lindex [Rappture::LibraryObj::value $_recent $col] 0]
487            $_col2widget($col) current $raw
488        }
489    }
490
491    # fix the settings after everything settles
492    $_dispatcher event -after 100 !settings
493}
494
495# ----------------------------------------------------------------------
496# USAGE: _fixSettings ?<eventArgs...>?
497#
498# Called automatically at the idle point after a control has changed
499# to load new data into the plotting area at the top of this result
500# set.  Extracts the current tuple of control values from the control
501# area, then finds the corresponding data values.  Loads the data
502# by invoking a -settingscommand callback with parameters that
503# describe what data should be plotted.
504# ----------------------------------------------------------------------
505itcl::body Rappture::ResultSet::_fixSettings {args} {
506    _doPrompt off
507
508    switch -- [$_results size] {
509        0 {
510            # no data? then do nothing
511            return
512        }
513        1 {
514            # only one data set? then plot it
515            set color [lindex $itk_option(-colors) 0]
516            _doSettings [list 0 [list -color $color -width 2]]
517            return
518        }
519    }
520
521    #
522    # Search for tuples matching the current setting and
523    # plot them.
524    #
525    set format ""
526    set tuple ""
527    foreach col [lrange [$_results column names] 1 end] {
528        if {$col != $_plotall} {
529            lappend format $col
530            set w $_col2widget($col)
531            lappend tuple [$w get current]
532        }
533    }
534
535    if {"" != $format} {
536        set ilist [$_results find -format $format -- $tuple]
537    } else {
538        set ilist [$_results find]
539    }
540
541    if {[llength $ilist] > 0} {
542        # search for the result for these settings
543        set format ""
544        set tuple ""
545        foreach col [lrange [$_results column names] 1 end] {
546            lappend format $col
547            set w $_col2widget($col)
548            lappend tuple [$w get current]
549        }
550        set icurr [$_results find -format $format -- $tuple]
551
552        # no data for these settings? prompt the user to simulate
553        if {"" == $icurr} {
554            _doPrompt on
555        }
556
557        if {[llength $ilist] == 1} {
558            # single result -- always use active color
559            set i [lindex $ilist 0]
560            set color [lindex $itk_option(-colors) 0]
561            set plist [list $i [list -color $color -width 2]]
562        } else {
563            #
564            # Get the color for all points according to
565            # the color spectrum.
566            #
567            set plist ""
568            foreach i $ilist {
569                set v [lindex [$_results get -format $_plotall $i] 0]
570                set color [$_col2widget($_plotall) color $v]
571
572                if {$i == $icurr} {
573                    lappend plist $i [list -color $color -width 3 -raise 1]
574                } else {
575                    lappend plist $i [list -color $color -width 1]
576                }
577            }
578        }
579
580        #
581        # Load up the matching plots
582        #
583        _doSettings $plist
584    } else {
585        # prompt the user to simulate these settings
586        _doPrompt on
587    }
588}
589
590# ----------------------------------------------------------------------
591# USAGE: _doPrompt <state>
592#
593# Used internally whenever the current settings represent a point
594# with no data.  Invokes the -promptcommand with an explanation of
595# the missing data, prompting the user to simulate it.
596# ----------------------------------------------------------------------
597itcl::body Rappture::ResultSet::_doPrompt {state} {
598    if {[string length $itk_option(-promptcommand)] > 0} {
599        if {$state} {
600            set message "No data for these settings"
601            set settings ""
602            foreach col [lrange [$_results column names] 1 end] {
603                set w $_col2widget($col)
604                set val [$w get current]
605                lappend settings $col $val
606            }
607            uplevel #0 $itk_option(-promptcommand) [list on $message $settings]
608        } else {
609            uplevel #0 $itk_option(-promptcommand) off
610        }
611    }
612}
613
614# ----------------------------------------------------------------------
615# USAGE: _toggleAll <path> <widget>
616#
617# Called automatically whenever the user clicks on an "All" button.
618# Toggles the button between its on/off states.  In the "on" state,
619# all results associated with the <path> are sent to the result viewer.
620# ----------------------------------------------------------------------
621itcl::body Rappture::ResultSet::_toggleAll {path widget} {
622    if {[$widget cget -relief] == "sunken"} {
623        $widget configure -relief raised \
624            -background $itk_option(-background) \
625            -foreground $itk_option(-foreground)
626
627        set color [lindex $itk_option(-colors) 0]
628        $_col2widget($path) configure -activelinecolor $color
629
630        set _plotall ""
631    } else {
632        if {"" != $_plotall} {
633            set color [lindex $itk_option(-colors) 0]
634            $_col2widget($_plotall) configure -activelinecolor $color
635        }
636
637        # pop out all other "All" buttons
638        set f [$itk_component(scroller) contents frame]
639        for {set i 0} {$i < $_counter} {incr i} {
640            if {[winfo exists $f.all$i]} {
641                $f.all$i configure -relief raised \
642                    -background $itk_option(-background) \
643                    -foreground $itk_option(-foreground)
644            }
645        }
646
647        # push this one in
648        $widget configure -relief sunken \
649            -background $itk_option(-togglebackground) \
650            -foreground $itk_option(-toggleforeground)
651
652        # switch the "All" context to this path
653        set _plotall $path
654        $_col2widget($path) configure -activelinecolor $_spectrum
655    }
656    $_dispatcher event -idle !settings
657}
658
659# ----------------------------------------------------------------------
660# CONFIGURATION OPTION: -colors
661# ----------------------------------------------------------------------
662itcl::configbody Rappture::ResultSet::colors {
663    if {"" != $_spectrum} {
664        set c1 [lindex $itk_option(-colors) 0]
665        set c0 [lindex $itk_option(-colors) 1]
666        if {"" == $c0} { set c0 #d9d9d9 }
667
668        $_spectrum delete 0 end
669        $_spectrum insert end 0 $c0 1 $c1
670    }
671}
Note: See TracBrowser for help on using the repository browser.