source: trunk/gui/scripts/balloon.tcl @ 4661

Last change on this file since 4661 was 4661, checked in by ldelgass, 6 years ago

Merge r4572 from 1.3 branch

File size: 21.5 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: Balloon - toplevel popup window, like a cartoon balloon
4#
5#  This widget is used as a container for pop-up panels in Rappture.
6#  If shape extensions are supported, then the window is drawn as
7#  a cartoon balloon.  Otherwise, it is a raised panel, with a little
8#  line connecting it to the widget that brought it up.  When active,
9#  the panel has a global grab and focus, so the user must interact
10#  with it or dismiss it.
11# ======================================================================
12#  AUTHOR:  Michael McLennan, Purdue University
13#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
14#
15#  See the file "license.terms" for information on usage and
16#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
17# ======================================================================
18package require Itk
19
20namespace eval Rappture { # forward declaration }
21
22option add *Balloon.dismissButton on widgetDefault
23option add *Balloon.padX 4 widgetDefault
24option add *Balloon.padY 4 widgetDefault
25option add *Balloon.titleBackground #999999 widgetDefault
26option add *Balloon.titleForeground white widgetDefault
27option add *Balloon.relief raised widgetDefault
28option add *Balloon.stemLength 16 widgetDefault
29
30itcl::class Rappture::Balloon {
31    inherit itk::Toplevel
32
33    itk_option define -background background Background ""
34    itk_option define -deactivatecommand deactivateCommand DeactivateCommand ""
35    itk_option define -dismissbutton dismissButton DismissButton "on"
36    itk_option define -padx padX Pad 0
37    itk_option define -pady padY Pad 0
38    itk_option define -title title Title ""
39    itk_option define -titlebackground titleBackground Background ""
40    itk_option define -titleforeground titleForeground Foreground ""
41    itk_option define -stemlength stemLength StemLength 20
42
43    constructor {args} { # defined below }
44
45    public method activate {where placement}
46    public method deactivate {}
47
48    protected method _createStems {}
49
50    protected variable _stems   ;# windows for cartoon balloon stems
51    protected variable _masks   ;# masks for cartoon balloon stems
52    protected variable _fills   ;# lines for cartoon balloon stems
53
54    public proc outside {widget x y}
55
56    bind RapptureBalloon <ButtonPress> \
57        {if {[Rappture::Balloon::outside %W %X %Y]} {%W deactivate}}
58}
59
60itk::usual Balloon {
61}
62
63# ----------------------------------------------------------------------
64# CONSTRUCTOR
65# ----------------------------------------------------------------------
66itcl::body Rappture::Balloon::constructor {args} {
67    wm overrideredirect $itk_component(hull) yes
68    wm withdraw $itk_component(hull)
69    component hull configure -borderwidth 1 -relief solid -padx 0 -pady 0
70
71    itk_component add border {
72        frame $itk_interior.border -borderwidth 2
73    } {
74        usual
75        keep -relief
76    }
77    pack $itk_component(border) -expand yes -fill both
78
79    itk_component add titlebar {
80        frame $itk_component(border).tbar
81    } {
82        usual
83        rename -background -titlebackground titleBackground Background
84    }
85
86    itk_component add title {
87        label $itk_component(titlebar).title -width 1 -anchor w
88    } {
89        usual
90        rename -background -titlebackground titleBackground Background
91        rename -foreground -titleforeground titleForeground Foreground
92        rename -highlightbackground -titlebackground titleBackground Background
93        rename -text -title title Title
94    }
95    pack $itk_component(title) -side left -expand yes -fill both -padx 2
96
97    itk_component add dismiss {
98        button $itk_component(titlebar).dismiss \
99            -bitmap [Rappture::icon dismiss] \
100            -relief flat -overrelief raised -command "
101              Rappture::Tooltip::cue hide
102              [list $itk_component(hull) deactivate]
103            "
104    } {
105        usual
106        rename -background -titlebackground titleBackground Background
107        rename -foreground -titleforeground titleForeground Foreground
108        rename -highlightbackground -titlebackground titleBackground Background
109    }
110
111    itk_component add inner {
112        frame $itk_component(border).inner
113    }
114    pack $itk_component(inner) -expand yes -fill both
115
116    # add bindings to release the grab
117    set btags [bindtags $itk_component(hull)]
118    bindtags $itk_component(hull) [linsert $btags 1 RapptureBalloon]
119
120    eval itk_initialize $args
121
122    _createStems
123}
124
125# ----------------------------------------------------------------------
126# USAGE: activate <where> <placement>
127#
128# Clients use this to pop up this balloon panel pointing to the
129# <where> location, which should be a widget name or @X,Y.  The
130# <placement> indicates whether the panel should be left, right,
131# above, or below the <where> coordinate.
132# ----------------------------------------------------------------------
133itcl::body Rappture::Balloon::activate {where placement} {
134    if {![info exists _stems($placement)]} {
135        error "bad placement \"$placement\": should be [join [lsort [array names _stems]] {, }]"
136    }
137    set s $_stems($placement)
138    set sw [image width $_fills($placement)]
139    set sh [image height $_fills($placement)]
140    set p $itk_component(hull)
141    set screenw [winfo screenwidth $p]
142    set screenh [winfo screenheight $p]
143
144    if {[winfo exists $where]} {
145        set x [expr {[winfo rootx $where]+[winfo width $where]/2}]
146        set y [expr {[winfo rooty $where]+[winfo height $where]/2}]
147        switch -- $placement {
148            left { set x [expr {[winfo rootx $where]+5}] }
149            right { set x [expr {[winfo rootx $where]+[winfo width $where]-5}] }
150            above { set y [expr {[winfo rooty $where]+5}] }
151            below { set y [expr {[winfo rooty $where]+[winfo height $where]-5}] }
152        }
153    } elseif {[regexp {^@([0-9]+),([0-9]+)$} $where match x y]} {
154        # got x and y
155    } else {
156        error "bad location \"$where\": should be widget or @x,y"
157    }
158
159    # if the panel is already up, take it down
160    deactivate
161
162    set pw [winfo reqwidth $p]
163    if {$pw > $screenw} { set pw [expr {$screenw-10}] }
164    set ph [winfo reqheight $p]
165    if {$ph > $screenh} { set ph [expr {$screenh-10}] }
166
167    switch -- $placement {
168        left {
169            set sx [expr {$x-$sw+3}]
170            set sy [expr {$y-$sh/2}]
171            set px [expr {$sx-$pw+3}]
172            set py [expr {$y-$ph/2}]
173
174            # make sure that the panel doesn't go off-screen
175            if {$py < 0} { set py 0 }
176            if {$py+$ph > $screenh} { set py [expr {$screenh-$ph}] }
177            if {$px < 0} { set pw [expr {$pw+$px}]; set px 0 }
178        }
179        right {
180            set sx $x
181            set sy [expr {$y-$sh/2}]
182            set px [expr {$x+$sw-3}]
183            set py [expr {$y-$ph/2}]
184
185            # make sure that the panel doesn't go off-screen
186            if {$py < 0} { set py 0 }
187            if {$py+$ph > $screenh} { set py [expr {$screenh-$ph}] }
188            if {$px+$pw > $screenw} { set pw [expr {$screenw-$px}] }
189        }
190        above {
191            set sx [expr {$x-$sw/2}]
192            set sy [expr {$y-$sh+3}]
193            set px [expr {$x-$pw/2}]
194            set py [expr {$sy-$ph+3}]
195
196            # make sure that the panel doesn't go off-screen
197            if {$px < 0} { set px 0 }
198            if {$px+$pw > $screenw} { set px [expr {$screenw-$pw}] }
199            if {$py < 0} { set ph [expr {$ph+$py}]; set py 0 }
200        }
201        below {
202            set sx [expr {$x-$sw/2}]
203            set sy $y
204            set px [expr {$x-$pw/2}]
205            set py [expr {$y+$sh-3}]
206
207            # make sure that the panel doesn't go off-screen
208            if {$px < 0} { set px 0 }
209            if {$px+$pw > $screenw} { set px [expr {$screenw-$pw}] }
210            if {$py+$ph > $screenh} { set ph [expr {$screenh-$py}] }
211        }
212    }
213    if {[info exists _masks($placement)]} {
214        shape set $s -bound photo $_masks($placement)
215    }
216    if { $pw < 1 || $ph < 1 }  {
217        # I really don't know why this is happenning.  I believe this occurs
218        # when in a work space (i.e the main window is smaller than the root
219        # window). So for now, better to place the balloon window somewhere
220        # than to fail with a bad geometry.
221        wm geometry $p +$px+$py
222    } else {
223        wm geometry $p ${pw}x${ph}+$px+$py
224    }
225    wm deiconify $p
226    raise $p
227
228    wm geometry $s +$sx+$sy
229    wm deiconify $s
230    raise $s
231
232    # grab the mouse pointer
233    update
234    while {[catch {grab set $itk_component(hull)}]} {
235        after 100
236    }
237    focus $itk_component(hull)
238}
239
240# ----------------------------------------------------------------------
241# USAGE: deactivate
242#
243# Clients use this to take down the balloon panel if it is on screen.
244# ----------------------------------------------------------------------
245itcl::body Rappture::Balloon::deactivate {} {
246    if {[string length $itk_option(-deactivatecommand)] > 0} {
247        uplevel #0 $itk_option(-deactivatecommand)
248    }
249
250    grab release $itk_component(hull)
251    wm withdraw $itk_component(hull)
252    foreach dir {left right above below} {
253        wm withdraw $_stems($dir)
254    }
255}
256
257# ----------------------------------------------------------------------
258# USAGE: _createStems
259#
260# Used internally to create the stems that connect a balloon panel
261# to its anchor point, in all four possible directions:  left, right,
262# above, and below.
263# ----------------------------------------------------------------------
264itcl::body Rappture::Balloon::_createStems {} {
265    # destroy any existing stems
266    foreach dir [array names _stems] {
267        destroy $_stems($dir)
268        unset _stems($dir)
269    }
270    foreach dir [array names _masks] {
271        image delete $_masks($dir)
272        unset _masks($dir)
273    }
274    foreach dir [array names _fills] {
275        image delete $_fills($dir)
276        unset _fills($dir)
277    }
278
279    if {[catch {package require Shape}] == 0} {
280        #
281        # We have the Shape extension.  Use it to create nice
282        # looking (triangle-shaped) stems.
283        #
284        set s $itk_option(-stemlength)
285        foreach dir {left right above below} {
286            switch -- $dir {
287                left - right {
288                    set sw [expr {$s+2}]
289                    set sh $s
290                }
291                above - below {
292                    set sw $s
293                    set sh [expr {$s+2}]
294                }
295            }
296
297            set _stems($dir) [toplevel $itk_interior.s$dir -borderwidth 0]
298            label $_stems($dir).l \
299                -width $sw -height $sh -borderwidth 0
300            pack $_stems($dir).l -expand yes -fill both
301
302            wm withdraw $_stems($dir)
303            wm overrideredirect $_stems($dir) yes
304
305            #
306            # Draw the triangle part of the stem, with a black outline
307            # and light/dark highlights:
308            #
309            #     --------  ---       LEFT STEM
310            #    |..##    |  ^ 
311            #    |  ..##  |  |        . = light color
312            #    |    ..##|  | s      @ = dark color
313            #    |    @@##|  |        # = black
314            #    |  @@##  |  |
315            #    |@@##    |  v
316            #     --------  ---
317            #    |<------>|
318            #        s+2
319            #
320            set _masks($dir) [image create photo -width $sw -height $sh]
321            set _fills($dir) [image create photo -width $sw -height $sh]
322
323            set bg $itk_option(-background)
324            set light [Rappture::color::brightness $bg 0.4]
325            set dark [Rappture::color::brightness $bg -0.4]
326            set rgb [winfo rgb . $bg]
327            set flatbg [format "#%04x%04x%04x" [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]]
328            switch -- $itk_option(-relief) {
329                raised {
330                    set light [Rappture::color::brightness $bg 0.4]
331                    set dark [Rappture::color::brightness $bg -0.4]
332                    set bg $flatbg
333                }
334                flat - solid {
335                    set light $flatbg
336                    set dark $flatbg
337                    set bg $flatbg
338                }
339                sunken {
340                    set light [Rappture::color::brightness $bg -0.4]
341                    set dark [Rappture::color::brightness $bg 0.4]
342                    set bg $flatbg
343                }
344            }
345            set bg [format "#%04x%04x%04x" [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]]
346
347            $_fills($dir) put $bg -to 0 0 $sw $sh
348
349            switch -- $dir {
350              left {
351                set i 0
352                for {set j 0} {$j < $s/2} {incr j} {
353                    set ybtm [expr {$s-$j-1}]
354                    $_fills($dir) put $dark \
355                        -to $i [expr {$ybtm-1}] [expr {$i+2}] [expr {$ybtm+1}]
356                    $_fills($dir) put black \
357                        -to [expr {$i+2}] $ybtm [expr {$i+4}] [expr {$ybtm+1}]
358
359                    set ytop $j
360                    set ytoffs [expr {($j == $s/2-1) ? 1 : 2}]
361                    $_fills($dir) put $light \
362                        -to $i $ytop [expr {$i+2}] [expr {$ytop+$ytoffs}]
363                    $_fills($dir) put black \
364                        -to [expr {$i+2}] $ytop [expr {$i+4}] [expr {$ytop+1}]
365                    incr i 2
366                }
367                $_stems($dir).l configure -image $_fills($dir)
368
369                $_masks($dir) put black -to 0 0 $sw $sh
370                set i 0
371                for {set j 0} {$j < $s/2} {incr j} {
372                    for {set k [expr {$i+4}]} {$k < $s+2} {incr k} {
373                        $_masks($dir) transparency set $k $j yes
374                        $_masks($dir) transparency set $k [expr {$s-$j-1}] yes
375                    }
376                    incr i 2
377                }
378              }
379              right {
380                set i $sw
381                for {set j 0} {$j < $s/2} {incr j} {
382                    set ybtm [expr {$s-$j-1}]
383                    $_fills($dir) put $dark \
384                        -to [expr {$i-2}] [expr {$ybtm-1}] $i [expr {$ybtm+1}]
385                    $_fills($dir) put black \
386                        -to [expr {$i-4}] $ybtm [expr {$i-2}] [expr {$ybtm+1}]
387
388                    set ytop $j
389                    set ytoffs [expr {($j == $s/2-1) ? 1 : 2}]
390                    $_fills($dir) put $light \
391                        -to [expr {$i-2}] $ytop $i [expr {$ytop+$ytoffs}]
392                    $_fills($dir) put black \
393                        -to [expr {$i-4}] $ytop [expr {$i-2}] [expr {$ytop+1}]
394                    incr i -2
395                }
396                $_stems($dir).l configure -image $_fills($dir)
397
398                $_masks($dir) put black -to 0 0 $sw $sh
399                set i $sw
400                for {set j 0} {$j < $s/2} {incr j} {
401                    for {set k 0} {$k < $i-4} {incr k} {
402                        $_masks($dir) transparency set $k $j yes
403                        $_masks($dir) transparency set $k [expr {$s-$j-1}] yes
404                    }
405                    incr i -2
406                }
407              }
408              above {
409                set i 0
410                for {set j 0} {$j < $s/2} {incr j} {
411                    set xrhs [expr {$s-$j-1}]
412                    $_fills($dir) put $dark \
413                        -to [expr {$xrhs-1}] $i [expr {$xrhs+1}] [expr {$i+2}]
414                    $_fills($dir) put black \
415                        -to $xrhs [expr {$i+2}] [expr {$xrhs+1}] [expr {$i+4}]
416
417                    set xlhs $j
418                    set xloffs [expr {($j == $s/2-1) ? 1 : 2}]
419                    $_fills($dir) put $light \
420                        -to $xlhs $i [expr {$xlhs+$xloffs}] [expr {$i+2}]
421                    $_fills($dir) put black \
422                        -to $xlhs [expr {$i+2}] [expr {$xlhs+1}] [expr {$i+4}]
423                    incr i 2
424                }
425                $_stems($dir).l configure -image $_fills($dir)
426
427                $_masks($dir) put black -to 0 0 $sw $sh
428                set i 0
429                for {set j 0} {$j < $s/2} {incr j} {
430                    for {set k [expr {$i+4}]} {$k < $s+2} {incr k} {
431                        $_masks($dir) transparency set $j $k yes
432                        $_masks($dir) transparency set [expr {$s-$j-1}] $k yes
433                    }
434                    incr i 2
435                }
436              }
437              below {
438                set i $sh
439                for {set j 0} {$j < $s/2} {incr j} {
440                    set xrhs [expr {$s-$j-1}]
441                    $_fills($dir) put $dark \
442                        -to [expr {$xrhs-1}] [expr {$i-2}] [expr {$xrhs+1}] $i
443                    $_fills($dir) put black \
444                        -to $xrhs [expr {$i-4}] [expr {$xrhs+1}] [expr {$i-2}]
445
446                    set xlhs $j
447                    set xloffs [expr {($j == $s/2-1) ? 1 : 2}]
448                    $_fills($dir) put $light \
449                        -to $xlhs [expr {$i-2}] [expr {$xlhs+$xloffs}] $i
450                    $_fills($dir) put black \
451                        -to $xlhs [expr {$i-4}] [expr {$xlhs+1}] [expr {$i-2}]
452                    incr i -2
453                }
454                $_stems($dir).l configure -image $_fills($dir)
455
456                $_masks($dir) put black -to 0 0 $sw $sh
457                set i $sh
458                for {set j 0} {$j < $s/2} {incr j} {
459                    for {set k 0} {$k < $i-4} {incr k} {
460                        $_masks($dir) transparency set $j $k yes
461                        $_masks($dir) transparency set [expr {$s-$j-1}] $k yes
462                    }
463                    incr i -2
464                }
465              }
466            }
467        }
468    } else {
469        #
470        # No shape extension.  Do the best we can by creating a
471        # black line for all directions.
472        #
473        foreach {dir w h} [list \
474            left   $itk_option(-stemlength) 3 \
475            right  $itk_option(-stemlength) 3 \
476            above  3 $itk_option(-stemlength) \
477            below  3 $itk_option(-stemlength) \
478        ] {
479            set _stems($dir) [toplevel $itk_interior.s$dir \
480                -width $w -height $h \
481                -borderwidth 1 -relief solid -background black]
482            wm withdraw $_stems($dir)
483            wm overrideredirect $_stems($dir) yes
484
485            # create this for size, even though we don't really use it
486            set _fills($dir) [image create photo -width $w -height $h]
487        }
488    }
489}
490
491# ----------------------------------------------------------------------
492# USAGE: outside <widget> <x> <y>
493#
494# Used internally to see if the click point <x>,<y> is outside of
495# this widget.  If so, the widget usually releases is grab and
496# deactivates.
497# ----------------------------------------------------------------------
498itcl::body Rappture::Balloon::outside {widget x y} {
499    return [expr {$x < [winfo rootx $widget]
500             || $x > [winfo rootx $widget]+[winfo width $widget]
501             || $y < [winfo rooty $widget]
502             || $y > [winfo rooty $widget]+[winfo height $widget]}]
503}
504
505# ----------------------------------------------------------------------
506# CONFIGURATION OPTION: -background
507# ----------------------------------------------------------------------
508itcl::configbody Rappture::Balloon::background {
509    _createStems
510}
511
512# ----------------------------------------------------------------------
513# CONFIGURATION OPTION: -stemlength
514#
515# Used internally to create the stems that connect a balloon panel
516# to its anchor point, in all four possible directions:  left, right,
517# above, and below.
518# ----------------------------------------------------------------------
519itcl::configbody Rappture::Balloon::stemlength {
520    if {$itk_option(-stemlength) % 2 != 0} {
521        error "stem length should be an even number of pixels"
522    }
523}
524
525# ----------------------------------------------------------------------
526# CONFIGURATION OPTION: -dismissbutton
527# ----------------------------------------------------------------------
528itcl::configbody Rappture::Balloon::dismissbutton {
529    if {![string is boolean $itk_option(-dismissbutton)]} {
530        error "bad value \"$itk_option(-dismissbutton)\": should be on/off, 1/0, true/false, yes/no"
531    }
532    if {$itk_option(-dismissbutton)} {
533        pack $itk_component(titlebar) -before $itk_component(inner) \
534            -side top -fill x
535        pack $itk_component(dismiss) -side right -padx 4
536    } elseif {"" != $itk_option(-title)} {
537        pack $itk_component(titlebar) -before $itk_component(inner) \
538            -side top -fill x
539        pack forget $itk_component(dismiss)
540    } else {
541        pack forget $itk_component(titlebar)
542    }
543}
544
545# ----------------------------------------------------------------------
546# CONFIGURATION OPTION: -padx
547# ----------------------------------------------------------------------
548itcl::configbody Rappture::Balloon::padx {
549    pack $itk_component(inner) -padx $itk_option(-padx)
550}
551
552# ----------------------------------------------------------------------
553# CONFIGURATION OPTION: -pady
554# ----------------------------------------------------------------------
555itcl::configbody Rappture::Balloon::pady {
556    pack $itk_component(inner) -pady $itk_option(-pady)
557}
558
559# ----------------------------------------------------------------------
560# CONFIGURATION OPTION: -title
561# ----------------------------------------------------------------------
562itcl::configbody Rappture::Balloon::title {
563    if {"" != $itk_option(-title) || $itk_option(-dismissbutton)} {
564        pack $itk_component(titlebar) -before $itk_component(inner) \
565            -side top -fill x
566        if {$itk_option(-dismissbutton)} {
567            pack $itk_component(dismiss) -side right -padx 4
568        } else {
569            pack forget $itk_component(dismiss)
570        }
571    } else {
572        pack forget $itk_component(titlebar)
573    }
574}
Note: See TracBrowser for help on using the repository browser.