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

Last change on this file since 3789 was 3741, checked in by gah, 11 years ago

fix Makefile
File size: 33.7 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 substituion 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    ParseDescription
326}
327
328#
329# ParseDescription --
330#
331itcl::body Rappture::DrawingEntry::ParseDescription {} {
332    ParseBackground
333    UpdateSubstitutions
334    foreach cname [$_xmlobj children $_path.components] {
335        switch -glob -- $cname {
336            "line*" {
337                ParseLine $_path.components.$cname $cname
338            }
339            "grid*" {
340                ParseGrid $_path.components.$cname $cname
341            }
342            "text*" {
343                ParseText $_path.components.$cname $cname
344            }
345            "picture*" {
346                ParsePicture $_path.components.$cname $cname
347            }
348            "rectangle*" {
349                ParseRectangle $_path.components.$cname $cname
350            }
351            "oval*" {
352                ParseOval $_path.components.$cname $cname
353            }
354            "polygon*" {
355                ParsePolygon $_path.components.$cname $cname
356            }
357            "hotspot*" {
358                ParseHotspot $_path.components.$cname $cname
359            }
360        }
361    }
362}
363
364#
365# ParseGrid --
366#
367itcl::body Rappture::DrawingEntry::ParseGrid { cpath cname } {
368    array set attr2option {
369        "linewidth"     "-width"
370        "arrow"         "-arrow"
371        "dash"          "-dash"
372        "color"         "-fill"
373    }
374    # Set default options first and then let tool.xml override them.
375    array set options {
376        -arrow          none
377        -width          0
378        -fill           black
379        -dash           ""
380    }
381    # Coords
382    set xcoords [XmlGetSubst $cpath.xcoords]
383    set ycoords [XmlGetSubst $cpath.ycoords]
384    if { $ycoords == "" } {
385        set ycoords "0 1"
386        set ymax 1
387        set ymin 0
388    } else {
389        set list {}
390        set ymax -10000
391        set ymin 10000
392        foreach c $ycoords {
393            set y [ScreenY $c]
394            if { $y > $ymax } {
395                set ymax $y
396            }
397            if { $y < $ymin } {
398                set ymin $y
399            }
400            lappend list $y
401        }
402        set ycoords $list
403    }
404    if { $xcoords == "" } {
405        set xcoords "0 1"
406        set xmax 1
407        set xmin 0
408    } else {
409        set list {}
410        set xmax -10000
411        set xmin 10000
412        foreach c $xcoords {
413            set x [ScreenX $c]
414            if { $x > $xmax } {
415                set xmax $x
416            }
417            if { $x < $xmin } {
418                set xmin $x
419            }
420            lappend list $x
421        }
422        set xcoords $list
423    }
424
425    set list {}
426    foreach attr [$_xmlobj children $cpath] {
427        if { [info exists attr2option($attr)] } {
428            set option $attr2option($attr)
429            set value [XmlGetSubst $cpath.$attr]
430            set options($option) $value
431        }
432    }
433    set options(-tags) $cname
434    foreach y $ycoords {
435        lappend ids \
436            [eval $itk_component(drawing) create line $xmin $y $xmax $y \
437                 [array get options]]
438    }
439    foreach x $xcoords {
440        lappend ids \
441            [eval $itk_component(drawing) create line $x $ymin $x $ymax \
442                 [array get options]]
443    }
444    set _cname2id($cname) $ids
445}
446
447#
448# ParseHotspot --
449#
450itcl::body Rappture::DrawingEntry::ParseHotspot { cpath cname } {
451    array set attr2option {
452        "color" "-fill"
453        "anchor" "-anchor"
454    }
455
456    # Set default options first and then let tool.xml override them.
457    array set options {
458        -fill red
459        -anchor c
460    }
461    foreach attr [$_xmlobj children $cpath] {
462        if { [info exists attr2option($attr)] } {
463            set option $attr2option($attr)
464            set value [XmlGetSubst $cpath.$attr]
465            set options($option) $value
466        }
467    }
468    # Coordinates
469    set coords [XmlGetSubst $cpath.coords]
470    if {$coords eq ""} {
471        set coords "0 0 1 1"
472    }
473    set c $itk_component(drawing)
474    foreach {x1 y1} [ScreenCoords $coords] break
475    set id [$itk_component(drawing) create image $x1 $y1]
476    array unset options -fill
477    set options(-tags) $cname
478    set options(-image) [Rappture::icon hotspot_normal]
479    eval $c itemconfigure $id [array get options]
480    set _cname2id($cname) $id
481    $c bind $id <Enter> [itcl::code $this Activate $cname]
482    $c bind $id <Leave> [itcl::code $this Deactivate $cname]
483    set bbox [$c bbox $id]
484    set y1 [lindex $bbox 1]
485    $c bind $id <ButtonPress-1> [itcl::code $this Invoke $cpath $x1 $y1]
486}
487
488#
489# ParseLine --
490#
491itcl::body Rappture::DrawingEntry::ParseLine { cpath cname } {
492    array set attr2option {
493        "linewidth"     "-width"
494        "arrow"         "-arrow"
495        "dash"          "-dash"
496        "color"         "-fill"
497    }
498    # Set default options first and then let tool.xml override them.
499    array set options {
500        -arrow          none
501        -width          0
502        -fill           black
503        -dash           ""
504    }
505    # Coords
506    set coords [XmlGetSubst $cpath.coords]
507    if {$coords eq ""} {
508        set coords "0 0"
509    }
510    set coords [ScreenCoords $coords]
511
512    set list {}
513    foreach attr [$_xmlobj children $cpath] {
514        if { [info exists attr2option($attr)] } {
515            set option $attr2option($attr)
516            set value [XmlGetSubst $cpath.$attr]
517            set options($option) $value
518        }
519    }
520    set options(-tags) $cname
521    set id [eval $itk_component(drawing) create line $coords]
522    set _cname2id($cname) $id
523    eval $itk_component(drawing) itemconfigure $id [array get options]
524}
525
526#
527# ParseOval --
528#
529itcl::body Rappture::DrawingEntry::ParseOval { cpath cname } {
530    array set attr2option {
531        "outline"       "-outline"
532        "fill"          "-fill"
533        "linewidth"     "-width"
534    }
535
536    # Set default options first and then let tool.xml override them.
537    array set options {
538        -fill blue
539        -width 1
540        -outline black
541    }
542    foreach attr [$_xmlobj children $cpath] {
543        if { [info exists attr2option($attr)] } {
544            set option $attr2option($attr)
545            set value [XmlGetSubst $cpath.$attr]
546            set options($option) $value
547        }
548    }
549    # Coordinates
550    set coords [XmlGetSubst $cpath.coords]
551    if {$coords eq ""} {
552        set coords "0 0 1 1"
553    }
554    foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
555    set id [$itk_component(drawing) create oval $x1 $y1 $x2 $y2]
556    set _cname2id($cname) $id
557    eval $itk_component(drawing) itemconfigure $id [array get options]
558}
559
560#
561# ParsePicture --
562#
563itcl::body Rappture::DrawingEntry::ParsePicture { cpath cname } {
564    array set attr2option {
565        "anchor"        "-anchor"
566    }
567
568    # Set default options first and then let tool.xml override them.
569    array set options {
570        -anchor nw
571    }
572    foreach attr [$_xmlobj children $cpath] {
573        if { [info exists attr2option($attr)] } {
574            set option $attr2option($attr)
575            set value [XmlGetSubst $cpath.$attr]
576            set options($option) $value
577        }
578    }
579    set contents [XmlGetSubst $cpath.contents]
580    set img ""
581    if { [string compare -length 7 $contents "file://"] == 0 } {
582        set fileName [string range $contents 7 end]
583        if { [file exists $fileName] } {
584            set img [image create photo -file $fileName]
585        } else {
586            puts stderr "WARNING: can't find picture contents \"$fileName\""
587        }
588    } elseif { [string compare -length 7 $contents "http://"] == 0 } {
589        puts stderr  "don't know how to handle http"
590        return
591    } else {
592        set img [image create photo -data $contents]
593    }
594    if {$img eq ""} {
595        return
596    }
597    # Coordinates
598    set coords [XmlGetSubst $cpath.coords]
599    if { [llength $coords] == 2 } {
600        foreach { x1 y1 } [ScreenCoords $coords] break
601        set w [XmlGetSubst $cpath.width]
602        if { $w == "" || ![string is double $w] || $w <= 0.0 } {
603            set width [expr [image width $img] / 4]
604        } else {
605            set width [expr int([ScreenX $w] - [ScreenX 0])]
606        }
607        set h [XmlGetSubst $cpath.height]
608        if { $h == "" || ![string is double $h] || $h <= 0.0 } {
609            set height [expr [image height $img] / 4]
610        } else {
611            set height [expr int([ScreenY $h] - [ScreenY 0])]
612        }
613        if { $width != [image width $img] || $height != [image height $img] } {
614            set dst [image create photo -width $width -height $height]
615            blt::winop resample $img $dst box
616            image delete $img
617            set img $dst
618        }
619    } elseif { [llength $coords] == 4 } {
620        foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
621        if { $x1 > $x2 } {
622            set tmp $x1
623            set x1 $x2
624            set x2 $tmp
625        }
626        if { $y1 > $y2 } {
627            set tmp $x1
628            set x1 $x2
629            set x2 $tmp
630        }
631        set width [expr {int($x2 - $x1 + 1)}]
632        set height [expr {int($y2 - $y1 + 1)}]
633        if { $width != [image width $img] || $height != [image height $img] } {
634            set dst [image create photo -width $width -height $height]
635            blt::winop resample $img $dst box
636            image delete $img
637            set img $dst
638        }
639    } else {
640        set width [expr [image width $img] / 4]
641        set height [expr [image height $img] / 4]
642        set dst [image create photo -width $width -height $height]
643        blt::winop resample $img $dst box
644        image delete $img
645        set img $dst
646        set x1 0
647        set y1 0
648    }
649    set options(-tags) $cname
650    set options(-image) $img
651    set id [$itk_component(drawing) create image $x1 $y1]
652    set _cname2image($cname) $img
653    set _cname2id($cname) $id
654    eval $itk_component(drawing) itemconfigure $id [array get options]
655}
656
657
658itcl::body Rappture::DrawingEntry::ParsePolygon { cpath cname } {
659    array set attr2option {
660        "linewidth"     "-width"
661        "color"         "-fill"
662    }
663    # Set default options first and then let tool.xml override them.
664    array set options {
665        -width          1
666        -fill           blue
667        -outline        black
668    }
669
670    # Coords
671    set coords [XmlGetSubst $cpath.coords]
672    if {$coords eq ""} {
673        set coords "0 0"
674    }
675    set coords [ScreenCoords $coords]
676
677    set list {}
678    foreach attr [$_xmlobj children $cpath] {
679        if { [info exists attr2option($attr)] } {
680            set option $attr2option($attr)
681            set value [XmlGetSubst $cpath.$attr]
682            set options($option) $value
683        }
684    }
685    set options(-tags) $cname
686    set id [eval $itk_component(drawing) create polygon $coords]
687    set _cname2id($cname) $id
688    eval $itk_component(drawing) itemconfigure $id [array get options]
689}
690
691#
692# ParseRectangle --
693#
694itcl::body Rappture::DrawingEntry::ParseRectangle { cpath cname } {
695    array set attr2option {
696        "outline"       "-outline"
697        "fill"          "-fill"
698        "linewidth"     "-width"
699    }
700
701    # Set default options first and then let tool.xml override them.
702    array set options {
703        -fill blue
704        -width 1
705        -outline black
706    }
707    foreach attr [$_xmlobj children $cpath] {
708        if { [info exists attr2option($attr)] } {
709            set option $attr2option($attr)
710            set value [XmlGetSubst $cpath.$attr]
711            set options($option) $value
712        }
713    }
714    # Coordinates
715    set coords [XmlGetSubst $cpath.coords]
716    if {$coords eq ""} {
717        set coords "0 0 1 1"
718    }
719    foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
720    set id [$itk_component(drawing) create rectangle $x1 $y1 $x2 $y2]
721    set _cname2id($cname) $id
722    eval $itk_component(drawing) itemconfigure $id [array get options]
723}
724
725#
726# ParseText --
727#
728itcl::body Rappture::DrawingEntry::ParseText { cpath cname } {
729    array set attr2option {
730        "font"          "-font"
731        "color"         "-foreground"
732        "valuecolor"    "-valueforeground"
733        "fill"          "-background"
734        "text"          "-text"
735        "anchor"        "-anchor"
736    }
737
738    # Set default options first and then let tool.xml override them.
739    array set options {
740        -font {Arial -14}
741        -valuefont {Arial -14}
742        -valueforeground blue3
743        -text {}
744        -fill {}
745        -anchor c
746    }
747    foreach attr [$_xmlobj children $cpath] {
748        if { [info exists attr2option($attr)] } {
749            set option $attr2option($attr)
750            if { $attr == "text" } {
751                set value [XmlGet $cpath.$attr]
752            } else {
753                set value [XmlGetSubst $cpath.$attr]
754            }
755            set options($option) $value
756        }
757    }
758    # Coords
759    set coords [XmlGetSubst $cpath.coords]
760    if {$coords eq ""} {
761        set coords "0 0"
762    }
763    foreach {x0 y0} [ScreenCoords $coords] break
764
765    set hotspot [XmlGetSubst $cpath.hotspot]
766    if {$hotspot eq ""} {
767        # assume inline by default
768        set hotspot "inline"
769    } elseif {[lsearch {inline off} $hotspot] < 0} {
770        puts stderr "WARNING: bad hotspot value \"$hotspot\": should be inline or off"
771    }
772
773    if {$hotspot eq "inline"} {
774        set options(-showicons) 1
775    }
776    set c $itk_component(drawing)
777    set options(-tags) $cname
778    set options(-image) [Rappture::icon hotspot_normal]
779    set options(-activeimage) [Rappture::icon hotspot_active]
780    set id [$c create hotspot $x0 $y0]
781    set _cname2id($cname) $id
782    set options(-interp) $_parser
783    eval $c itemconfigure $id [array get options]
784
785    if {$hotspot eq "inline"} {
786        $c bind $id <Enter> \
787            [itcl::code $this Hotspot activate $cname $id %x %y]
788        $c bind $id <Motion> \
789            [itcl::code $this Hotspot activate $cname $id %x %y]
790        $c bind $id <Leave> \
791            [itcl::code $this Hotspot deactivate $cname $id]
792        $c bind $id <ButtonRelease-1> \
793            [itcl::code $this Hotspot invoke $cname $id %x %y]
794    }
795}
796
797
798itcl::body Rappture::DrawingEntry::Hotspot { option cname item args } {
799    set c $itk_component(drawing)
800
801    # see what variable (if any) that we're touching within the text
802    set varName ""
803    if {[llength $args] >= 2} {
804        foreach {x y} $args break
805        foreach {varName x0 y0 x1 y1} [Rappture::hotspot identify $c $item $x $y] break
806    }
807
808    switch -- $option {
809        activate {
810            if {$varName ne ""} {
811                set active [$c itemcget $item -activevalue]
812                if {$varName ne $active} {
813                    $c itemconfigure $item -activevalue $varName
814                }
815                $itk_component(drawing) configure -cursor center_ptr
816
817                # put up a tooltip for this item
818                set cpath $_name2path($varName)
819                set tip [XmlGet $cpath.about.description]
820                if {$tip ne ""} {
821                    set x [expr {[winfo rootx $c]+$x0+10}]
822                    set y [expr {[winfo rooty $c]+$y1}]
823                    set tag "$c-[string map {. ""} $cpath]"
824                    Rappture::Tooltip::text $tag $tip -log $cpath
825                    Rappture::Tooltip::tooltip pending $tag @$x,$y
826                }
827            } else {
828                $c itemconfigure $item -activevalue ""
829                $itk_component(drawing) configure -cursor ""
830                Rappture::Tooltip::tooltip cancel
831            }
832        }
833        deactivate {
834            $c itemconfigure $item -activevalue ""
835            $itk_component(drawing) configure -cursor ""
836            Rappture::Tooltip::tooltip cancel
837        }
838        invoke {
839            if {$varName ne ""} {
840                set x [expr {($x0+$x1)/2}]
841                Invoke $_name2path($varName) $x $y0
842            }
843        }
844        default {
845            error "bad option \"$option\": should be activate, deactivate, invoke"
846        }
847    }
848}
849
850
851itcl::body Rappture::DrawingEntry::ScreenX { x } {
852    return [expr {($x - $_xMin)*$_xScale + $_xOffset}]
853}
854
855itcl::body Rappture::DrawingEntry::ScreenY { y } {
856    return [expr {($y - $_yMin)*$_yScale + $_yOffset}]
857}
858
859itcl::body Rappture::DrawingEntry::ScreenCoords { coords } {
860    set list {}
861    foreach {x y} $coords {
862        lappend list [ScreenX $x] [ScreenY $y]
863    }
864    return $list
865}
866
867itcl::body Rappture::DrawingEntry::AdjustDrawingArea { xAspect yAspect } {
868    set _drawingWidth $_canvasWidth
869    set _drawingHeight $_canvasHeight
870    if { $xAspect <= 0 || $yAspect <= 0 } {
871        return
872    }
873    set current [expr double($_canvasWidth) / double($_canvasHeight)]
874    set wanted [expr double($xAspect) / double($yAspect)]
875    if { $current > $wanted } {
876        set sw [ expr int($_canvasWidth * $wanted)]
877        if { $sw < 1 } {
878            set sw 1
879        }
880        set _xOffset [expr $_canvasWidth - $sw]
881        set _drawingWidth $sw
882    } else {
883        set sh [expr int($_canvasHeight / $wanted)]
884        if { $sh < 1 }  {
885            set sh 1
886        }
887        set _xOffset [expr $_canvasHeight - $sh]
888        set _drawingHeight $sh
889    }
890}
891
892#
893#      <background>
894#       <!-- background color of the drawing canvas (default white) -->
895#       <color>black</color>
896#       <!-- coordinate system:  x0 y0 ?at screenx screeny? x1 y1
897#                               ?at screenx screeny?
898#            The screenx/screeny values are optional, so you can also say
899#          something like "-.1 0 1.1 1" as you had in your example.
900#          This lets you put the origin at a specific point on screen,
901#          and also define the directions of the axes.  We still compute
902#          the overall bounding box.  In the example below, the bounding
903#          box goes from -1,1 in the upper-left corner to 1,-1 in the
904#          lower right.
905#       -->
906#       <coordinates>0 0 at 50% 50% 1 1 at 100% 100%</coordinates>
907
908#       <!-- aspect ratio:  scales coordinate system so that pixels may not
909#            be square.  A coordinate system like the one above implies a
910#          square drawing area, since x and y both go from -1 to 1.  But
911#          if you set the aspect to 2:1, you'll get something twice as
912#          wide as it is tall.  This effectively says that x goes from
913#          -1 to 1 in a certain distance, but y goes from -1 to 1 in half
914#          that screen distance.  Default is whatever aspect is defined
915#          by the coordinates.  If x goes 0-3 and y goes 0-1, then the
916#          drawing (without any other aspect ratio) would be 3x wide and
917#          1x tall.  The aspect ratio could be used to force it to be
918#          square instead by setting "1 1" instead.  In that case, x goes
919#          0-3 over the width, and y goes 0-1 over the same screen distance
920#          along the height.
921#       -->
922#       <aspect>2 1</aspect>
923#     </background>
924#
925
926itcl::body Rappture::DrawingEntry::ParseScreenCoordinates { values } {
927    set bad ""
928    foreach point {1 2} {
929        set xvals($point) [lindex $values 0]
930        if {![string is double -strict $xvals($point)]} {
931            set bad "missing background coordinate point $point in \"$values\""
932            break
933        }
934
935        set yvals($point) [lindex $values 1]
936        if {![string is double -strict $yvals($point)]} {
937            set bad "missing background coordinate point $point in \"$values\""
938            break
939        }
940        set values [lrange $values 2 end]
941
942        # each corner point can be place anywhere from 0% to 100%
943        if {[lindex $values 0] eq "at"} {
944            if {[regexp {^([0-9]+)%$} [lindex $values 1] match xpcnt]
945              && [regexp {^([0-9]+)%$} [lindex $values 2] match ypcnt]} {
946                set wherex($point) [expr {0.01*$xpcnt}]
947                set wherey($point) [expr {0.01*$ypcnt}]
948                set values [lrange $values 3 end]
949            } else {
950                set bad "expected \"at XX% YY%\" but got \"$values\""; break
951            }
952        } else {
953            set wherex($point) [expr {($point == 1) ? 0 : 1}]
954            set wherey($point) [expr {($point == 1) ? 0 : 1}]
955        }
956    }
957    if {$bad eq "" && $wherex(1) == $wherex(2)} {
958        set bad [format "drawing background limits have x points both at %d%%" [expr {round($wherex(1)*100)}]]
959    }
960    if {$bad eq "" && $wherey(1) == $wherey(2)} {
961        set bad [format "drawing background limits have y points both at %d%%" [expr {round($wherex(1)*100)}]]
962    }
963
964    if {$bad eq "" && $xvals(1) == $xvals(2)} {
965        set bad "drawing background coordinates have 0 range in x"
966    }
967    if {$bad eq "" && $yvals(1) == $yvals(2)} {
968        set bad "drawing background coordinates have 0 range in y"
969    }
970    if {$bad eq "" && [llength $values] > 0} {
971        set bad "extra coordinates \"$values\""
972    }
973
974    if {$bad ne ""} {
975        puts stderr "WARNING: $bad"
976        puts stderr "assuming default \"0 0 1 1\" coordinates"
977        array set xvals {1 0 2 1}
978        array set yvals {1 0 2 1}
979        array set wherex {1 0 2 1}
980        array set wherey {1 0 2 1}
981    }
982
983    # compute min/scale for each axis based on the input values
984    if {$wherex(1) < $wherex(2)} {
985        set min 1; set max 2
986    } else {
987        set min 2; set max 1
988    }
989
990    set slope [expr {double($xvals($max)-$xvals($min))
991                      / ($wherex($max)-$wherex($min))}]
992    set _xMin [expr {-$wherex($min)*$slope + $xvals($min)}]
993    set xmax [expr {(1-$wherex($max))*$slope + $xvals($max)}]
994    set _xScale [expr {[winfo width $itk_component(drawing)]/($xmax-$_xMin)}]
995
996    if {$wherey(1) < $wherey(2)} {
997        set min 1; set max 2
998    } else {
999        set min 2; set max 1
1000    }
1001
1002    set slope [expr {double($yvals($max)-$yvals($min))
1003                      / ($wherey($max)-$wherey($min))}]
1004    set _yMin [expr {-$wherey($min)*$slope + $yvals($min)}]
1005    set ymax [expr {(1-$wherey($max))*$slope + $yvals($max)}]
1006    set _yScale [expr {[winfo height $itk_component(drawing)]/($ymax-$_yMin)}]
1007}
1008
1009itcl::body Rappture::DrawingEntry::ParseBackground {} {
1010    foreach elem [$_xmlobj children $_path.background] {
1011        switch -- $elem {
1012            "color" {
1013                #  Background color of the drawing canvas (default white)
1014                set value [XmlGet $_path.background.$elem]
1015                $itk_component(drawing) configure -background $value
1016            }
1017            "aspect" {
1018                set value [XmlGet $_path.background.$elem]
1019                foreach { xAspect yAspect } $value break
1020                AdjustDrawingArea $xAspect $yAspect
1021            }
1022            "coords" - "coordinates" {
1023                set value [XmlGet $_path.background.$elem]
1024                ParseScreenCoordinates $value
1025            }
1026            "width" {
1027                set width [XmlGet $_path.background.$elem]
1028                $itk_component(drawing) configure -width $width
1029            }
1030            "height" {
1031                set height [XmlGet $_path.background.$elem]
1032                $itk_component(drawing) configure -height $height
1033            }
1034            default {
1035                puts stderr "WARNING: don't understand \"$elem\" in $_path"
1036            }
1037        }
1038    }
1039}
1040
1041#
1042# Invoke --
1043#
1044itcl::body Rappture::DrawingEntry::Invoke {cpath x y} {
1045    if {![info exists _cpath2popup($cpath)]} {
1046        puts stderr "WARNING: no controls for hotspot at $cpath"
1047        return
1048    }
1049    set popup $_cpath2popup($cpath)
1050
1051    # if this popup has only one control, watch for it to change and
1052    # take it down automatically
1053    set inner [$popup component inner]
1054    set n [expr {[$inner.controls index end]+1}]
1055    if {$n == 1} {
1056        set _takedown $popup
1057    } else {
1058        set _takedown ""
1059    }
1060
1061    # Activate the popup and call for the output.
1062    incr x [winfo rootx $itk_component(drawing)]
1063    incr y [winfo rooty $itk_component(drawing)]
1064    $popup activate @$x,$y above
1065}
1066
1067#
1068# Activate --
1069#
1070itcl::body Rappture::DrawingEntry::Activate { cname } {
1071    $itk_component(drawing) configure -cursor center_ptr
1072    $itk_component(drawing) itemconfigure $_cname2id($cname) \
1073        -image [Rappture::icon hotspot_active]
1074}
1075
1076#
1077# Deactivate --
1078#
1079itcl::body Rappture::DrawingEntry::Deactivate { cname } {
1080    $itk_component(drawing) configure -cursor ""
1081    $itk_component(drawing) itemconfigure $_cname2id($cname) \
1082        -image [Rappture::icon hotspot_normal]
1083}
1084
1085# ----------------------------------------------------------------------
1086# USAGE: value ?-check? ?<newval>?
1087#
1088# Clients use this to query/set the value for this widget.  With
1089# no args, it returns the current value for the widget.  If the
1090# <newval> is specified, it sets the value of the widget and
1091# sends a <<Value>> event.  If the -check flag is included, the
1092# new value is not actually applied, but just checked for correctness.
1093# ----------------------------------------------------------------------
1094itcl::body Rappture::DrawingEntry::value {args} {
1095    # Redraw if there's a new library object.
1096    if { [llength $args] > 0 } {
1097        set libobj [lindex $args 0]
1098        if { $libobj != "" } {
1099            $_dispatcher event -idle !redraw
1100        }
1101    }
1102    return ""
1103}
1104
1105itcl::body Rappture::DrawingEntry::UpdateSubstitutions {} {
1106    # Load parser with the variables representing the substitution
1107    foreach name [array names _name2path] {
1108        set path $_name2path($name)
1109        set w [$_owner widgetfor $path]
1110        if {$w ne ""} {
1111            set value [$w value]
1112        } else {
1113            set value ""
1114        }
1115        if {$_name2map($name) ne ""} {
1116            set value [string map $_name2map($name) $value]
1117        }
1118        $_parser eval [list set $name $value]
1119    }
1120}
1121
1122itcl::body Rappture::DrawingEntry::XmlGet { path } {
1123    set value [$_xmlobj get $path]
1124    return [string trim $value]
1125}
1126
1127itcl::body Rappture::DrawingEntry::XmlGetSubst { path } {
1128    set value [$_xmlobj get $path]
1129    if {$_parser == ""} {
1130        return [string trim $value]
1131    }
1132    return [string trim [$_parser eval [list subst -nocommands $value]]]
1133}
Note: See TracBrowser for help on using the repository browser.