mirror of
https://git.dev.opencascade.org/repos/occt.git
synced 2025-04-04 18:06:22 +03:00
273 lines
8.6 KiB
Plaintext
Executable File
273 lines
8.6 KiB
Plaintext
Executable File
# 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 "
|
|
}
|
|
|
|
if { [info exists imagedir] == 0 } {
|
|
set imagedir .
|
|
}
|
|
if { [info exists test_image] == 0 } {
|
|
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.
|
|
#
|
|
# 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
|
|
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
|
|
}
|
|
|
|
# Check if list of xdistcs-command is valid
|
|
proc checkList {List Tolerance D_good} {
|
|
set L1 [llength ${List}]
|
|
set L2 10
|
|
set L3 5
|
|
set N [expr (${L1} - ${L2})/${L3} + 1]
|
|
|
|
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: i=${i} T=${T} D=${D}"
|
|
}
|
|
}
|
|
}
|