Adding test cases from chl grid
[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
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
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)
29proc 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
42proc 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
97proc 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#
191proc 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}