0022898: IGES import fails in german environment
[occt.git] / tests / bugs / begin
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
28 # Procedure to check equality of two reals with tolerance (relative and absolute)
29 help checkreal {name value expected tol_abs tol_rel}
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
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     }
51
52     # compare with expected value
53     checkreal "area of $shape" $area $area_expected $tol_abs $tol_rel
54 }
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 } {
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
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 } {
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
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     }
212
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     }
220     set mean [expr $mean / $nbval]
221
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     }
230     set sigma [expr sqrt ($sigma / ($nbval - 1))]
231
232     puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"
233
234     # check if deviation is definitely too big
235     if { abs ($mean - $delta) > 2. * $sigma } {
236         puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
237         error $message
238     }
239
240     # check if deviation is clearly within a range
241     return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
242 }