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