Commit | Line | Data |
---|---|---|
fa920fb1 | 1 | # File : begin |
2 | if { [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 | |
11 | cpulimit 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 | |
16 | if { [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 | |
21 | if { [info exists imagedir] == 0 } { | |
22 | set imagedir . | |
23 | } | |
24 | if { [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 | 29 | help checkreal {name value expected tol_abs tol_rel} |
c2f5c748 | 30 | proc 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) |
40 | help checkarea {shape area_expected tol_abs tol_rel} | |
41 | proc 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 | ||
58 | proc 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 } { | |
302f96fb | 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 | |
f1aa2b62 | 108 | } |
109 | return $mistake | |
110 | } | |
111 | ||
112 | # Procedure to check color using command QAgetPixelColor with tolerance | |
113 | proc 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 } { | |
302f96fb | 121 | puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y" |
122 | return -1 | |
f1aa2b62 | 123 | } |
124 | global color2d | |
302f96fb | 125 | if { [info exists color2d] } { |
126 | set color [ QAAISGetPixelColor2d ${coord_x} ${coord_y} ] | |
127 | } else { | |
128 | set color [ QAGetPixelColor ${coord_x} ${coord_y} ] | |
129 | } | |
f1aa2b62 | 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 } { | |
302f96fb | 142 | set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch] |
f1aa2b62 | 143 | } else { |
302f96fb | 144 | set tol_rd $rd_int |
f1aa2b62 | 145 | } |
146 | if { $gr_ch != 0 } { | |
302f96fb | 147 | set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch] |
f1aa2b62 | 148 | } else { |
302f96fb | 149 | set tol_gr $gr_int |
f1aa2b62 | 150 | } |
151 | if { $bl_ch != 0 } { | |
302f96fb | 152 | set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch] |
f1aa2b62 | 153 | } else { |
302f96fb | 154 | set tol_bl $bl_int |
f1aa2b62 | 155 | } |
156 | set status 0 | |
157 | if { $tol_rd > 0.2 } { | |
302f96fb | 158 | puts "Warning : RED light of additive color model RGB is invalid" |
159 | set status 1 | |
f1aa2b62 | 160 | } |
161 | if { $tol_gr > 0.2 } { | |
302f96fb | 162 | puts "Warning : GREEN light of additive color model RGB is invalid" |
163 | set status 1 | |
f1aa2b62 | 164 | } |
165 | if { $tol_bl > 0.2 } { | |
302f96fb | 166 | puts "Warning : BLUE light of additive color model RGB is invalid" |
167 | set status 1 | |
f1aa2b62 | 168 | } |
169 | ||
170 | if { $status != 0 } { | |
302f96fb | 171 | puts "Warning : Colors of default coordinate are not equal" |
f1aa2b62 | 172 | } |
173 | ||
174 | global stat | |
175 | if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } { | |
302f96fb | 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 | } | |
f1aa2b62 | 185 | } else { |
302f96fb | 186 | set stat 1 |
f1aa2b62 | 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 | # | |
207 | proc 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 | |
245 | proc 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 | } |