Changeset 3671

Timestamp:

May 22, 2013, 6:44:15 PM (11 years ago)

Author:

mmc

Message:

Fixed the background coordinate scaling for the drawing. Now works with
either "coordinates" or "coords" and handles the "at XX% YY%" parts for
either end point.

Fixed the builder so that it doesn't warn about groups that have an empty
label. You should be able to create those sorts of invisible groups.

Location:

trunk

Files:

• gui/scripts/drawingentry.tcl (modified) (3 diffs)
• lang/tcl/scripts/objects.tcl (modified) (3 diffs)
• lang/tcl/scripts/objects/group/group.rp (modified) (1 diff)
• lang/tcl/scripts/objects/string/string.rp (modified) (1 diff)

trunk/gui/scripts/drawingentry.tcl

@@ -848 +848 @@
 
 itcl::body Rappture::DrawingEntry::ScreenX { x } {
-    set norm [expr {($x - $_xMin) * $_xScale}]
-    set x [expr {int($norm * $_drawingWidth) + $_xOffset}]
-    return $x
+    return [expr {($x - $_xMin)*$_xScale + $_xOffset}]
 }
 
 itcl::body Rappture::DrawingEntry::ScreenY { y } {
-    set norm [expr {($y - $_yMin) * $_yScale}]
-    set y [expr {int($norm * $_drawingHeight) + $_yOffset}]
-    return $y
+    return [expr {($y - $_yMin)*$_yScale + $_yOffset}]
 }
 
@@ -927 +923 @@
 
 itcl::body Rappture::DrawingEntry::ParseScreenCoordinates { values } {
-    set len [llength $values]
-    if { $len == 4 } {
-        if { [scan $values "%g %g %g %g" x1 y1 x2 y2] != 4 } {
-            error "bad coordinates specification \"$values\""
-        }
-        set _xScale [expr 1.0 / ($x2 - $x1)]
-        set _yScale [expr 1.0 / ($y2 - $y1)]
-        set _xMin $x1
-        set _yMin $y1
-    } elseif { $len == 10 } {
-        if { [scan $values "%g %g %s %d%% %d%% %g %g %s %d%% %d%%" \
-                  sx1 sy1 at1 x1 y1 sx2 sy2 at2 x2 y2] != 10 } {
-            error "bad coordinates specification \"$values\""
-        }
-        if { $at1 != "at" || $at2 != "at" } {
-            error "bad coordinates specification \"$values\""
-        }           
-        set x1 [expr $x1 / 100.0]
-        set x2 [expr $x2 / 100.0]
-        set y1 [expr $y1 / 100.0]
-        set y2 [expr $y2 / 100.0]
-        set _xScale [expr ($sx2 - $sx1) / ($x2 - $x1)]
-        set _yScale [expr ($sy2 - $sy2) / ($y2 - $y2)]
-        set _xMin $x1
-        set _yMin $y1
-    }
+    set bad ""
+    foreach point {1 2} {
+        set xvals($point) [lindex $values 0]
+        if {![string is double -strict $xvals($point)]} {
+            set bad "missing background coordinate point $point in \"$values\""
+            break
+        }
+
+        set yvals($point) [lindex $values 1]
+        if {![string is double -strict $yvals($point)]} {
+            set bad "missing background coordinate point $point in \"$values\""
+            break
+        }
+        set values [lrange $values 2 end]
+
+        # each corner point can be place anywhere from 0% to 100%
+        if {[lindex $values 0] eq "at"} {
+            if {[regexp {^([0-9]+)%$} [lindex $values 1] match xpcnt]
+              && [regexp {^([0-9]+)%$} [lindex $values 2] match ypcnt]} {
+                set wherex($point) [expr {0.01*$xpcnt}]
+                set wherey($point) [expr {0.01*$ypcnt}]
+                set values [lrange $values 3 end]
+            } else {
+                set bad "expected \"at XX% YY%\" but got \"$values\""; break
+            }
+        } else {
+            set wherex($point) [expr {($point == 1) ? 0 : 1}]
+            set wherey($point) [expr {($point == 1) ? 0 : 1}]
+        }
+    }
+    if {$bad eq "" && $wherex(1) == $wherex(2)} {
+        set bad [format "drawing background limits have x points both at %d%%" [expr {round($wherex(1)*100)}]]
+    }
+    if {$bad eq "" && $wherey(1) == $wherey(2)} {
+        set bad [format "drawing background limits have y points both at %d%%" [expr {round($wherex(1)*100)}]]
+    }
+
+    if {$bad eq "" && $xvals(1) == $xvals(2)} {
+        set bad "drawing background coordinates have 0 range in x"
+    }
+    if {$bad eq "" && $yvals(1) == $yvals(2)} {
+        set bad "drawing background coordinates have 0 range in y"
+    }
+    if {$bad eq "" && [llength $values] > 0} {
+        set bad "extra coordinates \"$values\""
+    }
+
+    if {$bad ne ""} {
+        puts "WARNING: $bad"
+        puts "assuming default \"0 0 1 1\" coordinates"
+        array set xvals {1 0 2 1}
+        array set yvals {1 0 2 1}
+        array set wherex {1 0 2 1}
+        array set wherey {1 0 2 1}
+    }
+
+    # compute min/scale for each axis based on the input values
+    if {$wherex(1) < $wherex(2)} {
+        set min 1; set max 2
+    } else {
+        set min 2; set max 1
+    }
+
+    set slope [expr {double($xvals($max)-$xvals($min))
+                      / ($wherex($max)-$wherex($min))}]
+    set _xMin [expr {-$wherex($min)*$slope + $xvals($min)}]
+    set xmax [expr {(1-$wherex($max))*$slope + $xvals($max)}]
+    set _xScale [expr {[winfo width $itk_component(drawing)]/($xmax-$_xMin)}]
+
+    if {$wherey(1) < $wherey(2)} {
+        set min 1; set max 2
+    } else {
+        set min 2; set max 1
+    }
+
+    set slope [expr {double($yvals($max)-$yvals($min))
+                      / ($wherey($max)-$wherey($min))}]
+    set _yMin [expr {-$wherey($min)*$slope + $yvals($min)}]
+    set ymax [expr {(1-$wherey($max))*$slope + $yvals($max)}]
+    set _yScale [expr {[winfo height $itk_component(drawing)]/($ymax-$_yMin)}]
 }
 
 itcl::body Rappture::DrawingEntry::ParseBackground {} {
     foreach elem [$_xmlobj children $_path.background] {
-        switch -glob -- $elem {
-            "color*" {
+        switch -- $elem {
+            "color" {
                 #  Background color of the drawing canvas (default white)
                 set value [XmlGet $_path.background.$elem]
                 $itk_component(drawing) configure -background $value
             }
-            "aspect*" {
+            "aspect" {
                 set value [XmlGet $_path.background.$elem]
                 foreach { xAspect yAspect } $value break
                 AdjustDrawingArea $xAspect $yAspect
             }
-            "coordinates*" {
+            "coords" - "coordinates" {
                 set value [XmlGet $_path.background.$elem]
                 ParseScreenCoordinates $value
             }
-            "width*" {
+            "width" {
                 set width [XmlGet $_path.background.$elem]
                 $itk_component(drawing) configure -width $width
             }
-            "height*" {
+            "height" {
                 set height [XmlGet $_path.background.$elem]
                 $itk_component(drawing) configure -height $height
             }
+            default {
+                puts "WARNING: don't understand \"$elem\" in $_path"
+            }
         }
     }
@@ -989 +1042 @@
 itcl::body Rappture::DrawingEntry::Invoke {cpath x y} {
     if {![info exists _cpath2popup($cpath)]} {
-        error "internal error: no controls for hotspot at $cpath"
+        puts "WARNING: no controls for hotspot at $cpath"
+        return
     }
     set popup $_cpath2popup($cpath)

trunk/lang/tcl/scripts/objects.tcl

@@ -819 +819 @@
             array set object $extra
         } else {
-            array set object [list type [type] palettes $palettes help $help]
-        }
-
-        # handle checks defined in a base class
-        foreach baseobj [cget -inherit] {
-            eval lappend rlist [$baseobj check $side $data $debug [array get object]]
-        }
-
-        # add checks defined in the current class
+            array set object [list type [type] palettes $palettes help $help checked ""]
+        }
+
+        # do checks defined in the current class
         for {set n 1} {$n <= $_checks(num)} {incr n} {
+            set aname $_checks($n-attr)
+
+            # if we already did this check on a derived class, then skip it
+            # derived classes override the base class
+            if {[lsearch $object(checked) $aname] >= 0} {
+                continue
+            }
+
             # look at the -only option and see if the check applies here
-            set aname $_checks($n-attr)
             set only [getAttr $aname -only]
             if {$only ne "" && [lsearch $only $side] < 0} {
@@ -838 +840 @@
             # execute the code to look for errors in the value
             set status [catch $_checks($n-code) result]
+            lappend object(checked) $aname
+
             if {$status != 0 && $status != 2} {
                 puts stderr "ERROR DURING VALUE CHECK:\n$result"
@@ -848 +852 @@
             }
         }
+
+        # handle checks defined in a base class
+        foreach baseobj [cget -inherit] {
+            eval lappend rlist [$baseobj check $side $data $debug [array get object]]
+        }
+
         return $rlist
     }

trunk/lang/tcl/scripts/objects/group/group.rp

@@ -18 +18 @@
     help http://rappture.org/wiki/rp_xml_ele_group
     terminal no
+
+    check label {
+        # it's okay to have a blank label for invisible groups
+    }
+
+    check description {
+        set label [string trim $attr(label)]
+        set desc [string trim $attr(description)]
+        if {$label ne ""} {
+            # label is set, so must have a good description
+            if {$desc eq ""} {
+                return [list warning "You should include a description of what this group represents."]
+            } elseif {$desc eq $label} {
+                return [list warning "The description should be different from the label and give additional information about this group."]
+            }
+        }
+    }
 }

trunk/lang/tcl/scripts/objects/string/string.rp

@@ -20 +20 @@
     attr default -title "Default Value" -type string -path default -only input -tooltip "Sets the value that this input has when the program first starts.  This value is used by default unless the user explicitly changes it."
 
-    attr size -title "Size" -type string:validate=size -path size -only input -tooltip "Sets the desired size for the string.  Strings are normally 1 line of text, but if the size is set to some WxH, then the entry area will be at least W chars wide and H lines tall.  For example, 40x5 says that the string should be 40 chars wide and 10 lines tall."
+    attr size -title "Size" -type string:validate=size -path size -only input -tooltip "Sets the desired size for the string.  Strings are normally 1 line of text, but if the size is set to some WxH, then the entry area will be at least W chars wide and H lines tall.  For example, 40x5 says that the string should be 40 chars wide and 5 lines tall."
 
     attr hints -title "Hint String" -type string -path about.hints -only input -tooltip "Sets a line of text displayed beneath the entry area for the string.  This is used to give a hint to the user about what should be entered in the string area."