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       incr narg
 175       if { $narg < [llength $args] && ! [regexp {^-[^0-9]} [lindex $args $narg]] } {
 176         set ${check_result} "[lindex $args $narg]"
 177       } else {
 178         error "Option ${check_result} requires argument"
 179       }
 180     } else {
 181       set ${check_result} 1
 182     }
 183     return 1
 184   }
 185   return 0
 186 }
 187
 188 help checknbshapes {
 189   Compare number of sub-shapes in "shape" with given reference data
 190
 191   Use: checknbshapes shape [options...]
 192   Allowed options are:
 193     -vertex N
 194     -edge N
 195     -wire N
 196     -face N
 197     -shell N
 198     -solid N
 199     -compsolid N
 200     -compound N
 201     -shape N
 202     -t: compare the number of sub-shapes in "shape" counting
 203         the same sub-shapes with different location as different sub-shapes.
 204     -m msg: print "msg" in case of error
 205     -ref [nbshapes a]: compare the number of sub-shapes in "shape" and in "a".
 206                        -vertex N, -edge N and other options are stil working.
 207 }
 208 proc checknbshapes {shape args} {
 209   puts "checknbshapes ${shape} ${args}"
 210   upvar ${shape} ${shape}
 211
 212   set nbVERTEX -1
 213   set nbEDGE -1
 214   set nbWIRE -1
 215   set nbFACE -1
 216   set nbSHELL -1
 217   set nbSOLID -1
 218   set nbCOMPSOLID -1
 219   set nbCOMPOUND -1
 220   set nbSHAPE -1
 221
 222   set message ""
 223   set count_locations 0
 224   set ref_info ""
 225
 226   for {set narg 0} {$narg < [llength $args]} {incr narg} {
 227     set arg [lindex $args $narg]
 228     if {[_check_arg "-vertex" nbVERTEX 1] ||
 229         [_check_arg "-edge" nbEDGE 1] ||
 230         [_check_arg "-wire" nbWIRE 1] ||
 231         [_check_arg "-face" nbFACE 1] ||
 232         [_check_arg "-shell" nbSHELL 1] ||
 233         [_check_arg "-solid" nbSOLID 1] ||
 234         [_check_arg "-compsolid" nbCOMPSOLID 1] ||
 235         [_check_arg "-compound" nbCOMPOUND 1] ||
 236         [_check_arg "-shape" nbSHAPE 1] ||
 237         [_check_arg "-t" count_locations] ||
 238         [_check_arg "-m" message 1] ||
 239         [_check_arg "-ref" ref_info 1]
 240        } {
 241       continue
 242     }
 243     # unsupported option
 244     if { [regexp {^-} $arg] } {
 245       error "Error: unsupported option \"$arg\""
 246     }
 247     error "Error: cannot interpret argument $narg ($arg)"
 248   }
 249
 250   if { ${count_locations} == 0 } {
 251     set nb_info [nbshapes ${shape}]
 252   } else {
 253     set nb_info [nbshapes ${shape} -t]
 254   }
 255
 256   set EntityList {VERTEX EDGE WIRE FACE SHELL SOLID COMPSOLID COMPOUND SHAPE}
 257
 258   foreach Entity ${EntityList} {
 259     set expr_string "${Entity} +: +(\[-0-9.+eE\]+)"
 260     set to_compare {}
 261     # get number of elements from ${shape}
 262     if { [regexp "${expr_string}" ${nb_info} full nb_entity2] } {
 263       lappend to_compare ${nb_entity2}
 264     } else {
 265       error "Error : command \"nbshapes ${shape}\" gives an empty result"
 266     }
 267     # get number of elements from options -vertex -edge and so on
 268     set nb_entity1 [set nb${Entity}]
 269     if { ${nb_entity1} != -1 } {
 270       lappend to_compare ${nb_entity1}
 271     }
 272     # get number of elements from option -ref
 273     if { [regexp "${expr_string}" ${ref_info} full nb_entity_ref] } {
 274       lappend to_compare ${nb_entity_ref}
 275     }
 276     # skip comparing if no reference data was given
 277     if {[llength $to_compare] == 1} {
 278       continue
 279     }
 280     # compare all values, if they are equal, length of sorted list "to_compare"
 281     # (with key -unique) should be equal to 1
 282     set to_compare [lsort -dictionary -unique $to_compare]
 283     if { [llength $to_compare] != 1 } {
 284       puts "Error : ${message} is WRONG because number of ${Entity} entities in shape \"${shape}\" is ${nb_entity2}"
 285     } else {
 286       puts "OK : ${message} is GOOD because number of ${Entity} entities is equal to number of expected ${Entity} entities"
 287     }
 288   }
 289 }
 290
 291 # Procedure to check equality of two reals with tolerance (relative and absolute)
 292 help checkreal {
 293   Compare value with expected
 294   Use: checkreal name value expected tol_abs tol_rel
 295 }
 296 proc checkreal {name value expected tol_abs tol_rel} {
 297     if { abs ($value - $expected) > $tol_abs + $tol_rel * abs ($expected) } {
 298         puts "Error: $name = $value is not equal to expected $expected"
 299     } else {
 300         puts "Check of $name OK: value = $value, expected = $expected"
 301     }
 302     return
 303 }
 304
 305 help checkfreebounds {
 306   Compare number of free edges with ref_value
 307
 308   Use: checkfreebounds shape ref_value [options...]
 309   Allowed options are:
 310     -tol N: used tolerance (default -0.01)
 311     -type N: used type, possible values are "closed" and "opened" (default "closed")
 312 }
 313 proc checkfreebounds {shape ref_value args} {
 314   puts "checkfreebounds ${shape} ${ref_value} ${args}"
 315   upvar ${shape} ${shape}
 316
 317   set tol -0.01
 318   set type "closed"
 319
 320   for {set narg 0} {$narg < [llength $args]} {incr narg} {
 321     set arg [lindex $args $narg]
 322     if {[_check_arg "-tol" tol 1] ||
 323         [_check_arg "-type" type 1]
 324        } {
 325       continue
 326     }
 327     # unsupported option
 328     if { [regexp {^-} $arg] } {
 329       error "Error: unsupported option \"$arg\""
 330     }
 331     error "Error: cannot interpret argument $narg ($arg)"
 332   }
 333
 334   if {"$type" != "closed" && "$type" != "opened"} {
 335     error "Error : wrong -type key \"${type}\""
 336   }
 337
 338   freebounds ${shape} ${tol}
 339   set free_edges [llength [explode ${shape}_[string range $type 0 0] e]]
 340
 341   if { ${ref_value} == -1 } {
 342     puts "Error : Number of free edges is UNSTABLE"
 343     return
 344   }
 345
 346   if { ${free_edges} != ${ref_value} } {
 347     puts "Error : Number of free edges is not equal to reference data"
 348   } else {
 349     puts "OK : Number of free edges is ${free_edges}"
 350   }
 351 }
 352
 353 help checkmaxtol {
 354   Compare max tolerance of shape with reference value.
 355   Command returns max tolerance of the shape.
 356
 357   Use: checkmaxtol shape [options...]
 358   Allowed options are:
 359     -ref: reference value of maximum tolerance.
 360     -source: list of shapes to compare with, e.g.: -source {shape1 shape2 shape3}
 361     -min_tol: minimum tolerance for comparison.
 362     -multi_tol: tolerance multiplier.
 363 }
 364
 365 proc checkmaxtol {shape args} {
 366   puts "checkmaxtol ${shape} ${args}"
 367   upvar ${shape} ${shape}
 368
 369   set ref_value ""
 370   set source_shapes {}
 371   set min_tol 0
 372   set tol_multiplier 0
 373
 374   # check arguments
 375   for {set narg 0} {$narg < [llength $args]} {incr narg} {
 376     set arg [lindex $args $narg]
 377     if {[_check_arg "-min_tol" min_tol 1] ||
 378         [_check_arg "-multi_tol" tol_multiplier 1] ||
 379         [_check_arg "-source" source_shapes 1] ||
 380         [_check_arg "-ref" ref_value 1]
 381        } {
 382       continue
 383     }
 384     # unsupported option
 385     if { [regexp {^-} $arg] } {
 386       error "Error: unsupported option \"$arg\""
 387     }
 388     error "Error: cannot interpret argument $narg ($arg)"
 389   }
 390
 391   # get max tol of shape
 392   set max_tol 0
 393   if {[regexp "Tolerance MAX=(\[-0-9.+eE\]+)" [tolerance ${shape}] full maxtol_temp]} {
 394     set max_tol ${maxtol_temp}
 395   } else {
 396     error "Error: cannot get tolerances of shape \"${shape}\""
 397   }
 398
 399   # find max tol of source shapes
 400   foreach source_shape ${source_shapes} {
 401     upvar ${source_shape} ${source_shape}
 402     set _src_max_tol [checkmaxtol ${source_shape}]
 403     if { [expr ${_src_max_tol} > ${min_tol} ] } {
 404       set min_tol ${_src_max_tol}
 405     }
 406   }
 407   # apply -multi_tol option
 408   if {${tol_multiplier}} {
 409     set min_tol [expr ${tol_multiplier} * ${_src_max_tol}]
 410   }
 411   # compare max tol of source shapes with checking tolerance
 412   if { ${min_tol} && [expr ${max_tol} > ${min_tol}] } {
 413     puts "Error: tolerance of \"${shape}\" (${max_tol}) is greater than checking tolerance (${min_tol})"
 414   }
 415   if { ${ref_value} != "" } {
 416     checkreal "Max tolerance" ${max_tol} ${ref_value} 0.0001 0.01
 417   }
 418   return ${max_tol}
 419 }
 420
 421 help checkfaults {
 422   Compare faults number of given shapes.
 423
 424   Use: checkfaults shape source_shape [ref_value=0]
 425 }
 426 proc checkfaults {shape source_shape {ref_value 0}} {
 427   puts "checkfaults ${shape} ${source_shape} ${ref_value}"
 428   upvar $shape $shape
 429   upvar $source_shape $source_shape
 430   set cs_a [checkshape $source_shape]
 431   set nb_a 0
 432   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_a full nb_a_begin nb_a_end]} {
 433     set nb_a [expr $nb_a_end - $nb_a_begin +1]
 434   }
 435   set cs_r [checkshape $shape]
 436   set nb_r 0
 437   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_r full nb_r_begin nb_r_end]} {
 438     set nb_r [expr $nb_r_end - $nb_r_begin +1]
 439   }
 440   puts "Number of faults for the initial shape is $nb_a."
 441   puts "Number of faults for the resulting shape is $nb_r."
 442
 443   if { ${ref_value} == -1 } {
 444     puts "Error : Number of faults is UNSTABLE"
 445     return
 446   }
 447
 448   if { $nb_r > $nb_a } {
 449     puts "Error : Number of faults is $nb_r"
 450   }
 451 }
 452
 453 # auxiliary: check all arguments
 454 proc _check_args { args {options {}} {command_name ""}} {
 455   # check arguments
 456   for {set narg 0} {${narg} < [llength ${args}]} {incr narg} {
 457     set arg [lindex ${args} ${narg}]
 458     set toContinue 0
 459     foreach option ${options} {
 460       set option_name            [lindex ${option} 0]
 461       set variable_to_save_value [lindex ${option} 1]
 462       set get_value              [lindex ${option} 2]
 463       set local_value ""
 464       if { [_check_arg ${option_name} local_value ${get_value}] } {
 465         upvar ${variable_to_save_value} ${variable_to_save_value}
 466         set ${variable_to_save_value} ${local_value}
 467         set toContinue 1
 468       }
 469     }
 470     if {${toContinue}} { continue }
 471     # unsupported option
 472     if { [regexp {^-} ${arg}] } {
 473       error "Error: unsupported option \"${arg}\""
 474     }
 475     error "Error: cannot interpret argument ${narg} (${arg})"
 476   }
 477   foreach option ${options} {
 478     set option_name            [lindex ${option} 0]
 479     set variable_to_save_value [lindex ${option} 1]
 480     set should_exist           [lindex ${option} 3]
 481     if {![info exists ${variable_to_save_value}] && ${should_exist} == 1} {
 482       error "Error: wrong using of command '${command_name}', '${option_name}' option is required"
 483     }
 484   }
 485 }
 486
 487 help checkprops {
 488   Procedure includes commands to compute length, area and volume of input shape.
 489
 490   Use: checkprops shapename [options...]
 491   Allowed options are:
 492     -l LENGTH: command lprops, computes the mass properties of all edges in the shape with a linear density of 1
 493     -s AREA: command sprops, computes the mass properties of all faces with a surface density of 1
 494     -v VOLUME: command vprops, computes the mass properties of all solids with a density of 1
 495     -eps EPSILON: the epsilon defines relative precision of computation
 496     -equal SHAPE: compare area\volume\length of input shapes. Puts error if its are not equal
 497     -notequal SHAPE: compare area\volume\length of input shapes. Puts error if its are equal
 498   Options -l, -s and -v are independent and can be used in any order. Tolerance epsilon is the same for all options.
 499 }
 500
 501 proc checkprops {shape args} {
 502     puts "checkprops ${shape} ${args}"
 503     upvar ${shape} ${shape}
 504
 505     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 506         puts "Error: The command cannot be built"
 507         return
 508     }
 509
 510     set length -1
 511     set area -1
 512     set volume -1
 513     set epsilon 1.0e-4
 514     set compared_equal_shape -1
 515     set compared_notequal_shape -1
 516     set equal_check 0
 517
 518     set options {{"-eps" epsilon 1}
 519                  {"-equal" compared_equal_shape 1}
 520                  {"-notequal" compared_notequal_shape 1}}
 521
 522     if { [regexp {\-[not]*equal} $args] } {
 523         lappend options {"-s" area 0}
 524         lappend options {"-l" length 0}
 525         lappend options {"-v" volume 0}
 526         set equal_check 1
 527     } else {
 528         lappend options {"-s" area 1}
 529         lappend options {"-l" length 1}
 530         lappend options {"-v" volume 1}
 531     }
 532     _check_args ${args} ${options} "checkprops"
 533
 534     if { ${length} != -1 || ${equal_check} == 1 } {
 535         set CommandName lprops
 536         set mass $length
 537         set prop "length"
 538         set equal_check 0
 539     }
 540     if { ${area} != -1 || ${equal_check} == 1 } {
 541         set CommandName sprops
 542         set mass $area
 543         set prop "area"
 544         set equal_check 0
 545     }
 546     if { ${volume} != -1 || ${equal_check} == 1 } {
 547         set CommandName vprops
 548         set mass $volume
 549         set prop "volume"
 550         set equal_check 0
 551     }
 552
 553     regexp {Mass +: +([-0-9.+eE]+)} [${CommandName} ${shape} ${epsilon}] full m
 554
 555     if { ${compared_equal_shape} != -1 } {
 556         upvar ${compared_equal_shape} ${compared_equal_shape}
 557         regexp {Mass +: +([-0-9.+eE]+)} [${CommandName} ${compared_equal_shape} ${epsilon}] full compared_m
 558         if { $compared_m != $m } {
 559             puts "Error: Shape ${compared_equal_shape} is not equal to shape ${shape}"
 560         }
 561     }
 562
 563     if { ${compared_notequal_shape} != -1 } {
 564         upvar ${compared_notequal_shape} ${compared_notequal_shape}
 565         regexp {Mass +: +([-0-9.+eE]+)} [${CommandName} ${compared_notequal_shape} ${epsilon}] full compared_m
 566         if { $compared_m == $m } {
 567             puts "Error: Shape ${compared_notequal_shape} is equal shape to ${shape}"
 568         }
 569     }
 570
 571     if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
 572         if { [string compare "$mass" "empty"] != 0 } {
 573             if { $m == 0 } {
 574                 puts "Error : The command is not valid. The $prop is 0."
 575             }
 576             if { $mass > 0 } {
 577                 puts "The expected $prop is $mass"
 578             }
 579             #check of change of area is < 1%
 580             if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } {
 581                 puts "Error : The $prop of result shape is $m"
 582             }
 583         } else {
 584             if { $m != 0 } {
 585                 puts "Error : The command is not valid. The $prop is $m"
 586             }
 587         }
 588     }
 589 }
 590
 591 help checkdump {
 592   Procedure includes command to parse output dump and compare it with reference values.
 593
 594   Use: checkdump shapename [options...]
 595   Allowed options are:
 596     -name NAME: list of parsing parameters (e.g. Center, Axis, etc)
 597     -ref VALUE: list of reference values for each parameter in NAME
 598     -eps EPSILON: the epsilon defines relative precision of computation
 599 }
 600
 601 proc checkdump {shape args} {
 602     puts "checkdump ${shape} ${args}"
 603     upvar ${shape} ${shape}
 604
 605     set ddump -1
 606     set epsilon -1
 607     set options {{"-name" params 1}
 608                  {"-ref" ref 1}
 609                  {"-eps" epsilon 1}
 610                  {"-dump" ddump 1}}
 611
 612     if { ${ddump} == -1 } {
 613         set ddump [dump ${shape}]
 614     }
 615     _check_args ${args} ${options} "checkdump"
 616
 617     set index 0
 618     foreach param ${params} {
 619         set pattern "${param}\\s*:\\s*"
 620         set number_pattern "(\[-0-9.+eE\]+)\\s*"
 621         set ref_values ""
 622         set local_ref ${ref}
 623         if { [llength ${params}] > 1 } {
 624             set local_ref [lindex ${ref} ${index}]
 625         }
 626         foreach item ${local_ref} {
 627             if { ![regexp "$pattern$number_pattern" $ddump full res] } {
 628                 puts "Error: cheked parameter ${param} is not listed in dump"
 629                 break
 630             }
 631             lappend ref_values $res
 632             set pattern "${pattern}${res},\\s*"
 633             ## without precision
 634             if { ${epsilon} == -1 } {
 635                 if { ${item} != ${res} } {
 636                     puts "Error: parameter ${param} - current value (${res}) is not equal to reference value (${item})"
 637                 } else {
 638                     puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
 639                 }
 640             ## with precision
 641             } else {
 642                 set precision 0.0000001
 643                 if { ( abs($res) > $precision ) || ( abs($item) > $precision ) } {
 644                     if { ($item != 0 && [expr 1.*abs($item - $res)/$item] > $epsilon) || ($item == 0 && $res != 0) } {
 645                         puts "Error: The $param of the resulting shape is $res and the expected $param is $item"
 646                     } else {
 647                         puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
 648                     }
 649                 }
 650             }
 651         }
 652         incr index
 653     }
 654 }
 655
 656 help checklength {
 657   Procedure includes commands to compute length of input shape.
 658
 659   Use: checklength shapename [options...]
 660   Allowed options are:
 661     -l LENGTH: command length, computes the length of input curve with precision of computation
 662     -eps EPSILON: the epsilon defines relative precision of computation
 663     -equal SHAPE: compare length of input shapes. Puts error if its are not equal
 664     -notequal SHAPE: compare length of input shapes. Puts error if its are equal
 665 }
 666
 667 proc checklength {shape args} {
 668     puts "checklength ${shape} ${args}"
 669     upvar ${shape} ${shape}
 670
 671     if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
 672         puts "Error: The command cannot be built"
 673         return
 674     }
 675
 676     set length -1
 677     set epsilon 1.0e-4
 678     set compared_equal_shape -1
 679     set compared_notequal_shape -1
 680     set equal_check 0
 681
 682     set options {{"-eps" epsilon 1}
 683                  {"-equal" compared_equal_shape 1}
 684                  {"-notequal" compared_notequal_shape 1}}
 685
 686     if { [regexp {\-[not]*equal} $args] } {
 687         lappend options {"-l" length 0}
 688         set equal_check 1
 689     } else {
 690         lappend options {"-l" length 1}
 691     }
 692     _check_args ${args} ${options} "checkprops"
 693
 694     if { ${length} != -1 || ${equal_check} == 1 } {
 695         set CommandName length
 696         set mass $length
 697         set prop "length"
 698         set equal_check 0
 699     }
 700
 701     regexp "The +length+ ${shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${shape} ${epsilon}] full m
 702
 703     if { ${compared_equal_shape} != -1 } {
 704         upvar ${compared_equal_shape} ${compared_equal_shape}
 705         regexp "The +length+ ${compared_equal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_equal_shape} ${epsilon}] full compared_m
 706         if { $compared_m != $m } {
 707             puts "Error: length of shape ${compared_equal_shape} is not equal to shape ${shape}"
 708         }
 709     }
 710
 711     if { ${compared_notequal_shape} != -1 } {
 712         upvar ${compared_notequal_shape} ${compared_notequal_shape}
 713         regexp regexp "The +length+ ${compared_notequal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_notequal_shape} ${epsilon}] full compared_m
 714         if { $compared_m == $m } {
 715             puts "Error: length of shape ${compared_notequal_shape} is equal shape to ${shape}"
 716         }
 717     }
 718
 719     if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
 720         if { [string compare "$mass" "empty"] != 0 } {
 721             if { $m == 0 } {
 722                 puts "Error : The command is not valid. The $prop is 0."
 723             }
 724             if { $mass > 0 } {
 725                 puts "The expected $prop is $mass"
 726             }
 727             #check of change of area is < 1%
 728             if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } {
 729                 puts "Error : The $prop of result shape is $m"
 730             }
 731         } else {
 732             if { $m != 0 } {
 733                 puts "Error : The command is not valid. The $prop is $m"
 734             }
 735         }
 736     }
 737 }