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                 # check of change of area is < 1%
 599                 if { ($mass != 0 && abs (($mass - $m) / double($mass)) > $depsilon) ||
 600                      ($mass == 0 && $m != 0) } {
 601                     puts "Error : The $prop of result shape is $m, expected $mass"
 602                 }
 603             } else {
 604                 if { $m != 0 } {
 605                     puts "Error : The command is not valid. The $prop is $m"
 606                 }
 607             }
 608         }
 609     }
 610 }
 611
 612 help checkdump {
 613   Procedure includes command to parse output dump and compare it with reference values.
 614
 615   Use: checkdump shapename [options...]
 616   Allowed options are:
 617     -name NAME: list of parsing parameters (e.g. Center, Axis, etc)
 618     -ref VALUE: list of reference values for each parameter in NAME
 619     -eps EPSILON: the epsilon defines relative precision of computation
 620 }
 621
 622 proc checkdump {shape args} {
 623     puts "checkdump ${shape} ${args}"
 624     upvar ${shape} ${shape}
 625
 626     set ddump -1
 627     set epsilon -1
 628     set options {{"-name" params 1}
 629                  {"-ref" ref 1}
 630                  {"-eps" epsilon 1}
 631                  {"-dump" ddump 1}}
 632
 633     if { ${ddump} == -1 } {
 634         set ddump [dump ${shape}]
 635     }
 636     _check_args ${args} ${options} "checkdump"
 637
 638     set index 0
 639     foreach param ${params} {
 640         set pattern "${param}\\s*:\\s*"
 641         set number_pattern "(\[-0-9.+eE\]+)\\s*"
 642         set ref_values ""
 643         set local_ref ${ref}
 644         if { [llength ${params}] > 1 } {
 645             set local_ref [lindex ${ref} ${index}]
 646         }
 647         foreach item ${local_ref} {
 648             if { ![regexp "$pattern$number_pattern" $ddump full res] } {
 649                 puts "Error: cheked parameter ${param} is not listed in dump"
 650                 break
 651             }
 652             lappend ref_values $res
 653             set pattern "${pattern}${res},\\s*"
 654             ## without precision
 655             if { ${epsilon} == -1 } {
 656                 if { ${item} != ${res} } {
 657                     puts "Error: parameter ${param} - current value (${res}) is not equal to reference value (${item})"
 658                 } else {
 659                     puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
 660                 }
 661             ## with precision
 662             } else {
 663                 set precision 0.0000001
 664                 if { ( abs($res) > $precision ) || ( abs($item) > $precision ) } {
 665                     if { ($item != 0 && [expr 1.*abs($item - $res)/$item] > $epsilon) || ($item == 0 && $res != 0) } {
 666                         puts "Error: The $param of the resulting shape is $res and the expected $param is $item"
 667                     } else {
 668                         puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
 669                     }
 670                 }
 671             }
 672         }
 673         incr index
 674     }
 675 }
 676
 677 help checklength {
 678   Procedure includes commands to compute length of input curve.
 679
 680   Use: checklength curvename [options...]
 681   Allowed options are:
 682     -l LENGTH: command length, computes the length of input curve with precision of computation
 683     -eps EPSILON: the epsilon defines relative precision of computation
 684     -equal CURVE: compare length of input curves. Puts error if its are not equal
 685     -notequal CURVE: compare length of input curves. Puts error if its are equal
 686 }
 687
 688 proc checklength {shape args} {
 689     puts "checklength ${shape} ${args}"
 690     upvar ${shape} ${shape}
 691
 692     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 693         puts "Error: The command cannot be built"
 694         return
 695     }
 696
 697     set length -1
 698     set epsilon 1.0e-4
 699     set compared_equal_shape -1
 700     set compared_notequal_shape -1
 701     set equal_check 0
 702
 703     set options {{"-eps" epsilon 1}
 704                  {"-equal" compared_equal_shape 1}
 705                  {"-notequal" compared_notequal_shape 1}}
 706
 707     if { [regexp {\-[not]*equal} $args] } {
 708         lappend options {"-l" length 0}
 709         set equal_check 1
 710     } else {
 711         lappend options {"-l" length 1}
 712     }
 713     _check_args ${args} ${options} "checkprops"
 714
 715     if { ${length} != -1 || ${equal_check} == 1 } {
 716         set CommandName length
 717         set mass $length
 718         set prop "length"
 719         set equal_check 0
 720     }
 721
 722     regexp "The +length+ ${shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${shape} ${epsilon}] full m
 723
 724     if { ${compared_equal_shape} != -1 } {
 725         upvar ${compared_equal_shape} ${compared_equal_shape}
 726         regexp "The +length+ ${compared_equal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_equal_shape} ${epsilon}] full compared_m
 727         if { $compared_m != $m } {
 728             puts "Error: length of shape ${compared_equal_shape} is not equal to shape ${shape}"
 729         }
 730     }
 731
 732     if { ${compared_notequal_shape} != -1 } {
 733         upvar ${compared_notequal_shape} ${compared_notequal_shape}
 734         regexp "The +length+ ${compared_notequal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_notequal_shape} ${epsilon}] full compared_m
 735         if { $compared_m == $m } {
 736             puts "Error: length of shape ${compared_notequal_shape} is equal shape to ${shape}"
 737         }
 738     }
 739
 740     if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
 741         if { [string compare "$mass" "empty"] != 0 } {
 742             if { $m == 0 } {
 743                 puts "Error : The command is not valid. The $prop is 0."
 744             }
 745             if { $mass > 0 } {
 746                 puts "The expected $prop is $mass"
 747             }
 748             #check of change of area is < 1%
 749             if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } {
 750                 puts "Error : The $prop of result shape is $m"
 751             }
 752         } else {
 753             if { $m != 0 } {
 754                 puts "Error : The command is not valid. The $prop is $m"
 755             }
 756         }
 757     }
 758 }
 759
 760 help checkview {
 761   Display shape in selected viewer.
 762
 763   Use: checkview [options...]
 764   Allowed options are:
 765     -display shapename: display shape with name 'shapename'
 766     -3d: display shape in 3d viewer
 767     -2d [ v2d / smallview ]: display shape in 2d viewer (default viewer is a 'smallview')
 768     -vdispmode N: it is possible to set vdispmode for 3d viewer (default value is 1)
 769     -screenshot: procedure will try to make screenshot of already created viewer
 770     -path <path>: location of saved screenshot of viewer
 771
 772     Procedure can check some property of shape (length, area or volume) and compare it with some value N:
 773       -l [N]
 774       -s [N]
 775       -v [N]
 776     If current property is equal to value N, shape is marked as valid in procedure.
 777     If value N is not given procedure will mark shape as valid if current property is non-zero.
 778     -with {a b c}: display shapes 'a' 'b' 'c' together with 'shape' (if shape is valid)
 779     -otherwise {d e f}: display shapes 'd' 'e' 'f' instead of 'shape' (if shape is NOT valid)
 780     Note that one of two options -2d/-3d is required.
 781 }
 782
 783 proc checkview {args} {
 784   puts "checkview ${args}"
 785
 786   set 3dviewer 0
 787   set 2dviewer false
 788   set shape ""
 789   set PathToSave ""
 790   set dispmode 1
 791   set isScreenshot 0
 792   set check_length false
 793   set check_area false
 794   set check_volume false
 795   set otherwise {}
 796   set with {}
 797
 798   set options {{"-3d" 3dviewer 0}
 799                {"-2d" 2dviewer ?}
 800                {"-display" shape 1}
 801                {"-path" PathToSave 1}
 802                {"-vdispmode" dispmode 1}
 803                {"-screenshot" isScreenshot 0}
 804                {"-otherwise" otherwise 1}
 805                {"-with" with 1}
 806                {"-l" check_length ?}
 807                {"-s" check_area ?}
 808                {"-v" check_volume ?}}
 809
 810   # check arguments
 811   _check_args ${args} ${options} "checkview"
 812
 813   if { ${PathToSave} == "" } {
 814     set PathToSave "./photo.png"
 815   }
 816
 817   if { ${3dviewer} == 0 && ${2dviewer} == false } {
 818     error "Error: wrong using of command 'checkview', please use -2d or -3d option"
 819   }
 820
 821   if { ${isScreenshot} } {
 822     if { ${3dviewer} } {
 823       vdump ${PathToSave}
 824     } else {
 825       xwd ${PathToSave}
 826     }
 827     return
 828   }
 829
 830   set mass 0
 831   set isBAD 0
 832   upvar ${shape} ${shape}
 833   if {[isdraw ${shape}]} {
 834     # check area
 835     if { [string is boolean ${check_area}] } {
 836       if { ${check_area} } {
 837         regexp {Mass +: +([-0-9.+eE]+)} [sprops ${shape}] full mass
 838       }
 839     } else {
 840       set mass ${check_area}
 841     }
 842     # check length
 843     if { [string is boolean ${check_length}] } {
 844       if { ${check_length} } {
 845         regexp {Mass +: +([-0-9.+eE]+)} [lprops ${shape}] full mass
 846       }
 847     } else {
 848       set mass ${check_length}
 849     }
 850     # check volume
 851     if { [string is boolean ${check_volume}] } {
 852       if { ${check_volume} } {
 853         regexp {Mass +: +([-0-9.+eE]+)} [vprops ${shape}] full mass
 854       }
 855     } else {
 856       set mass ${check_volume}
 857     }
 858   } else {
 859     set isBAD 1
 860   }
 861   if { ${3dviewer} } {
 862     vinit
 863     vclear
 864   } elseif { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
 865     smallview
 866     clear
 867   } elseif { ${2dviewer} == "v2d"} {
 868     v2d
 869     2dclear
 870   }
 871   if {[isdraw ${shape}]} {
 872     if { ( ${check_area} == false && ${check_length} == false && ${check_volume} == false ) || ( ${mass} != 0 ) } {
 873       foreach s ${with} {
 874         upvar ${s} ${s}
 875       }
 876       lappend with ${shape}
 877       if { ${3dviewer} } {
 878         vdisplay {*}${with}
 879       } else {
 880         donly {*}${with}
 881       }
 882     } else {
 883       set isBAD 1
 884     }
 885   } else {
 886     set isBAD 1
 887   }
 888
 889   if { ${isBAD} && [llength ${otherwise}] } {
 890     foreach s ${otherwise} {
 891       upvar ${s} ${s}
 892     }
 893     if { ${3dviewer} } {
 894       vdisplay {*}${otherwise}
 895     } else {
 896       donly {*}${otherwise}
 897     }
 898   }
 899
 900   if { ${3dviewer} } {
 901     vsetdispmode ${dispmode}
 902     vfit
 903     vdump ${PathToSave}
 904   } else {
 905     if { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
 906       fit
 907     } elseif { ${2dviewer} == "v2d"} {
 908       2dfit
 909     }
 910     xwd ${PathToSave}
 911   }
 912
 913 }
 914
 915 help checktrinfo {
 916   Compare maximum deflection, number of nodes and triangles in "shape" mesh with given reference data
 917
 918   Use: checktrinfo shapename [options...]
 919   Allowed options are:
 920     -tri [N]:  compare current number of triangles in "shapename" mesh with given reference data.
 921                If reference value N is not given and current number of triangles is equal to 0
 922                procedure checktrinfo will print an error.
 923     -nod [N]:  compare current number of nodes in "shapename" mesh with given reference data.
 924                If reference value N is not givenand current number of nodes is equal to 0
 925                procedure checktrinfo will print an error.
 926     -defl [N]: compare current value of maximum deflection in "shapename" mesh with given reference data
 927                If reference value N is not given and current maximum deflection is equal to 0
 928                procedure checktrinfo will print an error.
 929     -max_defl N:     compare current value of maximum deflection in "shapename" mesh with max possible value
 930     -tol_abs_tri N:  absolute tolerance for comparison of number of triangles (default value 0)
 931     -tol_rel_tri N:  relative tolerance for comparison of number of triangles (default value 0)
 932     -tol_abs_nod N:  absolute tolerance for comparison of number of nodes (default value 0)
 933     -tol_rel_nod N:  relative tolerance for comparison of number of nodes (default value 0)
 934     -tol_abs_defl N: absolute tolerance for deflection comparison (default value 0)
 935     -tol_rel_defl N: relative tolerance for deflection comparison (default value 0)
 936     -ref [trinfo a]: compare deflection, number of triangles and nodes in "shapename" and in "a"
 937 }
 938 proc checktrinfo {shape args} {
 939     puts "checktrinfo ${shape} ${args}"
 940     upvar ${shape} ${shape}
 941
 942     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 943         puts "Error: The command cannot be built"
 944         return
 945     }
 946
 947     set ref_nb_triangles false
 948     set ref_nb_nodes false
 949     set ref_deflection false
 950     set tol_abs_defl 0
 951     set tol_rel_defl 0
 952     set tol_abs_tri 0
 953     set tol_rel_tri 0
 954     set tol_abs_nod 0
 955     set tol_rel_nod 0
 956     set max_defl -1
 957     set ref_info ""
 958
 959     set options {{"-tri" ref_nb_triangles ?}
 960                  {"-nod" ref_nb_nodes ?}
 961                  {"-defl" ref_deflection ?}
 962                  {"-tol_abs_defl" tol_abs_defl 1}
 963                  {"-tol_rel_defl" tol_rel_defl 1}
 964                  {"-tol_abs_tri" tol_abs_tri 1}
 965                  {"-tol_rel_tri" tol_rel_tri 1}
 966                  {"-tol_abs_nod" tol_abs_nod 1}
 967                  {"-tol_rel_nod" tol_rel_nod 1}
 968                  {"-max_defl" max_defl 1}
 969                  {"-ref" ref_info 1}}
 970
 971     _check_args ${args} ${options} "checktrinfo"
 972
 973     # get current number of triangles and nodes, value of max deflection
 974     set tri_info [trinfo ${shape}]
 975     set triinfo_pattern "(\[0-9\]+) +triangles.*\[^0-9]\(\[0-9\]+) +nodes.*deflection +(\[-0-9.+eE\]+)"
 976     if {![regexp "${triinfo_pattern}" ${tri_info} dump cur_nb_triangles cur_nb_nodes cur_deflection]} {
 977         puts "Error: command trinfo prints empty info"
 978     }
 979
 980     # get reference values from -ref option
 981     if { "${ref_info}" != ""} {
 982         if {![regexp "${triinfo_pattern}" ${ref_info} dump ref_nb_triangles ref_nb_nodes ref_deflection]} {
 983             puts "Error: reference information gived by -ref option is wrong"
 984         }
 985     }
 986
 987     # check number of triangles
 988     if { [string is boolean ${ref_nb_triangles}] } {
 989         if { ${cur_nb_triangles} <= 0 && ${ref_nb_triangles} } {
 990             puts "Error: Number of triangles is equal to 0"
 991         }
 992     } else {
 993         if {[regexp {!([-0-9.+eE]+)} $ref_nb_triangles full ref_nb_triangles_value]} {
 994             if  {${ref_nb_triangles_value} == ${cur_nb_triangles} } {
 995                 puts "Error: Number of triangles is equal to ${ref_nb_triangles_value} but it should not"
 996             }
 997         } else {
 998             checkreal "Number of triangles" ${cur_nb_triangles} ${ref_nb_triangles} ${tol_abs_tri} ${tol_rel_tri}
 999         }
1000     }
1001
1002     # check number of nodes
1003     if { [string is boolean ${ref_nb_nodes}] } {
1004         if { ${cur_nb_nodes} <= 0 && ${ref_nb_nodes} } {
1005             puts "Error: Number of nodes is equal to 0"
1006         }
1007     } else {
1008         if {[regexp {!([-0-9.+eE]+)} $ref_nb_nodes full ref_nb_nodes_value]} {
1009             if  {${ref_nb_nodes_value} == ${cur_nb_nodes} } {
1010                 puts "Error: Number of nodes is equal to ${ref_nb_nodes_value} but it should not"
1011             }
1012         } else {
1013             checkreal "Number of nodes" ${cur_nb_nodes} ${ref_nb_nodes} ${tol_abs_nod} ${tol_rel_nod}
1014         }
1015     }
1016
1017     # check deflection
1018     if { [string is boolean ${ref_deflection}] } {
1019         if { ${cur_deflection} <= 0 && ${ref_deflection} } {
1020             puts "Error: Maximal deflection is equal to 0"
1021         }
1022     } else {
1023         checkreal "Maximal deflection" ${cur_deflection} ${ref_deflection} ${tol_abs_defl} ${tol_rel_defl}
1024     }
1025
1026     if { ${max_defl} != -1 && ${cur_deflection} > ${max_defl} } {
1027         puts "Error: Maximal deflection is too big"
1028     }
1029 }
1030
1031 help checkplatform {
1032   Return name of current platform if no options are given.
1033
1034   Use: checkplatform [options...]
1035   Allowed options are:
1036     -windows : return 1 if current platform is 'Windows', overwise return 0
1037     -linux   : return 1 if current platform is 'Linux', overwise return 0
1038     -osx     : return 1 if current platform is 'MacOS X', overwise return 0
1039
1040   Only one option can be used at once.
1041   If no option is given, procedure will return the name of current platform.
1042 }
1043 proc checkplatform {args} {
1044     set check_for_windows false
1045     set check_for_linux false
1046     set check_for_macosx false
1047
1048     set options {{"-windows" check_for_windows 0}
1049                  {"-linux" check_for_linux 0}
1050                  {"-osx" check_for_macosx 0}}
1051
1052     _check_args ${args} ${options} "checkplatform"
1053
1054     if { [regexp "indows" $::tcl_platform(os)] } {
1055         set current_platform Windows
1056     } elseif { $::tcl_platform(os) == "Linux" } {
1057         set current_platform Linux
1058     } elseif { $::tcl_platform(os) == "Darwin" } {
1059         set current_platform MacOS
1060     }
1061
1062     # no args are given
1063     if { !${check_for_windows} && !${check_for_linux} && !${check_for_macosx}} {
1064         return ${current_platform}
1065     }
1066
1067     # check usage of proc checkplatform
1068     if { [expr [string is true ${check_for_windows}] + [string is true ${check_for_linux}] + [string is true ${check_for_macosx}] ] > 1} {
1069         error "Error: wrong usage of command checkplatform, only single option can be used at once"
1070     }
1071
1072     # checking for Windows platform
1073     if { ${check_for_windows} && ${current_platform} == "Windows" } {
1074         return 1
1075     }
1076
1077     # checking for Mac OS X platforms
1078     if { ${check_for_linux} && ${current_platform} == "Linux" } {
1079         return 1
1080     }
1081
1082     # checking for Mac OS X platforms
1083     if { ${check_for_macosx} && ${current_platform} == "MacOS" } {
1084         return 1
1085     }
1086
1087     # current platform is not equal to given as argument platform, return false
1088     return 0
1089 }