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