0024048: "Basic Runtime Checks" option of VS projects should be equal to "RTC1"
[occt.git] / tests / bugs / begin
CommitLineData
fa920fb1 1# File : begin
2if { [array get Draw_Groups "TOPOLOGY Check commands"] == "" } {
3 pload TOPTEST
4 pload VISUALIZATION
5# set env(CSF_DrawPluginQADefaults) $env(CASROOT)/src/DrawResources/.
6# pload QAcommands
7# pload -DrawPluginQA QAcommands
8}
9
10# to prevent loops limit to 16 minutes
11cpulimit 1000
12
9753e6de 13# On Windows with VC, in typical configuration gl2ps is built with Release
14# mode only which will fail in Debug mode; add TODO for that case in order
15# to handle it once for all tests that can use vexport command
16if { [regexp {Debug mode} [dversion]] } {
17 puts "TODO ?#23540 windows: Error: export of image.*failed"
18 puts "TODO ?#23540 windows: Error: The file has been exported.*different size \[(\]0 "
19}
fa920fb1 20
21if { [info exists imagedir] == 0 } {
22 set imagedir .
23}
24if { [info exists test_image] == 0 } {
25 set test_image photo
26}
27
c2f5c748 28# Procedure to check equality of two reals with tolerance (relative and absolute)
91322f44 29help checkreal {name value expected tol_abs tol_rel}
c2f5c748 30proc checkreal {name value expected tol_abs tol_rel} {
31 if { abs ($value - $expected) > $tol_abs + $tol_rel * abs ($expected) } {
32 puts "Error: $name = $value is not equal to expected $expected"
33 } else {
34 puts "Check of $name OK: value = $value, expected = $expected"
35 }
36 return
37}
38
91322f44 39# Procedure to check equality of two reals with tolerance (relative and absolute)
40help checkarea {shape area_expected tol_abs tol_rel}
41proc checkarea {shape area_expected tol_abs tol_rel} {
42 # compute area with half of the relative tolerance
43 # to be used in comparison; 0.001 is added to avoid zero value
44 set prop [uplevel sprops $shape [expr 0.5 * abs($tol_rel) + 0.001]]
45
46 # get te value
47 if { ! [regexp {Mass\s*:\s*([0-9.e+-]+)} $prop res area] } {
48 puts "Error: cannot get area of the shape $shape"
49 return
50 }
f1aa2b62 51
91322f44 52 # compare with expected value
53 checkreal "area of $shape" $area $area_expected $tol_abs $tol_rel
54}
f1aa2b62 55
56# Procedure to check color in the point near default coordinate
57
58proc checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
59 set x_start [expr ${coord_x} - 2]
60 set y_start [expr ${coord_y} - 2]
61 set mistake 0
62 set i 0
63 while { $mistake != 1 && $i <= 5 } {
64 set j 0
65 while { $mistake != 1 && $j <= 5 } {
66 set position_x [expr ${x_start} + $j]
67 set position_y [expr ${y_start} + $i]
68 puts $position_x
69 puts $position_y
70 global color2d
71 if { [info exists color2d] } {
72 set color [ QAAISGetPixelColor2d ${position_x} ${position_y} ]
73 } else {
74 set color [ QAGetPixelColor ${position_x} ${position_y} ]
75 }
76 regexp {RED +: +([-0-9.+eE]+)} $color full rd
77 regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
78 regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
79 set rd_int [expr int($rd * 1.e+05)]
80 set gr_int [expr int($gr * 1.e+05)]
81 set bl_int [expr int($bl * 1.e+05)]
82
83 if { $rd_ch != 0 } {
84 set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
85 } else {
86 set tol_rd $rd_int
87 }
88 if { $gr_ch != 0 } {
89 set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
90 } else {
91 set tol_gr $gr_int
92 }
93 if { $bl_ch != 0 } {
94 set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
95 } else {
96 set tol_bl $bl_int
97 }
98
99 if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
100 puts "Warning : Point with true color was not found near default coordinates"
101 set mistake 0
102 } else {
103 set mistake 1
104 }
105 incr j
106 }
107 incr i
108 }
109 return $mistake
110}
111
112# Procedure to check color using command QAgetPixelColor with tolerance
113proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
114 puts "Coordinate x = $coord_x"
115 puts "Coordinate y = $coord_y"
116 puts "RED color of RGB is $rd_get"
117 puts "GREEN color of RGB is $gr_get"
118 puts "BLUE color of RGB is $bl_get"
119
120 if { $coord_x <= 1 || $coord_y <= 1 } {
121 puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
122 return -1
123 }
124 global color2d
125 if { [info exists color2d] } {
126 set color [ QAAISGetPixelColor2d ${coord_x} ${coord_y} ]
127 } else {
128 set color [ QAGetPixelColor ${coord_x} ${coord_y} ]
129 }
130
131 regexp {RED +: +([-0-9.+eE]+)} $color full rd
132 regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
133 regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
134 set rd_int [expr int($rd * 1.e+05)]
135 set gr_int [expr int($gr * 1.e+05)]
136 set bl_int [expr int($bl * 1.e+05)]
137 set rd_ch [expr int($rd_get * 1.e+05)]
138 set gr_ch [expr int($gr_get * 1.e+05)]
139 set bl_ch [expr int($bl_get * 1.e+05)]
140
141 if { $rd_ch != 0 } {
142 set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
143 } else {
144 set tol_rd $rd_int
145 }
146 if { $gr_ch != 0 } {
147 set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
148 } else {
149 set tol_gr $gr_int
150 }
151 if { $bl_ch != 0 } {
152 set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
153 } else {
154 set tol_bl $bl_int
155 }
156 set status 0
157 if { $tol_rd > 0.2 } {
158 puts "Warning : RED light of additive color model RGB is invalid"
159 set status 1
160 }
161 if { $tol_gr > 0.2 } {
162 puts "Warning : GREEN light of additive color model RGB is invalid"
163 set status 1
164 }
165 if { $tol_bl > 0.2 } {
166 puts "Warning : BLUE light of additive color model RGB is invalid"
167 set status 1
168 }
169
170 if { $status != 0 } {
171 puts "Warning : Colors of default coordinate are not equal"
172 }
173
174 global stat
175 if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
176 set info [checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
177 set stat [lindex $info end]
178 if { ${stat} != 1 } {
179 puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
180 return $stat
181 } else {
182 puts "Point with valid color was found"
183 return $stat
184 }
185 } else {
186 set stat 1
187 }
188}
189
190
deb26df7
RL
191# Procedure to check if sequence of values in listval follows linear trend
192# adding the same delta on each step.
193#
194# The function does statistical estimation of the mean variation of the
195# values of the sequence, and dispersion, and returns true only if both
196# dispersion and deviation of the mean from expected delta are within
197# specified tolerance.
198#
199# If mean variation differs from expected delta on more than two dispersions,
200# the check fails and procedure raises error with specified message.
201#
202# Otherwise the procedure returns false meaning that more iterations are needed.
203# Note that false is returned in any case if length of listval is less than 3.
204#
205# See example of use to check memory leaks in bugs/caf/bug23489
206#
207proc checktrend {listval delta tolerance message} {
208 set nbval [llength $listval]
209 if { $nbval < 3} {
210 return 0
211 }
fa920fb1 212
deb26df7
RL
213 # calculate mean value
214 set mean 0.
215 set prev [lindex $listval 0]
216 foreach val [lrange $listval 1 end] {
217 set mean [expr $mean + ($val - $prev)]
218 set prev $val
219 }
9753e6de 220 set mean [expr $mean / ($nbval - 1)]
fa920fb1 221
deb26df7
RL
222 # calculate dispersion
223 set sigma 0.
224 set prev [lindex $listval 0]
225 foreach val [lrange $listval 1 end] {
226 set d [expr ($val - $prev) - $mean]
227 set sigma [expr $sigma + $d * $d]
228 set prev $val
229 }
9753e6de 230 set sigma [expr sqrt ($sigma / ($nbval - 2))]
fa920fb1 231
deb26df7
RL
232 puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"
233
234 # check if deviation is definitely too big
9753e6de 235 if { abs ($mean - $delta) > $tolerance + 2. * $sigma } {
deb26df7 236 puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
67a1064e 237 error "$message"
deb26df7
RL
238 }
239
240 # check if deviation is clearly within a range
241 return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
242}
74f764ba 243
244# Check if area of triangles is valid
245proc CheckTriArea {shape {eps 0}} {
246 upvar #0 $shape result
247 set area [triarea result $eps]
248 set t_area [lindex $area 0]
249 set g_area [expr abs([lindex $area 1])]
250 puts "area by triangles: $t_area"
251 puts "area by geometry: $g_area"
252 expr ($t_area - $g_area) / $g_area * 100
253}