# to prevent loops limit to 16 minutes
cpulimit 1000
-#set script_dir [file dirname [info script]]/script
-# if { [info exist WorkDirectory] == 0 } {
-# set WorkDirectory "/tmp"
-# if { [array get env TEMP] != "" } {
-# set WorkDirectory "$env(TEMP)"
-# }
-# }
+# On Windows with VC, in typical configuration gl2ps is built with Release
+# mode only which will fail in Debug mode; add TODO for that case in order
+# to handle it once for all tests that can use vexport command
+if { [regexp {Debug mode} [dversion]] } {
+ puts "TODO ?#23540 windows: Error: export of image.*failed"
+ puts "TODO ?#23540 windows: Error: The file has been exported.*different size \[(\]0 "
+}
if { [info exists imagedir] == 0 } {
set imagedir .
set test_image photo
}
+# Procedure to check equality of two reals with tolerance (relative and absolute)
+help checkreal {name value expected tol_abs tol_rel}
+proc checkreal {name value expected tol_abs tol_rel} {
+ if { abs ($value - $expected) > $tol_abs + $tol_rel * abs ($expected) } {
+ puts "Error: $name = $value is not equal to expected $expected"
+ } else {
+ puts "Check of $name OK: value = $value, expected = $expected"
+ }
+ return
+}
+
+# Procedure to check equality of two reals with tolerance (relative and absolute)
+help checkarea {shape area_expected tol_abs tol_rel}
+proc checkarea {shape area_expected tol_abs tol_rel} {
+ # compute area with half of the relative tolerance
+ # to be used in comparison; 0.001 is added to avoid zero value
+ set prop [uplevel sprops $shape [expr 0.5 * abs($tol_rel) + 0.001]]
+
+ # get te value
+ if { ! [regexp {Mass\s*:\s*([0-9.e+-]+)} $prop res area] } {
+ puts "Error: cannot get area of the shape $shape"
+ return
+ }
+
+ # compare with expected value
+ checkreal "area of $shape" $area $area_expected $tol_abs $tol_rel
+}
+
+# Procedure to check color in the point near default coordinate
+
+proc checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
+ set x_start [expr ${coord_x} - 2]
+ set y_start [expr ${coord_y} - 2]
+ set mistake 0
+ set i 0
+ while { $mistake != 1 && $i <= 5 } {
+ set j 0
+ while { $mistake != 1 && $j <= 5 } {
+ set position_x [expr ${x_start} + $j]
+ set position_y [expr ${y_start} + $i]
+ puts $position_x
+ puts $position_y
+ global color2d
+ if { [info exists color2d] } {
+ set color [ QAAISGetPixelColor2d ${position_x} ${position_y} ]
+ } else {
+ set color [ QAGetPixelColor ${position_x} ${position_y} ]
+ }
+ regexp {RED +: +([-0-9.+eE]+)} $color full rd
+ regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
+ regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
+ set rd_int [expr int($rd * 1.e+05)]
+ set gr_int [expr int($gr * 1.e+05)]
+ set bl_int [expr int($bl * 1.e+05)]
+
+ if { $rd_ch != 0 } {
+ set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
+ } else {
+ set tol_rd $rd_int
+ }
+ if { $gr_ch != 0 } {
+ set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
+ } else {
+ set tol_gr $gr_int
+ }
+ if { $bl_ch != 0 } {
+ set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
+ } else {
+ set tol_bl $bl_int
+ }
+
+ if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
+ puts "Warning : Point with true color was not found near default coordinates"
+ set mistake 0
+ } else {
+ set mistake 1
+ }
+ incr j
+ }
+ incr i
+ }
+ return $mistake
+}
+
+# Procedure to check color using command QAgetPixelColor with tolerance
+proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
+ puts "Coordinate x = $coord_x"
+ puts "Coordinate y = $coord_y"
+ puts "RED color of RGB is $rd_get"
+ puts "GREEN color of RGB is $gr_get"
+ puts "BLUE color of RGB is $bl_get"
+
+ if { $coord_x <= 1 || $coord_y <= 1 } {
+ puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
+ return -1
+ }
+ global color2d
+ if { [info exists color2d] } {
+ set color [ QAAISGetPixelColor2d ${coord_x} ${coord_y} ]
+ } else {
+ set color [ QAGetPixelColor ${coord_x} ${coord_y} ]
+ }
+
+ regexp {RED +: +([-0-9.+eE]+)} $color full rd
+ regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
+ regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
+ set rd_int [expr int($rd * 1.e+05)]
+ set gr_int [expr int($gr * 1.e+05)]
+ set bl_int [expr int($bl * 1.e+05)]
+ set rd_ch [expr int($rd_get * 1.e+05)]
+ set gr_ch [expr int($gr_get * 1.e+05)]
+ set bl_ch [expr int($bl_get * 1.e+05)]
+
+ if { $rd_ch != 0 } {
+ set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
+ } else {
+ set tol_rd $rd_int
+ }
+ if { $gr_ch != 0 } {
+ set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
+ } else {
+ set tol_gr $gr_int
+ }
+ if { $bl_ch != 0 } {
+ set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
+ } else {
+ set tol_bl $bl_int
+ }
+ set status 0
+ if { $tol_rd > 0.2 } {
+ puts "Warning : RED light of additive color model RGB is invalid"
+ set status 1
+ }
+ if { $tol_gr > 0.2 } {
+ puts "Warning : GREEN light of additive color model RGB is invalid"
+ set status 1
+ }
+ if { $tol_bl > 0.2 } {
+ puts "Warning : BLUE light of additive color model RGB is invalid"
+ set status 1
+ }
+
+ if { $status != 0 } {
+ puts "Warning : Colors of default coordinate are not equal"
+ }
+
+ global stat
+ if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
+ set info [checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
+ set stat [lindex $info end]
+ if { ${stat} != 1 } {
+ puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
+ return $stat
+ } else {
+ puts "Point with valid color was found"
+ return $stat
+ }
+ } else {
+ set stat 1
+ }
+}
+
+
# Procedure to check if sequence of values in listval follows linear trend
# adding the same delta on each step.
#
set mean [expr $mean + ($val - $prev)]
set prev $val
}
- set mean [expr $mean / $nbval]
+ set mean [expr $mean / ($nbval - 1)]
# calculate dispersion
set sigma 0.
set sigma [expr $sigma + $d * $d]
set prev $val
}
- set sigma [expr sqrt ($sigma / ($nbval - 1))]
+ set sigma [expr sqrt ($sigma / ($nbval - 2))]
puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"
# check if deviation is definitely too big
- if { abs ($mean - $delta) > 2. * $sigma } {
+ if { abs ($mean - $delta) > $tolerance + 2. * $sigma } {
puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
- error $message
+ error "$message"
}
# check if deviation is clearly within a range
return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
}
+
+# Check if area of triangles is valid
+proc CheckTriArea {shape {eps 0}} {
+ upvar #0 $shape result
+ set area [triarea result $eps]
+ set t_area [lindex $area 0]
+ set g_area [expr abs([lindex $area 1])]
+ puts "area by triangles: $t_area"
+ puts "area by geometry: $g_area"
+ expr ($t_area - $g_area) / $g_area * 100
+}
projects / occt.git / blobdiff