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 {^-} [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 ref_value.
 355   Argument "source_shapes" is a list of used for sewing shapes.
 356   It can be empty to skip comparison of tolerance with source shapes.
 357
 358   Use: checkmaxtol shape ref_value [source_shapes={}] [options...]
 359   Allowed options are:
 360     -min_tol: minimum tolerance for comparison
 361     -multi_tol: tolerance multiplier
 362 }
 363 proc checkmaxtol {shape ref_value {source_shapes {}} args} {
 364   puts "checkmaxtol ${shape} ${ref_value} ${source_shapes} ${args}"
 365   upvar ${shape} ${shape}
 366
 367   set min_tol 0
 368   set tol_multiplier 0
 369
 370   for {set narg 0} {$narg < [llength $args]} {incr narg} {
 371     set arg [lindex $args $narg]
 372     if {[_check_arg "-min_tol" min_tol 1] ||
 373         [_check_arg "-multi_tol" tol_multiplier 1]
 374        } {
 375       continue
 376     }
 377     # unsupported option
 378     if { [regexp {^-} $arg] } {
 379       error "Error: unsupported option \"$arg\""
 380     }
 381     error "Error: cannot interpret argument $narg ($arg)"
 382   }
 383
 384   # get max tol of shape
 385   regexp {max tol = ([-0-9.+eE]+)} [tolmax ${shape}] full max_tol
 386
 387   checkreal "Max tolerance" $max_tol $ref_value 0.0001 0.01
 388   if {[llength $source_shapes]} {
 389     # find max tol of source shapes
 390     foreach source_shape $source_shapes {
 391       upvar ${source_shape} ${source_shape}
 392       regexp {max tol = ([-0-9.+eE]+)} [tolmax $source_shape] full _src_max_tol
 393       if { ${_src_max_tol} > ${min_tol} } {
 394         set min_tol ${_src_max_tol}
 395       }
 396     }
 397     if {${tol_multiplier}} {
 398       set min_tol [expr ${tol_multiplier} * ${_src_max_tol}]
 399     }
 400     # compare max tol of source shapes with max tol of sewing_result
 401     if { ${max_tol} > ${min_tol} } {
 402       puts "Error: tolerance of \"${shape}\" (${max_tol}) is greater than max tolerance of source shapes (${min_tol})"
 403     }
 404   }
 405 }
 406
 407 help checkfaults {
 408   Compare faults number of given shapes.
 409
 410   Use: checkfaults shape source_shape [ref_value=0]
 411 }
 412 proc checkfaults {shape source_shape {ref_value 0}} {
 413   puts "checkfaults ${shape} ${source_shape} ${ref_value}"
 414   upvar $shape $shape
 415   upvar $source_shape $source_shape
 416   set cs_a [checkshape $source_shape]
 417   set nb_a 0
 418   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_a full nb_a_begin nb_a_end]} {
 419     set nb_a [expr $nb_a_end - $nb_a_begin +1]
 420   }
 421   set cs_r [checkshape $shape]
 422   set nb_r 0
 423   if {[regexp {Faulty shapes in variables faulty_([0-9]*) to faulty_([0-9]*)} $cs_r full nb_r_begin nb_r_end]} {
 424     set nb_r [expr $nb_r_end - $nb_r_begin +1]
 425   }
 426   puts "Number of faults for the initial shape is $nb_a."
 427   puts "Number of faults for the resulting shape is $nb_r."
 428
 429   if { ${ref_value} == -1 } {
 430     puts "Error : Number of faults is UNSTABLE"
 431     return
 432   }
 433
 434   if { $nb_r > $nb_a } {
 435     puts "Error : Number of faults is $nb_r"
 436   }
 437 }