source: branches/1.3/gui/scripts/drawingentry.tcl @ 4706

Last change on this file since 4706 was 4409, checked in by ldelgass, 10 years ago

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