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 | ||
13 | #set script_dir [file dirname [info script]]/script | |
14 | # if { [info exist WorkDirectory] == 0 } { | |
15 | # set WorkDirectory "/tmp" | |
16 | # if { [array get env TEMP] != "" } { | |
17 | # set WorkDirectory "$env(TEMP)" | |
18 | # } | |
19 | # } | |
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) |
29 | proc checkreal {name value expected tol_abs tol_rel} { | |
30 | if { abs ($value - $expected) > $tol_abs + $tol_rel * abs ($expected) } { | |
31 | puts "Error: $name = $value is not equal to expected $expected" | |
32 | } else { | |
33 | puts "Check of $name OK: value = $value, expected = $expected" | |
34 | } | |
35 | return | |
36 | } | |
37 | ||
f1aa2b62 | 38 | |
39 | ||
40 | # Procedure to check color in the point near default coordinate | |
41 | ||
42 | proc checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} { | |
43 | set x_start [expr ${coord_x} - 2] | |
44 | set y_start [expr ${coord_y} - 2] | |
45 | set mistake 0 | |
46 | set i 0 | |
47 | while { $mistake != 1 && $i <= 5 } { | |
48 | set j 0 | |
49 | while { $mistake != 1 && $j <= 5 } { | |
50 | set position_x [expr ${x_start} + $j] | |
51 | set position_y [expr ${y_start} + $i] | |
52 | puts $position_x | |
53 | puts $position_y | |
54 | global color2d | |
55 | if { [info exists color2d] } { | |
56 | set color [ QAAISGetPixelColor2d ${position_x} ${position_y} ] | |
57 | } else { | |
58 | set color [ QAGetPixelColor ${position_x} ${position_y} ] | |
59 | } | |
60 | regexp {RED +: +([-0-9.+eE]+)} $color full rd | |
61 | regexp {GREEN +: +([-0-9.+eE]+)} $color full gr | |
62 | regexp {BLUE +: +([-0-9.+eE]+)} $color full bl | |
63 | set rd_int [expr int($rd * 1.e+05)] | |
64 | set gr_int [expr int($gr * 1.e+05)] | |
65 | set bl_int [expr int($bl * 1.e+05)] | |
66 | ||
67 | if { $rd_ch != 0 } { | |
68 | set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch] | |
69 | } else { | |
70 | set tol_rd $rd_int | |
71 | } | |
72 | if { $gr_ch != 0 } { | |
73 | set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch] | |
74 | } else { | |
75 | set tol_gr $gr_int | |
76 | } | |
77 | if { $bl_ch != 0 } { | |
78 | set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch] | |
79 | } else { | |
80 | set tol_bl $bl_int | |
81 | } | |
82 | ||
83 | if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } { | |
84 | puts "Warning : Point with true color was not found near default coordinates" | |
85 | set mistake 0 | |
86 | } else { | |
87 | set mistake 1 | |
88 | } | |
89 | incr j | |
90 | } | |
91 | incr i | |
92 | } | |
93 | return $mistake | |
94 | } | |
95 | ||
96 | # Procedure to check color using command QAgetPixelColor with tolerance | |
97 | proc checkcolor { coord_x coord_y rd_get gr_get bl_get } { | |
98 | puts "Coordinate x = $coord_x" | |
99 | puts "Coordinate y = $coord_y" | |
100 | puts "RED color of RGB is $rd_get" | |
101 | puts "GREEN color of RGB is $gr_get" | |
102 | puts "BLUE color of RGB is $bl_get" | |
103 | ||
104 | if { $coord_x <= 1 || $coord_y <= 1 } { | |
105 | puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y" | |
106 | return -1 | |
107 | } | |
108 | global color2d | |
109 | if { [info exists color2d] } { | |
110 | set color [ QAAISGetPixelColor2d ${coord_x} ${coord_y} ] | |
111 | } else { | |
112 | set color [ QAGetPixelColor ${coord_x} ${coord_y} ] | |
113 | } | |
114 | ||
115 | regexp {RED +: +([-0-9.+eE]+)} $color full rd | |
116 | regexp {GREEN +: +([-0-9.+eE]+)} $color full gr | |
117 | regexp {BLUE +: +([-0-9.+eE]+)} $color full bl | |
118 | set rd_int [expr int($rd * 1.e+05)] | |
119 | set gr_int [expr int($gr * 1.e+05)] | |
120 | set bl_int [expr int($bl * 1.e+05)] | |
121 | set rd_ch [expr int($rd_get * 1.e+05)] | |
122 | set gr_ch [expr int($gr_get * 1.e+05)] | |
123 | set bl_ch [expr int($bl_get * 1.e+05)] | |
124 | ||
125 | if { $rd_ch != 0 } { | |
126 | set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch] | |
127 | } else { | |
128 | set tol_rd $rd_int | |
129 | } | |
130 | if { $gr_ch != 0 } { | |
131 | set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch] | |
132 | } else { | |
133 | set tol_gr $gr_int | |
134 | } | |
135 | if { $bl_ch != 0 } { | |
136 | set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch] | |
137 | } else { | |
138 | set tol_bl $bl_int | |
139 | } | |
140 | set status 0 | |
141 | if { $tol_rd > 0.2 } { | |
142 | puts "Warning : RED light of additive color model RGB is invalid" | |
143 | set status 1 | |
144 | } | |
145 | if { $tol_gr > 0.2 } { | |
146 | puts "Warning : GREEN light of additive color model RGB is invalid" | |
147 | set status 1 | |
148 | } | |
149 | if { $tol_bl > 0.2 } { | |
150 | puts "Warning : BLUE light of additive color model RGB is invalid" | |
151 | set status 1 | |
152 | } | |
153 | ||
154 | if { $status != 0 } { | |
155 | puts "Warning : Colors of default coordinate are not equal" | |
156 | } | |
157 | ||
158 | global stat | |
159 | if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } { | |
160 | set info [checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch] | |
161 | set stat [lindex $info end] | |
162 | if { ${stat} != 1 } { | |
163 | puts "Error : Colors are not equal in default coordinate and in the near coordinates too" | |
164 | return $stat | |
165 | } else { | |
166 | puts "Point with valid color was found" | |
167 | return $stat | |
168 | } | |
169 | } else { | |
170 | set stat 1 | |
171 | } | |
172 | } | |
173 | ||
174 | ||
deb26df7 RL |
175 | # Procedure to check if sequence of values in listval follows linear trend |
176 | # adding the same delta on each step. | |
177 | # | |
178 | # The function does statistical estimation of the mean variation of the | |
179 | # values of the sequence, and dispersion, and returns true only if both | |
180 | # dispersion and deviation of the mean from expected delta are within | |
181 | # specified tolerance. | |
182 | # | |
183 | # If mean variation differs from expected delta on more than two dispersions, | |
184 | # the check fails and procedure raises error with specified message. | |
185 | # | |
186 | # Otherwise the procedure returns false meaning that more iterations are needed. | |
187 | # Note that false is returned in any case if length of listval is less than 3. | |
188 | # | |
189 | # See example of use to check memory leaks in bugs/caf/bug23489 | |
190 | # | |
191 | proc checktrend {listval delta tolerance message} { | |
192 | set nbval [llength $listval] | |
193 | if { $nbval < 3} { | |
194 | return 0 | |
195 | } | |
fa920fb1 | 196 | |
deb26df7 RL |
197 | # calculate mean value |
198 | set mean 0. | |
199 | set prev [lindex $listval 0] | |
200 | foreach val [lrange $listval 1 end] { | |
201 | set mean [expr $mean + ($val - $prev)] | |
202 | set prev $val | |
203 | } | |
204 | set mean [expr $mean / $nbval] | |
fa920fb1 | 205 | |
deb26df7 RL |
206 | # calculate dispersion |
207 | set sigma 0. | |
208 | set prev [lindex $listval 0] | |
209 | foreach val [lrange $listval 1 end] { | |
210 | set d [expr ($val - $prev) - $mean] | |
211 | set sigma [expr $sigma + $d * $d] | |
212 | set prev $val | |
213 | } | |
214 | set sigma [expr sqrt ($sigma / ($nbval - 1))] | |
fa920fb1 | 215 | |
deb26df7 RL |
216 | puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma" |
217 | ||
218 | # check if deviation is definitely too big | |
219 | if { abs ($mean - $delta) > 2. * $sigma } { | |
220 | puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta" | |
221 | error $message | |
222 | } | |
223 | ||
224 | # check if deviation is clearly within a range | |
225 | return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance] | |
226 | } |