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

Last change on this file since 4344 was 4176, checked in by gah, 10 years ago

typos
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 substituion 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        "linewidth"     "-width"
675        "color"         "-fill"
676    }
677    # Set default options first and then let tool.xml override them.
678    array set options {
679        -width          1
680        -fill           blue
681        -outline        black
682    }
683
684    # Coords
685    set coords [XmlGetSubst $cpath.coords]
686    if {$coords eq ""} {
687        set coords "0 0"
688    }
689    set coords [ScreenCoords $coords]
690
691    set list {}
692    foreach attr [$_xmlobj children $cpath] {
693        if { [info exists attr2option($attr)] } {
694            set option $attr2option($attr)
695            set value [XmlGetSubst $cpath.$attr]
696            set options($option) $value
697        }
698    }
699    set options(-tags) $cname
700    set id [eval $itk_component(drawing) create polygon $coords]
701    set _cname2id($cname) $id
702    eval $itk_component(drawing) itemconfigure $id [array get options]
703}
704
705#
706# ParseRectangle --
707#
708itcl::body Rappture::DrawingEntry::ParseRectangle { cpath cname } {
709    array set attr2option {
710        "outline"       "-outline"
711        "fill"          "-fill"
712        "linewidth"     "-width"
713    }
714
715    # Set default options first and then let tool.xml override them.
716    array set options {
717        -fill blue
718        -width 1
719        -outline black
720    }
721    foreach attr [$_xmlobj children $cpath] {
722        if { [info exists attr2option($attr)] } {
723            set option $attr2option($attr)
724            set value [XmlGetSubst $cpath.$attr]
725            set options($option) $value
726        }
727    }
728    # Coordinates
729    set coords [XmlGetSubst $cpath.coords]
730    if {$coords eq ""} {
731        set coords "0 0 1 1"
732    }
733    foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
734    set id [$itk_component(drawing) create rectangle $x1 $y1 $x2 $y2]
735    set _cname2id($cname) $id
736    eval $itk_component(drawing) itemconfigure $id [array get options]
737}
738
739#
740# ParseText --
741#
742itcl::body Rappture::DrawingEntry::ParseText { cpath cname } {
743    array set attr2option {
744        "font"          "-font"
745        "color"         "-foreground"
746        "valuecolor"    "-valueforeground"
747        "fill"          "-background"
748        "text"          "-text"
749        "anchor"        "-anchor"
750    }
751
752    # Set default options first and then let tool.xml override them.
753    array set options {
754        -font {Arial -14}
755        -valuefont {Arial -14}
756        -valueforeground blue3
757        -text {}
758        -fill {}
759        -anchor c
760    }
761    foreach attr [$_xmlobj children $cpath] {
762        if { [info exists attr2option($attr)] } {
763            set option $attr2option($attr)
764            if { $attr == "text" } {
765                set value [XmlGet $cpath.$attr]
766            } else {
767                set value [XmlGetSubst $cpath.$attr]
768            }
769            set options($option) $value
770        }
771    }
772    # Coords
773    set coords [XmlGetSubst $cpath.coords]
774    if {$coords eq ""} {
775        set coords "0 0"
776    }
777    foreach {x0 y0} [ScreenCoords $coords] break
778
779    set hotspot [XmlGetSubst $cpath.hotspot]
780    if {$hotspot eq ""} {
781        # assume inline by default
782        set hotspot "inline"
783    } elseif {[lsearch {inline off} $hotspot] < 0} {
784        puts stderr "WARNING: bad hotspot value \"$hotspot\": should be inline or off"
785    }
786
787    if {$hotspot eq "inline"} {
788        set options(-showicons) 1
789    }
790    set c $itk_component(drawing)
791    set options(-tags) $cname
792    set options(-image) [Rappture::icon hotspot_normal]
793    set options(-activeimage) [Rappture::icon hotspot_active]
794    set id [$c create hotspot $x0 $y0]
795    set _cname2id($cname) $id
796    set options(-interp) $_parser
797    eval $c itemconfigure $id [array get options]
798
799    if {$hotspot eq "inline"} {
800        $c bind $id <Enter> \
801            [itcl::code $this Hotspot activate $cname $id %x %y]
802        $c bind $id <Motion> \
803            [itcl::code $this Hotspot activate $cname $id %x %y]
804        $c bind $id <Leave> \
805            [itcl::code $this Hotspot deactivate $cname $id]
806        $c bind $id <ButtonRelease-1> \
807            [itcl::code $this Hotspot invoke $cname $id %x %y]
808    }
809}
810
811
812itcl::body Rappture::DrawingEntry::Hotspot { option cname item args } {
813    set c $itk_component(drawing)
814
815    # see what variable (if any) that we're touching within the text
816    set varName ""
817    if {[llength $args] >= 2} {
818        foreach {x y} $args break
819        foreach {varName x0 y0 x1 y1} [Rappture::hotspot identify $c $item $x $y] break
820    }
821
822    switch -- $option {
823        activate {
824            if {$varName ne ""} {
825                set active [$c itemcget $item -activevalue]
826                if {$varName ne $active} {
827                    $c itemconfigure $item -activevalue $varName
828                }
829                $itk_component(drawing) configure -cursor center_ptr
830
831                # put up a tooltip for this item
832                set cpath $_name2path($varName)
833                set tip [XmlGet $cpath.about.description]
834                if {$tip ne ""} {
835                    set x [expr {[winfo rootx $c]+$x0+10}]
836                    set y [expr {[winfo rooty $c]+$y1}]
837                    set tag "$c-[string map {. ""} $cpath]"
838                    Rappture::Tooltip::text $tag $tip -log $cpath
839                    Rappture::Tooltip::tooltip pending $tag @$x,$y
840                }
841            } else {
842                $c itemconfigure $item -activevalue ""
843                $itk_component(drawing) configure -cursor ""
844                Rappture::Tooltip::tooltip cancel
845            }
846        }
847        deactivate {
848            $c itemconfigure $item -activevalue ""
849            $itk_component(drawing) configure -cursor ""
850            Rappture::Tooltip::tooltip cancel
851        }
852        invoke {
853            if {$varName ne ""} {
854                set x [expr {($x0+$x1)/2}]
855                Invoke $_name2path($varName) $x $y0
856            }
857        }
858        default {
859            error "bad option \"$option\": should be activate, deactivate, invoke"
860        }
861    }
862}
863
864
865itcl::body Rappture::DrawingEntry::ScreenX { x } {
866    return [expr {($x - $_xMin)*$_xScale + $_xOffset}]
867}
868
869itcl::body Rappture::DrawingEntry::ScreenY { y } {
870    return [expr {($y - $_yMin)*$_yScale + $_yOffset}]
871}
872
873itcl::body Rappture::DrawingEntry::ScreenCoords { coords } {
874    set list {}
875    foreach {x y} $coords {
876        lappend list [ScreenX $x] [ScreenY $y]
877    }
878    return $list
879}
880
881itcl::body Rappture::DrawingEntry::AdjustDrawingArea { xAspect yAspect } {
882    set _drawingWidth $_canvasWidth
883    set _drawingHeight $_canvasHeight
884    if { $xAspect <= 0 || $yAspect <= 0 } {
885        return
886    }
887    set current [expr double($_canvasWidth) / double($_canvasHeight)]
888    set wanted [expr double($xAspect) / double($yAspect)]
889    if { $current > $wanted } {
890        set sw [ expr int($_canvasWidth * $wanted)]
891        if { $sw < 1 } {
892            set sw 1
893        }
894        set _xOffset [expr $_canvasWidth - $sw]
895        set _drawingWidth $sw
896    } else {
897        set sh [expr int($_canvasHeight / $wanted)]
898        if { $sh < 1 }  {
899            set sh 1
900        }
901        set _xOffset [expr $_canvasHeight - $sh]
902        set _drawingHeight $sh
903    }
904}
905
906#
907#      <background>
908#       <!-- background color of the drawing canvas (default white) -->
909#       <color>black</color>
910#       <!-- coordinate system:  x0 y0 ?at screenx screeny? x1 y1
911#                               ?at screenx screeny?
912#            The screenx/screeny values are optional, so you can also say
913#          something like "-.1 0 1.1 1" as you had in your example.
914#          This lets you put the origin at a specific point on screen,
915#          and also define the directions of the axes.  We still compute
916#          the overall bounding box.  In the example below, the bounding
917#          box goes from -1,1 in the upper-left corner to 1,-1 in the
918#          lower right.
919#       -->
920#       <coordinates>0 0 at 50% 50% 1 1 at 100% 100%</coordinates>
921
922#       <!-- aspect ratio:  scales coordinate system so that pixels may not
923#            be square.  A coordinate system like the one above implies a
924#          square drawing area, since x and y both go from -1 to 1.  But
925#          if you set the aspect to 2:1, you'll get something twice as
926#          wide as it is tall.  This effectively says that x goes from
927#          -1 to 1 in a certain distance, but y goes from -1 to 1 in half
928#          that screen distance.  Default is whatever aspect is defined
929#          by the coordinates.  If x goes 0-3 and y goes 0-1, then the
930#          drawing (without any other aspect ratio) would be 3x wide and
931#          1x tall.  The aspect ratio could be used to force it to be
932#          square instead by setting "1 1" instead.  In that case, x goes
933#          0-3 over the width, and y goes 0-1 over the same screen distance
934#          along the height.
935#       -->
936#       <aspect>2 1</aspect>
937#     </background>
938#
939
940itcl::body Rappture::DrawingEntry::ParseScreenCoordinates { values } {
941    set bad ""
942    foreach point {1 2} {
943        set xvals($point) [lindex $values 0]
944        if {![string is double -strict $xvals($point)]} {
945            set bad "missing background coordinate point $point in \"$values\""
946            break
947        }
948
949        set yvals($point) [lindex $values 1]
950        if {![string is double -strict $yvals($point)]} {
951            set bad "missing background coordinate point $point in \"$values\""
952            break
953        }
954        set values [lrange $values 2 end]
955
956        # each corner point can be place anywhere from 0% to 100%
957        if {[lindex $values 0] eq "at"} {
958            if {[regexp {^([0-9]+)%$} [lindex $values 1] match xpcnt]
959              && [regexp {^([0-9]+)%$} [lindex $values 2] match ypcnt]} {
960                set wherex($point) [expr {0.01*$xpcnt}]
961                set wherey($point) [expr {0.01*$ypcnt}]
962                set values [lrange $values 3 end]
963            } else {
964                set bad "expected \"at XX% YY%\" but got \"$values\""; break
965            }
966        } else {
967            set wherex($point) [expr {($point == 1) ? 0 : 1}]
968            set wherey($point) [expr {($point == 1) ? 0 : 1}]
969        }
970    }
971    if {$bad eq "" && $wherex(1) == $wherex(2)} {
972        set bad [format "drawing background limits have x points both at %d%%" [expr {round($wherex(1)*100)}]]
973    }
974    if {$bad eq "" && $wherey(1) == $wherey(2)} {
975        set bad [format "drawing background limits have y points both at %d%%" [expr {round($wherex(1)*100)}]]
976    }
977
978    if {$bad eq "" && $xvals(1) == $xvals(2)} {
979        set bad "drawing background coordinates have 0 range in x"
980    }
981    if {$bad eq "" && $yvals(1) == $yvals(2)} {
982        set bad "drawing background coordinates have 0 range in y"
983    }
984    if {$bad eq "" && [llength $values] > 0} {
985        set bad "extra coordinates \"$values\""
986    }
987
988    if {$bad ne ""} {
989        puts stderr "WARNING: $bad"
990        puts stderr "assuming default \"0 0 1 1\" coordinates"
991        array set xvals {1 0 2 1}
992        array set yvals {1 0 2 1}
993        array set wherex {1 0 2 1}
994        array set wherey {1 0 2 1}
995    }
996
997    # compute min/scale for each axis based on the input values
998    if {$wherex(1) < $wherex(2)} {
999        set min 1; set max 2
1000    } else {
1001        set min 2; set max 1
1002    }
1003
1004    set slope [expr {double($xvals($max)-$xvals($min))
1005                      / ($wherex($max)-$wherex($min))}]
1006    set _xMin [expr {-$wherex($min)*$slope + $xvals($min)}]
1007    set xmax [expr {(1-$wherex($max))*$slope + $xvals($max)}]
1008    set _xScale [expr {[winfo width $itk_component(drawing)]/($xmax-$_xMin)}]
1009
1010    if {$wherey(1) < $wherey(2)} {
1011        set min 1; set max 2
1012    } else {
1013        set min 2; set max 1
1014    }
1015
1016    set slope [expr {double($yvals($max)-$yvals($min))
1017                      / ($wherey($max)-$wherey($min))}]
1018    set _yMin [expr {-$wherey($min)*$slope + $yvals($min)}]
1019    set ymax [expr {(1-$wherey($max))*$slope + $yvals($max)}]
1020    set _yScale [expr {[winfo height $itk_component(drawing)]/($ymax-$_yMin)}]
1021}
1022
1023itcl::body Rappture::DrawingEntry::ParseBackground {} {
1024    foreach elem [$_xmlobj children $_path.background] {
1025        switch -- $elem {
1026            "color" {
1027                #  Background color of the drawing canvas (default white)
1028                set value [XmlGet $_path.background.$elem]
1029                $itk_component(drawing) configure -background $value
1030            }
1031            "aspect" {
1032                set value [XmlGet $_path.background.$elem]
1033                foreach { xAspect yAspect } $value break
1034                AdjustDrawingArea $xAspect $yAspect
1035            }
1036            "coords" - "coordinates" {
1037                set value [XmlGet $_path.background.$elem]
1038                ParseScreenCoordinates $value
1039            }
1040            "width" {
1041                set width [XmlGet $_path.background.$elem]
1042                $itk_component(drawing) configure -width $width
1043            }
1044            "height" {
1045                set height [XmlGet $_path.background.$elem]
1046                $itk_component(drawing) configure -height $height
1047            }
1048            default {
1049                puts stderr "WARNING: don't understand \"$elem\" in $_path"
1050            }
1051        }
1052    }
1053}
1054
1055#
1056# Invoke --
1057#
1058itcl::body Rappture::DrawingEntry::Invoke {cpath x y} {
1059    if {![info exists _cpath2popup($cpath)]} {
1060        puts stderr "WARNING: no controls for hotspot at $cpath"
1061        return
1062    }
1063    set popup $_cpath2popup($cpath)
1064
1065    # if this popup has only one control, watch for it to change and
1066    # take it down automatically
1067    set inner [$popup component inner]
1068    set n [expr {[$inner.controls index end]+1}]
1069    if {$n == 1} {
1070        set _takedown $popup
1071    } else {
1072        set _takedown ""
1073    }
1074
1075    # Activate the popup and call for the output.
1076    set rootx [winfo rootx $itk_component(drawing)]
1077    set rooty [winfo rooty $itk_component(drawing)]
1078
1079    set x [expr {round($x + $rootx)}]
1080    set y [expr {round($y + $rooty)}]
1081    $popup activate @$x,$y above
1082}
1083
1084#
1085# Activate --
1086#
1087itcl::body Rappture::DrawingEntry::Activate { cname } {
1088    $itk_component(drawing) configure -cursor center_ptr
1089    $itk_component(drawing) itemconfigure $_cname2id($cname) \
1090        -image [Rappture::icon hotspot_active]
1091}
1092
1093#
1094# Deactivate --
1095#
1096itcl::body Rappture::DrawingEntry::Deactivate { cname } {
1097    $itk_component(drawing) configure -cursor ""
1098    $itk_component(drawing) itemconfigure $_cname2id($cname) \
1099        -image [Rappture::icon hotspot_normal]
1100}
1101
1102# ----------------------------------------------------------------------
1103# USAGE: value ?-check? ?<newval>?
1104#
1105# Clients use this to query/set the value for this widget.  With
1106# no args, it returns the current value for the widget.  If the
1107# <newval> is specified, it sets the value of the widget and
1108# sends a <<Value>> event.  If the -check flag is included, the
1109# new value is not actually applied, but just checked for correctness.
1110# ----------------------------------------------------------------------
1111itcl::body Rappture::DrawingEntry::value {args} {
1112    # Redraw if there's a new library object.
1113    if { [llength $args] > 0 } {
1114        set libobj [lindex $args 0]
1115        if { $libobj != "" } {
1116            $_dispatcher event -idle !redraw
1117        }
1118    }
1119    return ""
1120}
1121
1122itcl::body Rappture::DrawingEntry::UpdateSubstitutions {} {
1123    # Load parser with the variables representing the substitution
1124    foreach name [array names _name2path] {
1125        set path $_name2path($name)
1126        set w [$_owner widgetfor $path]
1127        if {$w ne ""} {
1128            set value [$w value]
1129        } else {
1130            set value ""
1131        }
1132        if {$_name2map($name) ne ""} {
1133            set value [string map $_name2map($name) $value]
1134        }
1135        $_parser eval [list set $name $value]
1136    }
1137}
1138
1139itcl::body Rappture::DrawingEntry::XmlGet { path } {
1140    set value [$_xmlobj get $path]
1141    return [string trim $value]
1142}
1143
1144itcl::body Rappture::DrawingEntry::XmlGetSubst { path } {
1145    set value [$_xmlobj get $path]
1146    if {$_parser == ""} {
1147        return [string trim $value]
1148    }
1149    return [string trim [$_parser eval [list subst -nocommands $value]]]
1150}
Note: See TracBrowser for help on using the repository browser.