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     -equal SHAPE: compare area\volume\length of input shapes. Puts error if its are not equal
 505     -notequal SHAPE: compare area\volume\length of input shapes. Puts error if its are equal
 506     -skip: count shared shapes only once, skipping repeatitions
 507   Options -l, -s and -v are independent and can be used in any order. Tolerance epsilon is the same for all options.
 508 }
 509
 510 proc checkprops {shape args} {
 511     puts "checkprops ${shape} ${args}"
 512     upvar ${shape} ${shape}
 513
 514     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 515         puts "Error: The command cannot be built"
 516         return
 517     }
 518
 519     set length -1
 520     set area -1
 521     set volume -1
 522     set epsilon 1.0e-4
 523     set compared_equal_shape -1
 524     set compared_notequal_shape -1
 525     set equal_check 0
 526     set skip 0
 527
 528     set options {{"-eps" epsilon 1}
 529                  {"-equal" compared_equal_shape 1}
 530                  {"-notequal" compared_notequal_shape 1}
 531                  {"-skip" skip 0}}
 532
 533     if { [regexp {\-[not]*equal} $args] } {
 534         lappend options {"-s" area 0}
 535         lappend options {"-l" length 0}
 536         lappend options {"-v" volume 0}
 537         set equal_check 1
 538     } else {
 539         lappend options {"-s" area 1}
 540         lappend options {"-l" length 1}
 541         lappend options {"-v" volume 1}
 542     }
 543     _check_args ${args} ${options} "checkprops"
 544
 545     if { ${length} != -1 || ${equal_check} == 1 } {
 546         set CommandName lprops
 547         set mass $length
 548         set prop "length"
 549         set equal_check 0
 550     }
 551     if { ${area} != -1 || ${equal_check} == 1 } {
 552         set CommandName sprops
 553         set mass $area
 554         set prop "area"
 555         set equal_check 0
 556     }
 557     if { ${volume} != -1 || ${equal_check} == 1 } {
 558         set CommandName vprops
 559         set mass $volume
 560         set prop "volume"
 561         set equal_check 0
 562     }
 563
 564     set skip_option ""
 565     if { $skip } {
 566         set skip_option "-skip"
 567     }
 568
 569
 570     regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${shape} ${epsilon} $skip_option] full m
 571
 572     if { ${compared_equal_shape} != -1 } {
 573         upvar ${compared_equal_shape} ${compared_equal_shape}
 574         regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_equal_shape} ${epsilon} $skip_option] full compared_m
 575         if { $compared_m != $m } {
 576             puts "Error: Shape ${compared_equal_shape} is not equal to shape ${shape}"
 577         }
 578     }
 579
 580     if { ${compared_notequal_shape} != -1 } {
 581         upvar ${compared_notequal_shape} ${compared_notequal_shape}
 582         regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_notequal_shape} ${epsilon} $skip_option] full compared_m
 583         if { $compared_m == $m } {
 584             puts "Error: Shape ${compared_notequal_shape} is equal shape to ${shape}"
 585         }
 586     }
 587
 588     if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
 589         if { [string compare "$mass" "empty"] != 0 } {
 590             if { $m == 0 } {
 591                 puts "Error : The command is not valid. The $prop is 0."
 592             }
 593             if { $mass > 0 } {
 594                 puts "The expected $prop is $mass"
 595             }
 596             #check of change of area is < 1%
 597             if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } {
 598                 puts "Error : The $prop of result shape is $m"
 599             }
 600         } else {
 601             if { $m != 0 } {
 602                 puts "Error : The command is not valid. The $prop is $m"
 603             }
 604         }
 605     }
 606 }
 607
 608 help checkdump {
 609   Procedure includes command to parse output dump and compare it with reference values.
 610
 611   Use: checkdump shapename [options...]
 612   Allowed options are:
 613     -name NAME: list of parsing parameters (e.g. Center, Axis, etc)
 614     -ref VALUE: list of reference values for each parameter in NAME
 615     -eps EPSILON: the epsilon defines relative precision of computation
 616 }
 617
 618 proc checkdump {shape args} {
 619     puts "checkdump ${shape} ${args}"
 620     upvar ${shape} ${shape}
 621
 622     set ddump -1
 623     set epsilon -1
 624     set options {{"-name" params 1}
 625                  {"-ref" ref 1}
 626                  {"-eps" epsilon 1}
 627                  {"-dump" ddump 1}}
 628
 629     if { ${ddump} == -1 } {
 630         set ddump [dump ${shape}]
 631     }
 632     _check_args ${args} ${options} "checkdump"
 633
 634     set index 0
 635     foreach param ${params} {
 636         set pattern "${param}\\s*:\\s*"
 637         set number_pattern "(\[-0-9.+eE\]+)\\s*"
 638         set ref_values ""
 639         set local_ref ${ref}
 640         if { [llength ${params}] > 1 } {
 641             set local_ref [lindex ${ref} ${index}]
 642         }
 643         foreach item ${local_ref} {
 644             if { ![regexp "$pattern$number_pattern" $ddump full res] } {
 645                 puts "Error: cheked parameter ${param} is not listed in dump"
 646                 break
 647             }
 648             lappend ref_values $res
 649             set pattern "${pattern}${res},\\s*"
 650             ## without precision
 651             if { ${epsilon} == -1 } {
 652                 if { ${item} != ${res} } {
 653                     puts "Error: parameter ${param} - current value (${res}) is not equal to reference value (${item})"
 654                 } else {
 655                     puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
 656                 }
 657             ## with precision
 658             } else {
 659                 set precision 0.0000001
 660                 if { ( abs($res) > $precision ) || ( abs($item) > $precision ) } {
 661                     if { ($item != 0 && [expr 1.*abs($item - $res)/$item] > $epsilon) || ($item == 0 && $res != 0) } {
 662                         puts "Error: The $param of the resulting shape is $res and the expected $param is $item"
 663                     } else {
 664                         puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
 665                     }
 666                 }
 667             }
 668         }
 669         incr index
 670     }
 671 }
 672
 673 help checklength {
 674   Procedure includes commands to compute length of input curve.
 675
 676   Use: checklength curvename [options...]
 677   Allowed options are:
 678     -l LENGTH: command length, computes the length of input curve with precision of computation
 679     -eps EPSILON: the epsilon defines relative precision of computation
 680     -equal CURVE: compare length of input curves. Puts error if its are not equal
 681     -notequal CURVE: compare length of input curves. Puts error if its are equal
 682 }
 683
 684 proc checklength {shape args} {
 685     puts "checklength ${shape} ${args}"
 686     upvar ${shape} ${shape}
 687
 688     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 689         puts "Error: The command cannot be built"
 690         return
 691     }
 692
 693     set length -1
 694     set epsilon 1.0e-4
 695     set compared_equal_shape -1
 696     set compared_notequal_shape -1
 697     set equal_check 0
 698
 699     set options {{"-eps" epsilon 1}
 700                  {"-equal" compared_equal_shape 1}
 701                  {"-notequal" compared_notequal_shape 1}}
 702
 703     if { [regexp {\-[not]*equal} $args] } {
 704         lappend options {"-l" length 0}
 705         set equal_check 1
 706     } else {
 707         lappend options {"-l" length 1}
 708     }
 709     _check_args ${args} ${options} "checkprops"
 710
 711     if { ${length} != -1 || ${equal_check} == 1 } {
 712         set CommandName length
 713         set mass $length
 714         set prop "length"
 715         set equal_check 0
 716     }
 717
 718     regexp "The +length+ ${shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${shape} ${epsilon}] full m
 719
 720     if { ${compared_equal_shape} != -1 } {
 721         upvar ${compared_equal_shape} ${compared_equal_shape}
 722         regexp "The +length+ ${compared_equal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_equal_shape} ${epsilon}] full compared_m
 723         if { $compared_m != $m } {
 724             puts "Error: length of shape ${compared_equal_shape} is not equal to shape ${shape}"
 725         }
 726     }
 727
 728     if { ${compared_notequal_shape} != -1 } {
 729         upvar ${compared_notequal_shape} ${compared_notequal_shape}
 730         regexp "The +length+ ${compared_notequal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_notequal_shape} ${epsilon}] full compared_m
 731         if { $compared_m == $m } {
 732             puts "Error: length of shape ${compared_notequal_shape} is equal shape to ${shape}"
 733         }
 734     }
 735
 736     if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
 737         if { [string compare "$mass" "empty"] != 0 } {
 738             if { $m == 0 } {
 739                 puts "Error : The command is not valid. The $prop is 0."
 740             }
 741             if { $mass > 0 } {
 742                 puts "The expected $prop is $mass"
 743             }
 744             #check of change of area is < 1%
 745             if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } {
 746                 puts "Error : The $prop of result shape is $m"
 747             }
 748         } else {
 749             if { $m != 0 } {
 750                 puts "Error : The command is not valid. The $prop is $m"
 751             }
 752         }
 753     }
 754 }
 755
 756 help checkview {
 757   Display shape in selected viewer.
 758
 759   Use: checkview [options...]
 760   Allowed options are:
 761     -display shapename: display shape with name 'shapename'
 762     -3d: display shape in 3d viewer
 763     -2d [ v2d / smallview ]: display shape in 2d viewer (default viewer is a 'smallview')
 764     -path PATH: location of saved screenshot of viewer
 765     -vdispmode N: it is possible to set vdispmode for 3d viewer (default value is 1)
 766     -screenshot: procedure will try to make screenshot of already created viewer
 767     Procedure can check some property of shape (length, area or volume) and compare it with some value N:
 768       -l [N]
 769       -s [N]
 770       -v [N]
 771     If current property is equal to value N, shape is marked as valid in procedure.
 772     If value N is not given procedure will mark shape as valid if current property is non-zero.
 773     -with {a b c}: display shapes 'a' 'b' 'c' together with 'shape' (if shape is valid)
 774     -otherwise {d e f}: display shapes 'd' 'e' 'f' instead of 'shape' (if shape is NOT valid)
 775     Note that one of two options -2d/-3d is required.
 776 }
 777
 778 proc checkview {args} {
 779   puts "checkview ${args}"
 780
 781   set 3dviewer 0
 782   set 2dviewer false
 783   set shape ""
 784   set PathToSave ""
 785   set dispmode 1
 786   set isScreenshot 0
 787   set check_length false
 788   set check_area false
 789   set check_volume false
 790   set otherwise {}
 791   set with {}
 792
 793   set options {{"-3d" 3dviewer 0}
 794                {"-2d" 2dviewer ?}
 795                {"-display" shape 1}
 796                {"-path" PathToSave 1}
 797                {"-vdispmode" dispmode 1}
 798                {"-screenshot" isScreenshot 0}
 799                {"-otherwise" otherwise 1}
 800                {"-with" with 1}
 801                {"-l" check_length ?}
 802                {"-s" check_area ?}
 803                {"-v" check_volume ?}}
 804
 805   # check arguments
 806   _check_args ${args} ${options} "checkview"
 807
 808   if { ${PathToSave} == "" } {
 809     set PathToSave "./photo.png"
 810   }
 811
 812   if { ${3dviewer} == 0 && ${2dviewer} == false } {
 813     error "Error: wrong using of command 'checkview', please use -2d or -3d option"
 814   }
 815
 816   if { ${isScreenshot} } {
 817     if { ${3dviewer} } {
 818       vdump ${PathToSave}
 819     } else {
 820       xwd ${PathToSave}
 821     }
 822     return
 823   }
 824
 825   set mass 0
 826   set isBAD 0
 827   upvar ${shape} ${shape}
 828   if {[isdraw ${shape}]} {
 829     # check area
 830     if { [string is boolean ${check_area}] } {
 831       if { ${check_area} } {
 832         regexp {Mass +: +([-0-9.+eE]+)} [sprops ${shape}] full mass
 833       }
 834     } else {
 835       set mass ${check_area}
 836     }
 837     # check length
 838     if { [string is boolean ${check_length}] } {
 839       if { ${check_length} } {
 840         regexp {Mass +: +([-0-9.+eE]+)} [lprops ${shape}] full mass
 841       }
 842     } else {
 843       set mass ${check_length}
 844     }
 845     # check volume
 846     if { [string is boolean ${check_volume}] } {
 847       if { ${check_volume} } {
 848         regexp {Mass +: +([-0-9.+eE]+)} [vprops ${shape}] full mass
 849       }
 850     } else {
 851       set mass ${check_volume}
 852     }
 853   } else {
 854     set isBAD 1
 855   }
 856   if { ${3dviewer} } {
 857     vinit
 858     vclear
 859   } elseif { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
 860     smallview
 861     clear
 862   } elseif { ${2dviewer} == "v2d"} {
 863     v2d
 864     2dclear
 865   }
 866   if {[isdraw ${shape}]} {
 867     if { ( ${check_area} == false && ${check_length} == false && ${check_volume} == false ) || ( ${mass} != 0 ) } {
 868       foreach s ${with} {
 869         upvar ${s} ${s}
 870       }
 871       lappend with ${shape}
 872       if { ${3dviewer} } {
 873         vdisplay {*}${with}
 874       } else {
 875         donly {*}${with}
 876       }
 877     } else {
 878       set isBAD 1
 879     }
 880   } else {
 881     set isBAD 1
 882   }
 883
 884   if { ${isBAD} && [llength ${otherwise}] } {
 885     foreach s ${otherwise} {
 886       upvar ${s} ${s}
 887     }
 888     if { ${3dviewer} } {
 889       vdisplay {*}${otherwise}
 890     } else {
 891       donly {*}${otherwise}
 892     }
 893   }
 894
 895   if { ${3dviewer} } {
 896     vsetdispmode ${dispmode}
 897     vfit
 898     vdump ${PathToSave}
 899   } else {
 900     if { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
 901       fit
 902     } elseif { ${2dviewer} == "v2d"} {
 903       2dfit
 904     }
 905     xwd ${PathToSave}
 906   }
 907
 908 }
 909
 910 help checktrinfo {
 911   Compare maximum deflection, number of nodes and triangles in "shape" mesh with given reference data
 912
 913   Use: checktrinfo shapename [options...]
 914   Allowed options are:
 915     -tri [N]:  compare current number of triangles in "shapename" mesh with given reference data.
 916                If reference value N is not given and current number of triangles is equal to 0
 917                procedure checktrinfo will print an error.
 918     -nod [N]:  compare current number of nodes in "shapename" mesh with given reference data.
 919                If reference value N is not givenand current number of nodes is equal to 0
 920                procedure checktrinfo will print an error.
 921     -defl [N]: compare current value of maximum deflection in "shapename" mesh with given reference data
 922                If reference value N is not given and current maximum deflection is equal to 0
 923                procedure checktrinfo will print an error.
 924     -max_defl N:     compare current value of maximum deflection in "shapename" mesh with max possible value
 925     -tol_abs_tri N:  absolute tolerance for comparison of number of triangles (default value 0)
 926     -tol_rel_tri N:  relative tolerance for comparison of number of triangles (default value 0)
 927     -tol_abs_nod N:  absolute tolerance for comparison of number of nodes (default value 0)
 928     -tol_rel_nod N:  relative tolerance for comparison of number of nodes (default value 0)
 929     -tol_abs_defl N: absolute tolerance for deflection comparison (default value 0)
 930     -tol_rel_defl N: relative tolerance for deflection comparison (default value 0)
 931     -ref [trinfo a]: compare deflection, number of triangles and nodes in "shapename" and in "a"
 932 }
 933 proc checktrinfo {shape args} {
 934     puts "checktrinfo ${shape} ${args}"
 935     upvar ${shape} ${shape}
 936
 937     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 938         puts "Error: The command cannot be built"
 939         return
 940     }
 941
 942     set ref_nb_triangles false
 943     set ref_nb_nodes false
 944     set ref_deflection false
 945     set tol_abs_defl 0
 946     set tol_rel_defl 0
 947     set tol_abs_tri 0
 948     set tol_rel_tri 0
 949     set tol_abs_nod 0
 950     set tol_rel_nod 0
 951     set max_defl -1
 952     set ref_info ""
 953
 954     set options {{"-tri" ref_nb_triangles ?}
 955                  {"-nod" ref_nb_nodes ?}
 956                  {"-defl" ref_deflection ?}
 957                  {"-tol_abs_defl" tol_abs_defl 1}
 958                  {"-tol_rel_defl" tol_rel_defl 1}
 959                  {"-tol_abs_tri" tol_abs_tri 1}
 960                  {"-tol_rel_tri" tol_rel_tri 1}
 961                  {"-tol_abs_nod" tol_abs_nod 1}
 962                  {"-tol_rel_nod" tol_rel_nod 1}
 963                  {"-max_defl" max_defl 1}
 964                  {"-ref" ref_info 1}}
 965
 966     _check_args ${args} ${options} "checktrinfo"
 967
 968     # get current number of triangles and nodes, value of max deflection
 969     set tri_info [trinfo ${shape}]
 970     set triinfo_pattern "(\[0-9\]+) +triangles.*\[^0-9]\(\[0-9\]+) +nodes.*deflection +(\[-0-9.+eE\]+)"
 971     if {![regexp "${triinfo_pattern}" ${tri_info} dump cur_nb_triangles cur_nb_nodes cur_deflection]} {
 972         puts "Error: command trinfo prints empty info"
 973     }
 974
 975     # get reference values from -ref option
 976     if { "${ref_info}" != ""} {
 977         if {![regexp "${triinfo_pattern}" ${ref_info} dump ref_nb_triangles ref_nb_nodes ref_deflection]} {
 978             puts "Error: reference information gived by -ref option is wrong"
 979         }
 980     }
 981
 982     # check number of triangles
 983     if { [string is boolean ${ref_nb_triangles}] } {
 984         if { ${cur_nb_triangles} <= 0 && ${ref_nb_triangles} } {
 985             puts "Error: Number of triangles is equal to 0"
 986         }
 987     } else {
 988         if {[regexp {!([-0-9.+eE]+)} $ref_nb_triangles full ref_nb_triangles_value]} {
 989             if  {${ref_nb_triangles_value} == ${cur_nb_triangles} } {
 990                 puts "Error: Number of triangles is equal to ${ref_nb_triangles_value} but it should not"
 991             }
 992         } else {
 993             checkreal "Number of triangles" ${cur_nb_triangles} ${ref_nb_triangles} ${tol_abs_tri} ${tol_rel_tri}
 994         }
 995     }
 996
 997     # check number of nodes
 998     if { [string is boolean ${ref_nb_nodes}] } {
 999         if { ${cur_nb_nodes} <= 0 && ${ref_nb_nodes} } {
1000             puts "Error: Number of nodes is equal to 0"
1001         }
1002     } else {
1003         if {[regexp {!([-0-9.+eE]+)} $ref_nb_nodes full ref_nb_nodes_value]} {
1004             if  {${ref_nb_nodes_value} == ${cur_nb_nodes} } {
1005                 puts "Error: Number of nodes is equal to ${ref_nb_nodes_value} but it should not"
1006             }
1007         } else {
1008             checkreal "Number of nodes" ${cur_nb_nodes} ${ref_nb_nodes} ${tol_abs_nod} ${tol_rel_nod}
1009         }
1010     }
1011
1012     # check deflection
1013     if { [string is boolean ${ref_deflection}] } {
1014         if { ${cur_deflection} <= 0 && ${ref_deflection} } {
1015             puts "Error: Maximal deflection is equal to 0"
1016         }
1017     } else {
1018         checkreal "Maximal deflection" ${cur_deflection} ${ref_deflection} ${tol_abs_defl} ${tol_rel_defl}
1019     }
1020
1021     if { ${max_defl} != -1 && ${cur_deflection} > ${max_defl} } {
1022         puts "Error: Maximal deflection is too big"
1023     }
1024 }