# File : begin
+
if { [array get Draw_Groups "TOPOLOGY Check commands"] == "" } {
pload TOPTEST
pload VISUALIZATION
-# set env(CSF_DrawPluginQADefaults) $env(CASROOT)/src/DrawResources/.
-# pload QAcommands
-# pload -DrawPluginQA QAcommands
}
# to prevent loops limit to 16 minutes
cpulimit 1000
-# 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 "
-}
+set rel_tol 0
+set max_rel_tol_diff 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} {
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.
-#
-# The function does statistical estimation of the mean variation of the
-# values of the sequence, and dispersion, and returns true only if both
-# dispersion and deviation of the mean from expected delta are within
-# specified tolerance.
-#
-# If mean variation differs from expected delta on more than two dispersions,
-# the check fails and procedure raises error with specified message.
-#
-# Otherwise the procedure returns false meaning that more iterations are needed.
-# Note that false is returned in any case if length of listval is less than 3.
-#
-# See example of use to check memory leaks in bugs/caf/bug23489
-#
-proc checktrend {listval delta tolerance message} {
- set nbval [llength $listval]
- if { $nbval < 3} {
- return 0
- }
-
- # calculate mean value
- set mean 0.
- set prev [lindex $listval 0]
- foreach val [lrange $listval 1 end] {
- set mean [expr $mean + ($val - $prev)]
- set prev $val
- }
- set mean [expr $mean / ($nbval - 1)]
-
- # calculate dispersion
- set sigma 0.
- set prev [lindex $listval 0]
- foreach val [lrange $listval 1 end] {
- set d [expr ($val - $prev) - $mean]
- set sigma [expr $sigma + $d * $d]
- set prev $val
- }
- 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) > $tolerance + 2. * $sigma } {
- puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
- 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
expr ($t_area - $g_area) / $g_area * 100
}
-# Check if list of xdistcs-command is valid
-proc checkList {List Tolerance D_good Limit_Tol} {
- set L1 [llength ${List}]
- set L2 10
- set L3 5
- set N [expr (${L1} - ${L2})/${L3} + 1]
+# Check expected time
+proc checktime {value expected tol_rel message} {
+ set t1 [expr ${value} - ${expected}]
+ set t2 [expr ${expected} * abs (${tol_rel})]
- for {set i 1} {${i} <= ${N}} {incr i} {
- set j1 [expr ${L2} + (${i}-1)*${L3}]
- set j2 [expr ${j1} + 2]
- set T [lindex ${List} ${j1}]
- set D [lindex ${List} ${j2}]
- #puts "i=${i} j1=${j1} j2=${j2} T=${T} D=${D}"
- if { [expr abs(${D} - ${D_good})] > ${Tolerance} } {
- puts "Error : T=${T} D=${D}"
- }
-
- if { ${Tolerance} > ${Limit_Tol} } {
- if { [expr abs(${D} - ${D_good})] > ${Limit_Tol}
- && [expr abs(${D} - ${D_good})] <= ${Tolerance} } {
- puts "Attention (critical value of tolerance) : T=${T} D=${D}"
- }
- }
+ if { abs (${t1}) <= ${t2} } {
+ puts "OK. ${message}, ${value} seconds, is equal to expected time - ${expected} seconds"
+ } elseif {${t1} > ${t2}} {
+ puts "Error. ${message}, ${value} seconds, is more than expected time - ${expected} seconds"
+ } else {
+ puts "Improvement. ${message}, ${value} seconds, is less than expected time - ${expected} seconds"
}
}
-
-# Procedure to check result of nbshapes command
-proc checknbshapes { res nbshapes_expected_s count_locations message} {
-
- upvar $res shape
- if { ${count_locations} == 0 } {
- set nb_info [nbshapes shape]
- } else {
- set nb_info [nbshapes shape -t]
- }
-
- set EntityList {VERTEX EDGE WIRE FACE SHELL SOLID COMPSOLID COMPOUND SHAPE}
-
- foreach Entity ${EntityList} {
- set expr_string "${Entity} +: +(\[-0-9.+eE\]+)"
- if { [regexp "${expr_string}" ${nbshapes_expected_s} full nb_entity1] > 0 } {
- if { [regexp "${expr_string}" ${nb_info} full nb_entity2] > 0 } {
- if { ${nb_entity2} != ${nb_entity1} } {
- puts "Error : ${message} is WRONG because number of ${Entity} entities is ${nb_entity2} while ${nb_entity1} is expected"
- } else {
- puts "OK : ${message} is GOOD because number of ${Entity} entities is equal to number of expected ${Entity} entities"
- }
- }
- }
- }
-}
projects / occt.git / blobdiff