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

Last change on this file since 3555 was 3555, checked in by gah, 8 years ago

convert grab on balloon to local

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 -local $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
252    wm withdraw $itk_component(hull)
253    foreach dir {left right above below} {
254        wm withdraw $_stems($dir)
255    }
256}
257
258# ----------------------------------------------------------------------
259# USAGE: _createStems
260#
261# Used internally to create the stems that connect a balloon panel
262# to its anchor point, in all four possible directions:  left, right,
263# above, and below.
264# ----------------------------------------------------------------------
265itcl::body Rappture::Balloon::_createStems {} {
266    # destroy any existing stems
267    foreach dir [array names _stems] {
268        destroy $_stems($dir)
269        unset _stems($dir)
270    }
271    foreach dir [array names _masks] {
272        image delete $_masks($dir)
273        unset _masks($dir)
274    }
275    foreach dir [array names _fills] {
276        image delete $_fills($dir)
277        unset _fills($dir)
278    }
279
280    if {[catch {package require Shape}] == 0} {
281        #
282        # We have the Shape extension.  Use it to create nice
283        # looking (triangle-shaped) stems.
284        #
285        set s $itk_option(-stemlength)
286        foreach dir {left right above below} {
287            switch -- $dir {
288                left - right {
289                    set sw [expr {$s+2}]
290                    set sh $s
291                }
292                above - below {
293                    set sw $s
294                    set sh [expr {$s+2}]
295                }
296            }
297
298            set _stems($dir) [toplevel $itk_interior.s$dir -borderwidth 0]
299            label $_stems($dir).l \
300                -width $sw -height $sh -borderwidth 0
301            pack $_stems($dir).l -expand yes -fill both
302
303            wm withdraw $_stems($dir)
304            wm overrideredirect $_stems($dir) yes
305
306            #
307            # Draw the triangle part of the stem, with a black outline
308            # and light/dark highlights:
309            #
310            #     --------  ---       LEFT STEM
311            #    |..##    |  ^ 
312            #    |  ..##  |  |        . = light color
313            #    |    ..##|  | s      @ = dark color
314            #    |    @@##|  |        # = black
315            #    |  @@##  |  |
316            #    |@@##    |  v
317            #     --------  ---
318            #    |<------>|
319            #        s+2
320            #
321            set _masks($dir) [image create photo -width $sw -height $sh]
322            set _fills($dir) [image create photo -width $sw -height $sh]
323
324            set bg $itk_option(-background)
325            set light [Rappture::color::brightness $bg 0.4]
326            set dark [Rappture::color::brightness $bg -0.4]
327            set rgb [winfo rgb . $bg]
328            set flatbg [format "#%04x%04x%04x" [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]]
329            switch -- $itk_option(-relief) {
330                raised {
331                    set light [Rappture::color::brightness $bg 0.4]
332                    set dark [Rappture::color::brightness $bg -0.4]
333                    set bg $flatbg
334                }
335                flat - solid {
336                    set light $flatbg
337                    set dark $flatbg
338                    set bg $flatbg
339                }
340                sunken {
341                    set light [Rappture::color::brightness $bg -0.4]
342                    set dark [Rappture::color::brightness $bg 0.4]
343                    set bg $flatbg
344                }
345            }
346            set bg [format "#%04x%04x%04x" [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]]
347
348            $_fills($dir) put $bg -to 0 0 $sw $sh
349
350            switch -- $dir {
351              left {
352                set i 0
353                for {set j 0} {$j < $s/2} {incr j} {
354                    set ybtm [expr {$s-$j-1}]
355                    $_fills($dir) put $dark \
356                        -to $i [expr {$ybtm-1}] [expr {$i+2}] [expr {$ybtm+1}]
357                    $_fills($dir) put black \
358                        -to [expr {$i+2}] $ybtm [expr {$i+4}] [expr {$ybtm+1}]
359
360                    set ytop $j
361                    set ytoffs [expr {($j == $s/2-1) ? 1 : 2}]
362                    $_fills($dir) put $light \
363                        -to $i $ytop [expr {$i+2}] [expr {$ytop+$ytoffs}]
364                    $_fills($dir) put black \
365                        -to [expr {$i+2}] $ytop [expr {$i+4}] [expr {$ytop+1}]
366                    incr i 2
367                }
368                $_stems($dir).l configure -image $_fills($dir)
369
370                $_masks($dir) put black -to 0 0 $sw $sh
371                set i 0
372                for {set j 0} {$j < $s/2} {incr j} {
373                    for {set k [expr {$i+4}]} {$k < $s+2} {incr k} {
374                        $_masks($dir) transparency set $k $j yes
375                        $_masks($dir) transparency set $k [expr {$s-$j-1}] yes
376                    }
377                    incr i 2
378                }
379              }
380              right {
381                set i $sw
382                for {set j 0} {$j < $s/2} {incr j} {
383                    set ybtm [expr {$s-$j-1}]
384                    $_fills($dir) put $dark \
385                        -to [expr {$i-2}] [expr {$ybtm-1}] $i [expr {$ybtm+1}]
386                    $_fills($dir) put black \
387                        -to [expr {$i-4}] $ybtm [expr {$i-2}] [expr {$ybtm+1}]
388
389                    set ytop $j
390                    set ytoffs [expr {($j == $s/2-1) ? 1 : 2}]
391                    $_fills($dir) put $light \
392                        -to [expr {$i-2}] $ytop $i [expr {$ytop+$ytoffs}]
393                    $_fills($dir) put black \
394                        -to [expr {$i-4}] $ytop [expr {$i-2}] [expr {$ytop+1}]
395                    incr i -2
396                }
397                $_stems($dir).l configure -image $_fills($dir)
398
399                $_masks($dir) put black -to 0 0 $sw $sh
400                set i $sw
401                for {set j 0} {$j < $s/2} {incr j} {
402                    for {set k 0} {$k < $i-4} {incr k} {
403                        $_masks($dir) transparency set $k $j yes
404                        $_masks($dir) transparency set $k [expr {$s-$j-1}] yes
405                    }
406                    incr i -2
407                }
408              }
409              above {
410                set i 0
411                for {set j 0} {$j < $s/2} {incr j} {
412                    set xrhs [expr {$s-$j-1}]
413                    $_fills($dir) put $dark \
414                        -to [expr {$xrhs-1}] $i [expr {$xrhs+1}] [expr {$i+2}]
415                    $_fills($dir) put black \
416                        -to $xrhs [expr {$i+2}] [expr {$xrhs+1}] [expr {$i+4}]
417
418                    set xlhs $j
419                    set xloffs [expr {($j == $s/2-1) ? 1 : 2}]
420                    $_fills($dir) put $light \
421                        -to $xlhs $i [expr {$xlhs+$xloffs}] [expr {$i+2}]
422                    $_fills($dir) put black \
423                        -to $xlhs [expr {$i+2}] [expr {$xlhs+1}] [expr {$i+4}]
424                    incr i 2
425                }
426                $_stems($dir).l configure -image $_fills($dir)
427
428                $_masks($dir) put black -to 0 0 $sw $sh
429                set i 0
430                for {set j 0} {$j < $s/2} {incr j} {
431                    for {set k [expr {$i+4}]} {$k < $s+2} {incr k} {
432                        $_masks($dir) transparency set $j $k yes
433                        $_masks($dir) transparency set [expr {$s-$j-1}] $k yes
434                    }
435                    incr i 2
436                }
437              }
438              below {
439                set i $sh
440                for {set j 0} {$j < $s/2} {incr j} {
441                    set xrhs [expr {$s-$j-1}]
442                    $_fills($dir) put $dark \
443                        -to [expr {$xrhs-1}] [expr {$i-2}] [expr {$xrhs+1}] $i
444                    $_fills($dir) put black \
445                        -to $xrhs [expr {$i-4}] [expr {$xrhs+1}] [expr {$i-2}]
446
447                    set xlhs $j
448                    set xloffs [expr {($j == $s/2-1) ? 1 : 2}]
449                    $_fills($dir) put $light \
450                        -to $xlhs [expr {$i-2}] [expr {$xlhs+$xloffs}] $i
451                    $_fills($dir) put black \
452                        -to $xlhs [expr {$i-4}] [expr {$xlhs+1}] [expr {$i-2}]
453                    incr i -2
454                }
455                $_stems($dir).l configure -image $_fills($dir)
456
457                $_masks($dir) put black -to 0 0 $sw $sh
458                set i $sh
459                for {set j 0} {$j < $s/2} {incr j} {
460                    for {set k 0} {$k < $i-4} {incr k} {
461                        $_masks($dir) transparency set $j $k yes
462                        $_masks($dir) transparency set [expr {$s-$j-1}] $k yes
463                    }
464                    incr i -2
465                }
466              }
467            }
468        }
469    } else {
470        #
471        # No shape extension.  Do the best we can by creating a
472        # black line for all directions.
473        #
474        foreach {dir w h} [list \
475            left   $itk_option(-stemlength) 3 \
476            right  $itk_option(-stemlength) 3 \
477            above  3 $itk_option(-stemlength) \
478            below  3 $itk_option(-stemlength) \
479        ] {
480            set _stems($dir) [toplevel $itk_interior.s$dir \
481                -width $w -height $h \
482                -borderwidth 1 -relief solid -background black]
483            wm withdraw $_stems($dir)
484            wm overrideredirect $_stems($dir) yes
485
486            # create this for size, even though we don't really use it
487            set _fills($dir) [image create photo -width $w -height $h]
488        }
489    }
490}
491
492# ----------------------------------------------------------------------
493# USAGE: outside <widget> <x> <y>
494#
495# Used internally to see if the click point <x>,<y> is outside of
496# this widget.  If so, the widget usually releases is grab and
497# deactivates.
498# ----------------------------------------------------------------------
499itcl::body Rappture::Balloon::outside {widget x y} {
500    return [expr {$x < [winfo rootx $widget]
501             || $x > [winfo rootx $widget]+[winfo width $widget]
502             || $y < [winfo rooty $widget]
503             || $y > [winfo rooty $widget]+[winfo height $widget]}]
504}
505
506# ----------------------------------------------------------------------
507# CONFIGURATION OPTION: -background
508# ----------------------------------------------------------------------
509itcl::configbody Rappture::Balloon::background {
510    _createStems
511}
512
513# ----------------------------------------------------------------------
514# CONFIGURATION OPTION: -stemlength
515#
516# Used internally to create the stems that connect a balloon panel
517# to its anchor point, in all four possible directions:  left, right,
518# above, and below.
519# ----------------------------------------------------------------------
520itcl::configbody Rappture::Balloon::stemlength {
521    if {$itk_option(-stemlength) % 2 != 0} {
522        error "stem length should be an even number of pixels"
523    }
524}
525
526# ----------------------------------------------------------------------
527# CONFIGURATION OPTION: -dismissbutton
528# ----------------------------------------------------------------------
529itcl::configbody Rappture::Balloon::dismissbutton {
530    if {![string is boolean $itk_option(-dismissbutton)]} {
531        error "bad value \"$itk_option(-dismissbutton)\": should be on/off, 1/0, true/false, yes/no"
532    }
533    if {$itk_option(-dismissbutton)} {
534        pack $itk_component(titlebar) -before $itk_component(inner) \
535            -side top -fill x
536        pack $itk_component(dismiss) -side right -padx 4
537    } elseif {"" != $itk_option(-title)} {
538        pack $itk_component(titlebar) -before $itk_component(inner) \
539            -side top -fill x
540        pack forget $itk_component(dismiss)
541    } else {
542        pack forget $itk_component(titlebar)
543    }
544}
545
546# ----------------------------------------------------------------------
547# CONFIGURATION OPTION: -padx
548# ----------------------------------------------------------------------
549itcl::configbody Rappture::Balloon::padx {
550    pack $itk_component(inner) -padx $itk_option(-padx)
551}
552
553# ----------------------------------------------------------------------
554# CONFIGURATION OPTION: -pady
555# ----------------------------------------------------------------------
556itcl::configbody Rappture::Balloon::pady {
557    pack $itk_component(inner) -pady $itk_option(-pady)
558}
559
560# ----------------------------------------------------------------------
561# CONFIGURATION OPTION: -title
562# ----------------------------------------------------------------------
563itcl::configbody Rappture::Balloon::title {
564    if {"" != $itk_option(-title) || $itk_option(-dismissbutton)} {
565        pack $itk_component(titlebar) -before $itk_component(inner) \
566            -side top -fill x
567        if {$itk_option(-dismissbutton)} {
568            pack $itk_component(dismiss) -side right -padx 4
569        } else {
570            pack forget $itk_component(dismiss)
571        }
572    } else {
573        pack forget $itk_component(titlebar)
574    }
575}
Note: See TracBrowser for help on using the repository browser.