source: trunk/gui/scripts/drawingentry.tcl @ 3636

Last change on this file since 3636 was 3636, checked in by mmc, 9 years ago

Fixed the drawing widget to handle notifications from outside widgets, so
that canvas items react to value changes. Also added tooltips for drawing
items.

Nudged the next/back buttons for the pager in a bit, so they're a little
easier to press in the iPad app.

Fixed the Ruby template for the builder to include the overwrite/append flag.

File size: 31.4 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2
3# ----------------------------------------------------------------------
4#  COMPONENT: DrawingEntry - widget for entering numeric values
5#
6#  This widget represents a <number> entry on a control panel.
7#  It is used to enter numeric values.
8# ======================================================================
9#  AUTHOR:  Michael McLennan, Purdue University
10#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
11#
12#  See the file "license.terms" for information on usage and
13#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14# ======================================================================
15package require Itk
16package require Img
17
18itcl::class Rappture::DrawingEntry {
19    inherit itk::Widget
20    itk_option define -state state State "normal"
21
22    private variable _dispatcher ""
23    private variable _path
24    private variable _owner
25    private variable _monitoring ""
26    private variable _xmlobj ""
27
28    # slave interpreter where all substituted variables are stored
29    private variable _parser ""
30
31    # unique counter for popup names
32    private common _popupnum 0
33
34    private variable _canvasHeight 0
35    private variable _canvasWidth 0
36    private variable _cpath2popup
37    private variable _takedown ""
38    private variable _cname2id
39    private variable _cname2image
40    private variable _name2path
41    private variable _name2map
42    private variable _drawingHeight 0
43    private variable _drawingWidth 0
44    private variable _showing ""
45    private variable _xAspect 0
46    private variable _xMin 0
47    private variable _xOffset 0
48    private variable _xScale 1.0
49    private variable _yAspect 0
50    private variable _yMin 0
51    private variable _yOffset 0
52    private variable _yScale 1.0
53    private variable _cursor ""
54
55    constructor {owner path args} {
56        # defined below
57    }
58    destructor {
59        # defined below
60    }
61    public method value { args }
62    public method label {}
63    public method tooltip {}
64
65    private method Activate { tag }
66    private method AdjustDrawingArea { xAspect yAspect }
67    private method Deactivate { tag }
68    private method Highlight { tag }
69    private method Invoke { name x y }
70    private method ParseBackground {}
71    private method ParseDescription {}
72    private method ParseGrid { cpath cname }
73    private method ParseHotspot { cpath cname }
74    private method ParseLine { cpath cname }
75    private method ParseOval { cpath cname }
76    private method ParsePicture { cpath cname }
77    private method ParsePolygon { cpath cname }
78    private method ParseRectangle { cpath cname }
79    private method ParseScreenCoordinates { values }
80    private method ParseText { cpath cname }
81    private method Redraw {}
82    private method ScreenCoords { coords }
83    private method ScreenX { x }
84    private method ScreenY { y }
85    private method UpdateSubstitutions {}
86    private method XmlGet { path }
87    private method XmlGetSubst { path }
88    private method Hotspot { option cname item args }
89}
90
91itk::usual DrawingEntry {
92    keep -cursor -font
93    keep -foreground -background
94    keep -textbackground
95    keep -selectbackground -selectforeground -selectborderwidth
96}
97
98# ----------------------------------------------------------------------
99# CONSTRUCTOR
100# ----------------------------------------------------------------------
101itcl::body Rappture::DrawingEntry::constructor {owner path args} {
102    if {[catch {$owner isa Rappture::ControlOwner} valid] != 0 || !$valid} {
103        error "bad object \"$owner\": should be Rappture::ControlOwner"
104    }
105    set _path $path
106    set _owner $owner
107    set _xmlobj [$_owner xml object]
108
109    Rappture::dispatcher _dispatcher
110    $_dispatcher register !redraw
111    $_dispatcher dispatch $this !redraw "[itcl::code $this Redraw]; list"
112
113    #
114    # Display the current drawing.
115    #
116    itk_component add drawing {
117        canvas $itk_interior.canvas -background white -relief sunken -bd 1 \
118            -width 400 -height 300
119    } {
120        ignore -background
121    }
122    pack $itk_component(drawing) -expand yes -fill both
123    bind $itk_component(drawing) <Configure> \
124        [itcl::code $_dispatcher event -idle !redraw]
125
126    # scan through all variables and attach notifications for changes
127    foreach cpath [$_xmlobj children -as path -type variable $_path.substitutions] {
128        set map ""
129        set name ""
130        set path ""
131        foreach elem [$_xmlobj children $cpath] {
132            switch -glob -- $elem {
133                "name*" {
134                    set name [XmlGet $cpath.$elem]
135                }
136                "path*" {
137                    set path [XmlGet $cpath.$elem]
138                }
139                "map*" {
140                    set from [XmlGet $cpath.$elem.from]
141                    set to [XmlGet $cpath.$elem.to]
142                    if {$from eq "" || $to eq ""} {
143                        puts stderr "empty translation in map table \"$cpath\""
144                    }
145                    lappend map $from $to
146                }
147            }
148        }
149        if {$name eq ""} {
150            puts stderr "no name defined for substituion variable \"$cpath\""
151            continue
152        }
153        if {[info exists _name2path($name)]} {
154            puts stderr "substitution variable \"$name\" already defined"
155            continue
156        }
157        set _name2path($name) $path
158        if {$path eq ""} {
159            puts stderr "no path defined for substituion variable \"$cpath\""
160            continue
161        }
162        set _name2map($name) $map
163
164        # keep track of controls built for each variable (see below)
165        set controls($path) unused
166
167        # whenever variable changes, update drawing to report new values
168        if {[lsearch $_monitoring $path] < 0} {
169            $_owner notify add $this $path \
170                [itcl::code $_dispatcher event -idle !redraw]
171            lappend _monitoring $path
172        }
173    }
174
175    # find all embedded controls and build a popup for each hotspot
176    foreach cpath [$_xmlobj children -type hotspot -as path $_path.components] {
177        set listOfControls [$_xmlobj children -type controls $cpath]
178        if {[llength $listOfControls] > 0} {
179            set popup .drawingentrypopup[incr _popupnum]
180            Rappture::Balloon $popup -title "Change values..."
181            set inner [$popup component inner]
182            Rappture::Controls $inner.controls $_owner
183            pack $inner.controls -fill both -expand yes
184            set _cpath2popup($cpath) $popup
185
186            # Add control widgets to this popup.
187            # NOTE: if the widget exists elsewhere, it is deleted at this
188            #   point and "sucked in" to the popup.
189            foreach cname $listOfControls {
190                set cntlpath [XmlGetSubst $cpath.$cname]
191                $inner.controls insert end $cntlpath
192            }
193        }
194    }
195
196    set c $itk_component(drawing)
197    foreach cpath [$_xmlobj children -type text -as path $_path.components] {
198        set popup ""
199        set mode [XmlGetSubst $cpath.hotspot]
200        if {$mode eq "off"} {
201            # no popup if hotspot is turned off
202            continue
203        }
204
205        # easiest way to parse embedded variables is to create a hotspot item
206        set id [$c create hotspot 0 0 -text [XmlGet $cpath.text]]
207        foreach varName [Rappture::hotspot variables $c $id] {
208            if {[info exists _name2path($varName)]} {
209                set cntlpath $_name2path($varName)
210
211                if {$controls($cntlpath) ne "unused"} {
212                    puts stderr "WARNING: drawing variable \"$varName\" is used in two hotspots, but will appear in only one of them."
213                    continue
214                }
215                set controls($cntlpath) "--"
216
217                if {$popup eq ""} {
218                    # create the popup for this item, if we haven't already
219                    set popup .drawingentrypopup[incr _popupnum]
220                    Rappture::Balloon $popup -title "Change values..."
221                    set inner [$popup component inner]
222                    Rappture::Controls $inner.controls $_owner
223                    pack $inner.controls -fill both -expand yes
224                }
225
226                # Add the control widget for this variable to this popup.
227                # NOTE: if the widget exists elsewhere, it is deleted at this
228                #   point and "sucked in" to the popup.
229                set inner [$popup component inner]
230                $inner.controls insert end $cntlpath
231                set _cpath2popup($cntlpath) $popup
232            } else {
233                puts stderr "unknown variable \"$varName\" in drawing item at $cpath"
234            }
235        }
236        $c delete $id
237    }
238
239    # create a parser to manage substitions of variable values
240    set _parser [interp create -safe]
241
242    eval itk_initialize $args
243
244    # initialize the drawing at some point
245    $_dispatcher event -idle !redraw
246}
247
248itcl::body Rappture::DrawingEntry::destructor {} {
249    # stop monitoring controls for value changes
250    foreach cpath $_monitoring {
251        $_owner notify remove $this $cpath
252    }
253
254    # tear down the value subsitution parser
255    if {$_parser != ""} {
256        $_parser delete
257    }
258}
259# ----------------------------------------------------------------------
260# USAGE: label
261#
262# Clients use this to query the label associated with this widget.
263# Reaches into the XML and pulls out the appropriate label string.
264# ----------------------------------------------------------------------
265itcl::body Rappture::DrawingEntry::label {} {
266    set label [$_owner xml get $_path.about.label]
267    if {$label eq ""} {
268        set label "Drawing"
269    }
270    return $label
271}
272
273# ----------------------------------------------------------------------
274# USAGE: tooltip
275#
276# Clients use this to query the tooltip associated with this widget.
277# Reaches into the XML and pulls out the appropriate description
278# string.  Returns the string that should be used with the
279# Rappture::Tooltip facility.
280# ----------------------------------------------------------------------
281itcl::body Rappture::DrawingEntry::tooltip {} {
282    set str [$_xmlobj get $_path.about.description]
283    return [string trim $str]
284}
285
286# ----------------------------------------------------------------------
287# CONFIGURATION OPTION: -state
288# ----------------------------------------------------------------------
289itcl::configbody Rappture::DrawingEntry::state {
290    set valid {normal disabled}
291    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
292        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
293    }
294}
295
296itcl::body Rappture::DrawingEntry::Redraw {} {
297    # If a popup is pending, redraw signals a value change; take it down
298    if {$_takedown ne ""} {
299        $_takedown deactivate
300        set _takedown ""
301    }
302
303    # Remove exists canvas items and hints
304    $itk_component(drawing) delete all
305
306    # Delete any images that we created.
307    foreach name [array names _cname2image] {
308        image delete $_cname2image($name)
309    }
310    array unset _cname2id
311    array unset _cname2image
312   
313    # Recompute the size of the canvas/drawing area
314    set _canvasWidth [winfo width $itk_component(drawing)]
315    if { $_canvasWidth < 2 } {
316        set _canvasWidth [winfo reqwidth $itk_component(drawing)]
317    }
318    set _canvasHeight [winfo height $itk_component(drawing)]
319    if { $_canvasHeight < 2 } {
320        set _canvasHeight [winfo reqheight $itk_component(drawing)]
321    }
322    set _drawingWidth $_canvasWidth
323    set _drawingHeight $_canvasHeight
324    set _xOffset 0
325    set _yOffset 0
326    ParseDescription
327}
328
329#
330# ParseDescription --
331#
332itcl::body Rappture::DrawingEntry::ParseDescription {} {
333    ParseBackground
334    UpdateSubstitutions
335    foreach cname [$_xmlobj children $_path.components] {
336        switch -glob -- $cname {
337            "line*" {
338                ParseLine $_path.components.$cname $cname
339            }
340            "grid*" {
341                ParseGrid $_path.components.$cname $cname
342            }
343            "text*" {
344                ParseText $_path.components.$cname $cname
345            }
346            "picture*" {
347                ParsePicture $_path.components.$cname $cname
348            }
349            "rectangle*" {
350                ParseRectangle $_path.components.$cname $cname
351            }
352            "oval*" {
353                ParseOval $_path.components.$cname $cname
354            }
355            "polygon*" {
356                ParsePolygon $_path.components.$cname $cname
357            }
358            "hotspot*" {
359                ParseHotspot $_path.components.$cname $cname
360            }
361        }
362    }
363}
364
365#
366# ParseGrid --
367#
368itcl::body Rappture::DrawingEntry::ParseGrid { cpath cname } {
369    array set attr2option {
370        "linewidth"     "-width"
371        "arrow"         "-arrow"
372        "dash"          "-dash"
373        "color"         "-fill"
374    }
375    # Set default options first and then let tool.xml override them.
376    array set options {
377        -arrow          none
378        -width          0
379        -fill           black
380        -dash           ""
381    }
382    # Coords
383    set xcoords [XmlGetSubst $cpath.xcoords]
384    set ycoords [XmlGetSubst $cpath.ycoords]
385    if { $ycoords == "" } {
386        set ycoords "0 1"
387        set ymax 1
388        set ymin 0
389    } else {
390        set list {}
391        set ymax -10000
392        set ymin 10000
393        foreach c $ycoords {
394            set y [ScreenY $c]
395            if { $y > $ymax } {
396                set ymax $y
397            }
398            if { $y < $ymin } {
399                set ymin $y
400            }
401            lappend list $y
402        }
403        set ycoords $list
404    }
405    if { $xcoords == "" } {
406        set xcoords "0 1"
407        set xmax 1
408        set xmin 0
409    } else {
410        set list {}
411        set xmax -10000
412        set xmin 10000
413        foreach c $xcoords {
414            set x [ScreenX $c]
415            if { $x > $xmax } {
416                set xmax $x
417            }
418            if { $x < $xmin } {
419                set xmin $x
420            }
421            lappend list $x
422        }
423        set xcoords $list
424    }
425
426    set list {}
427    foreach attr [$_xmlobj children $cpath] {
428        if { [info exists attr2option($attr)] } {
429            set option $attr2option($attr)
430            set value [XmlGetSubst $cpath.$attr]
431            set options($option) $value
432        }
433    }
434    set options(-tags) $cname
435    foreach y $ycoords {
436        lappend ids \
437            [eval $itk_component(drawing) create line $xmin $y $xmax $y \
438                 [array get options]]
439    }
440    foreach x $xcoords {
441        lappend ids \
442            [eval $itk_component(drawing) create line $x $ymin $x $ymax \
443                 [array get options]]
444    }
445    set _cname2id($cname) $ids
446}
447
448#
449# ParseHotspot --
450#
451itcl::body Rappture::DrawingEntry::ParseHotspot { cpath cname } {
452    array set attr2option {
453        "color" "-fill"
454        "anchor" "-anchor"
455    }
456
457    # Set default options first and then let tool.xml override them.
458    array set options {
459        -fill red
460        -anchor c
461    }
462    foreach attr [$_xmlobj children $cpath] {
463        if { [info exists attr2option($attr)] } {
464            set option $attr2option($attr)
465            set value [XmlGetSubst $cpath.$attr]
466            set options($option) $value
467        }
468    }
469    # Coordinates
470    set coords [XmlGetSubst $cpath.coords]
471    if {$coords eq ""} {
472        set coords "0 0 1 1"
473    }
474    set c $itk_component(drawing)
475    foreach {x1 y1} [ScreenCoords $coords] break
476    set id [$itk_component(drawing) create image $x1 $y1]
477    array unset options -fill
478    set options(-tags) $cname
479    set options(-image) [Rappture::icon hotspot_normal]
480    eval $c itemconfigure $id [array get options]
481    set _cname2id($cname) $id
482    $c bind $id <Enter> [itcl::code $this Activate $cname]
483    $c bind $id <Leave> [itcl::code $this Deactivate $cname]
484    set bbox [$c bbox $id]
485    set y1 [lindex $bbox 1]
486    $c bind $id <ButtonPress-1> [itcl::code $this Invoke $cpath $x1 $y1]
487}
488
489#
490# ParseLine --
491#
492itcl::body Rappture::DrawingEntry::ParseLine { cpath cname } {
493    array set attr2option {
494        "linewidth"     "-width"
495        "arrow"         "-arrow"
496        "dash"          "-dash"
497        "color"         "-fill"
498    }
499    # Set default options first and then let tool.xml override them.
500    array set options {
501        -arrow          none
502        -width          0
503        -fill           black
504        -dash           ""
505    }
506    # Coords
507    set coords [XmlGetSubst $cpath.coords]
508    if {$coords eq ""} {
509        set coords "0 0"
510    }
511    set coords [ScreenCoords $coords]
512
513    set list {}
514    foreach attr [$_xmlobj children $cpath] {
515        if { [info exists attr2option($attr)] } {
516            set option $attr2option($attr)
517            set value [XmlGetSubst $cpath.$attr]
518            set options($option) $value
519        }
520    }
521    set options(-tags) $cname
522    set id [eval $itk_component(drawing) create line $coords]
523    set _cname2id($cname) $id
524    eval $itk_component(drawing) itemconfigure $id [array get options]
525}
526
527#
528# ParseOval --
529#
530itcl::body Rappture::DrawingEntry::ParseOval { cpath cname } {
531    array set attr2option {
532        "outline"       "-outline"
533        "fill"          "-fill"
534        "linewidth"     "-width"
535    }
536
537    # Set default options first and then let tool.xml override them.
538    array set options {
539        -fill blue
540        -width 1
541        -outline black
542    }
543    foreach attr [$_xmlobj children $cpath] {
544        if { [info exists attr2option($attr)] } {
545            set option $attr2option($attr)
546            set value [XmlGetSubst $cpath.$attr]
547            set options($option) $value
548        }
549    }
550    # Coordinates
551    set coords [XmlGetSubst $cpath.coords]
552    if {$coords eq ""} {
553        set coords "0 0 1 1"
554    }
555    foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
556    set id [$itk_component(drawing) create oval $x1 $y1 $x2 $y2]
557    set _cname2id($cname) $id
558    eval $itk_component(drawing) itemconfigure $id [array get options]
559}
560
561#
562# ParsePicture --
563#
564itcl::body Rappture::DrawingEntry::ParsePicture { cpath cname } {
565    array set attr2option {
566        "anchor"        "-anchor"
567    }
568
569    # Set default options first and then let tool.xml override them.
570    array set options {
571        -anchor nw
572    }
573    foreach attr [$_xmlobj children $cpath] {
574        if { [info exists attr2option($attr)] } {
575            set option $attr2option($attr)
576            set value [XmlGetSubst $cpath.$attr]
577            set options($option) $value
578        }
579    }
580    set contents [XmlGetSubst $cpath.contents]
581    set img ""
582    if { [string compare -length 7 $contents "file://"] == 0 } {
583        set fileName [string range $contents 7 end]
584        if { [file exists $fileName] } {
585            set img [image create photo -file $fileName]
586        } else {
587            puts stderr "WARNING: can't find picture contents \"$fileName\""
588        }
589    } elseif { [string compare -length 7 $contents "http://"] == 0 } {
590        puts stderr  "don't know how to handle http"
591        return
592    } else {
593        set img [image create photo -data $contents]
594    }
595    if {$img eq ""} {
596        return
597    }
598    # Coordinates
599    set coords [XmlGetSubst $cpath.coords]
600    if { [llength $coords] == 2 } {
601        foreach { x1 y1 } [ScreenCoords $coords] break
602        set w [XmlGetSubst $cpath.width]
603        if { $w == "" || ![string is number $w] || $w <= 0.0 } {
604            set width [expr [image width $img] / 4]
605        } else {
606            set width [expr [ScreenX $w] - [ScreenX 0]]
607        }
608        set h [XmlGetSubst $cpath.height]
609        if { $h == "" || ![string is number $h] || $h <= 0.0 } {
610            set height [expr [image height $img] / 4]
611        } else {
612            set height [expr [ScreenY $h] - [ScreenY 0]]
613        }
614        if { $width != [image width $img] || $height != [image height $img] } {
615            set dst [image create photo -width $width -height $height]
616            blt::winop resample $img $dst
617            image delete $img
618            set img $dst
619        }
620    } elseif { [llength $coords] == 4 } {
621        foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
622        if { $x1 > $x2 } {
623            set tmp $x1
624            set x1 $x2
625            set x2 $tmp
626        }
627        if { $y1 > $y2 } {
628            set tmp $x1
629            set x1 $x2
630            set x2 $tmp
631        }
632        set width [expr {$x2 - $x1 + 1}]
633        set height [expr {$y2 - $y1 + 1}]
634        if { $width != [image width $img] || $height != [image height $img] } {
635            set dst [image create photo -width $width -height $height]
636            blt::winop resample $img $dst
637            image delete $img
638            set img $dst
639        }
640    } else {
641        set width [expr [image width $img] / 4]
642        set height [expr [image height $img] / 4]
643        set dst [image create photo -width $width -height $height]
644        blt::winop resample $img $dst
645        image delete $img
646        set img $dst
647        set x1 0
648        set y1 0
649    }
650    set options(-tags) $cname
651    set options(-image) $img
652    set id [$itk_component(drawing) create image $x1 $y1]
653    set _cname2image($cname) $img
654    set _cname2id($cname) $id
655    eval $itk_component(drawing) itemconfigure $id [array get options]
656}
657
658
659itcl::body Rappture::DrawingEntry::ParsePolygon { cpath cname } {
660    array set attr2option {
661        "linewidth"     "-width"
662        "color"         "-fill"
663    }
664    # Set default options first and then let tool.xml override them.
665    array set options {
666        -width          1
667        -fill           blue
668        -outline        black
669    }
670
671    # Coords
672    set coords [XmlGetSubst $cpath.coords]
673    if {$coords eq ""} {
674        set coords "0 0"
675    }
676    set coords [ScreenCoords $coords]
677
678    set list {}
679    foreach attr [$_xmlobj children $cpath] {
680        if { [info exists attr2option($attr)] } {
681            set option $attr2option($attr)
682            set value [XmlGetSubst $cpath.$attr]
683            set options($option) $value
684        }
685    }
686    set options(-tags) $cname
687    set id [eval $itk_component(drawing) create polygon $coords]
688    set _cname2id($cname) $id
689    eval $itk_component(drawing) itemconfigure $id [array get options]
690}
691
692#
693# ParseRectangle --
694#
695itcl::body Rappture::DrawingEntry::ParseRectangle { cpath cname } {
696    array set attr2option {
697        "outline"       "-outline"
698        "fill"          "-fill"
699        "linewidth"     "-width"
700    }
701
702    # Set default options first and then let tool.xml override them.
703    array set options {
704        -fill blue
705        -width 1
706        -outline black
707    }
708    foreach attr [$_xmlobj children $cpath] {
709        if { [info exists attr2option($attr)] } {
710            set option $attr2option($attr)
711            set value [XmlGetSubst $cpath.$attr]
712            set options($option) $value
713        }
714    }
715    # Coordinates
716    set coords [XmlGetSubst $cpath.coords]
717    if {$coords eq ""} {
718        set coords "0 0 1 1"
719    }
720    foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
721    set id [$itk_component(drawing) create rectangle $x1 $y1 $x2 $y2]
722    set _cname2id($cname) $id
723    eval $itk_component(drawing) itemconfigure $id [array get options]
724}
725
726#
727# ParseText --
728#
729itcl::body Rappture::DrawingEntry::ParseText { cpath cname } {
730    array set attr2option {
731        "font"          "-font"
732        "color"         "-foreground"
733        "valuecolor"    "-valueforeground"
734        "text"          "-text"
735        "anchor"        "-anchor"
736    }
737
738    # Set default options first and then let tool.xml override them.
739    array set options {
740        -font {Arial -14}
741        -valuefont {Arial -14}
742        -valueforeground blue3
743        -text {}
744        -fill {}
745        -anchor c
746    }
747    foreach attr [$_xmlobj children $cpath] {
748        if { [info exists attr2option($attr)] } {
749            set option $attr2option($attr)
750            if { $attr == "text" } {
751                set value [XmlGet $cpath.$attr]
752            } else {
753                set value [XmlGetSubst $cpath.$attr]
754            }
755            set options($option) $value
756        }
757    }
758    # Coords
759    set coords [XmlGetSubst $cpath.coords]
760    if {$coords eq ""} {
761        set coords "0 0"
762    }
763    foreach {x0 y0} [ScreenCoords $coords] break
764
765    set hotspot [XmlGetSubst $cpath.hotspot]
766    if {$hotspot eq ""} {
767        # assume inline by default
768        set hotspot "inline"
769    } elseif {[lsearch {inline off} $hotspot] < 0} {
770        puts stderr "WARNING: bad hotspot value \"$hotspot\": should be inline or off"
771    }
772
773    if {$hotspot eq "inline"} {
774        set options(-showicons) 1
775    }
776    set c $itk_component(drawing)
777    set options(-tags) $cname
778    set options(-image) [Rappture::icon hotspot_normal]
779    set options(-activeimage) [Rappture::icon hotspot_active]
780    set id [$c create hotspot $x0 $y0]
781    set _cname2id($cname) $id
782    set options(-interp) $_parser
783    eval $c itemconfigure $id [array get options]
784
785    if {$hotspot eq "inline"} {
786        $c bind $id <Enter> \
787            [itcl::code $this Hotspot activate $cname $id %x %y]
788        $c bind $id <Motion> \
789            [itcl::code $this Hotspot activate $cname $id %x %y]
790        $c bind $id <Leave> \
791            [itcl::code $this Hotspot deactivate $cname $id]
792        $c bind $id <ButtonRelease-1> \
793            [itcl::code $this Hotspot invoke $cname $id %x %y]
794    }
795}
796
797
798itcl::body Rappture::DrawingEntry::Hotspot { option cname item args } {
799    set c $itk_component(drawing)
800
801    # see what variable (if any) that we're touching within the text
802    set varName ""
803    if {[llength $args] >= 2} {
804        foreach {x y} $args break
805        foreach {varName x0 y0 x1 y1} [Rappture::hotspot identify $c $item $x $y] break
806    }
807
808    switch -- $option {
809        activate {
810            if {$varName ne ""} {
811                set active [$c itemcget $item -activevalue]
812                if {$varName ne $active} {
813                    $c itemconfigure $item -activevalue $varName
814                }
815                $itk_component(drawing) configure -cursor center_ptr
816
817                # put up a tooltip for this item
818                set cpath $_name2path($varName)
819                set tip [XmlGet $cpath.about.description]
820                if {$tip ne ""} {
821                    set x [expr {[winfo rootx $c]+$x0+10}]
822                    set y [expr {[winfo rooty $c]+$y1}]
823                    set tag "$c-[string map {. ""} $cpath]"
824                    Rappture::Tooltip::text $tag $tip -log $cpath
825                    Rappture::Tooltip::tooltip pending $tag @$x,$y
826                }
827            } else {
828                $c itemconfigure $item -activevalue ""
829                $itk_component(drawing) configure -cursor ""
830                Rappture::Tooltip::tooltip cancel
831            }
832        }
833        deactivate {
834            $c itemconfigure $item -activevalue ""
835            $itk_component(drawing) configure -cursor ""
836            Rappture::Tooltip::tooltip cancel
837        }
838        invoke {
839            if {$varName ne ""} {
840                set x [expr {($x0+$x1)/2}]
841                Invoke $_name2path($varName) $x $y0
842            }
843        }
844        default {
845            error "bad option \"$option\": should be activate, deactivate, invoke"
846        }
847    }
848}
849
850
851itcl::body Rappture::DrawingEntry::ScreenX { x } {
852    set norm [expr {($x - $_xMin) * $_xScale}]
853    set x [expr {int($norm * $_drawingWidth) + $_xOffset}]
854    return $x
855}
856
857itcl::body Rappture::DrawingEntry::ScreenY { y } {
858    set norm [expr {($y - $_yMin) * $_yScale}]
859    set y [expr {int($norm * $_drawingHeight) + $_yOffset}]
860    return $y
861}
862
863itcl::body Rappture::DrawingEntry::ScreenCoords { coords } {
864    set list {}
865    foreach {x y} $coords {
866        lappend list [ScreenX $x] [ScreenY $y]
867    }
868    return $list
869}
870
871itcl::body Rappture::DrawingEntry::AdjustDrawingArea { xAspect yAspect } {
872    set _drawingWidth $_canvasWidth
873    set _drawingHeight $_canvasHeight
874    if { $xAspect <= 0 || $yAspect <= 0 } {
875        return
876    }
877    set current [expr double($_canvasWidth) / double($_canvasHeight)]
878    set wanted [expr double($xAspect) / double($yAspect)]
879    if { $current > $wanted } {
880        set sw [ expr int($_canvasWidth * $wanted)]
881        if { $sw < 1 } {
882            set sw 1
883        }
884        set _xOffset [expr $_canvasWidth - $sw]
885        set _drawingWidth $sw
886    } else {
887        set sh [expr int($_canvasHeight / $wanted)]
888        if { $sh < 1 }  {
889            set sh 1
890        }
891        set _xOffset [expr $_canvasHeight - $sh]
892        set _drawingHeight $sh
893    }
894}
895
896#
897#      <background>
898#       <!-- background color of the drawing canvas (default white) -->
899#       <color>black</color>
900#       <!-- coordinate system:  x0 y0 ?at screenx screeny? x1 y1
901#                               ?at screenx screeny?
902#            The screenx/screeny values are optional, so you can also say
903#          something like "-.1 0 1.1 1" as you had in your example.
904#          This lets you put the origin at a specific point on screen,
905#          and also define the directions of the axes.  We still compute
906#          the overall bounding box.  In the example below, the bounding
907#          box goes from -1,1 in the upper-left corner to 1,-1 in the
908#          lower right.
909#       -->
910#       <coordinates>0 0 at 50% 50% 1 1 at 100% 100%</coordinates>
911
912#       <!-- aspect ratio:  scales coordinate system so that pixels may not
913#            be square.  A coordinate system like the one above implies a
914#          square drawing area, since x and y both go from -1 to 1.  But
915#          if you set the aspect to 2:1, you'll get something twice as
916#          wide as it is tall.  This effectively says that x goes from
917#          -1 to 1 in a certain distance, but y goes from -1 to 1 in half
918#          that screen distance.  Default is whatever aspect is defined
919#          by the coordinates.  If x goes 0-3 and y goes 0-1, then the
920#          drawing (without any other aspect ratio) would be 3x wide and
921#          1x tall.  The aspect ratio could be used to force it to be
922#          square instead by setting "1 1" instead.  In that case, x goes
923#          0-3 over the width, and y goes 0-1 over the same screen distance
924#          along the height.
925#       -->
926#       <aspect>2 1</aspect>
927#     </background>
928#
929
930itcl::body Rappture::DrawingEntry::ParseScreenCoordinates { values } {
931    set len [llength $values]
932    if { $len == 4 } {
933        if { [scan $values "%g %g %g %g" x1 y1 x2 y2] != 4 } {
934            error "bad coordinates specification \"$values\""
935        }
936        set _xScale [expr 1.0 / ($x2 - $x1)]
937        set _yScale [expr 1.0 / ($y2 - $y1)]
938        set _xMin $x1
939        set _yMin $y1
940    } elseif { $len == 10 } {
941        if { [scan $values "%g %g %s %d%% %d%% %g %g %s %d%% %d%%" \
942                  sx1 sy1 at1 x1 y1 sx2 sy2 at2 x2 y2] != 10 } {
943            error "bad coordinates specification \"$values\""
944        }
945        if { $at1 != "at" || $at2 != "at" } {
946            error "bad coordinates specification \"$values\""
947        }           
948        set x1 [expr $x1 / 100.0]
949        set x2 [expr $x2 / 100.0]
950        set y1 [expr $y1 / 100.0]
951        set y2 [expr $y2 / 100.0]
952        set _xScale [expr ($sx2 - $sx1) / ($x2 - $x1)]
953        set _yScale [expr ($sy2 - $sy2) / ($y2 - $y2)]
954        set _xMin $x1
955        set _yMin $y1
956    }
957}
958
959itcl::body Rappture::DrawingEntry::ParseBackground {} {
960    foreach elem [$_xmlobj children $_path.background] {
961        switch -glob -- $elem {
962            "color*" {
963                #  Background color of the drawing canvas (default white)
964                set value [XmlGet $_path.background.$elem]
965                $itk_component(drawing) configure -background $value
966            }
967            "aspect*" {
968                set value [XmlGet $_path.background.$elem]
969                foreach { xAspect yAspect } $value break
970                AdjustDrawingArea $xAspect $yAspect
971            }
972            "coordinates*" {
973                set value [XmlGet $_path.background.$elem]
974                ParseScreenCoordinates $value
975            }
976            "width*" {
977                set width [XmlGet $_path.background.$elem]
978                $itk_component(drawing) configure -width $width
979            }
980            "height*" {
981                set height [XmlGet $_path.background.$elem]
982                $itk_component(drawing) configure -height $height
983            }
984        }
985    }
986}
987
988#
989# Invoke --
990#
991itcl::body Rappture::DrawingEntry::Invoke {cpath x y} {
992    if {![info exists _cpath2popup($cpath)]} {
993        error "internal error: no controls for hotspot at $cpath"
994    }
995    set popup $_cpath2popup($cpath)
996
997    # if this popup has only one control, watch for it to change and
998    # take it down automatically
999    set inner [$popup component inner]
1000    set n [expr {[$inner.controls index end]+1}]
1001    if {$n == 1} {
1002        set _takedown $popup
1003    } else {
1004        set _takedown ""
1005    }
1006
1007    # Activate the popup and call for the output.
1008    incr x [winfo rootx $itk_component(drawing)]
1009    incr y [winfo rooty $itk_component(drawing)]
1010    $popup activate @$x,$y above
1011}
1012
1013#
1014# Activate --
1015#
1016itcl::body Rappture::DrawingEntry::Activate { cname } {
1017    $itk_component(drawing) configure -cursor center_ptr
1018    $itk_component(drawing) itemconfigure $_cname2id($cname) \
1019        -image [Rappture::icon hotspot_active]
1020}
1021
1022#
1023# Deactivate --
1024#
1025itcl::body Rappture::DrawingEntry::Deactivate { cname } {
1026    $itk_component(drawing) configure -cursor ""
1027    $itk_component(drawing) itemconfigure $_cname2id($cname) \
1028        -image [Rappture::icon hotspot_normal]
1029}
1030
1031# ----------------------------------------------------------------------
1032# USAGE: value ?-check? ?<newval>?
1033#
1034# Clients use this to query/set the value for this widget.  With
1035# no args, it returns the current value for the widget.  If the
1036# <newval> is specified, it sets the value of the widget and
1037# sends a <<Value>> event.  If the -check flag is included, the
1038# new value is not actually applied, but just checked for correctness.
1039# ----------------------------------------------------------------------
1040itcl::body Rappture::DrawingEntry::value {args} {
1041    # Redraw if there's a new library object.
1042    if { [llength $args] > 0 } {
1043        set libobj [lindex $args 0]
1044        if { $libobj != "" } {
1045            $_dispatcher event -idle !redraw
1046        }
1047    }
1048    return ""
1049}
1050
1051itcl::body Rappture::DrawingEntry::UpdateSubstitutions {} {
1052    # Load parser with the variables representing the substitution
1053    foreach name [array names _name2path] {
1054        set path $_name2path($name)
1055        set w [$_owner widgetfor $path]
1056        if {$w ne ""} {
1057            set value [$w value]
1058        } else {
1059            set value ""
1060        }
1061        if {$_name2map($name) ne ""} {
1062            set value [string map $_name2map($name) $value]
1063        }
1064        $_parser eval [list set $name $value]
1065    }
1066}
1067
1068itcl::body Rappture::DrawingEntry::XmlGet { path } {
1069    set value [$_xmlobj get $path]
1070    return [string trim $value]
1071}
1072
1073itcl::body Rappture::DrawingEntry::XmlGetSubst { path } {
1074    set value [$_xmlobj get $path]
1075    if {$_parser == ""} {
1076        return [string trim $value]
1077    }
1078    return [string trim [$_parser eval [list subst -nocommands $value]]]
1079}
Note: See TracBrowser for help on using the repository browser.