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

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

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