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

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

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