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

Last change on this file since 3754 was 3330, checked in by gah, 12 years ago

merge (by hand) with Rappture1.2 branch

File size: 20.9 KB
RevLine 
[3330]1# -*- mode: tcl; indent-tabs-mode: nil -*-
[11]2# ----------------------------------------------------------------------
[3024]3#  COMPONENT: ResultSet - set of XML objects for simulated results
[11]4#
[3024]5#  This data structure collects all of the simulated results
6#  produced by a series of tool runs.  It is used by the Analyzer,
7#  ResultSelector, and other widgets to keep track of all known runs
8#  and visualize the result that is currently selected.  Each run
9#  has an index number ("#1", "#2", "#3", etc.) that can be used to
10#  label the run and refer to it later.
[11]11# ======================================================================
12#  AUTHOR:  Michael McLennan, Purdue University
[3177]13#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
[115]14#
15#  See the file "license.terms" for information on usage and
16#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
[11]17# ======================================================================
[3024]18package require Itcl
[11]19
20itcl::class Rappture::ResultSet {
21    constructor {args} { # defined below }
22    destructor { # defined below }
23
24    public method add {xmlobj}
[2943]25    public method clear {{xmlobj ""}}
[3024]26    public method diff {option args}
27    public method find {collist vallist}
28    public method get {collist xmlobj}
[11]29    public method contains {xmlobj}
[3024]30    public method size {}
[11]31
[3024]32    public method notify {option args}
33    protected method _notifyHandler {args}
34
[2943]35    protected method _addOneResult {tuples xmlobj {simnum ""}}
[11]36
37    private variable _dispatcher ""  ;# dispatchers for !events
38    private variable _results ""     ;# tuple of known results
[2943]39    private variable _resultnum 0    ;# counter for result #1, #2, etc.
[3024]40    private variable _notify         ;# info used for notify command
[11]41}
[1929]42                                                                               
[11]43# ----------------------------------------------------------------------
44# CONSTRUCTOR
45# ----------------------------------------------------------------------
46itcl::body Rappture::ResultSet::constructor {args} {
47    # create a dispatcher for events
48    Rappture::dispatcher _dispatcher
[3024]49    $_dispatcher register !change
50    $_dispatcher dispatch $this !change \
51        [itcl::code $this _notifyHandler]
[11]52
53    # create a list of tuples for data
54    set _results [Rappture::Tuples ::#auto]
55    $_results column insert end -name xmlobj -label "top-level XML object"
[2943]56    $_results column insert end -name simnum -label "simulation number"
[11]57
[3024]58    # clear notification info
59    set _notify(ALL) ""
[11]60
[3024]61    eval configure $args
[11]62}
63
64# ----------------------------------------------------------------------
65# DESTRUCTOR
66# ----------------------------------------------------------------------
67itcl::body Rappture::ResultSet::destructor {} {
[3024]68    clear
[11]69    itcl::delete object $_results
70}
71
72# ----------------------------------------------------------------------
73# USAGE: add <xmlobj>
74#
75# Adds a new result to this result set.  Scans through all existing
76# results to look for a difference compared to previous results.
[2943]77# Returns the simulation number (#1, #2, #3, etc.) of this new result
78# to the caller.  The various data objects for this result set should
79# be added to their result viewers at the same index.
[11]80# ----------------------------------------------------------------------
81itcl::body Rappture::ResultSet::add {xmlobj} {
82    set xmlobj0 [$_results get -format xmlobj end]
[3024]83    if {$xmlobj0 eq ""} {
84        #
85        # If this is the first result, then there are no diffs.
86        # Add it right in.
87        #
[2943]88        set simnum "#[incr _resultnum]"
89        $_results insert end [list $xmlobj $simnum]
[3024]90    } else {
91        #
92        # For all later results, find the diffs and add any new columns
93        # into the results tuple.  The latest result is the most recent.
94        #
95        set simnum [_addOneResult $_results $xmlobj]
[11]96    }
97
[3024]98    # make sure we fix up associated controls
99    $_dispatcher event -now !change op add what $xmlobj
[1400]100
[2943]101    return $simnum
102}
[1400]103
[2943]104# ----------------------------------------------------------------------
105# USAGE: clear ?<xmlobj>?
106#
107# Clears one or all results in this result set.  If no specific
108# result object is specified, then all results are cleared.
109# ----------------------------------------------------------------------
110itcl::body Rappture::ResultSet::clear {{xmlobj ""}} {
111    if {$xmlobj ne ""} {
112        #
113        # Delete just one result.  Look for the result among the
114        # tuples and remove it.  Then, rebuild all of the tuples
115        # by scanning back through them and building them back up.
116        # This will rebuild the columns/controls as they should
117        # be now, removing anything that is no longer necessary.
118        #
119        set irun [$_results find -format xmlobj $xmlobj]
120        if {[llength $irun] == 1} {
[3024]121            # grab a description of what we're about to delete
122            set dlist [list simnum [$_results get -format simnum $irun]]
123            foreach col [lrange [$_results column names] 2 end] {
124                set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0]
125                lappend dlist $col $raw  ;# use "raw" (user-readable) label
[2943]126            }
[11]127
[3024]128            # delete this from the tuples of all results
129            itcl::delete object $xmlobj
[2943]130            $_results delete $irun
[11]131
[2943]132            set new [Rappture::Tuples ::#auto]
133            $new column insert end -name xmlobj -label "top-level XML object"
134            $new column insert end -name simnum -label "simulation number"
[11]135
[2943]136            for {set n 0} {$n < [$_results size]} {incr n} {
137                set rec [lindex [$_results get -format {xmlobj simnum} $n] 0]
138                foreach {obj num} $rec break
139                if {$n == 0} {
140                    $new insert end [list $obj $num]
141                } else {
142                    _addOneResult $new $obj $num
143                }
144            }
[11]145
[2943]146            # plug in the new set of rebuilt tuples
147            itcl::delete object $_results
148            set _results $new
[11]149
[3024]150            # make sure we fix up associated controls at some point
151            $_dispatcher event -now !change op clear what $dlist
[2943]152        }
153    } else {
154        #
155        # Delete all results.
156        #
[3024]157        for {set irun 0} {$irun < [$_results size]} {incr irun} {
158            set xo [$_results get -format xmlobj $irun]
159            itcl::delete object $xo
160        }
[2943]161        $_results delete 0 end
162
[3024]163        # make sure we fix up associated controls at some point
164        $_dispatcher event -now !change op clear what all
[413]165    }
[11]166
[2943]167    if {[$_results size] == 0} {
[3024]168        # no results left?  then reset to a clean state
169        eval $_results column delete [lrange [$_results column names] 2 end]
170        set _resultnum 0
171    }
172}
[11]173
[3024]174# ----------------------------------------------------------------------
175# USAGE: diff names
176# USAGE: diff values <column> ?<which>?
177#
178# Returns information about the diffs in the current set of known
179# results.  The "diff names" returns a list of column names for
180# parameters that have diffs.  (These are the columns in the tuples.)
181#
182# The "diff values" returns the various values associated with a
183# particular <column> name.  If the optional <which> is specified,
184# then it is treated as an index into the list of values--0 for the
185# first value, 1 for the second, etc.  Each value is returned as
186# a list with two words.  The first is the the label associated with
187# the value.  The second is the normalized (numeric) value, which can
188# be sorted to get a particular ordering.
189# ----------------------------------------------------------------------
190itcl::body Rappture::ResultSet::diff {option args} {
191    switch -- $option {
192        names {
193            return [$_results column names]
[2943]194        }
[3024]195        values {
196            if {[llength $args] < 1} {
197                error "wrong # args: should be \"diff values col ?which?\""
198            }
199            set col [lindex $args 0]
[413]200
[3024]201            set which "all"
202            if {[llength $args] > 1} {
203                set which [lindex $args 1]
204            }
[2943]205
[3099]206            set rlist ""
207            # build an array of normalized values and their labels
208            if {$col == "simnum"} {
209                set nruns [$_results size]
210                for {set n 0} {$n < $nruns} {incr n} {
211                    set simnum [$_results get -format simnum $n]
212                    lappend rlist $simnum $n
213                }
214            } else {
215                set havenums 1
216                foreach rec [$_results get -format [list xmlobj $col]] {
217                    set xo [lindex $rec 0]
218                    set v [lindex $rec 1]
219                    foreach {raw norm} \
220                        [Rappture::LibraryObj::value $xo $col] break
[2943]221
[3099]222                    if {![info exists unique($v)]} {
223                        # keep only unique label strings
224                        set unique($v) $norm
[3024]225                    }
[3099]226                    if {$havenums && ![string is double $norm]} {
227                        set havenums 0
228                    }
229                }
[413]230
[3099]231                if {!$havenums} {
232                    # don't have normalized nums? then sort and create nums
233                    set rlist ""
234                    set n 0
235                    foreach val [lsort -dictionary [array names unique]] {
236                        lappend rlist $val [incr n]
[3024]237                    }
[3099]238                } else {
239                    set rlist [array get unique]
[3024]240                }
[3099]241            }
242
243            if {$which eq "all"} {
[3024]244                return $rlist
245            }
[2943]246
[3024]247            # treat the "which" parameter as an XML object
248            set irun [lindex [$_results find -format xmlobj $which] 0]
249            if {$irun ne ""} {
[3099]250                set val [$_results get -format $col $irun]
251                array set val2norm $rlist
252                if {[info exists val2norm($val)]} {
253                    return [list $val $val2norm($val)]
[3024]254                }
255            }
256        }
257        default {
258            error "bad option \"$option\": should be names or values"
259        }
[2943]260    }
[11]261}
262
263# ----------------------------------------------------------------------
[3024]264# USAGE: find <columnList> <valueList>
[413]265#
[3024]266# Searches through the results for a set of tuple values that match
267# the <valueList> for the given <columnList>.  Returns a list of
268# matching xml objects or "" if there is no match.  If the <valueList>
269# is *, then it returns a list of all xml objects.
[413]270# ----------------------------------------------------------------------
[3024]271itcl::body Rappture::ResultSet::find {collist vallist} {
272    if {$vallist eq "*"} {
273        return [$_results get -format xmlobj]
[413]274    }
275
[3024]276    set rlist ""
[3099]277    foreach irun [$_results find -format $collist -- $vallist] {
[3024]278        lappend rlist [$_results get -format xmlobj $irun]
279    }
280    return $rlist
281}
[413]282
[3024]283# ----------------------------------------------------------------------
284# USAGE: get <columnList> <xmlobj>
285#
286# Returns values for the specified <columnList> for the given <xmlobj>.
287# This is a way of querying associated data for the given object.
288# ----------------------------------------------------------------------
289itcl::body Rappture::ResultSet::get {collist xmlobj} {
290    set irun [lindex [$_results find -format xmlobj $xmlobj] 0]
291    if {$irun ne ""} {
292        return [lindex [$_results get -format $collist $irun] 0]
293    }
294    return ""
[413]295}
296
297# ----------------------------------------------------------------------
[11]298# USAGE: contains <xmlobj>
299#
300# Checks to see if the given <xmlobj> is already represented by
301# some result in this result set.  This comes in handy when checking
302# to see if an input case is already covered.
303#
304# Returns 1 if the result set already contains this result, and
305# 0 otherwise.
306# ----------------------------------------------------------------------
307itcl::body Rappture::ResultSet::contains {xmlobj} {
308    # no results? then this must be new
309    if {[$_results size] == 0} {
[1929]310        return 0
[11]311    }
312
313    #
314    # Compare this new object against the last XML object in the
315    # results set.  If it has a difference, make sure that there
316    # is a column to represent the quantity with the difference.
317    #
318    set xmlobj0 [$_results get -format xmlobj end]
319    foreach {op vpath oldval newval} [$xmlobj0 diff $xmlobj] {
[1929]320        if {[$xmlobj get $vpath.about.diffs] == "ignore"} {
321            continue
322        }
323        if {$op == "+" || $op == "-"} {
324            # ignore differences where parameters come and go
325            # such differences make it hard to work controls
326            continue
327        }
328        if {[$_results column names $vpath] == ""} {
329            # no column for this quantity yet
330            return 0
331        }
[11]332    }
333
334    #
335    # If we got this far, then look through existing results for
336    # matching tuples, then check each one for diffs.
337    #
338    set format ""
339    set tuple ""
[2943]340    foreach col [lrange [$_results column names] 2 end] {
[1929]341        lappend format $col
342        set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0]
343        lappend tuple $raw  ;# use the "raw" (user-readable) label
[11]344    }
345    if {[llength $format] > 0} {
[1929]346        set ilist [$_results find -format $format -- $tuple]
[11]347    } else {
[1929]348        set ilist 0  ;# no diffs -- must match first entry
[11]349    }
350
351    foreach i $ilist {
[1929]352        set xmlobj0 [$_results get -format xmlobj $i]
353        set diffs [$xmlobj0 diff $xmlobj]
354        if {[llength $diffs] == 0} {
355            # no diffs -- already contained here
356            return 1
357        }
[11]358    }
359
360    # must be some differences
361    return 0
362}
363
364
365# ----------------------------------------------------------------------
[3024]366# USAGE: size
[11]367#
[3024]368# Returns the number of results currently stored in the set.
[11]369# ----------------------------------------------------------------------
[3024]370itcl::body Rappture::ResultSet::size {} {
371    return [$_results size]
[11]372}
373
374# ----------------------------------------------------------------------
[3024]375# USAGE: notify add <client> ?!event !event ...? <command>
376# USAGE: notify get ?<client>? ?!event?
377# USAGE: notify remove <client> ?!event !event ...?
[11]378#
[3024]379# Clients use this to add/remove requests for notifications about
380# various events that signal changes to the data in each ResultSet.
[11]381#
[3024]382# The "notify add" operation takes a <client> name (any unique string
383# identifying the client), an optional list of events, and the <command>
384# that should be called for the callback.
[413]385#
[3024]386# The "notify get" command returns information about clients and their
387# registered callbacks.  With no args, it returns a list of <client>
388# names.  If the <client> is specified, it returns a list of !events.
389# If the <client> and !event is specified, it returns the <command>.
390#
391# The "notify remove" command removes any callback associated with
392# a given <client>.  If no particular !events are specified, then it
393# removes callbacks for all events.
[413]394# ----------------------------------------------------------------------
[3024]395itcl::body Rappture::ResultSet::notify {option args} {
396    set allEvents {!change}
[413]397    switch -- $option {
[3024]398        add {
399            if {[llength $args] < 2} {
400                error "wrong # args: should be \"notify add caller ?!event !event ...? command"
[1929]401            }
[3024]402            set caller [lindex $args 0]
403            set command [lindex $args end]
404            if {[llength $args] > 2} {
405                set events [lrange $args 1 end-1]
[1929]406            } else {
[3024]407                set events $allEvents
[1929]408            }
[413]409
[3024]410            foreach name $events {
411                if {[lsearch -exact $allEvents $name] < 0} {
412                    error "bad event \"$name\": should be [join $allEvents ,]"
[1929]413                }
[3024]414                if {[lsearch $_notify(ALL) $caller] < 0} {
415                    lappend _notify(ALL) $caller
416                }
417                set _notify($caller-$name) $command
[1929]418            }
419        }
[3024]420        get {
421            switch -- [llength $args] {
422                0 {
423                    return $_notify(ALL)
424                }
425                1 {
426                    set caller [lindex $args 0]
427                    set rlist ""
428                    foreach key [array names _notify $caller-*] {
429                        lappend rlist [lindex [split $key -] end]
[1929]430                    }
[3024]431                    return $rlist
[1929]432                }
[3024]433                2 {
434                    set caller [lindex $args 0]
435                    set name [lindex $args 1]
436                    if {[info exists _notify($caller-$name)]} {
437                        return $_notify($caller-$name)
438                    }
439                    return ""
[1929]440                }
[3024]441                default {
442                    error "wrong # args: should be \"notify get ?caller? ?!event?\""
[1929]443                }
444            }
445        }
[3024]446        remove {
447            if {[llength $args] < 1} {
448                error "wrong # args: should be \"notify remove caller ?!event !event ...?"
[1929]449            }
[3024]450            set caller [lindex $args 0]
451            if {[llength $args] > 1} {
452                set events [lrange $args 1 end]
453            } else {
454                set events $allEvents
[1929]455            }
[11]456
[3024]457            foreach name $events {
458                catch {unset _notify($caller-$name)}
[1929]459            }
[3024]460            if {[llength [array names _notify $caller-*]] == 0} {
461                set i [lsearch $_notify(ALL) $caller]
462                if {$i >= 0} {
463                    set _notify(ALL) [lreplace $_notify(ALL) $i $i]
[1929]464                }
465            }
466        }
467        default {
[3024]468            error "wrong # args: should be add, get, remove"
[1929]469        }
[766]470    }
471}
472
473# ----------------------------------------------------------------------
[3024]474# USAGE: _notifyHandler ?<eventArgs>...?
[413]475#
[3024]476# Called automatically whenever a !change event is triggered in this
477# object.  Scans through the list of clients that want to receive this
478# event and executes each of their callbacks.
[413]479# ----------------------------------------------------------------------
[3024]480itcl::body Rappture::ResultSet::_notifyHandler {args} {
481    array set data $args
482    set event $data(event)
[413]483
[3024]484    foreach caller $_notify(ALL) {
485        if {[info exists _notify($caller-$event)]} {
486            if {[catch {uplevel #0 $_notify($caller-$event) $args} result]} {
487                # anything go wrong? then throw a background error
488                bgerror "$result\n(while dispatching $event to $caller)"
[1929]489            }
490        }
[413]491    }
492}
493
494# ----------------------------------------------------------------------
[2943]495# USAGE: _addOneResult <tuples> <xmlobj> ?<simNum>?
496#
497# Used internally to add one new <xmlobj> to the given <tuples>
498# object.  If the new xmlobj contains different input parameters
499# that are not already columns in the tuple, then this routine
500# creates the new columns.  If the optional <simNum> is specified,
501# then it is added as the simulation number #1, #2, #3, etc.  If
502# not, then the new object is automatically numbered.
[67]503# ----------------------------------------------------------------------
[2943]504itcl::body Rappture::ResultSet::_addOneResult {tuples xmlobj {simnum ""}} {
505    #
506    # Compare this new object against the last XML object in the
507    # results set.  If it has a difference, make sure that there
508    # is a column to represent the quantity with the difference.
509    #
510    set xmlobj0 [$tuples get -format xmlobj end]
511    foreach {op vpath oldval newval} [$xmlobj0 diff $xmlobj] {
512        if {[$xmlobj get $vpath.about.diffs] == "ignore"} {
513            continue
514        }
515        if {$op == "+" || $op == "-"} {
516            # ignore differences where parameters come and go
517            # such differences make it hard to work controls
518            continue
519        }
520
521        # make sure that these values really are different
522        set oldval [lindex [Rappture::LibraryObj::value $xmlobj0 $vpath] 0]
523        set newval [lindex [Rappture::LibraryObj::value $xmlobj $vpath] 0]
524
525        if {$oldval != $newval && [$tuples column names $vpath] == ""} {
526            # no column for this quantity yet
527            $tuples column insert end -name $vpath -default $oldval
528        }
[67]529    }
[2943]530
531    # build a tuple for this new object
532    set cols ""
533    set tuple ""
534    foreach col [lrange [$tuples column names] 2 end] {
535        lappend cols $col
536        set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0]
537        lappend tuple $raw  ;# use the "raw" (user-readable) label
538    }
539
540    # find a matching tuple? then replace it -- only need one
541    if {[llength $cols] > 0} {
542        set ilist [$tuples find -format $cols -- $tuple]
543    } else {
544        set ilist 0  ;# no diffs -- must match first entry
545    }
546
547    # add all remaining columns for this new entry
548    set tuple [linsert $tuple 0 $xmlobj]
549    set cols [linsert $cols 0 "xmlobj"]
550
551    if {[llength $ilist] > 0} {
552        if {[llength $ilist] > 1} {
553            error "why so many matching results?"
554        }
555
556        # overwrite the first matching entry
[3024]557        # start by freeing the old result
[2943]558        set index [lindex $ilist 0]
[3024]559        set xo [$tuples get -format xmlobj $index]
560        itcl::delete object $xo
561
562        # put this new result in its place
[2943]563        $tuples put -format $cols $index $tuple
[3024]564        set simnum [$tuples get -format simnum $index]
[2943]565    } else {
566        if {$simnum eq ""} {
567            set simnum "#[incr _resultnum]"
568        }
569        set tuple [linsert $tuple 1 $simnum]
570        $tuples insert end $tuple
571    }
572    return $simnum
[67]573}
Note: See TracBrowser for help on using the repository browser.