source: branches/1.3/gui/scripts/panes.tcl @ 5045

Last change on this file since 5045 was 5045, checked in by mmc, 5 years ago

Ported changes to Panes widget over from trunk:
Fixed the Panes widget to handle fractional sizes better. Instead of
adjusting the fractions internally after each change, it keeps the
requested fractions, but normalizes them before the layout. This keeps
the behavior of the widget consistent, and keeps sizes closer to what
was requested for each pane. Also, fixed the -orientation option so
that the widget can switch back and forth between orientations.

File size: 19.7 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: Panes - creates a series of adjustable panes
3#
4#  This is a simple paned window with an adjustable sash.
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-2015  HUBzero Foundation, LLC
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# ======================================================================
14package require Itk
15
16option add *Panes.width 3i widgetDefault
17option add *Panes.height 3i widgetDefault
18option add *Panes.sashRelief sunken widgetDefault
19option add *Panes.sashWidth 2 widgetDefault
20option add *Panes.sashPadding 4 widgetDefault
21option add *Panes.orientation vertical widgetDefault
22
23itcl::class Rappture::Panes {
24    inherit itk::Widget
25
26    itk_option define -sashrelief sashRelief SashRelief ""
27    itk_option define -sashwidth sashWidth SashWidth 0
28    itk_option define -sashpadding sashPadding SashPadding 0
29    itk_option define -orientation orientation Orientation ""
30
31    constructor {args} { # defined below }
32
33    public method insert {pos args}
34    public method pane {pos}
35    public method visibility {pos args}
36    public method fraction {pos args}
37    public method hilite {state sash}
38    public method size {}
39
40    protected method _grab {pane X Y}
41    protected method _drag {pane X Y}
42    protected method _drop {pane X Y}
43    protected method _fixLayout {args}
44    protected method _fixSashes {args}
45
46    private variable _dispatcher ""  ;# dispatcher for !events
47    private variable _panes ""       ;# list of pane frames
48    private variable _visibility ""  ;# list of visibilities for panes
49    private variable _counter 0      ;# counter for auto-generated names
50    private variable _reqfrac 0.0    ;# requested fraction size of each pane
51    private variable _dragfrom 0     ;# starting coordinate of drag operation
52    private variable _dragfrac 0     ;# limit on fraction of drag operation
53}
54
55itk::usual Panes {
56    keep -background -cursor -sashwidth -sashrelief
57}
58
59# ----------------------------------------------------------------------
60# CONSTRUCTOR
61# ----------------------------------------------------------------------
62itcl::body Rappture::Panes::constructor {args} {
63    itk_option add hull.width hull.height
64
65    # create a dispatcher for events
66    Rappture::dispatcher _dispatcher
67    $_dispatcher register !layout
68    $_dispatcher dispatch $this !layout [itcl::code $this _fixLayout]
69    $_dispatcher register !sashes
70    $_dispatcher dispatch $this !sashes [itcl::code $this _fixSashes]
71
72    # fix the layout whenever the window size changes
73    bind Panes <Configure> [itcl::code %W _fixLayout]
74
75    set pname "pane[incr _counter]"
76    itk_component add $pname {
77        frame $itk_interior.$pname
78    }
79
80    lappend _panes $pname
81    lappend _visibility 1
82    set _reqfrac 0.5
83
84    eval itk_initialize $args
85
86    # make sure we fix up the layout at some point
87    $_dispatcher event -idle !layout
88}
89
90# ----------------------------------------------------------------------
91# USAGE: insert <pos> ?-fraction f?
92#
93# Adds a new page to this widget at the given position <pos>.
94# ----------------------------------------------------------------------
95itcl::body Rappture::Panes::insert {pos args} {
96    Rappture::getopts args params {
97        value -fraction 0.5
98    }
99    if {[llength $args] > 0} {
100        error "wrong # args: should be \"insert pos ?-fraction f?\""
101    }
102
103    set pname "pane[incr _counter]"
104    set sash "${pname}sash"
105    itk_component add $sash {
106        frame $itk_interior.$sash
107    } {
108        usual
109        ignore -cursor
110    }
111    bind $itk_component($sash) <Enter> [itcl::code $this hilite on $sash]
112    bind $itk_component($sash) <Leave> [itcl::code $this hilite off $sash]
113
114    itk_component add ${sash}ridge {
115        frame $itk_component($sash).ridge
116    } {
117        usual
118        rename -relief -sashrelief sashRelief SashRelief
119        ignore -borderwidth
120    }
121    if {$itk_option(-orientation) eq "vertical"} {
122        pack $itk_component(${sash}ridge) -fill x
123        $itk_component($sash) configure -cursor sb_v_double_arrow
124        $itk_component(${sash}ridge) configure -cursor sb_v_double_arrow
125    } else {
126        pack $itk_component(${sash}ridge) -fill y -side left
127        $itk_component($sash) configure -cursor sb_h_double_arrow
128        $itk_component(${sash}ridge) configure -cursor sb_h_double_arrow
129    }
130    foreach comp [list $sash ${sash}ridge] {
131        bind $itk_component($comp) <ButtonPress-1> \
132            [itcl::code $this _grab $pname %X %Y]
133        bind $itk_component($comp) <B1-Motion> \
134            [itcl::code $this _drag $pname %X %Y]
135        bind $itk_component($comp) <ButtonRelease-1> \
136            [itcl::code $this _drop $pname %X %Y]
137    }
138
139
140    itk_component add $pname {
141        frame $itk_interior.$pname
142    }
143    set _panes [linsert $_panes $pos $pname]
144    set _visibility [linsert $_visibility $pos 1]
145    set _reqfrac [linsert $_reqfrac $pos $params(-fraction)]
146
147    # fix sash characteristics
148    $_dispatcher event -idle !sashes
149
150    # make sure we fix up the layout at some point
151    $_dispatcher event -idle !layout
152
153    return $itk_component($pname)
154}
155
156# ----------------------------------------------------------------------
157# USAGE: pane <pos>
158#
159# Returns the frame representing the pane at position <pos>.
160# ----------------------------------------------------------------------
161itcl::body Rappture::Panes::pane {pos} {
162    set pname [lindex $_panes $pos]
163    if {[info exists itk_component($pname)]} {
164        return $itk_component($pname)
165    }
166    return ""
167}
168
169# ----------------------------------------------------------------------
170# USAGE: visibility <pos> ?<newval>? ?<pos> <newval> ...?
171#
172# Clients use this to get/set the visibility of the pane at position
173# <pos>.  Can also be used to set the visibility for multiple panes
174# if multiple <pos>/<newval> pairs are specified in the same command.
175# ----------------------------------------------------------------------
176itcl::body Rappture::Panes::visibility {pos args} {
177    if {[llength $args] == 0} {
178        return [lindex $_visibility $pos]
179    }
180    if {[llength $args] % 2 == 0} {
181        error "wrong # args: should be \"visibility pos ?val pos val ...?\""
182    }
183
184    set args [linsert $args 0 $pos]
185    foreach {pos newval} $args {
186        if {![string is boolean -strict $newval]} {
187            error "bad value \"$newval\": should be boolean"
188        }
189        if {$pos eq "end" || ($pos >= 0 && $pos < [llength $_visibility])} {
190            set _visibility [lreplace $_visibility $pos $pos [expr {$newval}]]
191            $_dispatcher event -idle !layout
192        } else {
193            error "bad index \"$pos\": out of range"
194        }
195    }
196}
197
198# ----------------------------------------------------------------------
199# USAGE: fraction <pos> ?<newval>? ?<pos> <newval> ...?
200#
201# Clients use this to get/set the fraction of real estate associated
202# with the pane at position <pos>.  Can also be used to set the
203# fractions for multiple panes if multiple <pos>/<newval> pairs
204# are specified in the same command.
205# ----------------------------------------------------------------------
206itcl::body Rappture::Panes::fraction {pos args} {
207    if {[llength $args] == 0} {
208        return [lindex $_reqfrac $pos]
209    }
210    if {[llength $args] % 2 == 0} {
211        error "wrong # args: should be \"fraction pos ?val pos val ...?\""
212    }
213
214    set args [linsert $args 0 $pos]
215    foreach {pos newval} $args {
216        if {![string is double -strict $newval]} {
217            error "bad value \"$newval\": should be fraction 0-1"
218        }
219        if {$pos eq "end" || ($pos >= 0 && $pos < [llength $_reqfrac])} {
220            set _reqfrac [lreplace $_reqfrac $pos $pos $newval]
221            $_dispatcher event -idle !layout
222        } else {
223            error "bad index \"$pos\": out of range"
224        }
225    }
226}
227
228# ----------------------------------------------------------------------
229# USAGE: hilite <state> <sash>
230#
231# Invoked automatically whenever the user touches a sash.  Highlights
232# the sash by changing its size or relief.
233# ----------------------------------------------------------------------
234itcl::body Rappture::Panes::hilite {state sash} {
235    switch -- $itk_option(-sashrelief) {
236      flat {
237        if {$state} {
238            $itk_component(${sash}ridge) configure -background black
239        } else {
240            $itk_component(${sash}ridge) configure -background $itk_option(-background)
241        }
242      }
243      sunken {
244        if {$state} {
245            $itk_component(${sash}ridge) configure -relief raised
246        } else {
247            $itk_component(${sash}ridge) configure -relief sunken
248        }
249      }
250      raised {
251        if {$state} {
252            $itk_component(${sash}ridge) configure -relief sunken
253        } else {
254            $itk_component(${sash}ridge) configure -relief raised
255        }
256      }
257      solid {
258        if {$state} {
259            $itk_component($sash) configure -background black
260        } else {
261            $itk_component($sash) configure \
262                -background $itk_option(-background)
263        }
264      }
265    }
266}
267
268# ----------------------------------------------------------------------
269# USAGE: size
270#
271# Returns the number of panes in this widget.  That makes it easier
272# to index the various panes, since indices run from 0 to size-1.
273# ----------------------------------------------------------------------
274itcl::body Rappture::Panes::size {} {
275    return [llength $_panes]
276}
277
278# ----------------------------------------------------------------------
279# USAGE: _grab <pane> <X> <Y>
280#
281# Invoked automatically when the user clicks on a sash, to initiate
282# movement.
283# ----------------------------------------------------------------------
284itcl::body Rappture::Panes::_grab {pname X Y} {
285    set pos [lsearch $_panes $pname]
286    if {$pos < 0} return
287    set frac0 [lindex $_reqfrac [expr {$pos-1}]]
288    set frac1 [lindex $_reqfrac $pos]
289    set _dragfrac [expr {$frac0+$frac1}]
290
291    if {$itk_option(-orientation) eq "vertical"} {
292        set _dragfrom $Y
293    } else {
294        set _dragfrom $X
295    }
296}
297
298# ----------------------------------------------------------------------
299# USAGE: _drag <pane> <X> <Y>
300#
301# Invoked automatically as the user drags a sash, to resize the panes.
302# ----------------------------------------------------------------------
303itcl::body Rappture::Panes::_drag {pname X Y} {
304    set pos [lsearch $_panes $pname]
305    if {$pos < 0} return
306    set frac [lindex $_reqfrac $pos]
307
308    if {$itk_option(-orientation) eq "vertical"} {
309        set delY [expr {$_dragfrom-$Y}]
310        set Ymax  [winfo height $itk_component(hull)]
311        set delta [expr {double($delY)/$Ymax}]
312        set frac [expr {$frac + $delta}]
313        set _dragfrom $Y
314    } else {
315        set delX [expr {$_dragfrom-$X}]
316        set Xmax  [winfo width $itk_component(hull)]
317        set delta [expr {double($delX)/$Xmax}]
318        set frac [expr {$frac + $delta}]
319        set _dragfrom $X
320    }
321    if {$delta == 0.0} {
322        return
323    }
324
325    # set limits so the pane can't get too large or too small
326    if {$frac < 0.05} {
327        set frac 0.05
328    }
329    if {$frac > $_dragfrac-0.05} {
330        set frac [expr {$_dragfrac-0.05}]
331    }
332
333    # replace the fractions for this pane and the one before it
334    set prevfrac [expr {$_dragfrac-$frac}]
335    set _reqfrac [lreplace $_reqfrac [expr {$pos-1}] $pos $prevfrac $frac]
336
337    # normalize all fractions and fix the layout
338    _fixLayout
339
340    return $frac
341}
342
343# ----------------------------------------------------------------------
344# USAGE: _drop <pane> <X> <Y>
345#
346# Invoked automatically as the user drops a sash, to resize the panes.
347# ----------------------------------------------------------------------
348itcl::body Rappture::Panes::_drop {pname X Y} {
349    set frac [_drag $pname $X $Y]
350}
351
352# ----------------------------------------------------------------------
353# USAGE: _fixLayout ?<eventArgs>...?
354#
355# Used internally to update the layout of panes whenever a new pane
356# is added or a sash is moved.
357# ----------------------------------------------------------------------
358itcl::body Rappture::Panes::_fixLayout {args} {
359    # normalize the fractions for all panes to they add to 1.0
360    set total 0
361    foreach f $_reqfrac v $_visibility {
362        if {$v && $f > 0} {
363            set total [expr {$total + $f}]
364        }
365    }
366    if {$total == 0.0} { set total 1 }
367
368    set normfrac ""
369    foreach f $_reqfrac v $_visibility {
370        if {$v} {
371            lappend normfrac [expr {double($f)/$total}]
372        } else {
373            lappend normfrac [expr {double($f)/$total}]
374        }
375    }
376
377    # note that sash padding can be a single number or different on each side
378    if {[llength $itk_option(-sashpadding)] == 1} {
379        set pad [expr {2*$itk_option(-sashpadding)}]
380    } else {
381        set pad [expr [join $itk_option(-sashpadding) +]]
382    }
383
384    if {$itk_option(-orientation) eq "vertical"} {
385        set h [winfo height $itk_component(hull)]
386        set sh [expr {$itk_option(-sashwidth) + $pad}]
387
388        set plist ""
389        set flist ""
390        foreach p $_panes f $normfrac v $_visibility {
391            set sash ${p}sash
392            if {$v} {
393                # this pane is visible -- make room for it
394                lappend plist $p
395                lappend flist $f
396                if {[info exists itk_component($sash)]} {
397                    set h [expr {$h - $sh}]
398                }
399            } else {
400                # this pane is not visible -- remove sash
401                if {[info exists itk_component($sash)]} {
402                    place forget $itk_component($sash)
403                }
404                place forget $itk_component($p)
405            }
406        }
407
408        # lay out the various panes
409        set y 0
410        foreach p $plist f $flist {
411            set sash ${p}sash
412            if {[info exists itk_component($sash)]} {
413                place $itk_component($sash) -y $y -relx 0.5 -anchor n \
414                    -relwidth 1.0 -height $sh
415                set y [expr {$y + $sh}]
416            }
417           
418            set ph [expr {$h*$f}]
419            place $itk_component($p) -y $y -relx 0.5 -anchor n \
420                -relwidth 1.0 -height $ph
421            set y [expr {$y + $ph}]
422        }
423    } else {
424        set w [winfo width $itk_component(hull)]
425        set sw [expr {$itk_option(-sashwidth) + $pad}]
426
427        set plist ""
428        set flist ""
429        foreach p $_panes f $normfrac v $_visibility {
430            set sash ${p}sash
431            if {$v} {
432                # this pane is visible -- make room for it
433                lappend plist $p
434                lappend flist $f
435                if {[info exists itk_component($sash)]} {
436                    set w [expr {$w - $sw}]
437                }
438            } else {
439                # this pane is not visible -- remove sash
440                if {[info exists itk_component($sash)]} {
441                    place forget $itk_component($sash)
442                }
443                place forget $itk_component($p)
444            }
445        }
446
447        # lay out the various panes
448        set x 0
449        foreach p $plist f $flist {
450            set sash ${p}sash
451            if {[info exists itk_component($sash)]} {
452                place $itk_component($sash) -x $x -rely 0.5 -anchor w \
453                    -relheight 1.0 -width $sw
454                set x [expr {$x + $sw}]
455            }
456           
457            set pw [expr {$w*$f}]
458            place $itk_component($p) -x $x -rely 0.5 -anchor w \
459                -relheight 1.0 -width $pw
460            set x [expr {$x + $pw}]
461        }
462    }   
463}
464
465# ----------------------------------------------------------------------
466# USAGE: _fixSashes
467#
468# Used internally to fix the appearance of sashes whenever a new
469# sash appears or the controlling configuration options change.
470# ----------------------------------------------------------------------
471itcl::body Rappture::Panes::_fixSashes {args} {
472    if {$itk_option(-orientation) eq "vertical"} {
473        set ht [winfo pixels $itk_component(hull) $itk_option(-sashwidth)]
474        set bd [expr {$ht/2}]
475        foreach pane $_panes {
476            set sash "${pane}sashridge"
477            if {[info exists itk_component($sash)]} {
478                $itk_component($sash) configure -height $ht \
479                    -borderwidth $bd -relief $itk_option(-sashrelief)
480                pack $itk_component($sash) -pady $itk_option(-sashpadding) \
481                    -side top
482            }
483        }
484    } else {
485        set w [winfo pixels $itk_component(hull) $itk_option(-sashwidth)]
486        set bd [expr {$w/2}]
487        foreach pane $_panes {
488            set sash "${pane}sashridge"
489            if {[info exists itk_component($sash)]} {
490                $itk_component($sash) configure -width $w \
491                    -borderwidth $bd -relief $itk_option(-sashrelief)
492                pack $itk_component($sash) -padx $itk_option(-sashpadding) \
493                    -side left
494            }
495        }
496    }
497}
498
499# ----------------------------------------------------------------------
500# CONFIGURATION OPTION: -sashrelief
501# ----------------------------------------------------------------------
502itcl::configbody Rappture::Panes::sashrelief {
503    $_dispatcher event -idle !sashes
504}
505
506# ----------------------------------------------------------------------
507# CONFIGURATION OPTION: -sashwidth
508# ----------------------------------------------------------------------
509itcl::configbody Rappture::Panes::sashwidth {
510    $_dispatcher event -idle !sashes
511}
512
513# ----------------------------------------------------------------------
514# CONFIGURATION OPTION: -sashpadding
515# ----------------------------------------------------------------------
516itcl::configbody Rappture::Panes::sashpadding {
517    set count 0
518    foreach val $itk_option(-sashpadding) {
519        if {![string is integer -strict $val]} {
520            error "bad padding value \"$val\": should be integer"
521        }
522        incr count
523    }
524    if {$count < 1 || $count > 2} {
525        error "bad padding value \"$itk_option(-sashpadding)\": should be \"#\" or \"# #\""
526    }
527    $_dispatcher event -idle !sashes
528}
529
530# ----------------------------------------------------------------------
531# CONFIGURATION OPTION: -orientation
532# ----------------------------------------------------------------------
533itcl::configbody Rappture::Panes::orientation {
534    foreach pname $_panes {
535        set sash "${pname}sash"
536        if {$itk_option(-orientation) eq "vertical"} {
537            place $itk_component($pname) -x 0 -relx 0.5 -relwidth 1 \
538                -y 0 -rely 0 -relheight 0
539
540            if {[info exists itk_component($sash)]} {
541                place $itk_component($sash) -x 0 -relx 0.5 -relwidth 1 \
542                    -y 0 -rely 0 -relheight 0
543                $itk_component($sash) configure \
544                    -cursor sb_v_double_arrow
545
546                pack $itk_component(${sash}ridge) -fill x -side top
547                $itk_component(${sash}ridge) configure \
548                    -cursor sb_v_double_arrow
549            }
550        } else {
551            place $itk_component($pname) -y 0 -rely 0.5 -relheight 1 \
552                -x 0 -relx 0 -relwidth 0
553
554            if {[info exists itk_component($sash)]} {
555                place $itk_component($sash) -y 0 -rely 0.5 -relheight 1 \
556                    -x 0 -relx 0 -relwidth 0
557                $itk_component($sash) configure \
558                    -cursor sb_h_double_arrow
559
560                pack $itk_component(${sash}ridge) -fill y -side left
561                $itk_component(${sash}ridge) configure \
562                    -cursor sb_h_double_arrow
563            }
564        }
565    }
566
567    # fix sash characteristics
568    $_dispatcher event -idle !sashes
569
570    # make sure we fix up the layout at some point
571    $_dispatcher event -idle !layout
572}
Note: See TracBrowser for help on using the repository browser.