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

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

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