source: trunk/gui/scripts/tooltip.tcl @ 11

Last change on this file since 11 was 11, checked in by mmc, 19 years ago

Major reorganization of the entire package. The config.xml file
is now irrelevant. All the action is in the tool.xml file. The
main program now organizes all input into 1) side-by-side pages,
2) input/result (wizard-style) pages, or 3) a series of wizard-
style pages. The <input> can have <phase> parts representing
the various pages.

Added a new ContourResult? widget based on Swaroop's vtk plotting
code.

Also, added easymesh and showmesh to the "tools" directory.
We need these for Eric Polizzi's code.
File size: 12.2 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: tooltip - help information that pops up beneath a widget
3#
4#  This file provides support for tooltips, which are little bits
5#  of help information that pop up beneath a widget.
6#
7#  Tooltips can be registered for various widgets as follows:
8#
9#    Rappture::Tooltip::for .w "Some help text."
10#    Rappture::Tooltip::for .x.y "Some more help text."
11#
12#  Tooltips can also be popped up as an error cue beneath a widget
13#  with bad information:
14#
15#    Rappture::Tooltip::cue .w "Bad data in this widget."
16#
17# ======================================================================
18#  AUTHOR:  Michael McLennan, Purdue University
19#  Copyright (c) 2004-2005
20#  Purdue Research Foundation, West Lafayette, IN
21# ======================================================================
22package require Itk
23
24option add *Tooltip.background white widgetDefault
25option add *Tooltip.outline black widgetDefault
26option add *Tooltip.borderwidth 1 widgetDefault
27option add *Tooltip.font -*-helvetica-medium-r-normal-*-*-120-* widgetDefault
28option add *Tooltip.wrapLength 4i widgetDefault
29
30itcl::class Rappture::Tooltip {
31    inherit itk::Toplevel
32
33    itk_option define -outline outline Outline ""
34    itk_option define -icon icon Icon ""
35    itk_option define -message message Message ""
36
37    constructor {args} { # defined below }
38
39    public method show {where}
40    public method hide {}
41
42    public proc for {widget args}
43    public proc text {widget args}
44    private common catalog    ;# maps widget => message
45
46    public proc tooltip {option args}
47    private common pending "" ;# after ID for pending "tooltip show"
48
49    public proc cue {option args}
50
51    bind RapptureTooltip <Enter> \
52        [list ::Rappture::Tooltip::tooltip pending %W]
53    bind RapptureTooltip <Leave> \
54        [list ::Rappture::Tooltip::tooltip cancel]
55    bind RapptureTooltip <ButtonPress> \
56        [list ::Rappture::Tooltip::tooltip cancel]
57    bind RapptureTooltip <KeyPress> \
58        [list ::Rappture::Tooltip::tooltip cancel]
59
60    private common icons
61    set dir [file dirname [info script]]
62    set icons(cue) [image create photo -file [file join $dir images cue24.gif]]
63}
64
65itk::usual Tooltip {
66    keep -background -outline -cursor -font
67}
68
69# ----------------------------------------------------------------------
70# CONSTRUCTOR
71# ----------------------------------------------------------------------
72itcl::body Rappture::Tooltip::constructor {args} {
73    wm overrideredirect $itk_component(hull) yes
74    wm withdraw $itk_component(hull)
75
76    component hull configure -borderwidth 1 -background black
77    itk_option remove hull.background hull.borderwidth
78
79    itk_component add icon {
80        label $itk_interior.icon -anchor n
81    }
82
83    itk_component add text {
84        label $itk_interior.text -justify left
85    } {
86        usual
87        keep -wraplength
88    }
89    pack $itk_component(text) -expand yes -fill both -ipadx 4 -ipady 4
90
91    eval itk_initialize $args
92}
93
94# ----------------------------------------------------------------------
95# USAGE: show @<x>,<y>|<widget>+<x>,<y>
96#
97# Clients use this to pop up the tooltip on the screen.  The position
98# should be either a <widget> name with an optional offset +<x>,<y>
99# (tooltip pops up beneath widget by default), or a specific root
100# window coordinate of the form @x,y.
101#
102# If the -message has the form "@command", then the command is executed
103# now, just before the tooltip is popped up, to build the message
104# on-the-fly.
105# ----------------------------------------------------------------------
106itcl::body Rappture::Tooltip::show {where} {
107    set hull $itk_component(hull)
108
109    if {[regexp {^@([0-9]+),([0-9]+)$} $where match x y]} {
110        set xpos $x
111        set ypos $y
112    } elseif {[regexp {^(.*)\+([0-9]+),([0-9]+)$} $where match win x y]} {
113        set xpos [expr {[winfo rootx $win]+$x}]
114        set ypos [expr {[winfo rooty $win]+$y}]
115    } elseif {[winfo exists $where]} {
116        set xpos [expr {[winfo rootx $where]+10}]
117        set ypos [expr {[winfo rooty $where]+[winfo height $where]}]
118    } else {
119        error "bad position \"$where\": should be widget name, +x,y, or @x,y"
120    }
121
122    if {[string index $itk_option(-message) 0] == "@"} {
123        set cmd [string range $itk_option(-message) 1 end]
124        if {[catch $cmd mesg] != 0} {
125            bgerror $mesg
126            return
127        }
128    } else {
129        set mesg $itk_option(-message)
130    }
131
132    # strings can't be too big, or they'll go off screen!
133    if {[string length $mesg] > 1000} {
134        set mesg "[string range $mesg 0 1000]..."
135    }
136    set pos 0
137    ::for {set i 0} {$pos >= 0 && $i < 5} {incr i} {
138        incr pos
139        set pos [string first \n $mesg $pos]
140    }
141    if {$pos > 0} {
142        set mesg "[string range $mesg 0 $pos]..."
143    }
144    $itk_component(text) configure -text $mesg
145
146    #
147    # Make sure the tooltip doesn't go off screen.  Then, put it up.
148    #
149    update
150    if {$xpos+[winfo reqwidth $hull] > [winfo screenwidth $hull]} {
151        set xpos [expr {[winfo screenwidth $hull]-[winfo reqwidth $hull]}]
152    }
153    if {$xpos < 0} { set xpos 0 }
154
155    if {$ypos+[winfo reqheight $hull] > [winfo screenheight $hull]} {
156        set ypos [expr {[winfo screenheight $hull]-[winfo reqheight $hull]}]
157    }
158    if {$ypos < 0} { set ypos 0 }
159
160    wm geometry $hull +$xpos+$ypos
161    update
162
163    wm deiconify $hull
164    raise $hull
165}
166
167# ----------------------------------------------------------------------
168# USAGE: hide
169#
170# Takes down the tooltip, if it is showing on the screen.
171# ----------------------------------------------------------------------
172itcl::body Rappture::Tooltip::hide {} {
173    wm withdraw $itk_component(hull)
174}
175
176# ----------------------------------------------------------------------
177# USAGE: for <widget> <text>
178#
179# Used to register the tooltip <text> for a particular <widget>.
180# This sets up bindings on the widget so that, when the mouse pointer
181# lingers over the widget, the tooltip pops up automatically after
182# a small delay.  When the mouse pointer leaves the widget or the
183# user clicks on the widget, it cancels the tip.
184#
185# If the <text> has the form "@command", then the command is executed
186# just before the tip pops up to build the message on-the-fly.
187# ----------------------------------------------------------------------
188itcl::body Rappture::Tooltip::for {widget text} {
189    set catalog($widget) $text
190
191    set btags [bindtags $widget]
192    set i [lsearch $btags RapptureTooltip]
193    if {$i < 0} {
194        set i [lsearch $btags [winfo class $widget]]
195        if {$i < 0} {set i 0}
196        set btags [linsert $btags $i RapptureTooltip]
197        bindtags $widget $btags
198    }
199}
200
201# ----------------------------------------------------------------------
202# USAGE: text <widget> ?<text>?
203#
204# Used to query or set the text used for the tooltip for a widget.
205# This is done automatically when you call the "for" proc, but it
206# is sometimes handy to query or change the text later.
207# ----------------------------------------------------------------------
208itcl::body Rappture::Tooltip::text {widget args} {
209    if {[llength $args] == 0} {
210        if {[info exists catalog($widget)]} {
211            return $catalog($widget)
212        }
213        return ""
214    } elseif {[llength $args] == 1} {
215        set str [lindex $args 0]
216        set catalog($widget) $str
217    } else {
218        error "wrong # args: should be \"text widget ?str?\""
219    }
220}
221
222# ----------------------------------------------------------------------
223# USAGE: tooltip pending <widget> ?@<x>,<y>|+<x>,<y>?
224# USAGE: tooltip show <widget> ?@<x>,<y>|+<x>,<y>?
225# USAGE: tooltip cancel
226#
227# This is invoked automatically whenever the user clicks somewhere
228# inside or outside of the editor.  If the <X>,<Y> coordinate is
229# outside the editor, then we assume the user is done and wants to
230# take the editor down.  Otherwise, we do nothing, and let the entry
231# bindings take over.
232# ----------------------------------------------------------------------
233itcl::body Rappture::Tooltip::tooltip {option args} {
234    switch -- $option {
235        pending {
236            if {[llength $args] < 1 || [llength $args] > 2} {
237                error "wrong # args: should be \"tooltip pending widget ?@x,y?\""
238            }
239            set widget [lindex $args 0]
240            set loc [lindex $args 1]
241
242            if {![info exists catalog($widget)]} {
243                error "can't find tooltip for $widget"
244            }
245            if {$pending != ""} {
246                after cancel $pending
247            }
248            set pending [after 1500 [itcl::code tooltip show $widget $loc]]
249        }
250        show {
251            if {[llength $args] < 1 || [llength $args] > 2} {
252                error "wrong # args: should be \"tooltip pending widget ?@x,y?\""
253            }
254            set widget [lindex $args 0]
255            set loc [lindex $args 1]
256
257            if {[winfo exists $widget]} {
258                .rappturetooltip configure -message $catalog($widget)
259                if {[string index $loc 0] == "@"} {
260                    .rappturetooltip show $loc
261                } elseif {[string index $loc 0] == "+"} {
262                    .rappturetooltip show $widget$loc
263                } else {
264                    .rappturetooltip show $widget
265                }
266            }
267        }
268        cancel {
269            if {$pending != ""} {
270                after cancel $pending
271                set pending ""
272            }
273            .rappturetooltip hide
274        }
275        default {
276            error "bad option \"$option\": should be show, pending, cancel"
277        }
278    }
279}
280
281# ----------------------------------------------------------------------
282# USAGE: cue <location> <message>
283# USAGE: cue hide
284#
285# Clients use this to show a <message> in a tooltip cue at the
286# specified <location>, which can be a widget name or a root coordinate
287# at @x,y.
288# ----------------------------------------------------------------------
289itcl::body Rappture::Tooltip::cue {option args} {
290    if {"hide" == $option} {
291        grab release .rappturetoolcue
292        .rappturetoolcue hide
293    } elseif {[regexp {^@[0-9]+,[0-9]+$} $option] || [winfo exists $option]} {
294        if {[llength $args] != 1} {
295            error "wrong # args: should be \"cue location message\""
296        }
297        set loc $option
298        set mesg [lindex $args 0]
299
300        .rappturetoolcue configure -message $mesg
301        .rappturetoolcue show $loc
302
303        #
304        # Add a binding to all widgets so that any keypress will
305        # take this cue down.
306        #
307        set cmd [bind all <KeyPress>]
308        if {![regexp {Rappture::Tooltip::cue} $cmd]} {
309            bind all <KeyPress> "+[list ::Rappture::Tooltip::cue hide]"
310            bind all <KeyPress-Return> "+ "
311        }
312
313        #
314        # If nobody has the pointer, then grab it.  Otherwise,
315        # we assume the pop-up editor or someone like that has
316        # the grab, so we don't need to impose a grab here.
317        #
318        if {"" == [grab current]} {
319            update
320            while {[catch {grab set -global .rappturetoolcue}]} {
321                after 100
322            }
323        }
324    } else {
325        error "bad option \"$option\": should be hide, a widget name, or @x,y"
326    }
327}
328
329# ----------------------------------------------------------------------
330# CONFIGURATION OPTION: -icon
331# ----------------------------------------------------------------------
332itcl::configbody Rappture::Tooltip::icon {
333    if {"" == $itk_option(-icon)} {
334        $itk_component(icon) configure -image ""
335        pack forget $itk_component(icon)
336    } else {
337        $itk_component(icon) configure -image $itk_option(-icon)
338        pack $itk_component(icon) -before $itk_component(text) \
339            -side left -fill y
340    }
341}
342
343# ----------------------------------------------------------------------
344# CONFIGURATION OPTION: -outline
345# ----------------------------------------------------------------------
346itcl::configbody Rappture::Tooltip::outline {
347    component hull configure -background $itk_option(-outline)
348}
349
350# create a tooltip widget to show tool tips
351Rappture::Tooltip .rappturetooltip
352
353# create a tooltip widget to show error cues
354Rappture::Tooltip .rappturetoolcue \
355    -icon $Rappture::Tooltip::icons(cue) \
356    -background black -outline #333333 -foreground white
357
358# when cue is up, it has a grab, and any click brings it down
359bind .rappturetoolcue <ButtonPress> [list ::Rappture::Tooltip::cue hide]
Note: See TracBrowser for help on using the repository browser.