source: branches/blt4/gui/scripts/drawingentry.tcl @ 2991

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