source: trunk/tester/scripts/legend.tcl @ 4503

Last change on this file since 4503 was 3177, checked in by mmc, 8 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.

File size: 8.5 KB
Line 
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) 2004-2012  HUBzero Foundation, LLC
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# ======================================================================
13package require Itk
14
15namespace eval Rappture::Tester { # forward declaration }
16
17option add *Legend.font {Arial -12} widgetDefault
18option add *Legend.padX 12 widgetDefault
19
20itcl::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
42itcl::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# ----------------------------------------------------------------------
66itcl::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
82itk::usual Legend {
83    keep -background -foreground -cursor -font
84}
85
86# ----------------------------------------------------------------------
87# DESTRUCTOR
88# ----------------------------------------------------------------------
89itcl::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# ----------------------------------------------------------------------
99itcl::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# ----------------------------------------------------------------------
111itcl::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# ----------------------------------------------------------------------
129itcl::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# ----------------------------------------------------------------------
166itcl::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# ----------------------------------------------------------------------
187itcl::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# ----------------------------------------------------------------------
254itcl::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}
Note: See TracBrowser for help on using the repository browser.