tests/bugs/begin

   1 # File : begin
   2 if { [array get Draw_Groups "TOPOLOGY Check commands"] == "" } {
   3     pload TOPTEST
   4     pload VISUALIZATION
   5 #    set env(CSF_DrawPluginQADefaults) $env(CASROOT)/src/DrawResources/.
   6 #    pload QAcommands
   7 #    pload -DrawPluginQA QAcommands
   8 }
   9
  10 # to prevent loops limit to 16 minutes
  11 cpulimit 1000
  12
  13 # On Windows with VC, in typical configuration gl2ps is built with Release
  14 # mode only which will fail in Debug mode; add TODO for that case in order
  15 # to handle it once for all tests that can use vexport command
  16 if { [regexp {Debug mode} [dversion]] } {
  17     puts "TODO ?#23540 windows: Error: export of image.*failed"
  18     puts "TODO ?#23540 windows: Error: The file has been exported.*different size \[(\]0 "
  19 }
  20
  21 if { [info exists imagedir] == 0 } {
  22    set imagedir .
  23 }
  24 if { [info exists test_image] == 0 } {
  25    set test_image photo
  26 }
  27
  28 # Procedure to check equality of two reals with tolerance (relative and absolute)
  29 help checkreal {name value expected tol_abs tol_rel}
  30 proc checkreal {name value expected tol_abs tol_rel} {
  31     if { abs ($value - $expected) > $tol_abs + $tol_rel * abs ($expected) } {
  32         puts "Error: $name = $value is not equal to expected $expected"
  33     } else {
  34         puts "Check of $name OK: value = $value, expected = $expected"
  35     }
  36     return
  37 }
  38
  39 # Procedure to check equality of two reals with tolerance (relative and absolute)
  40 help checkarea {shape area_expected tol_abs tol_rel}
  41 proc checkarea {shape area_expected tol_abs tol_rel} {
  42     # compute area with half of the relative tolerance
  43     # to be used in comparison; 0.001 is added to avoid zero value
  44     set prop [uplevel sprops $shape [expr 0.5 * abs($tol_rel) + 0.001]]
  45
  46     # get te value
  47     if { ! [regexp {Mass\s*:\s*([0-9.e+-]+)} $prop res area] } {
  48         puts "Error: cannot get area of the shape $shape"
  49         return
  50     }
  51
  52     # compare with expected value
  53     checkreal "area of $shape" $area $area_expected $tol_abs $tol_rel
  54 }
  55
  56 # Procedure to check color in the point near default coordinate
  57
  58 proc checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
  59     set x_start [expr ${coord_x} - 2]
  60     set y_start [expr ${coord_y} - 2]
  61     set mistake 0
  62     set i 0
  63     while { $mistake != 1 && $i <= 5 } {
  64       set j 0
  65       while { $mistake != 1 && $j <= 5 } {
  66           set position_x [expr ${x_start} + $j]
  67           set position_y [expr ${y_start} + $i]
  68           puts $position_x
  69           puts $position_y
  70           global color2d
  71           if { [info exists color2d] } {
  72             set color [ QAAISGetPixelColor2d ${position_x} ${position_y} ]
  73           } else {
  74             set color [ QAGetPixelColor ${position_x} ${position_y} ]
  75           }
  76           regexp {RED +: +([-0-9.+eE]+)} $color full rd
  77           regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
  78           regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
  79           set rd_int [expr int($rd * 1.e+05)]
  80           set gr_int [expr int($gr * 1.e+05)]
  81           set bl_int [expr int($bl * 1.e+05)]
  82
  83           if { $rd_ch != 0 } {
  84             set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
  85           } else {
  86             set tol_rd $rd_int
  87           }
  88           if { $gr_ch != 0 } {
  89             set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
  90           } else {
  91             set tol_gr $gr_int
  92           }
  93           if { $bl_ch != 0 } {
  94             set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
  95           } else {
  96             set tol_bl $bl_int
  97           }
  98
  99           if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
 100             puts "Warning : Point with true color was not found near default coordinates"
 101             set mistake 0
 102           } else {
 103             set mistake 1
 104           }
 105           incr j
 106       }
 107       incr i
 108     }
 109     return $mistake
 110 }
 111
 112 # Procedure to check color using command QAgetPixelColor with tolerance
 113 proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
 114     puts "Coordinate x = $coord_x"
 115     puts "Coordinate y = $coord_y"
 116     puts "RED color of RGB is $rd_get"
 117     puts "GREEN color of RGB is $gr_get"
 118     puts "BLUE color of RGB is $bl_get"
 119
 120     if { $coord_x <= 1 || $coord_y <= 1 } {
 121       puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
 122       return -1
 123     }
 124     global color2d
 125     if { [info exists color2d] } {
 126       set color [ QAAISGetPixelColor2d ${coord_x} ${coord_y} ]
 127     } else {
 128       set color [ QAGetPixelColor ${coord_x} ${coord_y} ]
 129     }
 130
 131     regexp {RED +: +([-0-9.+eE]+)} $color full rd
 132     regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
 133     regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
 134     set rd_int [expr int($rd * 1.e+05)]
 135     set gr_int [expr int($gr * 1.e+05)]
 136     set bl_int [expr int($bl * 1.e+05)]
 137     set rd_ch [expr int($rd_get * 1.e+05)]
 138     set gr_ch [expr int($gr_get * 1.e+05)]
 139     set bl_ch [expr int($bl_get * 1.e+05)]
 140
 141     if { $rd_ch != 0 } {
 142       set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
 143     } else {
 144       set tol_rd $rd_int
 145     }
 146     if { $gr_ch != 0 } {
 147       set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
 148     } else {
 149       set tol_gr $gr_int
 150     }
 151     if { $bl_ch != 0 } {
 152       set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
 153     } else {
 154       set tol_bl $bl_int
 155     }
 156     set status 0
 157     if { $tol_rd > 0.2 } {
 158       puts "Warning : RED light of additive color model RGB is invalid"
 159       set status 1
 160     }
 161     if { $tol_gr > 0.2 } {
 162       puts "Warning : GREEN light of additive color model RGB is invalid"
 163       set status 1
 164     }
 165     if { $tol_bl > 0.2 } {
 166       puts "Warning : BLUE light of additive color model RGB is invalid"
 167       set status 1
 168     }
 169
 170     if { $status != 0 } {
 171       puts "Warning : Colors of default coordinate are not equal"
 172     }
 173
 174     global stat
 175     if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
 176       set info [checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
 177       set stat [lindex $info end]
 178       if { ${stat} != 1 } {
 179           puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
 180           return $stat
 181       } else {
 182           puts "Point with valid color was found"
 183           return $stat
 184       }
 185     } else {
 186       set stat 1
 187     }
 188 }
 189
 190
 191 # Procedure to check if sequence of values in listval follows linear trend
 192 # adding the same delta on each step.
 193 #
 194 # The function does statistical estimation of the mean variation of the
 195 # values of the sequence, and dispersion, and returns true only if both
 196 # dispersion and deviation of the mean from expected delta are within
 197 # specified tolerance.
 198 #
 199 # If mean variation differs from expected delta on more than two dispersions,
 200 # the check fails and procedure raises error with specified message.
 201 #
 202 # Otherwise the procedure returns false meaning that more iterations are needed.
 203 # Note that false is returned in any case if length of listval is less than 3.
 204 #
 205 # See example of use to check memory leaks in bugs/caf/bug23489
 206 #
 207 proc checktrend {listval delta tolerance message} {
 208     set nbval [llength $listval]
 209     if { $nbval < 3} {
 210         return 0
 211     }
 212
 213     # calculate mean value
 214     set mean 0.
 215     set prev [lindex $listval 0]
 216     foreach val [lrange $listval 1 end] {
 217         set mean [expr $mean + ($val - $prev)]
 218         set prev $val
 219     }
 220     set mean [expr $mean / ($nbval - 1)]
 221
 222     # calculate dispersion
 223     set sigma 0.
 224     set prev [lindex $listval 0]
 225     foreach val [lrange $listval 1 end] {
 226         set d [expr ($val - $prev) - $mean]
 227         set sigma [expr $sigma + $d * $d]
 228         set prev $val
 229     }
 230     set sigma [expr sqrt ($sigma / ($nbval - 2))]
 231
 232     puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"
 233
 234     # check if deviation is definitely too big
 235     if { abs ($mean - $delta) > $tolerance + 2. * $sigma } {
 236         puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
 237         error "$message"
 238     }
 239
 240     # check if deviation is clearly within a range
 241     return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
 242 }
 243
 244 # Check if area of triangles is valid
 245 proc CheckTriArea {shape {eps 0}} {
 246   upvar #0 $shape result
 247   set area [triarea result $eps]
 248   set t_area [lindex $area 0]
 249   set g_area [expr abs([lindex $area 1])]
 250   puts "area by triangles: $t_area"
 251   puts "area by geometry:  $g_area"
 252   expr ($t_area - $g_area) / $g_area * 100
 253 }