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

Last change on this file since 3177 was 3177, checked in by mmc, 12 years ago

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