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 # Procedure to check equality of two 3D points with tolerance
 314 help checkpoint {
 315   Compare two 3D points with given tolerance
 316   Use: checkpoint name {valueX valueY valueZ} {expectedX expectedY expectedZ} tolerance
 317 }
 318 proc checkpoint {theName theValue theExpected theTolerance} {
 319   set e 0.0001
 320   foreach i {0 1 2} {
 321     if { [expr abs([lindex $theValue $i] - [lindex $theExpected $i])] > $theTolerance } {
 322       puts "Error: $theName, ($theValue) is not equal to expected ($theExpected)"
 323       return
 324     }
 325   }
 326   puts "Check of $theName OK: value = ($theValue), expected = ($theExpected)"
 327   return
 328 }
 329
 330 help checkfreebounds {
 331   Compare number of free edges with ref_value
 332
 333   Use: checkfreebounds shape ref_value [options...]
 334   Allowed options are:
 335     -tol N: used tolerance (default -0.01)
 336     -type N: used type, possible values are "closed" and "opened" (default "closed")
 337 }
 338 proc checkfreebounds {shape ref_value args} {
 339   puts "checkfreebounds ${shape} ${ref_value} ${args}"
 340   upvar ${shape} ${shape}
 341
 342   set tol -0.01
 343   set type "closed"
 344
 345   for {set narg 0} {$narg < [llength $args]} {incr narg} {
 346     set arg [lindex $args $narg]
 347     if {[_check_arg "-tol" tol 1] ||
 348         [_check_arg "-type" type 1]
 349        } {
 350       continue
 351     }
 352     # unsupported option
 353     if { [regexp {^-} $arg] } {
 354       error "Error: unsupported option \"$arg\""
 355     }
 356     error "Error: cannot interpret argument $narg ($arg)"
 357   }
 358
 359   if {"$type" != "closed" && "$type" != "opened"} {
 360     error "Error : wrong -type key \"${type}\""
 361   }
 362
 363   freebounds ${shape} ${tol}
 364   set free_edges [llength [explode ${shape}_[string range $type 0 0] e]]
 365
 366   if { ${ref_value} == -1 } {
 367     puts "Error : Number of free edges is UNSTABLE"
 368     return
 369   }
 370
 371   if { ${free_edges} != ${ref_value} } {
 372     puts "Error : Number of free edges is not equal to reference data"
 373   } else {
 374     puts "OK : Number of free edges is ${free_edges}"
 375   }
 376 }
 377
 378 help checkmaxtol {
 379   Returns max tolerance of the shape and prints error message if specified
 380   criteria are not satisfied.
 381
 382   Use: checkmaxtol shape [options...]
 383
 384   Options specify criteria for checking the maximal tolerance value:
 385     -ref <value>: check it to be equal to reference value.
 386     -min_tol <value>: check it to be not greater than specified value.
 387     -source <list of shapes>: check it to be not greater than
 388             maximal tolerance of specified shape(s)
 389     -multi_tol <value>: additional multiplier for value specified by -min_tol
 390                or -shapes options.
 391 }
 392
 393 proc checkmaxtol {shape args} {
 394   puts "checkmaxtol ${shape} ${args}"
 395   upvar ${shape} ${shape}
 396
 397   set ref_value ""
 398   set source_shapes {}
 399   set min_tol 0
 400   set tol_multiplier 0
 401
 402   # check arguments
 403   for {set narg 0} {$narg < [llength $args]} {incr narg} {
 404     set arg [lindex $args $narg]
 405     if {[_check_arg "-min_tol" min_tol 1] ||
 406         [_check_arg "-multi_tol" tol_multiplier 1] ||
 407         [_check_arg "-source" source_shapes 1] ||
 408         [_check_arg "-ref" ref_value 1]
 409        } {
 410       continue
 411     }
 412     # unsupported option
 413     if { [regexp {^-} $arg] } {
 414       error "Error: unsupported option \"$arg\""
 415     }
 416     error "Error: cannot interpret argument $narg ($arg)"
 417   }
 418
 419   # get max tol of shape
 420   set max_tol 0
 421   if {[regexp "Tolerance MAX=(\[-0-9.+eE\]+)" [tolerance ${shape}] full maxtol_temp]} {
 422     set max_tol ${maxtol_temp}
 423   } else {
 424     error "Error: cannot get tolerances of shape \"${shape}\""
 425   }
 426
 427   # find max tol of source shapes
 428   foreach source_shape ${source_shapes} {
 429     upvar ${source_shape} ${source_shape}
 430     set _src_max_tol [checkmaxtol ${source_shape}]
 431     if { [expr ${_src_max_tol} > ${min_tol} ] } {
 432       set min_tol ${_src_max_tol}
 433     }
 434   }
 435   # apply -multi_tol option
 436   if {${tol_multiplier}} {
 437     set min_tol [expr ${tol_multiplier} * ${_src_max_tol}]
 438   }
 439   # compare max tol of source shapes with checking tolerance
 440   if { ${min_tol} && [expr ${max_tol} > ${min_tol}] } {
 441     puts "Error: tolerance of \"${shape}\" (${max_tol}) is greater than checking tolerance (${min_tol})"
 442   }
 443   if { ${ref_value} != "" } {
 444     checkreal "Max tolerance" ${max_tol} ${ref_value} 0.0001 0.01
 445   }
 446   return ${max_tol}
 447 }
 448
 449 help checkfaults {
 450   Compare faults number of given shapes.
 451
 452   Use: checkfaults shape source_shape [ref_value=0]
 453 }
 454 proc checkfaults {shape source_shape {ref_value 0}} {
 455   puts "checkfaults ${shape} ${source_shape} ${ref_value}"
 456   upvar $shape $shape
 457   upvar $source_shape $source_shape
 458   set cs_a [checkshape $source_shape]
 459   set nb_a 0
 460   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_a full nb_a_begin nb_a_end]} {
 461     set nb_a [expr $nb_a_end - $nb_a_begin +1]
 462   }
 463   set cs_r [checkshape $shape]
 464   set nb_r 0
 465   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_r full nb_r_begin nb_r_end]} {
 466     set nb_r [expr $nb_r_end - $nb_r_begin +1]
 467   }
 468   puts "Number of faults for the initial shape is $nb_a."
 469   puts "Number of faults for the resulting shape is $nb_r."
 470
 471   if { ${ref_value} == -1 } {
 472     puts "Error : Number of faults is UNSTABLE"
 473     return
 474   }
 475
 476   if { $nb_r > $nb_a } {
 477     puts "Error : Number of faults is $nb_r"
 478   }
 479 }
 480
 481 # auxiliary: check all arguments
 482 proc _check_args { args {options {}} {command_name ""}} {
 483   # check arguments
 484   for {set narg 0} {${narg} < [llength ${args}]} {incr narg} {
 485     set arg [lindex ${args} ${narg}]
 486     set toContinue 0
 487     foreach option ${options} {
 488       set option_name            [lindex ${option} 0]
 489       set variable_to_save_value [lindex ${option} 1]
 490       set get_value              [lindex ${option} 2]
 491       set local_value ""
 492       if { [_check_arg ${option_name} local_value ${get_value}] } {
 493         upvar 1 ${variable_to_save_value} ${variable_to_save_value}
 494         set ${variable_to_save_value} ${local_value}
 495         set toContinue 1
 496       }
 497     }
 498     if {${toContinue}} { continue }
 499     # unsupported option
 500     if { [regexp {^-} ${arg}] } {
 501       error "Error: unsupported option \"${arg}\""
 502     }
 503     error "Error: cannot interpret argument ${narg} (${arg})"
 504   }
 505   foreach option ${options} {
 506     set option_name            [lindex ${option} 0]
 507     set variable_to_save_value [lindex ${option} 1]
 508     set should_exist           [lindex ${option} 3]
 509     if {![info exists ${variable_to_save_value}] && ${should_exist} == 1} {
 510       error "Error: wrong using of command '${command_name}', '${option_name}' option is required"
 511     }
 512   }
 513 }
 514
 515 help checkprops {
 516   Procedure includes commands to compute length, area and volume of input shape.
 517
 518   Use: checkprops shapename [options...]
 519   Allowed options are:
 520     -l LENGTH: command lprops, computes the mass properties of all edges in the shape with a linear density of 1
 521     -s AREA: command sprops, computes the mass properties of all faces with a surface density of 1
 522     -v VOLUME: command vprops, computes the mass properties of all solids with a density of 1
 523     -eps EPSILON: the epsilon defines relative precision of computation
 524     -deps DEPSILON: the epsilon defines relative precision to compare corresponding values
 525     -equal SHAPE: compare area\volume\length of input shapes. Puts error if its are not equal
 526     -notequal SHAPE: compare area\volume\length of input shapes. Puts error if its are equal
 527     -skip: count shared shapes only once, skipping repeatitions
 528   Options -l, -s and -v are independent and can be used in any order. Tolerance epsilon is the same for all options.
 529 }
 530
 531 proc checkprops {shape args} {
 532     puts "checkprops ${shape} ${args}"
 533     upvar ${shape} ${shape}
 534
 535     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 536         puts "Error: The command cannot be built"
 537         return
 538     }
 539
 540     set length -1
 541     set area -1
 542     set volume -1
 543     set epsilon 1.0e-4
 544     set compared_equal_shape -1
 545     set compared_notequal_shape -1
 546     set equal_check 0
 547     set skip 0
 548     set depsilon 1e-2
 549
 550     set options {{"-eps" epsilon 1}
 551                  {"-equal" compared_equal_shape 1}
 552                  {"-notequal" compared_notequal_shape 1}
 553                  {"-skip" skip 0}
 554                  {"-deps" depsilon 1}}
 555
 556     if { [regexp {\-[not]*equal} $args] } {
 557         lappend options {"-s" area 0}
 558         lappend options {"-l" length 0}
 559         lappend options {"-v" volume 0}
 560         set equal_check 1
 561     } else {
 562         lappend options {"-s" area 1}
 563         lappend options {"-l" length 1}
 564         lappend options {"-v" volume 1}
 565     }
 566     _check_args ${args} ${options} "checkprops"
 567
 568     if { ${length} != -1 || ${equal_check} == 1 } {
 569         lappend CommandNames {lprops}
 570         set equal_check 0
 571     }
 572     if { ${area} != -1 || ${equal_check} == 1 } {
 573         lappend CommandNames {sprops}
 574         set equal_check 0
 575     }
 576     if { ${volume} != -1 || ${equal_check} == 1 } {
 577         lappend CommandNames {vprops}
 578         set equal_check 0
 579     }
 580
 581     set skip_option ""
 582     if { $skip } {
 583         set skip_option "-skip"
 584     }
 585
 586     foreach CommandName ${CommandNames} {
 587         switch $CommandName {
 588             "lprops"    { set mass ${length}; set prop "length" }
 589             "sprops"    { set mass ${area}; set prop "area" }
 590             "vprops"    { set mass ${volume}; set prop "volume" }
 591         }
 592         regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${shape} ${epsilon} $skip_option] full m
 593
 594         if { ${compared_equal_shape} != -1 } {
 595             upvar ${compared_equal_shape} ${compared_equal_shape}
 596             regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_equal_shape} ${epsilon} $skip_option] full compared_m
 597             if { $compared_m != $m } {
 598                 puts "Error: Shape ${compared_equal_shape} is not equal to shape ${shape}"
 599             }
 600         }
 601
 602         if { ${compared_notequal_shape} != -1 } {
 603             upvar ${compared_notequal_shape} ${compared_notequal_shape}
 604             regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_notequal_shape} ${epsilon} $skip_option] full compared_m
 605             if { $compared_m == $m } {
 606                 puts "Error: Shape ${compared_notequal_shape} is equal shape to ${shape}"
 607             }
 608         }
 609
 610         if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
 611             if { [string compare "$mass" "empty"] != 0 } {
 612                 if { $m == 0 } {
 613                     puts "Error : The command is not valid. The $prop is 0."
 614                 }
 615                 # check of change of area is < 1%
 616                 if { ($mass != 0 && abs (($mass - $m) / double($mass)) > $depsilon) ||
 617                      ($mass == 0 && $m != 0) } {
 618                     puts "Error : The $prop of result shape is $m, expected $mass"
 619                 }
 620             } else {
 621                 if { $m != 0 } {
 622                     puts "Error : The command is not valid. The $prop is $m"
 623                 }
 624             }
 625         }
 626     }
 627 }
 628
 629 help checkdump {
 630   Procedure includes command to parse output dump and compare it with reference values.
 631
 632   Use: checkdump shapename [options...]
 633   Allowed options are:
 634     -name NAME: list of parsing parameters (e.g. Center, Axis, etc)
 635     -ref VALUE: list of reference values for each parameter in NAME
 636     -eps EPSILON: the epsilon defines relative precision of computation
 637 }
 638
 639 proc checkdump {shape args} {
 640     puts "checkdump ${shape} ${args}"
 641     upvar ${shape} ${shape}
 642
 643     set ddump -1
 644     set epsilon -1
 645     set options {{"-name" params 1}
 646                  {"-ref" ref 1}
 647                  {"-eps" epsilon 1}
 648                  {"-dump" ddump 1}}
 649
 650     if { ${ddump} == -1 } {
 651         set ddump [dump ${shape}]
 652     }
 653     _check_args ${args} ${options} "checkdump"
 654
 655     set index 0
 656     foreach param ${params} {
 657         set pattern "${param}\\s*:\\s*"
 658         set number_pattern "(\[-0-9.+eE\]+)\\s*"
 659         set ref_values ""
 660         set local_ref ${ref}
 661         if { [llength ${params}] > 1 } {
 662             set local_ref [lindex ${ref} ${index}]
 663         }
 664         foreach item ${local_ref} {
 665             if { ![regexp "$pattern$number_pattern" $ddump full res] } {
 666                 puts "Error: cheked parameter ${param} is not listed in dump"
 667                 break
 668             }
 669             lappend ref_values $res
 670             set pattern "${pattern}${res},\\s*"
 671             ## without precision
 672             if { ${epsilon} == -1 } {
 673                 if { ${item} != ${res} } {
 674                     puts "Error: parameter ${param} - current value (${res}) is not equal to reference value (${item})"
 675                 } else {
 676                     puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
 677                 }
 678             ## with precision
 679             } else {
 680                 set precision 0.0000001
 681                 if { ( abs($res) > $precision ) || ( abs($item) > $precision ) } {
 682                     if { ($item != 0 && [expr 1.*abs($item - $res)/$item] > $epsilon) || ($item == 0 && $res != 0) } {
 683                         puts "Error: The $param of the resulting shape is $res and the expected $param is $item"
 684                     } else {
 685                         puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
 686                     }
 687                 }
 688             }
 689         }
 690         incr index
 691     }
 692 }
 693
 694 help checklength {
 695   Procedure includes commands to compute length of input curve.
 696
 697   Use: checklength curvename [options...]
 698   Allowed options are:
 699     -l LENGTH: command length, computes the length of input curve with precision of computation
 700     -eps EPSILON: the epsilon defines relative precision of computation
 701     -equal CURVE: compare length of input curves. Puts error if its are not equal
 702     -notequal CURVE: compare length of input curves. Puts error if its are equal
 703 }
 704
 705 proc checklength {shape args} {
 706     puts "checklength ${shape} ${args}"
 707     upvar ${shape} ${shape}
 708
 709     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 710         puts "Error: The command cannot be built"
 711         return
 712     }
 713
 714     set length -1
 715     set epsilon 1.0e-4
 716     set compared_equal_shape -1
 717     set compared_notequal_shape -1
 718     set equal_check 0
 719
 720     set options {{"-eps" epsilon 1}
 721                  {"-equal" compared_equal_shape 1}
 722                  {"-notequal" compared_notequal_shape 1}}
 723
 724     if { [regexp {\-[not]*equal} $args] } {
 725         lappend options {"-l" length 0}
 726         set equal_check 1
 727     } else {
 728         lappend options {"-l" length 1}
 729     }
 730     _check_args ${args} ${options} "checkprops"
 731
 732     if { ${length} != -1 || ${equal_check} == 1 } {
 733         set CommandName length
 734         set mass $length
 735         set prop "length"
 736         set equal_check 0
 737     }
 738
 739     regexp "The +length+ ${shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${shape} ${epsilon}] full m
 740
 741     if { ${compared_equal_shape} != -1 } {
 742         upvar ${compared_equal_shape} ${compared_equal_shape}
 743         regexp "The +length+ ${compared_equal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_equal_shape} ${epsilon}] full compared_m
 744         if { $compared_m != $m } {
 745             puts "Error: length of shape ${compared_equal_shape} is not equal to shape ${shape}"
 746         }
 747     }
 748
 749     if { ${compared_notequal_shape} != -1 } {
 750         upvar ${compared_notequal_shape} ${compared_notequal_shape}
 751         regexp "The +length+ ${compared_notequal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_notequal_shape} ${epsilon}] full compared_m
 752         if { $compared_m == $m } {
 753             puts "Error: length of shape ${compared_notequal_shape} is equal shape to ${shape}"
 754         }
 755     }
 756
 757     if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
 758         if { [string compare "$mass" "empty"] != 0 } {
 759             if { $m == 0 } {
 760                 puts "Error : The command is not valid. The $prop is 0."
 761             }
 762             if { $mass > 0 } {
 763                 puts "The expected $prop is $mass"
 764             }
 765             #check of change of area is < 1%
 766             if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } {
 767                 puts "Error : The $prop of result shape is $m"
 768             }
 769         } else {
 770             if { $m != 0 } {
 771                 puts "Error : The command is not valid. The $prop is $m"
 772             }
 773         }
 774     }
 775 }
 776
 777 help checkview {
 778   Display shape in selected viewer.
 779
 780   Use: checkview [options...]
 781   Allowed options are:
 782     -display shapename: display shape with name 'shapename'
 783     -3d: display shape in 3d viewer
 784     -2d [ v2d / smallview ]: display shape in 2d viewer (default viewer is a 'smallview')
 785     -vdispmode N: it is possible to set vdispmode for 3d viewer (default value is 1)
 786     -screenshot: procedure will try to make screenshot of already created viewer
 787     -path <path>: location of saved screenshot of viewer
 788
 789     Procedure can check some property of shape (length, area or volume) and compare it with some value N:
 790       -l [N]
 791       -s [N]
 792       -v [N]
 793     If current property is equal to value N, shape is marked as valid in procedure.
 794     If value N is not given procedure will mark shape as valid if current property is non-zero.
 795     -with {a b c}: display shapes 'a' 'b' 'c' together with 'shape' (if shape is valid)
 796     -otherwise {d e f}: display shapes 'd' 'e' 'f' instead of 'shape' (if shape is NOT valid)
 797     Note that one of two options -2d/-3d is required.
 798 }
 799
 800 proc checkview {args} {
 801   puts "checkview ${args}"
 802
 803   set 3dviewer 0
 804   set 2dviewer false
 805   set shape ""
 806   set PathToSave ""
 807   set dispmode 1
 808   set isScreenshot 0
 809   set check_length false
 810   set check_area false
 811   set check_volume false
 812   set otherwise {}
 813   set with {}
 814
 815   set options {{"-3d" 3dviewer 0}
 816                {"-2d" 2dviewer ?}
 817                {"-display" shape 1}
 818                {"-path" PathToSave 1}
 819                {"-vdispmode" dispmode 1}
 820                {"-screenshot" isScreenshot 0}
 821                {"-otherwise" otherwise 1}
 822                {"-with" with 1}
 823                {"-l" check_length ?}
 824                {"-s" check_area ?}
 825                {"-v" check_volume ?}}
 826
 827   # check arguments
 828   _check_args ${args} ${options} "checkview"
 829
 830   if { ${PathToSave} == "" } {
 831     set PathToSave "./photo.png"
 832   }
 833
 834   if { ${3dviewer} == 0 && ${2dviewer} == false } {
 835     error "Error: wrong using of command 'checkview', please use -2d or -3d option"
 836   }
 837
 838   if { ${isScreenshot} } {
 839     if { ${3dviewer} } {
 840       vdump ${PathToSave}
 841     } else {
 842       xwd ${PathToSave}
 843     }
 844     return
 845   }
 846
 847   set mass 0
 848   set isBAD 0
 849   upvar ${shape} ${shape}
 850   if {[isdraw ${shape}]} {
 851     # check area
 852     if { [string is boolean ${check_area}] } {
 853       if { ${check_area} } {
 854         regexp {Mass +: +([-0-9.+eE]+)} [sprops ${shape}] full mass
 855       }
 856     } else {
 857       set mass ${check_area}
 858     }
 859     # check length
 860     if { [string is boolean ${check_length}] } {
 861       if { ${check_length} } {
 862         regexp {Mass +: +([-0-9.+eE]+)} [lprops ${shape}] full mass
 863       }
 864     } else {
 865       set mass ${check_length}
 866     }
 867     # check volume
 868     if { [string is boolean ${check_volume}] } {
 869       if { ${check_volume} } {
 870         regexp {Mass +: +([-0-9.+eE]+)} [vprops ${shape}] full mass
 871       }
 872     } else {
 873       set mass ${check_volume}
 874     }
 875   } else {
 876     set isBAD 1
 877   }
 878   if { ${3dviewer} } {
 879     vinit
 880     vclear
 881   } elseif { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
 882     smallview
 883     clear
 884   } elseif { ${2dviewer} == "v2d"} {
 885     v2d
 886     2dclear
 887   }
 888   if {[isdraw ${shape}]} {
 889     if { ( ${check_area} == false && ${check_length} == false && ${check_volume} == false ) || ( ${mass} != 0 ) } {
 890       foreach s ${with} {
 891         upvar ${s} ${s}
 892       }
 893       lappend with ${shape}
 894       if { ${3dviewer} } {
 895         vdisplay {*}${with}
 896       } else {
 897         donly {*}${with}
 898       }
 899     } else {
 900       set isBAD 1
 901     }
 902   } else {
 903     set isBAD 1
 904   }
 905
 906   if { ${isBAD} && [llength ${otherwise}] } {
 907     foreach s ${otherwise} {
 908       upvar ${s} ${s}
 909     }
 910     if { ${3dviewer} } {
 911       vdisplay {*}${otherwise}
 912     } else {
 913       donly {*}${otherwise}
 914     }
 915   }
 916
 917   if { ${3dviewer} } {
 918     vsetdispmode ${dispmode}
 919     vfit
 920     vdump ${PathToSave}
 921   } else {
 922     if { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
 923       fit
 924     } elseif { ${2dviewer} == "v2d"} {
 925       2dfit
 926     }
 927     xwd ${PathToSave}
 928   }
 929
 930 }
 931
 932 help checktrinfo {
 933   Compare maximum deflection, number of nodes and triangles in "shape" mesh with given reference data
 934
 935   Use: checktrinfo shapename [options...]
 936   Allowed options are:
 937     -tri [N]:  compare current number of triangles in "shapename" mesh with given reference data.
 938                If reference value N is not given and current number of triangles is equal to 0
 939                procedure checktrinfo will print an error.
 940     -nod [N]:  compare current number of nodes in "shapename" mesh with given reference data.
 941                If reference value N is not givenand current number of nodes is equal to 0
 942                procedure checktrinfo will print an error.
 943     -defl [N]: compare current value of maximum deflection in "shapename" mesh with given reference data
 944                If reference value N is not given and current maximum deflection is equal to 0
 945                procedure checktrinfo will print an error.
 946     -max_defl N:     compare current value of maximum deflection in "shapename" mesh with max possible value
 947     -tol_abs_tri N:  absolute tolerance for comparison of number of triangles (default value 0)
 948     -tol_rel_tri N:  relative tolerance for comparison of number of triangles (default value 0)
 949     -tol_abs_nod N:  absolute tolerance for comparison of number of nodes (default value 0)
 950     -tol_rel_nod N:  relative tolerance for comparison of number of nodes (default value 0)
 951     -tol_abs_defl N: absolute tolerance for deflection comparison (default value 0)
 952     -tol_rel_defl N: relative tolerance for deflection comparison (default value 0)
 953     -ref [trinfo a]: compare deflection, number of triangles and nodes in "shapename" and in "a"
 954 }
 955 proc checktrinfo {shape args} {
 956     puts "checktrinfo ${shape} ${args}"
 957     upvar ${shape} ${shape}
 958
 959     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 960         puts "Error: The command cannot be built"
 961         return
 962     }
 963
 964     set ref_nb_triangles false
 965     set ref_nb_nodes false
 966     set ref_deflection false
 967     set tol_abs_defl 0
 968     set tol_rel_defl 0
 969     set tol_abs_tri 0
 970     set tol_rel_tri 0
 971     set tol_abs_nod 0
 972     set tol_rel_nod 0
 973     set max_defl -1
 974     set ref_info ""
 975
 976     set options {{"-tri" ref_nb_triangles ?}
 977                  {"-nod" ref_nb_nodes ?}
 978                  {"-defl" ref_deflection ?}
 979                  {"-tol_abs_defl" tol_abs_defl 1}
 980                  {"-tol_rel_defl" tol_rel_defl 1}
 981                  {"-tol_abs_tri" tol_abs_tri 1}
 982                  {"-tol_rel_tri" tol_rel_tri 1}
 983                  {"-tol_abs_nod" tol_abs_nod 1}
 984                  {"-tol_rel_nod" tol_rel_nod 1}
 985                  {"-max_defl" max_defl 1}
 986                  {"-ref" ref_info 1}}
 987
 988     _check_args ${args} ${options} "checktrinfo"
 989
 990     # get current number of triangles and nodes, value of max deflection
 991     set tri_info [trinfo ${shape}]
 992     set triinfo_pattern "(\[0-9\]+) +triangles.*\[^0-9]\(\[0-9\]+) +nodes.*deflection +(\[-0-9.+eE\]+)"
 993     if {![regexp "${triinfo_pattern}" ${tri_info} dump cur_nb_triangles cur_nb_nodes cur_deflection]} {
 994         puts "Error: command trinfo prints empty info"
 995     }
 996
 997     # get reference values from -ref option
 998     if { "${ref_info}" != ""} {
 999         if {![regexp "${triinfo_pattern}" ${ref_info} dump ref_nb_triangles ref_nb_nodes ref_deflection]} {
1000             puts "Error: reference information gived by -ref option is wrong"
1001         }
1002     }
1003
1004     # check number of triangles
1005     if { [string is boolean ${ref_nb_triangles}] } {
1006         if { ${cur_nb_triangles} <= 0 && ${ref_nb_triangles} } {
1007             puts "Error: Number of triangles is equal to 0"
1008         }
1009     } else {
1010         if {[regexp {!([-0-9.+eE]+)} $ref_nb_triangles full ref_nb_triangles_value]} {
1011             if  {${ref_nb_triangles_value} == ${cur_nb_triangles} } {
1012                 puts "Error: Number of triangles is equal to ${ref_nb_triangles_value} but it should not"
1013             }
1014         } else {
1015             checkreal "Number of triangles" ${cur_nb_triangles} ${ref_nb_triangles} ${tol_abs_tri} ${tol_rel_tri}
1016         }
1017     }
1018
1019     # check number of nodes
1020     if { [string is boolean ${ref_nb_nodes}] } {
1021         if { ${cur_nb_nodes} <= 0 && ${ref_nb_nodes} } {
1022             puts "Error: Number of nodes is equal to 0"
1023         }
1024     } else {
1025         if {[regexp {!([-0-9.+eE]+)} $ref_nb_nodes full ref_nb_nodes_value]} {
1026             if  {${ref_nb_nodes_value} == ${cur_nb_nodes} } {
1027                 puts "Error: Number of nodes is equal to ${ref_nb_nodes_value} but it should not"
1028             }
1029         } else {
1030             checkreal "Number of nodes" ${cur_nb_nodes} ${ref_nb_nodes} ${tol_abs_nod} ${tol_rel_nod}
1031         }
1032     }
1033
1034     # check deflection
1035     if { [string is boolean ${ref_deflection}] } {
1036         if { ${cur_deflection} <= 0 && ${ref_deflection} } {
1037             puts "Error: Maximal deflection is equal to 0"
1038         }
1039     } else {
1040         checkreal "Maximal deflection" ${cur_deflection} ${ref_deflection} ${tol_abs_defl} ${tol_rel_defl}
1041     }
1042
1043     if { ${max_defl} != -1 && ${cur_deflection} > ${max_defl} } {
1044         puts "Error: Maximal deflection is too big"
1045     }
1046 }
1047
1048 help checkplatform {
1049   Return name of current platform if no options are given.
1050
1051   Use: checkplatform [options...]
1052   Allowed options are:
1053     -windows : return 1 if current platform is 'Windows', overwise return 0
1054     -linux   : return 1 if current platform is 'Linux', overwise return 0
1055     -osx     : return 1 if current platform is 'MacOS X', overwise return 0
1056
1057   Only one option can be used at once.
1058   If no option is given, procedure will return the name of current platform.
1059 }
1060 proc checkplatform {args} {
1061     set check_for_windows false
1062     set check_for_linux false
1063     set check_for_macosx false
1064
1065     set options {{"-windows" check_for_windows 0}
1066                  {"-linux" check_for_linux 0}
1067                  {"-osx" check_for_macosx 0}}
1068
1069     _check_args ${args} ${options} "checkplatform"
1070
1071     if { [regexp "indows" $::tcl_platform(os)] } {
1072         set current_platform Windows
1073     } elseif { $::tcl_platform(os) == "Linux" } {
1074         set current_platform Linux
1075     } elseif { $::tcl_platform(os) == "Darwin" } {
1076         set current_platform MacOS
1077     }
1078
1079     # no args are given
1080     if { !${check_for_windows} && !${check_for_linux} && !${check_for_macosx}} {
1081         return ${current_platform}
1082     }
1083
1084     # check usage of proc checkplatform
1085     if { [expr [string is true ${check_for_windows}] + [string is true ${check_for_linux}] + [string is true ${check_for_macosx}] ] > 1} {
1086         error "Error: wrong usage of command checkplatform, only single option can be used at once"
1087     }
1088
1089     # checking for Windows platform
1090     if { ${check_for_windows} && ${current_platform} == "Windows" } {
1091         return 1
1092     }
1093
1094     # checking for Mac OS X platforms
1095     if { ${check_for_linux} && ${current_platform} == "Linux" } {
1096         return 1
1097     }
1098
1099     # checking for Mac OS X platforms
1100     if { ${check_for_macosx} && ${current_platform} == "MacOS" } {
1101         return 1
1102     }
1103
1104     # current platform is not equal to given as argument platform, return false
1105     return 0
1106 }
1107
1108 help checkgravitycenter {
1109   Compare Center Of Gravity with given reference data
1110
1111   Use: checkgravitycenter shape prop_type x y z tol
1112 }
1113 proc checkgravitycenter {shape prop_type x y z tol} {
1114   puts "checkgravitycenter ${shape} $prop_type $x $y $z $tol"
1115   upvar ${shape} ${shape}
1116
1117   if { $prop_type == "-l" } {
1118     set outstr [lprops $shape]
1119   } elseif { $prop_type == "-s" } {
1120     set outstr [sprops $shape]
1121   } elseif { $prop_type == "-v" } {
1122     set outstr [vprops $shape]
1123   } else {
1124     error "Error : invalid prop_type"
1125   }
1126
1127   if { ![regexp {\nX = +([-0-9.+eE]+).*\nY = +([-0-9.+eE]+).*\nZ = +([-0-9.+eE]+)} ${outstr} full comp_x comp_y comp_z] } {
1128     error "Error : cannot evaluate properties"
1129   }
1130
1131   if { [expr abs($comp_x-$x)] < $tol && [expr abs($comp_y-$y)] < $tol && [expr abs($comp_z-$z)] < $tol } {
1132     puts "Check of center of gravity is OK: value = ($comp_x, $comp_y, $comp_z), expected = ($x, $y, $z)"
1133   } else {
1134     puts "Error: center of gravity ($comp_x, $comp_y, $comp_z) is not equal to expected ($x, $y, $z)"
1135   }
1136 }
1137
1138 help checkMultilineStrings {
1139   Compares two strings.
1140   Logically splits the strings to lines by the new line characters.
1141   Outputs the first different lines.
1142
1143   Use: checkMultilineStrings <string_1> <string_2>
1144 }
1145 proc checkMultilineStrings {tS1 tS2} {
1146   set aL1 [split $tS1 \n]
1147   set aL2 [split $tS2 \n]
1148
1149   set aC1 [llength $aL1]
1150   set aC2 [llength $aL2]
1151   set aC [expr {min($aC1, $aC2)}]
1152
1153   for {set aI 0} {$aI < $aC} {incr aI} {
1154     if {[lindex $aL1 $aI] != [lindex $aL2 $aI]} {
1155       puts "Error. $aI-th lines are different:"
1156       puts "[lindex $aL1 $aI]"
1157       puts "[lindex $aL2 $aI]"
1158     }
1159   }
1160
1161   if {$aC1 != $aC2} {
1162     puts "Error. Line counts are different: $aC1 != $aC2."
1163   }
1164 }