0025945: Make stable checking of shape global properties in tests
[occt.git] / src / DrawResources / CheckCommands.tcl
1 # Copyright (c) 2013-2014 OPEN CASCADE SAS
2 #
3 # This file is part of Open CASCADE Technology software library.
4 #
5 # This library is free software; you can redistribute it and/or modify it under
6 # the terms of the GNU Lesser General Public License version 2.1 as published
7 # by the Free Software Foundation, with special exception defined in the file
8 # OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
9 # distribution for complete text of the license and disclaimer of any warranty.
10 #
11 # Alternatively, this file may be used under the terms of Open CASCADE
12 # commercial license or contractual agreement.
13
14 ############################################################################
15 # This file defines scripts for verification of OCCT tests.
16 # It provides top-level commands starting with 'check'.
17 # Type 'help check*' to get their synopsys.
18 # See OCCT Tests User Guide for description of the test system.
19 #
20 # Note: procedures with names starting with underscore are for internal use
21 # inside the test system.
22 ############################################################################
23
24 help checkcolor {
25   Check pixel color.
26   Use: checkcolor x y red green blue
27   x y - pixel coordinates
28   red green blue - expected pixel color (values from 0 to 1)
29   Function check color with tolerance (5x5 area)
30 }
31 # Procedure to check color using command vreadpixel with tolerance
32 proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
33     puts "Coordinate x = $coord_x"
34     puts "Coordinate y = $coord_y"
35     puts "RED color of RGB is $rd_get"
36     puts "GREEN color of RGB is $gr_get"
37     puts "BLUE color of RGB is $bl_get"
38
39     if { $coord_x <= 1 || $coord_y <= 1 } {
40       puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
41       return -1
42     }
43
44     set color ""
45     catch { [set color "[vreadpixel ${coord_x} ${coord_y} rgb]"] }
46     if {"$color" == ""} {
47       puts "Error : Pixel coordinates (${position_x}; ${position_y}) are out of view"
48     }
49     set rd [lindex $color 0]
50     set gr [lindex $color 1]
51     set bl [lindex $color 2]
52     set rd_int [expr int($rd * 1.e+05)]
53     set gr_int [expr int($gr * 1.e+05)]
54     set bl_int [expr int($bl * 1.e+05)]
55     set rd_ch [expr int($rd_get * 1.e+05)]
56     set gr_ch [expr int($gr_get * 1.e+05)]
57     set bl_ch [expr int($bl_get * 1.e+05)]
58
59     if { $rd_ch != 0 } {
60       set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
61     } else {
62       set tol_rd $rd_int
63     }
64     if { $gr_ch != 0 } {
65       set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
66     } else {
67       set tol_gr $gr_int
68     }
69     if { $bl_ch != 0 } {
70       set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
71     } else {
72       set tol_bl $bl_int
73     }
74
75     set status 0
76     if { $tol_rd > 0.2 } {
77       puts "Warning : RED light of additive color model RGB is invalid"
78       set status 1
79     }
80     if { $tol_gr > 0.2 } {
81       puts "Warning : GREEN light of additive color model RGB is invalid"
82       set status 1
83     }
84     if { $tol_bl > 0.2 } {
85       puts "Warning : BLUE light of additive color model RGB is invalid"
86       set status 1
87     }
88
89     if { $status != 0 } {
90       puts "Warning : Colors of default coordinate are not equal"
91     }
92
93     global stat
94     if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
95       set info [_checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
96       set stat [lindex $info end]
97       if { ${stat} != 1 } {
98           puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
99           return $stat
100       } else {
101           puts "Point with valid color was found"
102           return $stat
103       }
104     } else {
105       set stat 1
106     }
107 }
108
109 # Procedure to check color in the point near default coordinate
110 proc _checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
111     set x_start [expr ${coord_x} - 2]
112     set y_start [expr ${coord_y} - 2]
113     set mistake 0
114     set i 0
115     while { $mistake != 1 && $i <= 5 } {
116       set j 0
117       while { $mistake != 1 && $j <= 5 } {
118           set position_x [expr ${x_start} + $j]
119           set position_y [expr ${y_start} + $i]
120           puts $position_x
121           puts $position_y
122
123           set color ""
124           catch { [set color "[vreadpixel ${position_x} ${position_y} rgb]"] }
125           if {"$color" == ""} {
126             puts "Warning : Pixel coordinates (${position_x}; ${position_y}) are out of view"
127             incr j
128             continue
129           }
130           set rd [lindex $color 0]
131           set gr [lindex $color 1]
132           set bl [lindex $color 2]
133           set rd_int [expr int($rd * 1.e+05)]
134           set gr_int [expr int($gr * 1.e+05)]
135           set bl_int [expr int($bl * 1.e+05)]
136
137           if { $rd_ch != 0 } {
138             set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
139           } else {
140             set tol_rd $rd_int
141           }
142           if { $gr_ch != 0 } {
143             set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
144           } else {
145             set tol_gr $gr_int
146           }
147           if { $bl_ch != 0 } {
148             set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
149           } else {
150             set tol_bl $bl_int
151           }
152
153           if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
154             puts "Warning : Point with true color was not found near default coordinates"
155             set mistake 0
156           } else {
157             set mistake 1
158           }
159           incr j
160       }
161       incr i
162     }
163     return $mistake
164 }
165
166 # auxiliary: check argument
167 proc _check_arg {check_name check_result {get_value 0}} {
168   upvar ${check_result} ${check_result}
169   upvar arg arg
170   upvar narg narg
171   upvar args args
172   if { $arg == ${check_name} } {
173     if {${get_value}} {
174       incr narg
175       if { $narg < [llength $args] && ! [regexp {^-[^0-9]} [lindex $args $narg]] } {
176         set ${check_result} "[lindex $args $narg]"
177       } else {
178         error "Option ${check_result} requires argument"
179       }
180     } else {
181       set ${check_result} 1
182     }
183     return 1
184   }
185   return 0
186 }
187
188 help checknbshapes {
189   Compare number of sub-shapes in "shape" with given reference data
190
191   Use: checknbshapes shape [options...]
192   Allowed options are:
193     -vertex N
194     -edge N
195     -wire N
196     -face N
197     -shell N
198     -solid N
199     -compsolid N
200     -compound N
201     -shape N
202     -t: compare the number of sub-shapes in "shape" counting
203         the same sub-shapes with different location as different sub-shapes.
204     -m msg: print "msg" in case of error
205     -ref [nbshapes a]: compare the number of sub-shapes in "shape" and in "a".
206                        -vertex N, -edge N and other options are stil working.
207 }
208 proc checknbshapes {shape args} {
209   puts "checknbshapes ${shape} ${args}"
210   upvar ${shape} ${shape}
211
212   set nbVERTEX -1
213   set nbEDGE -1
214   set nbWIRE -1
215   set nbFACE -1
216   set nbSHELL -1
217   set nbSOLID -1
218   set nbCOMPSOLID -1
219   set nbCOMPOUND -1
220   set nbSHAPE -1
221
222   set message ""
223   set count_locations 0
224   set ref_info ""
225
226   for {set narg 0} {$narg < [llength $args]} {incr narg} {
227     set arg [lindex $args $narg]
228     if {[_check_arg "-vertex" nbVERTEX 1] ||
229         [_check_arg "-edge" nbEDGE 1] ||
230         [_check_arg "-wire" nbWIRE 1] ||
231         [_check_arg "-face" nbFACE 1] ||
232         [_check_arg "-shell" nbSHELL 1] ||
233         [_check_arg "-solid" nbSOLID 1] ||
234         [_check_arg "-compsolid" nbCOMPSOLID 1] ||
235         [_check_arg "-compound" nbCOMPOUND 1] ||
236         [_check_arg "-shape" nbSHAPE 1] ||
237         [_check_arg "-t" count_locations] ||
238         [_check_arg "-m" message 1] ||
239         [_check_arg "-ref" ref_info 1]
240        } {
241       continue
242     }
243     # unsupported option
244     if { [regexp {^-} $arg] } {
245       error "Error: unsupported option \"$arg\""
246     }
247     error "Error: cannot interpret argument $narg ($arg)"
248   }
249
250   if { ${count_locations} == 0 } {
251     set nb_info [nbshapes ${shape}]
252   } else {
253     set nb_info [nbshapes ${shape} -t]
254   }
255
256   set EntityList {VERTEX EDGE WIRE FACE SHELL SOLID COMPSOLID COMPOUND SHAPE}
257
258   foreach Entity ${EntityList} {
259     set expr_string "${Entity} +: +(\[-0-9.+eE\]+)"
260     set to_compare {}
261     # get number of elements from ${shape}
262     if { [regexp "${expr_string}" ${nb_info} full nb_entity2] } {
263       lappend to_compare ${nb_entity2}
264     } else {
265       error "Error : command \"nbshapes ${shape}\" gives an empty result"
266     }
267     # get number of elements from options -vertex -edge and so on
268     set nb_entity1 [set nb${Entity}]
269     if { ${nb_entity1} != -1 } {
270       lappend to_compare ${nb_entity1}
271     }
272     # get number of elements from option -ref
273     if { [regexp "${expr_string}" ${ref_info} full nb_entity_ref] } {
274       lappend to_compare ${nb_entity_ref}
275     }
276     # skip comparing if no reference data was given
277     if {[llength $to_compare] == 1} {
278       continue
279     }
280     # compare all values, if they are equal, length of sorted list "to_compare"
281     # (with key -unique) should be equal to 1
282     set to_compare [lsort -dictionary -unique $to_compare]
283     if { [llength $to_compare] != 1 } {
284       puts "Error : ${message} is WRONG because number of ${Entity} entities in shape \"${shape}\" is ${nb_entity2}"
285     } else {
286       puts "OK : ${message} is GOOD because number of ${Entity} entities is equal to number of expected ${Entity} entities"
287     }
288   }
289 }
290
291 # Procedure to check equality of two reals with tolerance (relative and absolute)
292 help checkreal {
293   Compare value with expected
294   Use: checkreal name value expected tol_abs tol_rel
295 }
296 proc checkreal {name value expected tol_abs tol_rel} {
297     if { abs ($value - $expected) > $tol_abs + $tol_rel * abs ($expected) } {
298         puts "Error: $name = $value is not equal to expected $expected"
299     } else {
300         puts "Check of $name OK: value = $value, expected = $expected"
301     }
302     return
303 }
304
305 help checkfreebounds {
306   Compare number of free edges with ref_value
307
308   Use: checkfreebounds shape ref_value [options...]
309   Allowed options are:
310     -tol N: used tolerance (default -0.01)
311     -type N: used type, possible values are "closed" and "opened" (default "closed")
312 }
313 proc checkfreebounds {shape ref_value args} {
314   puts "checkfreebounds ${shape} ${ref_value} ${args}"
315   upvar ${shape} ${shape}
316
317   set tol -0.01
318   set type "closed"
319
320   for {set narg 0} {$narg < [llength $args]} {incr narg} {
321     set arg [lindex $args $narg]
322     if {[_check_arg "-tol" tol 1] ||
323         [_check_arg "-type" type 1]
324        } {
325       continue
326     }
327     # unsupported option
328     if { [regexp {^-} $arg] } {
329       error "Error: unsupported option \"$arg\""
330     }
331     error "Error: cannot interpret argument $narg ($arg)"
332   }
333
334   if {"$type" != "closed" && "$type" != "opened"} {
335     error "Error : wrong -type key \"${type}\""
336   }
337
338   freebounds ${shape} ${tol}
339   set free_edges [llength [explode ${shape}_[string range $type 0 0] e]]
340
341   if { ${ref_value} == -1 } {
342     puts "Error : Number of free edges is UNSTABLE"
343     return
344   }
345
346   if { ${free_edges} != ${ref_value} } {
347     puts "Error : Number of free edges is not equal to reference data"
348   } else {
349     puts "OK : Number of free edges is ${free_edges}"
350   }
351 }
352
353 help checkmaxtol {
354   Compare max tolerance of shape with reference value.
355   Command returns max tolerance of the shape.
356
357   Use: checkmaxtol shape [options...]
358   Allowed options are:
359     -ref: reference value of maximum tolerance.
360     -source: list of shapes to compare with, e.g.: -source {shape1 shape2 shape3}
361     -min_tol: minimum tolerance for comparison.
362     -multi_tol: tolerance multiplier.
363 }
364
365 proc checkmaxtol {shape args} {
366   puts "checkmaxtol ${shape} ${args}"
367   upvar ${shape} ${shape}
368
369   set ref_value ""
370   set source_shapes {}
371   set min_tol 0
372   set tol_multiplier 0
373
374   # check arguments
375   for {set narg 0} {$narg < [llength $args]} {incr narg} {
376     set arg [lindex $args $narg]
377     if {[_check_arg "-min_tol" min_tol 1] ||
378         [_check_arg "-multi_tol" tol_multiplier 1] ||
379         [_check_arg "-source" source_shapes 1] ||
380         [_check_arg "-ref" ref_value 1]
381        } {
382       continue
383     }
384     # unsupported option
385     if { [regexp {^-} $arg] } {
386       error "Error: unsupported option \"$arg\""
387     }
388     error "Error: cannot interpret argument $narg ($arg)"
389   }
390
391   # get max tol of shape
392   set max_tol 0
393   if {[regexp "Tolerance MAX=(\[-0-9.+eE\]+)" [tolerance ${shape}] full maxtol_temp]} {
394     set max_tol ${maxtol_temp}
395   } else {
396     error "Error: cannot get tolerances of shape \"${shape}\""
397   }
398
399   # find max tol of source shapes
400   foreach source_shape ${source_shapes} {
401     upvar ${source_shape} ${source_shape}
402     set _src_max_tol [checkmaxtol ${source_shape}]
403     if { [expr ${_src_max_tol} > ${min_tol} ] } {
404       set min_tol ${_src_max_tol}
405     }
406   }
407   # apply -multi_tol option
408   if {${tol_multiplier}} {
409     set min_tol [expr ${tol_multiplier} * ${_src_max_tol}]
410   }
411   # compare max tol of source shapes with checking tolerance
412   if { ${min_tol} && [expr ${max_tol} > ${min_tol}] } {
413     puts "Error: tolerance of \"${shape}\" (${max_tol}) is greater than checking tolerance (${min_tol})"
414   }
415   if { ${ref_value} != "" } {
416     checkreal "Max tolerance" ${max_tol} ${ref_value} 0.0001 0.01
417   }
418   return ${max_tol}
419 }
420
421 help checkfaults {
422   Compare faults number of given shapes.
423
424   Use: checkfaults shape source_shape [ref_value=0]
425 }
426 proc checkfaults {shape source_shape {ref_value 0}} {
427   puts "checkfaults ${shape} ${source_shape} ${ref_value}"
428   upvar $shape $shape
429   upvar $source_shape $source_shape
430   set cs_a [checkshape $source_shape]
431   set nb_a 0
432   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_a full nb_a_begin nb_a_end]} {
433     set nb_a [expr $nb_a_end - $nb_a_begin +1]
434   }
435   set cs_r [checkshape $shape]
436   set nb_r 0
437   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_r full nb_r_begin nb_r_end]} {
438     set nb_r [expr $nb_r_end - $nb_r_begin +1]
439   }
440   puts "Number of faults for the initial shape is $nb_a."
441   puts "Number of faults for the resulting shape is $nb_r."
442
443   if { ${ref_value} == -1 } {
444     puts "Error : Number of faults is UNSTABLE"
445     return
446   }
447
448   if { $nb_r > $nb_a } {
449     puts "Error : Number of faults is $nb_r"
450   }
451 }
452
453 # auxiliary: check all arguments
454 proc _check_args { args {options {}} {command_name ""}} {
455   # check arguments
456   for {set narg 0} {${narg} < [llength ${args}]} {incr narg} {
457     set arg [lindex ${args} ${narg}]
458     set toContinue 0
459     foreach option ${options} {
460       set option_name            [lindex ${option} 0]
461       set variable_to_save_value [lindex ${option} 1]
462       set get_value              [lindex ${option} 2]
463       set local_value ""
464       if { [_check_arg ${option_name} local_value ${get_value}] } {
465         upvar ${variable_to_save_value} ${variable_to_save_value}
466         set ${variable_to_save_value} ${local_value}
467         set toContinue 1
468       }
469     }
470     if {${toContinue}} { continue }
471     # unsupported option
472     if { [regexp {^-} ${arg}] } {
473       error "Error: unsupported option \"${arg}\""
474     }
475     error "Error: cannot interpret argument ${narg} (${arg})"
476   }
477   foreach option ${options} {
478     set option_name            [lindex ${option} 0]
479     set variable_to_save_value [lindex ${option} 1]
480     set should_exist           [lindex ${option} 3]
481     if {![info exists ${variable_to_save_value}] && ${should_exist} == 1} {
482       error "Error: wrong using of command '${command_name}', '${option_name}' option is required"
483     }
484   }
485 }
486
487 help checkprops {
488   Procedure includes commands to compute length, area and volume of input shape.
489
490   Use: checkprops shapename [options...]
491   Allowed options are:
492     -l LENGTH: command lprops, computes the mass properties of all edges in the shape with a linear density of 1
493     -s AREA: command sprops, computes the mass properties of all faces with a surface density of 1 
494     -v VOLUME: command vprops, computes the mass properties of all solids with a density of 1
495     -eps EPSILON: the epsilon defines relative precision of computation
496     -equal SHAPE: compare area\volume\length of input shapes. Puts error if its are not equal
497     -notequal SHAPE: compare area\volume\length of input shapes. Puts error if its are equal
498   Options -l, -s and -v are independent and can be used in any order. Tolerance epsilon is the same for all options.
499 }
500
501 proc checkprops {shape args} {
502     puts "checkprops ${shape} ${args}"
503     upvar ${shape} ${shape}
504
505     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
506         puts "Error: The command cannot be built"
507         return
508     }
509
510     set length -1
511     set area -1
512     set volume -1
513     set epsilon 1.0e-4
514     set compared_equal_shape -1
515     set compared_notequal_shape -1
516     set equal_check 0
517
518     set options {{"-eps" epsilon 1}
519                  {"-equal" compared_equal_shape 1}
520                  {"-notequal" compared_notequal_shape 1}}
521
522     if { [regexp {\-[not]*equal} $args] } {
523         lappend options {"-s" area 0}
524         lappend options {"-l" length 0}
525         lappend options {"-v" volume 0}
526         set equal_check 1
527     } else {
528         lappend options {"-s" area 1}
529         lappend options {"-l" length 1}
530         lappend options {"-v" volume 1}
531     }
532     _check_args ${args} ${options} "checkprops"
533
534     if { ${length} != -1 || ${equal_check} == 1 } {
535         set CommandName lprops
536         set mass $length
537         set prop "length"
538         set equal_check 0
539     }
540     if { ${area} != -1 || ${equal_check} == 1 } {
541         set CommandName sprops
542         set mass $area
543         set prop "area"
544         set equal_check 0
545     }
546     if { ${volume} != -1 || ${equal_check} == 1 } {
547         set CommandName vprops
548         set mass $volume
549         set prop "volume"
550         set equal_check 0
551     }
552     
553     regexp {Mass +: +([-0-9.+eE]+)} [${CommandName} ${shape} ${epsilon}] full m
554
555     if { ${compared_equal_shape} != -1 } {
556         upvar ${compared_equal_shape} ${compared_equal_shape}
557         regexp {Mass +: +([-0-9.+eE]+)} [${CommandName} ${compared_equal_shape} ${epsilon}] full compared_m
558         if { $compared_m != $m } {
559             puts "Error: Shape ${compared_equal_shape} is not equal to shape ${shape}"
560         }
561     }
562
563     if { ${compared_notequal_shape} != -1 } {
564         upvar ${compared_notequal_shape} ${compared_notequal_shape}
565         regexp {Mass +: +([-0-9.+eE]+)} [${CommandName} ${compared_notequal_shape} ${epsilon}] full compared_m
566         if { $compared_m == $m } {
567             puts "Error: Shape ${compared_notequal_shape} is equal shape to ${shape}"
568         }
569     }
570
571     if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
572         if { [string compare "$mass" "empty"] != 0 } {
573             if { $m == 0 } {
574                 puts "Error : The command is not valid. The $prop is 0."
575             }
576             if { $mass > 0 } {
577                 puts "The expected $prop is $mass"
578             }
579             #check of change of area is < 1%
580             if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } {
581                 puts "Error : The $prop of result shape is $m"
582             }
583         } else {
584             if { $m != 0 } {
585                 puts "Error : The command is not valid. The $prop is $m"
586             }
587         }
588     }
589 }