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

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