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

Last change on this file since 48 was 48, checked in by mmc, 16 years ago

Oops! Fixed the Balloon widget so that it works properly even
if the Shape extension is not installed.

File size: 14.6 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: Balloon - toplevel popup window, like a cartoon balloon
3#
4#  This widget is used as a container for pop-up panels in Rappture.
5#  If shape extensions are supported, then the window is drawn as
6#  a cartoon balloon.  Otherwise, it is a raised panel, with a little
7#  line connecting it to the widget that brought it up.  When active,
8#  the panel has a global grab and focus, so the user must interact
9#  with it or dismiss it.
10# ======================================================================
11#  AUTHOR:  Michael McLennan, Purdue University
12#  Copyright (c) 2004-2005
13#  Purdue Research Foundation, West Lafayette, IN
14# ======================================================================
15package require Itk
16
17namespace eval Rappture { # forward declaration }
18
19option add *Balloon.stemLength 16 widgetDefault
20
21itcl::class Rappture::Balloon {
22    inherit itk::Toplevel
23
24    itk_option define -stemlength stemLength StemLength 20
25
26    constructor {args} { # defined below }
27
28    public method activate {where placement}
29    public method deactivate {}
30
31    protected method _createStems {}
32
33    protected variable _stems   ;# windows for cartoon balloon stems
34    protected variable _masks   ;# masks for cartoon balloon stems
35    protected variable _fills   ;# lines for cartoon balloon stems
36
37    public proc outside {widget x y}
38
39    bind RapptureBalloon <ButtonPress> \
40        {if {[Rappture::Balloon::outside %W %X %Y]} {%W deactivate}}
41}
42
43itk::usual Balloon {
44}
45
46# ----------------------------------------------------------------------
47# CONSTRUCTOR
48# ----------------------------------------------------------------------
49itcl::body Rappture::Balloon::constructor {args} {
50    wm overrideredirect $itk_component(hull) yes
51    wm withdraw $itk_component(hull)
52    component hull configure -borderwidth 1 -relief solid
53
54    itk_component add inner {
55        frame $itk_interior.inner -borderwidth 2 -relief raised
56    }
57    pack $itk_component(inner) -expand yes -fill both
58
59    # add bindings to release the grab
60    set btags [bindtags $itk_component(hull)]
61    bindtags $itk_component(hull) [linsert $btags 1 RapptureBalloon]
62
63    eval itk_initialize $args
64
65    _createStems
66}
67
68# ----------------------------------------------------------------------
69# USAGE: activate <where> <placement>
70#
71# Clients use this to pop up this balloon panel pointing to the
72# <where> location, which should be a widget name or @X,Y.  The
73# <placement> indicates whether the panel should be left, right,
74# above, or below the <where> coordinate.
75# ----------------------------------------------------------------------
76itcl::body Rappture::Balloon::activate {where placement} {
77    if {![info exists _stems($placement)]} {
78        error "bad placement \"$placement\": should be [join [lsort [array names _stems]] {, }]"
79    }
80    set s $_stems($placement)
81    set sw [image width $_fills($placement)]
82    set sh [image height $_fills($placement)]
83    set p $itk_component(hull)
84
85    if {[winfo exists $where]} {
86        set x [expr {[winfo rootx $where]+[winfo width $where]/2}]
87        set y [expr {[winfo rooty $where]+[winfo height $where]/2}]
88        switch -- $placement {
89            left { set x [expr {[winfo rootx $where]+5}] }
90            right { set x [expr {[winfo rootx $where]+[winfo width $where]-5}] }
91            above { set y [expr {[winfo rooty $where]+5}] }
92            below { set y [expr {[winfo rooty $where]+[winfo height $where]-5}] }
93        }
94    } elseif {[regexp {^@([0-9]+),([0-9]+)$} $where match x y]} {
95        # got x and y
96    } else {
97        error "bad location \"$where\": should be widget or @x,y"
98    }
99
100    # if the panel is already up, take it down
101    deactivate
102
103    switch -- $placement {
104        left {
105            set sx [expr {$x-$sw+3}]
106            set sy [expr {$y-$sh/2}]
107            set px [expr {$sx-[winfo reqwidth $p]+3}]
108            set py [expr {$y-[winfo reqheight $p]/2}]
109        }
110        right {
111            set sx $x
112            set sy [expr {$y-$sh/2}]
113            set px [expr {$x+$sw-3}]
114            set py [expr {$y-[winfo reqheight $p]/2}]
115        }
116        above {
117            set sx [expr {$x-$sw/2}]
118            set sy [expr {$y-$sh+3}]
119            set px [expr {$x-[winfo reqwidth $p]/2}]
120            set py [expr {$sy-[winfo reqheight $p]+3}]
121        }
122        below {
123            set sx [expr {$x-$sw/2}]
124            set sy $y
125            set px [expr {$x-[winfo reqwidth $p]/2}]
126            set py [expr {$y+$sh-3}]
127        }
128    }
129    if {[info exists _masks($placement)]} {
130        shape set $s -bound photo $_masks($placement)
131    }
132
133    wm geometry $p +$px+$py
134    wm deiconify $p
135    raise $p
136
137    wm geometry $s +$sx+$sy
138    wm deiconify $s
139    raise $s
140
141    # grab the mouse pointer
142    update
143    while {[catch {grab set -global $itk_component(hull)}]} {
144        after 100
145    }
146    focus $itk_component(hull)
147}
148
149# ----------------------------------------------------------------------
150# USAGE: deactivate
151#
152# Clients use this to take down the balloon panel if it is on screen.
153# ----------------------------------------------------------------------
154itcl::body Rappture::Balloon::deactivate {} {
155    grab release $itk_component(hull)
156
157    wm withdraw $itk_component(hull)
158    foreach dir {left right above below} {
159        wm withdraw $_stems($dir)
160    }
161}
162
163# ----------------------------------------------------------------------
164# USAGE: _createStems
165#
166# Used internally to create the stems that connect a balloon panel
167# to its anchor point, in all four possible directions:  left, right,
168# above, and below.
169# ----------------------------------------------------------------------
170itcl::body Rappture::Balloon::_createStems {} {
171    # destroy any existing stems
172    foreach dir [array names _stems] {
173        destroy $_stems($dir)
174        unset _stems($dir)
175    }
176    foreach dir [array names _masks] {
177        image delete $_masks($dir)
178        unset _masks($dir)
179    }
180    foreach dir [array names _fills] {
181        image delete $_fills($dir)
182        unset _fills($dir)
183    }
184
185    if {[catch {package require Shape}] == 0} {
186        #
187        # We have the Shape extension.  Use it to create nice
188        # looking (triangle-shaped) stems.
189        #
190        set s $itk_option(-stemlength)
191        foreach dir {left right above below} {
192            switch -- $dir {
193                left - right {
194                    set sw [expr {$s+2}]
195                    set sh $s
196                }
197                above - below {
198                    set sw $s
199                    set sh [expr {$s+2}]
200                }
201            }
202
203            set _stems($dir) [toplevel $itk_interior.s$dir -borderwidth 0]
204            label $_stems($dir).l \
205                -width $sw -height $sh -borderwidth 0
206            pack $_stems($dir).l -expand yes -fill both
207
208            wm withdraw $_stems($dir)
209            wm overrideredirect $_stems($dir) yes
210
211            #
212            # Draw the triangle part of the stem, with a black outline
213            # and light/dark highlights:
214            #
215            #     --------  ---       LEFT STEM
216            #    |..##    |  ^ 
217            #    |  ..##  |  |        . = light color
218            #    |    ..##|  | s      @ = dark color
219            #    |    @@##|  |        # = black
220            #    |  @@##  |  |
221            #    |@@##    |  v
222            #     --------  ---
223            #    |<------>|
224            #        s+2
225            #
226            set _masks($dir) [image create photo -width $sw -height $sh]
227            set _fills($dir) [image create photo -width $sw -height $sh]
228
229            set bg $itk_option(-background)
230            set light [Rappture::color::brightness $bg 0.4]
231            set dark [Rappture::color::brightness $bg -0.4]
232
233            $_fills($dir) put $bg -to 0 0 $sw $sh
234
235            switch -- $dir {
236              left {
237                set i 0
238                for {set j 0} {$j < $s/2} {incr j} {
239                    set ybtm [expr {$s-$j-1}]
240                    $_fills($dir) put $dark \
241                        -to $i [expr {$ybtm-1}] [expr {$i+2}] [expr {$ybtm+1}]
242                    $_fills($dir) put black \
243                        -to [expr {$i+2}] $ybtm [expr {$i+4}] [expr {$ybtm+1}]
244
245                    set ytop $j
246                    set ytoffs [expr {($j == $s/2-1) ? 1 : 2}]
247                    $_fills($dir) put $light \
248                        -to $i $ytop [expr {$i+2}] [expr {$ytop+$ytoffs}]
249                    $_fills($dir) put black \
250                        -to [expr {$i+2}] $ytop [expr {$i+4}] [expr {$ytop+1}]
251                    incr i 2
252                }
253                $_stems($dir).l configure -image $_fills($dir)
254
255                $_masks($dir) put black -to 0 0 $sw $sh
256                set i 0
257                for {set j 0} {$j < $s/2} {incr j} {
258                    for {set k [expr {$i+4}]} {$k < $s+2} {incr k} {
259                        $_masks($dir) transparency set $k $j yes
260                        $_masks($dir) transparency set $k [expr {$s-$j-1}] yes
261                    }
262                    incr i 2
263                }
264              }
265              right {
266                set i $sw
267                for {set j 0} {$j < $s/2} {incr j} {
268                    set ybtm [expr {$s-$j-1}]
269                    $_fills($dir) put $dark \
270                        -to [expr {$i-2}] [expr {$ybtm-1}] $i [expr {$ybtm+1}]
271                    $_fills($dir) put black \
272                        -to [expr {$i-4}] $ybtm [expr {$i-2}] [expr {$ybtm+1}]
273
274                    set ytop $j
275                    set ytoffs [expr {($j == $s/2-1) ? 1 : 2}]
276                    $_fills($dir) put $light \
277                        -to [expr {$i-2}] $ytop $i [expr {$ytop+$ytoffs}]
278                    $_fills($dir) put black \
279                        -to [expr {$i-4}] $ytop [expr {$i-2}] [expr {$ytop+1}]
280                    incr i -2
281                }
282                $_stems($dir).l configure -image $_fills($dir)
283
284                $_masks($dir) put black -to 0 0 $sw $sh
285                set i $sw
286                for {set j 0} {$j < $s/2} {incr j} {
287                    for {set k 0} {$k < $i-4} {incr k} {
288                        $_masks($dir) transparency set $k $j yes
289                        $_masks($dir) transparency set $k [expr {$s-$j-1}] yes
290                    }
291                    incr i -2
292                }
293              }
294              above {
295                set i 0
296                for {set j 0} {$j < $s/2} {incr j} {
297                    set xrhs [expr {$s-$j-1}]
298                    $_fills($dir) put $dark \
299                        -to [expr {$xrhs-1}] $i [expr {$xrhs+1}] [expr {$i+2}]
300                    $_fills($dir) put black \
301                        -to $xrhs [expr {$i+2}] [expr {$xrhs+1}] [expr {$i+4}]
302
303                    set xlhs $j
304                    set xloffs [expr {($j == $s/2-1) ? 1 : 2}]
305                    $_fills($dir) put $light \
306                        -to $xlhs $i [expr {$xlhs+$xloffs}] [expr {$i+2}]
307                    $_fills($dir) put black \
308                        -to $xlhs [expr {$i+2}] [expr {$xlhs+1}] [expr {$i+4}]
309                    incr i 2
310                }
311                $_stems($dir).l configure -image $_fills($dir)
312
313                $_masks($dir) put black -to 0 0 $sw $sh
314                set i 0
315                for {set j 0} {$j < $s/2} {incr j} {
316                    for {set k [expr {$i+4}]} {$k < $s+2} {incr k} {
317                        $_masks($dir) transparency set $j $k yes
318                        $_masks($dir) transparency set [expr {$s-$j-1}] $k yes
319                    }
320                    incr i 2
321                }
322              }
323              below {
324                set i $sh
325                for {set j 0} {$j < $s/2} {incr j} {
326                    set xrhs [expr {$s-$j-1}]
327                    $_fills($dir) put $dark \
328                        -to [expr {$xrhs-1}] [expr {$i-2}] [expr {$xrhs+1}] $i
329                    $_fills($dir) put black \
330                        -to $xrhs [expr {$i-4}] [expr {$xrhs+1}] [expr {$i-2}]
331
332                    set xlhs $j
333                    set xloffs [expr {($j == $s/2-1) ? 1 : 2}]
334                    $_fills($dir) put $light \
335                        -to $xlhs [expr {$i-2}] [expr {$xlhs+$xloffs}] $i
336                    $_fills($dir) put black \
337                        -to $xlhs [expr {$i-4}] [expr {$xlhs+1}] [expr {$i-2}]
338                    incr i -2
339                }
340                $_stems($dir).l configure -image $_fills($dir)
341
342                $_masks($dir) put black -to 0 0 $sw $sh
343                set i $sh
344                for {set j 0} {$j < $s/2} {incr j} {
345                    for {set k 0} {$k < $i-4} {incr k} {
346                        $_masks($dir) transparency set $j $k yes
347                        $_masks($dir) transparency set [expr {$s-$j-1}] $k yes
348                    }
349                    incr i -2
350                }
351              }
352            }
353        }
354    } else {
355        #
356        # No shape extension.  Do the best we can by creating a
357        # black line for all directions.
358        #
359        foreach {dir w h} [list \
360            left   $itk_option(-stemlength) 3 \
361            right  $itk_option(-stemlength) 3 \
362            above  3 $itk_option(-stemlength) \
363            below  3 $itk_option(-stemlength) \
364        ] {
365            set _stems($dir) [toplevel $itk_interior.s$dir \
366                -width $w -height $h \
367                -borderwidth 1 -relief solid -background black]
368            wm withdraw $_stems($dir)
369            wm overrideredirect $_stems($dir) yes
370
371            # create this for size, even though we don't really use it
372            set _fills($dir) [image create photo -width $w -height $h]
373        }
374    }
375}
376
377# ----------------------------------------------------------------------
378# USAGE: outside <widget> <x> <y>
379#
380# Used internally to see if the click point <x>,<y> is outside of
381# this widget.  If so, the widget usually releases is grab and
382# deactivates.
383# ----------------------------------------------------------------------
384itcl::body Rappture::Balloon::outside {widget x y} {
385    return [expr {$x < [winfo rootx $widget]
386             || $x > [winfo rootx $widget]+[winfo width $widget]
387             || $y < [winfo rooty $widget]
388             || $y > [winfo rooty $widget]+[winfo height $widget]}]
389}
390
391# ----------------------------------------------------------------------
392# CONFIGURATION OPTION: -stemlength
393#
394# Used internally to create the stems that connect a balloon panel
395# to its anchor point, in all four possible directions:  left, right,
396# above, and below.
397# ----------------------------------------------------------------------
398itcl::configbody Rappture::Balloon::stemlength {
399    if {$itk_option(-stemlength) % 2 != 0} {
400        error "stem length should be an even number of pixels"
401    }
402}
Note: See TracBrowser for help on using the repository browser.