0029247: Tests, CheckCommands.tcl - Tcl exception "expected integer but got 3dviewer...
[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       set next_arg_index [expr $narg + 1]
175       if { $next_arg_index < [llength $args] && ! [regexp {^-[^0-9]} [lindex $args $next_arg_index]] } {
176         set ${check_result} "[lindex $args $next_arg_index]"
177         set narg ${next_arg_index}
178       } else {
179         set ${check_result} "true"
180       }
181     } elseif {${get_value}} {
182       incr narg
183       if { $narg < [llength $args] && ! [regexp {^-[^0-9]} [lindex $args $narg]] } {
184         set ${check_result} "[lindex $args $narg]"
185       } else {
186         error "Option ${check_result} requires argument"
187       }
188     } else {
189       set ${check_result} "true"
190     }
191     return 1
192   }
193   return 0
194 }
195
196 help checknbshapes {
197   Compare number of sub-shapes in "shape" with given reference data
198
199   Use: checknbshapes shape [options...]
200   Allowed options are:
201     -vertex N
202     -edge N
203     -wire N
204     -face N
205     -shell N
206     -solid N
207     -compsolid N
208     -compound N
209     -shape N
210     -t: compare the number of sub-shapes in "shape" counting
211         the same sub-shapes with different location as different sub-shapes.
212     -m msg: print "msg" in case of error
213     -ref [nbshapes a]: compare the number of sub-shapes in "shape" and in "a".
214                        -vertex N, -edge N and other options are stil working.
215 }
216 proc checknbshapes {shape args} {
217   puts "checknbshapes ${shape} ${args}"
218   upvar ${shape} ${shape}
219
220   set nbVERTEX -1
221   set nbEDGE -1
222   set nbWIRE -1
223   set nbFACE -1
224   set nbSHELL -1
225   set nbSOLID -1
226   set nbCOMPSOLID -1
227   set nbCOMPOUND -1
228   set nbSHAPE -1
229
230   set message ""
231   set count_locations 0
232   set ref_info ""
233
234   for {set narg 0} {$narg < [llength $args]} {incr narg} {
235     set arg [lindex $args $narg]
236     if {[_check_arg "-vertex" nbVERTEX 1] ||
237         [_check_arg "-edge" nbEDGE 1] ||
238         [_check_arg "-wire" nbWIRE 1] ||
239         [_check_arg "-face" nbFACE 1] ||
240         [_check_arg "-shell" nbSHELL 1] ||
241         [_check_arg "-solid" nbSOLID 1] ||
242         [_check_arg "-compsolid" nbCOMPSOLID 1] ||
243         [_check_arg "-compound" nbCOMPOUND 1] ||
244         [_check_arg "-shape" nbSHAPE 1] ||
245         [_check_arg "-t" count_locations] ||
246         [_check_arg "-m" message 1] ||
247         [_check_arg "-ref" ref_info 1]
248        } {
249       continue
250     }
251     # unsupported option
252     if { [regexp {^-} $arg] } {
253       error "Error: unsupported option \"$arg\""
254     }
255     error "Error: cannot interpret argument $narg ($arg)"
256   }
257
258   if { ${count_locations} == 0 } {
259     set nb_info [nbshapes ${shape}]
260   } else {
261     set nb_info [nbshapes ${shape} -t]
262   }
263
264   set EntityList {VERTEX EDGE WIRE FACE SHELL SOLID COMPSOLID COMPOUND SHAPE}
265
266   foreach Entity ${EntityList} {
267     set expr_string "${Entity} +: +(\[-0-9.+eE\]+)"
268     set to_compare {}
269     # get number of elements from ${shape}
270     if { [regexp "${expr_string}" ${nb_info} full nb_entity2] } {
271       lappend to_compare ${nb_entity2}
272     } else {
273       error "Error : command \"nbshapes ${shape}\" gives an empty result"
274     }
275     # get number of elements from options -vertex -edge and so on
276     set nb_entity1 [set nb${Entity}]
277     if { ${nb_entity1} != -1 } {
278       lappend to_compare ${nb_entity1}
279     }
280     # get number of elements from option -ref
281     if { [regexp "${expr_string}" ${ref_info} full nb_entity_ref] } {
282       lappend to_compare ${nb_entity_ref}
283     }
284     # skip comparing if no reference data was given
285     if {[llength $to_compare] == 1} {
286       continue
287     }
288     # compare all values, if they are equal, length of sorted list "to_compare"
289     # (with key -unique) should be equal to 1
290     set to_compare [lsort -dictionary -unique $to_compare]
291     if { [llength $to_compare] != 1 } {
292       puts "Error : ${message} is WRONG because number of ${Entity} entities in shape \"${shape}\" is ${nb_entity2}"
293     } else {
294       puts "OK : ${message} is GOOD because number of ${Entity} entities is equal to number of expected ${Entity} entities"
295     }
296   }
297 }
298
299 # Procedure to check equality of two reals with tolerance (relative and absolute)
300 help checkreal {
301   Compare value with expected
302   Use: checkreal name value expected tol_abs tol_rel
303 }
304 proc checkreal {name value expected tol_abs tol_rel} {
305     if { abs ($value - $expected) > $tol_abs + $tol_rel * abs ($expected) } {
306         puts "Error: $name = $value is not equal to expected $expected"
307     } else {
308         puts "Check of $name OK: value = $value, expected = $expected"
309     }
310     return
311 }
312
313 help checkfreebounds {
314   Compare number of free edges with ref_value
315
316   Use: checkfreebounds shape ref_value [options...]
317   Allowed options are:
318     -tol N: used tolerance (default -0.01)
319     -type N: used type, possible values are "closed" and "opened" (default "closed")
320 }
321 proc checkfreebounds {shape ref_value args} {
322   puts "checkfreebounds ${shape} ${ref_value} ${args}"
323   upvar ${shape} ${shape}
324
325   set tol -0.01
326   set type "closed"
327
328   for {set narg 0} {$narg < [llength $args]} {incr narg} {
329     set arg [lindex $args $narg]
330     if {[_check_arg "-tol" tol 1] ||
331         [_check_arg "-type" type 1]
332        } {
333       continue
334     }
335     # unsupported option
336     if { [regexp {^-} $arg] } {
337       error "Error: unsupported option \"$arg\""
338     }
339     error "Error: cannot interpret argument $narg ($arg)"
340   }
341
342   if {"$type" != "closed" && "$type" != "opened"} {
343     error "Error : wrong -type key \"${type}\""
344   }
345
346   freebounds ${shape} ${tol}
347   set free_edges [llength [explode ${shape}_[string range $type 0 0] e]]
348
349   if { ${ref_value} == -1 } {
350     puts "Error : Number of free edges is UNSTABLE"
351     return
352   }
353
354   if { ${free_edges} != ${ref_value} } {
355     puts "Error : Number of free edges is not equal to reference data"
356   } else {
357     puts "OK : Number of free edges is ${free_edges}"
358   }
359 }
360
361 help checkmaxtol {
362   Returns max tolerance of the shape and prints error message if specified
363   criteria are not satisfied.
364
365   Use: checkmaxtol shape [options...]
366
367   Options specify criteria for checking the maximal tolerance value:
368     -ref <value>: check it to be equal to reference value.
369     -min_tol <value>: check it to be not greater than specified value.
370     -source <list of shapes>: check it to be not greater than 
371             maximal tolerance of specified shape(s)
372     -multi_tol <value>: additional multiplier for value specified by -min_tol 
373                or -shapes options.
374 }
375
376 proc checkmaxtol {shape args} {
377   puts "checkmaxtol ${shape} ${args}"
378   upvar ${shape} ${shape}
379
380   set ref_value ""
381   set source_shapes {}
382   set min_tol 0
383   set tol_multiplier 0
384
385   # check arguments
386   for {set narg 0} {$narg < [llength $args]} {incr narg} {
387     set arg [lindex $args $narg]
388     if {[_check_arg "-min_tol" min_tol 1] ||
389         [_check_arg "-multi_tol" tol_multiplier 1] ||
390         [_check_arg "-source" source_shapes 1] ||
391         [_check_arg "-ref" ref_value 1]
392        } {
393       continue
394     }
395     # unsupported option
396     if { [regexp {^-} $arg] } {
397       error "Error: unsupported option \"$arg\""
398     }
399     error "Error: cannot interpret argument $narg ($arg)"
400   }
401
402   # get max tol of shape
403   set max_tol 0
404   if {[regexp "Tolerance MAX=(\[-0-9.+eE\]+)" [tolerance ${shape}] full maxtol_temp]} {
405     set max_tol ${maxtol_temp}
406   } else {
407     error "Error: cannot get tolerances of shape \"${shape}\""
408   }
409
410   # find max tol of source shapes
411   foreach source_shape ${source_shapes} {
412     upvar ${source_shape} ${source_shape}
413     set _src_max_tol [checkmaxtol ${source_shape}]
414     if { [expr ${_src_max_tol} > ${min_tol} ] } {
415       set min_tol ${_src_max_tol}
416     }
417   }
418   # apply -multi_tol option
419   if {${tol_multiplier}} {
420     set min_tol [expr ${tol_multiplier} * ${_src_max_tol}]
421   }
422   # compare max tol of source shapes with checking tolerance
423   if { ${min_tol} && [expr ${max_tol} > ${min_tol}] } {
424     puts "Error: tolerance of \"${shape}\" (${max_tol}) is greater than checking tolerance (${min_tol})"
425   }
426   if { ${ref_value} != "" } {
427     checkreal "Max tolerance" ${max_tol} ${ref_value} 0.0001 0.01
428   }
429   return ${max_tol}
430 }
431
432 help checkfaults {
433   Compare faults number of given shapes.
434
435   Use: checkfaults shape source_shape [ref_value=0]
436 }
437 proc checkfaults {shape source_shape {ref_value 0}} {
438   puts "checkfaults ${shape} ${source_shape} ${ref_value}"
439   upvar $shape $shape
440   upvar $source_shape $source_shape
441   set cs_a [checkshape $source_shape]
442   set nb_a 0
443   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_a full nb_a_begin nb_a_end]} {
444     set nb_a [expr $nb_a_end - $nb_a_begin +1]
445   }
446   set cs_r [checkshape $shape]
447   set nb_r 0
448   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_r full nb_r_begin nb_r_end]} {
449     set nb_r [expr $nb_r_end - $nb_r_begin +1]
450   }
451   puts "Number of faults for the initial shape is $nb_a."
452   puts "Number of faults for the resulting shape is $nb_r."
453
454   if { ${ref_value} == -1 } {
455     puts "Error : Number of faults is UNSTABLE"
456     return
457   }
458
459   if { $nb_r > $nb_a } {
460     puts "Error : Number of faults is $nb_r"
461   }
462 }
463
464 # auxiliary: check all arguments
465 proc _check_args { args {options {}} {command_name ""}} {
466   # check arguments
467   for {set narg 0} {${narg} < [llength ${args}]} {incr narg} {
468     set arg [lindex ${args} ${narg}]
469     set toContinue 0
470     foreach option ${options} {
471       set option_name            [lindex ${option} 0]
472       set variable_to_save_value [lindex ${option} 1]
473       set get_value              [lindex ${option} 2]
474       set local_value ""
475       if { [_check_arg ${option_name} local_value ${get_value}] } {
476         upvar 1 ${variable_to_save_value} ${variable_to_save_value}
477         set ${variable_to_save_value} ${local_value}
478         set toContinue 1
479       }
480     }
481     if {${toContinue}} { continue }
482     # unsupported option
483     if { [regexp {^-} ${arg}] } {
484       error "Error: unsupported option \"${arg}\""
485     }
486     error "Error: cannot interpret argument ${narg} (${arg})"
487   }
488   foreach option ${options} {
489     set option_name            [lindex ${option} 0]
490     set variable_to_save_value [lindex ${option} 1]
491     set should_exist           [lindex ${option} 3]
492     if {![info exists ${variable_to_save_value}] && ${should_exist} == 1} {
493       error "Error: wrong using of command '${command_name}', '${option_name}' option is required"
494     }
495   }
496 }
497
498 help checkprops {
499   Procedure includes commands to compute length, area and volume of input shape.
500
501   Use: checkprops shapename [options...]
502   Allowed options are:
503     -l LENGTH: command lprops, computes the mass properties of all edges in the shape with a linear density of 1
504     -s AREA: command sprops, computes the mass properties of all faces with a surface density of 1 
505     -v VOLUME: command vprops, computes the mass properties of all solids with a density of 1
506     -eps EPSILON: the epsilon defines relative precision of computation
507     -deps DEPSILON: the epsilon defines relative precision to compare corresponding values
508     -equal SHAPE: compare area\volume\length of input shapes. Puts error if its are not equal
509     -notequal SHAPE: compare area\volume\length of input shapes. Puts error if its are equal
510     -skip: count shared shapes only once, skipping repeatitions
511   Options -l, -s and -v are independent and can be used in any order. Tolerance epsilon is the same for all options.
512 }
513
514 proc checkprops {shape args} {
515     puts "checkprops ${shape} ${args}"
516     upvar ${shape} ${shape}
517
518     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
519         puts "Error: The command cannot be built"
520         return
521     }
522
523     set length -1
524     set area -1
525     set volume -1
526     set epsilon 1.0e-4
527     set compared_equal_shape -1
528     set compared_notequal_shape -1
529     set equal_check 0
530     set skip 0
531     set depsilon 1e-2
532
533     set options {{"-eps" epsilon 1}
534                  {"-equal" compared_equal_shape 1}
535                  {"-notequal" compared_notequal_shape 1}
536                  {"-skip" skip 0}
537                  {"-deps" depsilon 1}}
538
539     if { [regexp {\-[not]*equal} $args] } {
540         lappend options {"-s" area 0}
541         lappend options {"-l" length 0}
542         lappend options {"-v" volume 0}
543         set equal_check 1
544     } else {
545         lappend options {"-s" area 1}
546         lappend options {"-l" length 1}
547         lappend options {"-v" volume 1}
548     }
549     _check_args ${args} ${options} "checkprops"
550
551     if { ${length} != -1 || ${equal_check} == 1 } {
552         lappend CommandNames {lprops}
553         set equal_check 0
554     }
555     if { ${area} != -1 || ${equal_check} == 1 } {
556         lappend CommandNames {sprops}
557         set equal_check 0
558     }
559     if { ${volume} != -1 || ${equal_check} == 1 } {
560         lappend CommandNames {vprops}
561         set equal_check 0
562     }
563
564     set skip_option ""
565     if { $skip } {
566         set skip_option "-skip"
567     }
568     
569     foreach CommandName ${CommandNames} {
570         switch $CommandName {
571             "lprops"    { set mass ${length}; set prop "length" }
572             "sprops"    { set mass ${area}; set prop "area" }
573             "vprops"    { set mass ${volume}; set prop "volume" }
574         }
575         regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${shape} ${epsilon} $skip_option] full m
576
577         if { ${compared_equal_shape} != -1 } {
578             upvar ${compared_equal_shape} ${compared_equal_shape}
579             regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_equal_shape} ${epsilon} $skip_option] full compared_m
580             if { $compared_m != $m } {
581                 puts "Error: Shape ${compared_equal_shape} is not equal to shape ${shape}"
582             }
583         }
584
585         if { ${compared_notequal_shape} != -1 } {
586             upvar ${compared_notequal_shape} ${compared_notequal_shape}
587             regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_notequal_shape} ${epsilon} $skip_option] full compared_m
588             if { $compared_m == $m } {
589                 puts "Error: Shape ${compared_notequal_shape} is equal shape to ${shape}"
590             }
591         }
592
593         if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
594             if { [string compare "$mass" "empty"] != 0 } {
595                 if { $m == 0 } {
596                     puts "Error : The command is not valid. The $prop is 0."
597                 }
598                 if { $mass > 0 } {
599                     puts "The expected $prop is $mass"
600                 }
601                 #check of change of area is < 1%
602                 if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > $depsilon) || ($mass == 0 && $m != 0) } {
603                     puts "Error : The $prop of result shape is $m"
604                 }
605             } else {
606                 if { $m != 0 } {
607                     puts "Error : The command is not valid. The $prop is $m"
608                 }
609             }
610         }
611     }
612 }
613
614 help checkdump {
615   Procedure includes command to parse output dump and compare it with reference values.
616
617   Use: checkdump shapename [options...]
618   Allowed options are:
619     -name NAME: list of parsing parameters (e.g. Center, Axis, etc)
620     -ref VALUE: list of reference values for each parameter in NAME 
621     -eps EPSILON: the epsilon defines relative precision of computation
622 }
623
624 proc checkdump {shape args} {
625     puts "checkdump ${shape} ${args}"
626     upvar ${shape} ${shape}
627
628     set ddump -1
629     set epsilon -1
630     set options {{"-name" params 1}
631                  {"-ref" ref 1}
632                  {"-eps" epsilon 1}
633                  {"-dump" ddump 1}}
634
635     if { ${ddump} == -1 } {
636         set ddump [dump ${shape}]
637     }
638     _check_args ${args} ${options} "checkdump"
639
640     set index 0
641     foreach param ${params} {
642         set pattern "${param}\\s*:\\s*" 
643         set number_pattern "(\[-0-9.+eE\]+)\\s*" 
644         set ref_values ""
645         set local_ref ${ref}
646         if { [llength ${params}] > 1 } {
647             set local_ref [lindex ${ref} ${index}]
648         }
649         foreach item ${local_ref} {
650             if { ![regexp "$pattern$number_pattern" $ddump full res] } {
651                 puts "Error: cheked parameter ${param} is not listed in dump"
652                 break
653             }
654             lappend ref_values $res 
655             set pattern "${pattern}${res},\\s*" 
656             ## without precision
657             if { ${epsilon} == -1 } {
658                 if { ${item} != ${res} } {
659                     puts "Error: parameter ${param} - current value (${res}) is not equal to reference value (${item})"
660                 } else {
661                     puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
662                 }
663             ## with precision
664             } else {
665                 set precision 0.0000001
666                 if { ( abs($res) > $precision ) || ( abs($item) > $precision ) } {
667                     if { ($item != 0 && [expr 1.*abs($item - $res)/$item] > $epsilon) || ($item == 0 && $res != 0) } {
668                         puts "Error: The $param of the resulting shape is $res and the expected $param is $item"
669                     } else {
670                         puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
671                     }
672                 }
673             }
674         }
675         incr index
676     }
677 }
678
679 help checklength {
680   Procedure includes commands to compute length of input curve.
681
682   Use: checklength curvename [options...]
683   Allowed options are:
684     -l LENGTH: command length, computes the length of input curve with precision of computation
685     -eps EPSILON: the epsilon defines relative precision of computation
686     -equal CURVE: compare length of input curves. Puts error if its are not equal
687     -notequal CURVE: compare length of input curves. Puts error if its are equal
688 }
689
690 proc checklength {shape args} {
691     puts "checklength ${shape} ${args}"
692     upvar ${shape} ${shape}
693
694     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
695         puts "Error: The command cannot be built"
696         return
697     }
698
699     set length -1
700     set epsilon 1.0e-4
701     set compared_equal_shape -1
702     set compared_notequal_shape -1
703     set equal_check 0
704
705     set options {{"-eps" epsilon 1}
706                  {"-equal" compared_equal_shape 1}
707                  {"-notequal" compared_notequal_shape 1}}
708
709     if { [regexp {\-[not]*equal} $args] } {
710         lappend options {"-l" length 0}
711         set equal_check 1
712     } else {
713         lappend options {"-l" length 1}
714     }
715     _check_args ${args} ${options} "checkprops"
716
717     if { ${length} != -1 || ${equal_check} == 1 } {
718         set CommandName length
719         set mass $length
720         set prop "length"
721         set equal_check 0
722     }
723
724     regexp "The +length+ ${shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${shape} ${epsilon}] full m
725
726     if { ${compared_equal_shape} != -1 } {
727         upvar ${compared_equal_shape} ${compared_equal_shape}
728         regexp "The +length+ ${compared_equal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_equal_shape} ${epsilon}] full compared_m
729         if { $compared_m != $m } {
730             puts "Error: length of shape ${compared_equal_shape} is not equal to shape ${shape}"
731         }
732     }
733
734     if { ${compared_notequal_shape} != -1 } {
735         upvar ${compared_notequal_shape} ${compared_notequal_shape}
736         regexp "The +length+ ${compared_notequal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_notequal_shape} ${epsilon}] full compared_m
737         if { $compared_m == $m } {
738             puts "Error: length of shape ${compared_notequal_shape} is equal shape to ${shape}"
739         }
740     }
741
742     if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
743         if { [string compare "$mass" "empty"] != 0 } {
744             if { $m == 0 } {
745                 puts "Error : The command is not valid. The $prop is 0."
746             }
747             if { $mass > 0 } {
748                 puts "The expected $prop is $mass"
749             }
750             #check of change of area is < 1%
751             if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } {
752                 puts "Error : The $prop of result shape is $m"
753             }
754         } else {
755             if { $m != 0 } {
756                 puts "Error : The command is not valid. The $prop is $m"
757             }
758         }
759     }
760 }
761
762 help checkview {
763   Display shape in selected viewer.
764
765   Use: checkview [options...]
766   Allowed options are:
767     -display shapename: display shape with name 'shapename'
768     -3d: display shape in 3d viewer
769     -2d [ v2d / smallview ]: display shape in 2d viewer (default viewer is a 'smallview')
770     -vdispmode N: it is possible to set vdispmode for 3d viewer (default value is 1)
771     -screenshot: procedure will try to make screenshot of already created viewer
772     -path <path>: location of saved screenshot of viewer
773
774     Procedure can check some property of shape (length, area or volume) and compare it with some value N:
775       -l [N]
776       -s [N]
777       -v [N]
778     If current property is equal to value N, shape is marked as valid in procedure.
779     If value N is not given procedure will mark shape as valid if current property is non-zero.
780     -with {a b c}: display shapes 'a' 'b' 'c' together with 'shape' (if shape is valid)
781     -otherwise {d e f}: display shapes 'd' 'e' 'f' instead of 'shape' (if shape is NOT valid)
782     Note that one of two options -2d/-3d is required.
783 }
784
785 proc checkview {args} {
786   puts "checkview ${args}"
787
788   set 3dviewer 0
789   set 2dviewer false
790   set shape ""
791   set PathToSave ""
792   set dispmode 1
793   set isScreenshot 0
794   set check_length false
795   set check_area false
796   set check_volume false
797   set otherwise {}
798   set with {}
799
800   set options {{"-3d" 3dviewer 0}
801                {"-2d" 2dviewer ?}
802                {"-display" shape 1}
803                {"-path" PathToSave 1}
804                {"-vdispmode" dispmode 1}
805                {"-screenshot" isScreenshot 0}
806                {"-otherwise" otherwise 1}
807                {"-with" with 1}
808                {"-l" check_length ?}
809                {"-s" check_area ?}
810                {"-v" check_volume ?}}
811
812   # check arguments
813   _check_args ${args} ${options} "checkview"
814
815   if { ${PathToSave} == "" } {
816     set PathToSave "./photo.png"
817   }
818
819   if { ${3dviewer} == 0 && ${2dviewer} == false } {
820     error "Error: wrong using of command 'checkview', please use -2d or -3d option"
821   }
822
823   if { ${isScreenshot} } {
824     if { ${3dviewer} } {
825       vdump ${PathToSave}
826     } else {
827       xwd ${PathToSave}
828     }
829     return
830   }
831
832   set mass 0
833   set isBAD 0
834   upvar ${shape} ${shape}
835   if {[isdraw ${shape}]} {
836     # check area
837     if { [string is boolean ${check_area}] } {
838       if { ${check_area} } {
839         regexp {Mass +: +([-0-9.+eE]+)} [sprops ${shape}] full mass
840       }
841     } else {
842       set mass ${check_area}
843     }
844     # check length
845     if { [string is boolean ${check_length}] } {
846       if { ${check_length} } {
847         regexp {Mass +: +([-0-9.+eE]+)} [lprops ${shape}] full mass
848       }
849     } else {
850       set mass ${check_length}
851     }
852     # check volume
853     if { [string is boolean ${check_volume}] } {
854       if { ${check_volume} } {
855         regexp {Mass +: +([-0-9.+eE]+)} [vprops ${shape}] full mass
856       }
857     } else {
858       set mass ${check_volume}
859     }
860   } else {
861     set isBAD 1
862   }
863   if { ${3dviewer} } {
864     vinit
865     vclear
866   } elseif { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
867     smallview
868     clear
869   } elseif { ${2dviewer} == "v2d"} {
870     v2d
871     2dclear
872   }
873   if {[isdraw ${shape}]} {
874     if { ( ${check_area} == false && ${check_length} == false && ${check_volume} == false ) || ( ${mass} != 0 ) } {
875       foreach s ${with} {
876         upvar ${s} ${s}
877       }
878       lappend with ${shape}
879       if { ${3dviewer} } {
880         vdisplay {*}${with}
881       } else {
882         donly {*}${with}
883       }
884     } else {
885       set isBAD 1
886     }
887   } else {
888     set isBAD 1
889   }
890
891   if { ${isBAD} && [llength ${otherwise}] } {
892     foreach s ${otherwise} {
893       upvar ${s} ${s}
894     }
895     if { ${3dviewer} } {
896       vdisplay {*}${otherwise}
897     } else {
898       donly {*}${otherwise}
899     }
900   }
901
902   if { ${3dviewer} } {
903     vsetdispmode ${dispmode}
904     vfit
905     vdump ${PathToSave}
906   } else {
907     if { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
908       fit
909     } elseif { ${2dviewer} == "v2d"} {
910       2dfit
911     }
912     xwd ${PathToSave}
913   }
914
915 }
916
917 help checktrinfo {
918   Compare maximum deflection, number of nodes and triangles in "shape" mesh with given reference data
919
920   Use: checktrinfo shapename [options...]
921   Allowed options are:
922     -tri [N]:  compare current number of triangles in "shapename" mesh with given reference data.
923                If reference value N is not given and current number of triangles is equal to 0
924                procedure checktrinfo will print an error.
925     -nod [N]:  compare current number of nodes in "shapename" mesh with given reference data.
926                If reference value N is not givenand current number of nodes is equal to 0
927                procedure checktrinfo will print an error.
928     -defl [N]: compare current value of maximum deflection in "shapename" mesh with given reference data
929                If reference value N is not given and current maximum deflection is equal to 0
930                procedure checktrinfo will print an error.
931     -max_defl N:     compare current value of maximum deflection in "shapename" mesh with max possible value
932     -tol_abs_tri N:  absolute tolerance for comparison of number of triangles (default value 0)
933     -tol_rel_tri N:  relative tolerance for comparison of number of triangles (default value 0)
934     -tol_abs_nod N:  absolute tolerance for comparison of number of nodes (default value 0)
935     -tol_rel_nod N:  relative tolerance for comparison of number of nodes (default value 0)
936     -tol_abs_defl N: absolute tolerance for deflection comparison (default value 0)
937     -tol_rel_defl N: relative tolerance for deflection comparison (default value 0)
938     -ref [trinfo a]: compare deflection, number of triangles and nodes in "shapename" and in "a"
939 }
940 proc checktrinfo {shape args} {
941     puts "checktrinfo ${shape} ${args}"
942     upvar ${shape} ${shape}
943
944     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
945         puts "Error: The command cannot be built"
946         return
947     }
948
949     set ref_nb_triangles false
950     set ref_nb_nodes false
951     set ref_deflection false
952     set tol_abs_defl 0
953     set tol_rel_defl 0
954     set tol_abs_tri 0
955     set tol_rel_tri 0
956     set tol_abs_nod 0
957     set tol_rel_nod 0
958     set max_defl -1
959     set ref_info ""
960
961     set options {{"-tri" ref_nb_triangles ?}
962                  {"-nod" ref_nb_nodes ?}
963                  {"-defl" ref_deflection ?}
964                  {"-tol_abs_defl" tol_abs_defl 1}
965                  {"-tol_rel_defl" tol_rel_defl 1}
966                  {"-tol_abs_tri" tol_abs_tri 1}
967                  {"-tol_rel_tri" tol_rel_tri 1}
968                  {"-tol_abs_nod" tol_abs_nod 1}
969                  {"-tol_rel_nod" tol_rel_nod 1}
970                  {"-max_defl" max_defl 1}
971                  {"-ref" ref_info 1}}
972
973     _check_args ${args} ${options} "checktrinfo"
974
975     # get current number of triangles and nodes, value of max deflection
976     set tri_info [trinfo ${shape}]
977     set triinfo_pattern "(\[0-9\]+) +triangles.*\[^0-9]\(\[0-9\]+) +nodes.*deflection +(\[-0-9.+eE\]+)"
978     if {![regexp "${triinfo_pattern}" ${tri_info} dump cur_nb_triangles cur_nb_nodes cur_deflection]} {
979         puts "Error: command trinfo prints empty info"
980     }
981
982     # get reference values from -ref option
983     if { "${ref_info}" != ""} {
984         if {![regexp "${triinfo_pattern}" ${ref_info} dump ref_nb_triangles ref_nb_nodes ref_deflection]} {
985             puts "Error: reference information gived by -ref option is wrong"
986         }
987     }
988
989     # check number of triangles
990     if { [string is boolean ${ref_nb_triangles}] } {
991         if { ${cur_nb_triangles} <= 0 && ${ref_nb_triangles} } {
992             puts "Error: Number of triangles is equal to 0"
993         }
994     } else {
995         if {[regexp {!([-0-9.+eE]+)} $ref_nb_triangles full ref_nb_triangles_value]} {
996             if  {${ref_nb_triangles_value} == ${cur_nb_triangles} } {
997                 puts "Error: Number of triangles is equal to ${ref_nb_triangles_value} but it should not"
998             }
999         } else {
1000             checkreal "Number of triangles" ${cur_nb_triangles} ${ref_nb_triangles} ${tol_abs_tri} ${tol_rel_tri}
1001         }
1002     }
1003
1004     # check number of nodes
1005     if { [string is boolean ${ref_nb_nodes}] } {
1006         if { ${cur_nb_nodes} <= 0 && ${ref_nb_nodes} } {
1007             puts "Error: Number of nodes is equal to 0"
1008         }
1009     } else {
1010         if {[regexp {!([-0-9.+eE]+)} $ref_nb_nodes full ref_nb_nodes_value]} {
1011             if  {${ref_nb_nodes_value} == ${cur_nb_nodes} } {
1012                 puts "Error: Number of nodes is equal to ${ref_nb_nodes_value} but it should not"
1013             }
1014         } else {
1015             checkreal "Number of nodes" ${cur_nb_nodes} ${ref_nb_nodes} ${tol_abs_nod} ${tol_rel_nod}
1016         }
1017     }
1018
1019     # check deflection
1020     if { [string is boolean ${ref_deflection}] } {
1021         if { ${cur_deflection} <= 0 && ${ref_deflection} } {
1022             puts "Error: Maximal deflection is equal to 0"
1023         }
1024     } else {
1025         checkreal "Maximal deflection" ${cur_deflection} ${ref_deflection} ${tol_abs_defl} ${tol_rel_defl}
1026     }
1027
1028     if { ${max_defl} != -1 && ${cur_deflection} > ${max_defl} } {
1029         puts "Error: Maximal deflection is too big"
1030     }
1031 }
1032
1033 help checkplatform {
1034   Return name of current platform if no options are given.
1035
1036   Use: checkplatform [options...]
1037   Allowed options are:
1038     -windows : return 1 if current platform is 'Windows', overwise return 0
1039     -linux   : return 1 if current platform is 'Linux', overwise return 0
1040     -osx     : return 1 if current platform is 'MacOS X', overwise return 0
1041
1042   Only one option can be used at once.
1043   If no option is given, procedure will return the name of current platform.
1044 }
1045 proc checkplatform {args} {
1046     set check_for_windows false
1047     set check_for_linux false
1048     set check_for_macosx false
1049
1050     set options {{"-windows" check_for_windows 0}
1051                  {"-linux" check_for_linux 0}
1052                  {"-osx" check_for_macosx 0}}
1053
1054     _check_args ${args} ${options} "checkplatform"
1055
1056     if { [regexp "indows" $::tcl_platform(os)] } {
1057         set current_platform Windows
1058     } elseif { $::tcl_platform(os) == "Linux" } {
1059         set current_platform Linux
1060     } elseif { $::tcl_platform(os) == "Darwin" } {
1061         set current_platform MacOS
1062     }
1063
1064     # no args are given
1065     if { !${check_for_windows} && !${check_for_linux} && !${check_for_macosx}} {
1066         return ${current_platform}
1067     }
1068
1069     # check usage of proc checkplatform
1070     if { [expr [string is true ${check_for_windows}] + [string is true ${check_for_linux}] + [string is true ${check_for_macosx}] ] > 1} {
1071         error "Error: wrong usage of command checkplatform, only single option can be used at once"
1072     }
1073
1074     # checking for Windows platform
1075     if { ${check_for_windows} && ${current_platform} == "Windows" } {
1076         return 1
1077     }
1078
1079     # checking for Mac OS X platforms
1080     if { ${check_for_linux} && ${current_platform} == "Linux" } {
1081         return 1
1082     }
1083
1084     # checking for Mac OS X platforms
1085     if { ${check_for_macosx} && ${current_platform} == "MacOS" } {
1086         return 1
1087     }
1088
1089     # current platform is not equal to given as argument platform, return false
1090     return 0
1091 }