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

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

fixes for drawing. Allow empty html file.
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-2005  Purdue Research Foundation
10#
11#  See the file "license.terms" for information on usage and
12#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13# ======================================================================
14package require Itk
15package require Img
16
17itcl::class Rappture::DrawingEntry {
18    inherit itk::Widget
19    itk_option define -state state State "normal"
20
21    private variable _canvasHeight 0
22    private variable _canvasWidth 0
23    private variable _cname2controls
24    private variable _cname2id
25    private variable _cname2image
26    private variable _name2path
27    private variable _drawingHeight 0
28    private variable _drawingWidth 0
29    private variable _owner
30    private variable _parser "";        # Slave interpreter where all
31                                        # substituted variables are stored.
32    private variable _path
33    private variable _showing ""
34    private variable _xAspect 0
35    private variable _xMin 0
36    private variable _xOffset 0
37    private variable _xScale 1.0
38    private variable _yAspect 0
39    private variable _yMin 0
40    private variable _yOffset 0
41    private variable _yScale 1.0
42    private variable _cursor ""
43
44    constructor {owner path args} {
45        # defined below
46    }
47    destructor {
48        # defined below
49    }
50    public method value { args }
51    public method label {}
52    public method tooltip {}
53
54    private method Activate { tag }
55    private method AdjustDrawingArea { xAspect yAspect }
56    private method ControlValue {path {units ""}}
57    private method Deactivate { tag }
58    private method Highlight { tag }
59    private method InitSubstitutions {}
60    private method Invoke { name x y }
61    private method ParseBackground {}
62    private method ParseDescription {}
63    private method ParseGrid { cpath cname }
64    private method ParseHotspot { cpath cname }
65    private method ParseLine { cpath cname }
66    private method ParseOval { cpath cname }
67    private method ParsePicture { cpath cname }
68    private method ParsePolygon { cpath cname }
69    private method ParseRectangle { cpath cname }
70    private method ParseScreenCoordinates { values }
71    private method ParseSubstitutions {}
72    private method ParseText { cpath cname }
73    private method Redraw {}
74    private method ScreenCoords { coords }
75    private method ScreenX { x }
76    private method ScreenY { y }
77    private method XmlGet { path }
78    private method XmlGetSubst { path }
79    private method Withdraw { cname }
80    private method Hotspot { option cname item args }
81    private method IsEnabled { path }
82    private method NumControlsEnabled { cname }
83}
84
85itk::usual DrawingEntry {
86    keep -cursor -font
87    keep -foreground -background
88    keep -textbackground
89    keep -selectbackground -selectforeground -selectborderwidth
90}
91
92# ----------------------------------------------------------------------
93# CONSTRUCTOR
94# ----------------------------------------------------------------------
95itcl::body Rappture::DrawingEntry::constructor {owner path args} {
96    if {[catch {$owner isa Rappture::ControlOwner} valid] != 0 || !$valid} {
97        error "bad object \"$owner\": should be Rappture::ControlOwner"
98    }
99    set _path $path
100    set _owner $owner
101    #
102    # Display the current drawing.
103    #
104    itk_component add drawing {
105        canvas $itk_interior.canvas -background white -relief sunken -bd 1 \
106            -width 800 -height 600
107    } {
108        ignore -background
109    }
110    pack $itk_component(drawing) -expand yes -fill both
111    bind $itk_component(drawing) <Configure> [itcl::code $this Redraw]
112    set _parser [interp create -safe]
113    Redraw
114    eval itk_initialize $args
115}
116
117itcl::body Rappture::DrawingEntry::destructor {} {
118    if { $_parser != "" } {
119        $_parser delete
120    }
121}
122# ----------------------------------------------------------------------
123# USAGE: label
124#
125# Clients use this to query the label associated with this widget.
126# Reaches into the XML and pulls out the appropriate label string.
127# ----------------------------------------------------------------------
128itcl::body Rappture::DrawingEntry::label {} {
129return ""
130    set label [$_owner xml get $_path.about.label]
131    if {"" == $label} {
132        set label "Drawing"
133    }
134    return $label
135}
136
137# ----------------------------------------------------------------------
138# USAGE: tooltip
139#
140# Clients use this to query the tooltip associated with this widget.
141# Reaches into the XML and pulls out the appropriate description
142# string.  Returns the string that should be used with the
143# Rappture::Tooltip facility.
144# ----------------------------------------------------------------------
145itcl::body Rappture::DrawingEntry::tooltip {} {
146return ""
147    set str [$_owner xml get $_path.about.description]
148    return [string trim $str]
149}
150
151# ----------------------------------------------------------------------
152# CONFIGURATION OPTION: -state
153# ----------------------------------------------------------------------
154itcl::configbody Rappture::DrawingEntry::state {
155    set valid {normal disabled}
156    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
157        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
158    }
159}
160
161itcl::body Rappture::DrawingEntry::Redraw {} {
162    # Remove exists canvas items and hints
163    $itk_component(drawing) delete all
164    # Delete any images that we created.
165    foreach name [array names _cname2image] {
166        image delete $_cname2image($name)
167    }
168    array unset _name2path
169    array unset _cname2id
170    array unset _cnames2controls
171    array unset _cname2image
172   
173    # Recompute the size of the canvas/drawing area
174    set _canvasWidth [winfo width $itk_component(drawing)]
175    if { $_canvasWidth < 2 } {
176        set _canvasWidth [winfo reqwidth $itk_component(drawing)]
177    }
178    set _canvasHeight [winfo height $itk_component(drawing)]
179    if { $_canvasHeight < 2 } {
180        set _canvasHeight [winfo reqheight $itk_component(drawing)]
181    }
182    set _drawingWidth $_canvasWidth
183    set _drawingHeight $_canvasHeight
184    set _xOffset 0
185    set _yOffset 0
186    ParseDescription
187}
188
189#
190# ParseDescription --
191#
192itcl::body Rappture::DrawingEntry::ParseDescription {} {
193    #puts stderr "ParseDescription owner=$_owner path=$_path"
194    ParseBackground
195    ParseSubstitutions
196    foreach cname [$_owner xml children $_path.components] {
197        switch -glob -- $cname {
198            "line*" {
199                ParseLine $_path.components.$cname $cname
200            }
201            "grid*" {
202                ParseGrid $_path.components.$cname $cname
203            }
204            "text*" {
205                ParseText $_path.components.$cname $cname
206            }
207            "picture*" {
208                ParsePicture $_path.components.$cname $cname
209            }
210            "rectangle*" {
211                ParseRectangle $_path.components.$cname $cname
212            }
213            "oval*" {
214                ParseOval $_path.components.$cname $cname
215            }
216            "polygon*" {
217                ParsePolygon $_path.components.$cname $cname
218            }
219            "hotspot*" {
220                ParseHotspot $_path.components.$cname $cname
221            }
222        }
223    }
224}
225
226#
227# ParseGrid --
228#
229itcl::body Rappture::DrawingEntry::ParseGrid { cpath cname } {
230    #puts stderr "ParseGrid owner=$_owner cpath=$cpath"
231    array set attr2option {
232        "linewidth"     "-width"
233        "arrow"         "-arrow"
234        "dash"          "-dash"
235        "color"         "-fill"
236    }
237    # Set default options first and then let tool.xml override them.
238    array set options {
239        -arrow          none
240        -width          0
241        -fill           black
242        -dash           ""
243    }
244    # Coords
245    set xcoords [XmlGetSubst $cpath.xcoords]
246    set xcoords [string trim $xcoords]
247    set ycoords [XmlGetSubst $cpath.ycoords]
248    set ycoords [string trim $ycoords]
249    if { $ycoords == "" } {
250        set ycoords "0 1"
251        set ymax 1
252        set ymin 0
253    } else {
254        set list {}
255        set ymax -10000
256        set ymin 10000
257        foreach c $ycoords {
258            set y [ScreenY $c]
259            if { $y > $ymax } {
260                set ymax $y
261            }
262            if { $y < $ymin } {
263                set ymin $y
264            }
265            lappend list $y
266        }
267        set ycoords $list
268    }
269    if { $xcoords == "" } {
270        set xcoords "0 1"
271        set xmax 1
272        set xmin 0
273    } else {
274        set list {}
275        set xmax -10000
276        set xmin 10000
277        foreach c $xcoords {
278            set x [ScreenX $c]
279            if { $x > $xmax } {
280                set xmax $x
281            }
282            if { $x < $xmin } {
283                set xmin $x
284            }
285            lappend list $x
286        }
287        set xcoords $list
288    }
289    #puts stderr "ParseGrid owner=$_owner cpath=$cpath xcoords=$xcoords ycoords=$ycoords"
290    set list {}
291    foreach attr [$_owner xml children $cpath] {
292        if { [info exists attr2option($attr)] } {
293            set option $attr2option($attr)
294            set value [XmlGetSubst $cpath.$attr]
295            set options($option) $value
296        }
297    }
298    set options(-tags) $cname
299    foreach y $ycoords {
300        lappend ids \
301            [eval $itk_component(drawing) create line $xmin $y $xmax $y \
302                 [array get options]]
303    }
304    foreach x $xcoords {
305        lappend ids \
306            [eval $itk_component(drawing) create line $x $ymin $x $ymax \
307                 [array get options]]
308    }
309    set _cname2id($cname) $ids
310}
311
312#
313# ParseHotspot --
314#
315itcl::body Rappture::DrawingEntry::ParseHotspot { cpath cname } {
316    array set attr2option {
317        "color" "-fill"
318        "anchor" "-anchor"
319    }
320    #puts stderr "ParseHotspot owner=$_owner cpath=$cpath"
321    # Set default options first and then let tool.xml override them.
322    array set options {
323        -fill red
324        -anchor c
325    }
326    array unset _cname2controls $cname
327    foreach attr [$_owner xml children $cpath] {
328        if { [info exists attr2option($attr)] } {
329            set option $attr2option($attr)
330            set value [XmlGetSubst $cpath.$attr]
331            set options($option) $value
332        } elseif { [string match "controls*" $attr] } {
333            set value [XmlGetSubst $cpath.$attr]
334            lappend _cname2controls($cname) $value
335            $_owner xml put $value.hide 1
336        }
337    }
338    # Coordinates
339    set coords [XmlGetSubst $cpath.coords]
340    set coords [ScreenCoords $coords]
341    if { $coords == "" } {
342        set coords "0 0 1 1"
343    }
344    set c $itk_component(drawing)
345    set img [Rappture::icon hotspot_normal]
346    foreach { x1 y1 } $coords break
347    set id [$itk_component(drawing) create image $x1 $y1]
348    array unset options -fill
349    set options(-tags) $cname
350    set options(-image) $img
351    eval $c itemconfigure $id [array get options]
352    set _cname2id($cname) $id
353    $c bind $id <Enter> [itcl::code $this Activate $cname]
354    $c bind $id <Leave> [itcl::code $this Deactivate $cname]
355    #$c bind $id <ButtonPress-1> [itcl::code $this Depress $cname]
356    set bbox [$c bbox $id]
357    set y1 [lindex $bbox 1]
358    $c bind $id <ButtonPress-1> [itcl::code $this Invoke $cname $x1 $y1]
359}
360
361#
362# ParseLine --
363#
364itcl::body Rappture::DrawingEntry::ParseLine { cpath cname } {
365    array set attr2option {
366        "linewidth"     "-width"
367        "arrow"         "-arrow"
368        "dash"          "-dash"
369        "color"         "-fill"
370    }
371    # Set default options first and then let tool.xml override them.
372    array set options {
373        -arrow          none
374        -width          0
375        -fill           black
376        -dash           ""
377    }
378    # Coords
379    set coords {}
380    set coords [XmlGetSubst $cpath.coords]
381    set coords [string trim $coords]
382    if { $coords == "" } {
383        set coords "0 0"
384    } else {
385        set coords [ScreenCoords $coords]
386    }
387    #puts stderr "ParseLine owner=$_owner cpath=$cpath coords=$coords"
388    set list {}
389    foreach attr [$_owner xml children $cpath] {
390        if { [info exists attr2option($attr)] } {
391            set option $attr2option($attr)
392            set value [XmlGetSubst $cpath.$attr]
393            set options($option) $value
394        }
395    }
396    set options(-tags) $cname
397    set id [eval $itk_component(drawing) create line $coords]
398    set _cname2id($cname) $id
399    eval $itk_component(drawing) itemconfigure $id [array get options]
400}
401
402#
403# ParseOval --
404#
405itcl::body Rappture::DrawingEntry::ParseOval { cpath cname } {
406    array set attr2option {
407        "outline"       "-outline"
408        "fill"          "-fill"
409        "linewidth"     "-width"
410    }
411    #puts stderr "ParseOval owner=$_owner cpath=$cpath"
412
413    # Set default options first and then let tool.xml override them.
414    array set options {
415        -fill blue
416        -width 1
417        -outline black
418    }
419    foreach attr [$_owner xml children $cpath] {
420        if { [info exists attr2option($attr)] } {
421            set option $attr2option($attr)
422            set value [XmlGetSubst $cpath.$attr]
423            set options($option) $value
424        }
425    }
426    # Coordinates
427    set coords {}
428    set coords [XmlGetSubst $cpath.coords]
429    set coords [string trim $coords]
430    if { $coords == "" } {
431        set coords "0 0 1 1"
432    }
433    foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
434    set id [$itk_component(drawing) create oval $x1 $y1 $x2 $y2]
435    set _cname2id($cname) $id
436    eval $itk_component(drawing) itemconfigure $id [array get options]
437}
438
439#
440# ParsePicture --
441#
442itcl::body Rappture::DrawingEntry::ParsePicture { cpath cname } {
443    array set attr2option {
444        "anchor"        "-anchor"
445    }
446    #puts stderr "ParsePicture owner=$_owner cpath=$cpath"
447    # Set default options first and then let tool.xml override them.
448    array set options {
449        -anchor nw
450    }
451    foreach attr [$_owner xml children $cpath] {
452        if { [info exists attr2option($attr)] } {
453            set option $attr2option($attr)
454            set value [XmlGetSubst $cpath.$attr]
455            set options($option) $value
456        }
457    }
458    set contents [XmlGetSubst $cpath.contents]
459    set img ""
460    if { [string compare -length 5 $contents "file:"] == 0 } {
461        set fileName [string range $contents 5 end]
462        if { [file exists $fileName] } {
463            set img [image create photo -file $fileName]
464        }
465    } elseif { [string compare -length 5 $contents "http:"] == 0 } {
466        puts stderr  "don't know how to handle http"
467        return
468    } else {
469        set img [image create photo -data $contents]
470    }
471    if { $img == "" } {
472        return
473    }
474    # Coordinates
475    set coords [XmlGetSubst $cpath.coords]
476    set coords [ScreenCoords $coords]
477    if { [llength $coords] == 2 } {
478        foreach { x1 y1 } $coords break
479        set w [XmlGetSubst $cpath.width]
480        if { $w == "" || ![string is number $w] || $w <= 0.0 } {
481            set width [expr [image width $img] / 4]
482        } else {
483            set width [expr [ScreenX $w] - [ScreenX 0]]
484        }
485        set h [XmlGetSubst $cpath.height]
486        if { $h == "" || ![string is number $h] || $h <= 0.0 } {
487            set height [expr [image height $img] / 4]
488        } else {
489            set height [expr [ScreenY $h] - [ScreenY 0]]
490        }
491        if { $width != [image width $img] || $height != [image height $img] } {
492            set dst [image create photo -width $width -height $height]
493            blt::winop resample $img $dest
494            image delete $img
495            set img $dst
496        }
497    } elseif { [llength $coords] == 4 } {
498        foreach { x1 y1 x2 y2 } $coords break
499        if { $x1 > $x2 } {
500            set tmp $x1
501            set x1 $x2
502            set x2 $tmp
503        }
504        if { $y1 > $y2 } {
505            set tmp $x1
506            set x1 $x2
507            set x2 $tmp
508        }
509        set width [expr $x2 - $x1 + 1]
510        set height [expr $x2 - $x1 + 1]
511        if { $width != [image width $img] || $height != [image height $img] } {
512            set dst [image create photo -width $width -height $height]
513            blt::winop resample $img $dst
514            image delete $img
515            set img $dst
516        }
517    } else {
518        set width [expr [image width $img] / 4]
519        set height [expr [image height $img] / 4]
520        set dst [image create photo -width $width -height $height]
521        blt::winop resample $img $dst
522        image delete $img
523        set img $dst
524        set x1 0
525        set y1 0
526    }
527    set options(-tags) $cname
528    set options(-image) $img
529    set id [$itk_component(drawing) create image $x1 $y1]
530    set _cname2image($cname) $img
531    set _cname2id($cname) $id
532    eval $itk_component(drawing) itemconfigure $id [array get options]
533}
534
535
536itcl::body Rappture::DrawingEntry::ParsePolygon { cpath cname } {
537    array set attr2option {
538        "linewidth"     "-width"
539        "color"         "-fill"
540    }
541    # Set default options first and then let tool.xml override them.
542    array set options {
543        -width          1
544        -fill           blue
545        -outline        black
546    }
547    # Coords
548    set coords [XmlGetSubst $cpath.coords]
549    set coords [string trim $coords]
550    if { $coords == "" } {
551        set coords "0 0"
552    } else {
553        set coords [ScreenCoords $coords]
554    }
555    set x1 [lindex $coords 0]
556    set y1 [lindex $coords 1]
557    lappend coords $x1 $y1
558    #puts stderr "ParsePolygon owner=$_owner cpath=$cpath coords=$coords"
559    set list {}
560    foreach attr [$_owner xml children $cpath] {
561        if { [info exists attr2option($attr)] } {
562            set option $attr2option($attr)
563            set value [XmlGetSubst $cpath.$attr]
564            set options($option) $value
565        }
566    }
567    set options(-tags) $cname
568    set id [eval $itk_component(drawing) create polygon $coords]
569    set _cname2id($cname) $id
570    eval $itk_component(drawing) itemconfigure $id [array get options]
571}
572
573#
574# ParseRectangle --
575#
576itcl::body Rappture::DrawingEntry::ParseRectangle { cpath cname } {
577    array set attr2option {
578        "outline"       "-outline"
579        "fill"          "-fill"
580        "linewidth"     "-width"
581    }
582    #puts stderr "ParseRectangle owner=$_owner cpath=$cpath"
583
584    # Set default options first and then let tool.xml override them.
585    array set options {
586        -fill blue
587        -width 1
588        -outline black
589    }
590    foreach attr [$_owner xml children $cpath] {
591        if { [info exists attr2option($attr)] } {
592            set option $attr2option($attr)
593            set value [XmlGetSubst $cpath.$attr]
594            set options($option) $value
595        }
596    }
597    # Coordinates
598    set coords [XmlGetSubst $cpath.coords]
599    set coords [string trim $coords]
600    if { $coords == "" } {
601        set coords "0 0 1 1"
602    }
603    foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
604    foreach { x1 y1 x2 y2 } [ScreenCoords $coords] break
605    set id [$itk_component(drawing) create rectangle $x1 $y1 $x2 $y2]
606puts stderr "$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 [$_owner xml 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                $_owner xml 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 [$_owner xml 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 [$_owner xml 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 [$_owner xml 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    # drawing entries have no value
985    return ""
986}
987
988
989#
990# InitSubstitutions --
991#
992itcl::body Rappture::DrawingEntry::InitSubstitutions {} {
993    # Load a new parser with the variables representing the substitution
994    foreach name [array names _name2path] {
995        set path $_name2path($name)
996        set w [$_owner widgetfor $path]
997        if { $w != "" } {
998            set value [$w value]
999        } else {
1000            set value ""
1001        }
1002        $_parser eval [list set $name $value]
1003    }
1004}
1005
1006itcl::body Rappture::DrawingEntry::XmlGet { path } {
1007    set value [$_owner xml get $path]
1008    return [string trim $value]
1009}
1010
1011itcl::body Rappture::DrawingEntry::XmlGetSubst { path } {
1012    set value [$_owner xml get $path]
1013    if { $_parser == "" } {
1014        return $value
1015    }
1016    return [string trim [$_parser eval [list subst -nocommands $value]]]
1017}
1018
1019itcl::body Rappture::DrawingEntry::IsEnabled { path } {
1020    set enable [string trim [$_owner xml get $path.about.enable]]
1021    if {"" == $enable} {
1022        return 1
1023    }
1024    if {![string is boolean $enable]} {
1025        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/]+)?}
1026        set rest $enable
1027        set enable ""
1028        set deps ""
1029        while {1} {
1030            if {[regexp -indices $re $rest match]} {
1031                foreach {s0 s1} $match break
1032
1033                if {[string index $rest [expr {$s0-1}]] == "\""
1034                      && [string index $rest [expr {$s1+1}]] == "\""} {
1035                    # string in ""'s? then leave it alone
1036                    append enable [string range $rest 0 $s1]
1037                    set rest [string range $rest [expr {$s1+1}] end]
1038                } else {
1039                    #
1040                    # This is a symbol which should be substituted
1041                    # it can be either:
1042                    #   input.foo.bar
1043                    #   input.foo.bar:units
1044                    #
1045                    set cpath [string range $rest $s0 $s1]
1046                    set parts [split $cpath :]
1047                    set ccpath [lindex $parts 0]
1048                    set units [lindex $parts 1]
1049
1050                    # make sure we have the standard path notation
1051                    set stdpath [$_owner regularize $ccpath]
1052                    if {"" == $stdpath} {
1053                        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."
1054                        set stdpath $ccpath
1055                    }
1056                    # substitute [_controlValue ...] call in place of path
1057                    append enable [string range $rest 0 [expr {$s0-1}]]
1058                    append enable [format {[ControlValue %s %s]} $stdpath $units]
1059                    lappend deps $stdpath
1060                    set rest [string range $rest [expr {$s1+1}] end]
1061                }
1062            } else {
1063                append enable $rest
1064                break
1065            }
1066        }
1067    }
1068    return [expr $enable]
1069}
1070
1071# ----------------------------------------------------------------------
1072# USAGE: ControlValue <path> ?<units>?
1073#
1074# Used internally to get the value of a control with the specified
1075# <path>.  Returns the current value for the control.
1076# ----------------------------------------------------------------------
1077itcl::body Rappture::DrawingEntry::ControlValue {path {units ""}} {
1078    if {"" != $_owner} {
1079        set val [$_owner valuefor $path]
1080         if {"" != $units} {
1081            set val [Rappture::Units::convert $val -to $units -units off]
1082        }
1083        return $val
1084    }
1085    return ""
1086}
1087
1088itcl::body Rappture::DrawingEntry::NumControlsEnabled { cname } {
1089    set controls $_cname2controls($cname)
1090    set count 0
1091    foreach path $controls {
1092        if { [IsEnabled $path] } {
1093            incr count
1094        }
1095    }
1096    return $count
1097}
Note: See TracBrowser for help on using the repository browser.