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

Last change on this file since 2992 was 2992, checked in by gah, 12 years ago

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