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 #set script_dir [file dirname [info script]]/script
  14 # if { [info exist WorkDirectory] == 0 } {
  15 #    set WorkDirectory "/tmp"
  16 #    if { [array get env TEMP] != "" } {
  17 #       set WorkDirectory "$env(TEMP)"
  18 #       }
  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 proc checkreal {name value expected tol_abs tol_rel} {
  30     if { abs ($value - $expected) > $tol_abs + $tol_rel * abs ($expected) } {
  31         puts "Error: $name = $value is not equal to expected $expected"
  32     } else {
  33         puts "Check of $name OK: value = $value, expected = $expected"
  34     }
  35     return
  36 }
  37
  38
  39
  40 # Procedure to check color in the point near default coordinate
  41
  42 proc checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
  43     set x_start [expr ${coord_x} - 2]
  44     set y_start [expr ${coord_y} - 2]
  45     set mistake 0
  46     set i 0
  47     while { $mistake != 1 && $i <= 5 } {
  48         set j 0
  49         while { $mistake != 1 && $j <= 5 } {
  50             set position_x [expr ${x_start} + $j]
  51             set position_y [expr ${y_start} + $i]
  52             puts $position_x
  53             puts $position_y
  54             global color2d
  55             if { [info exists color2d] } {
  56                 set color [ QAAISGetPixelColor2d ${position_x} ${position_y} ]
  57             } else {
  58                 set color [ QAGetPixelColor ${position_x} ${position_y} ]
  59             }
  60             regexp {RED +: +([-0-9.+eE]+)} $color full rd
  61             regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
  62             regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
  63             set rd_int [expr int($rd * 1.e+05)]
  64             set gr_int [expr int($gr * 1.e+05)]
  65             set bl_int [expr int($bl * 1.e+05)]
  66
  67             if { $rd_ch != 0 } {
  68                 set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
  69             } else {
  70                 set tol_rd $rd_int
  71             }
  72             if { $gr_ch != 0 } {
  73                 set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
  74             } else {
  75                 set tol_gr $gr_int
  76             }
  77             if { $bl_ch != 0 } {
  78                 set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
  79             } else {
  80                 set tol_bl $bl_int
  81             }
  82
  83             if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
  84                 puts "Warning : Point with true color was not found near default coordinates"
  85                 set mistake 0
  86             } else {
  87                 set mistake 1
  88             }
  89             incr j
  90         }
  91         incr i
  92     }
  93     return $mistake
  94 }
  95
  96 # Procedure to check color using command QAgetPixelColor with tolerance
  97 proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
  98     puts "Coordinate x = $coord_x"
  99     puts "Coordinate y = $coord_y"
 100     puts "RED color of RGB is $rd_get"
 101     puts "GREEN color of RGB is $gr_get"
 102     puts "BLUE color of RGB is $bl_get"
 103
 104     if { $coord_x <= 1 || $coord_y <= 1 } {
 105         puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
 106         return -1
 107     }
 108     global color2d
 109         if { [info exists color2d] } {
 110             set color [ QAAISGetPixelColor2d ${coord_x} ${coord_y} ]
 111         } else {
 112             set color [ QAGetPixelColor ${coord_x} ${coord_y} ]
 113         }
 114
 115     regexp {RED +: +([-0-9.+eE]+)} $color full rd
 116     regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
 117     regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
 118     set rd_int [expr int($rd * 1.e+05)]
 119     set gr_int [expr int($gr * 1.e+05)]
 120     set bl_int [expr int($bl * 1.e+05)]
 121     set rd_ch [expr int($rd_get * 1.e+05)]
 122     set gr_ch [expr int($gr_get * 1.e+05)]
 123     set bl_ch [expr int($bl_get * 1.e+05)]
 124
 125     if { $rd_ch != 0 } {
 126         set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
 127     } else {
 128         set tol_rd $rd_int
 129     }
 130     if { $gr_ch != 0 } {
 131         set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
 132     } else {
 133         set tol_gr $gr_int
 134     }
 135     if { $bl_ch != 0 } {
 136         set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
 137     } else {
 138         set tol_bl $bl_int
 139     }
 140     set status 0
 141     if { $tol_rd > 0.2 } {
 142         puts "Warning : RED light of additive color model RGB is invalid"
 143         set status 1
 144     }
 145     if { $tol_gr > 0.2 } {
 146         puts "Warning : GREEN light of additive color model RGB is invalid"
 147         set status 1
 148     }
 149     if { $tol_bl > 0.2 } {
 150         puts "Warning : BLUE light of additive color model RGB is invalid"
 151         set status 1
 152     }
 153
 154     if { $status != 0 } {
 155         puts "Warning : Colors of default coordinate are not equal"
 156     }
 157
 158     global stat
 159     if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
 160         set info [checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
 161         set stat [lindex $info end]
 162         if { ${stat} != 1 } {
 163             puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
 164             return $stat
 165         } else {
 166             puts "Point with valid color was found"
 167             return $stat
 168         }
 169     } else {
 170         set stat 1
 171     }
 172 }
 173
 174
 175 # Procedure to check if sequence of values in listval follows linear trend
 176 # adding the same delta on each step.
 177 #
 178 # The function does statistical estimation of the mean variation of the
 179 # values of the sequence, and dispersion, and returns true only if both
 180 # dispersion and deviation of the mean from expected delta are within
 181 # specified tolerance.
 182 #
 183 # If mean variation differs from expected delta on more than two dispersions,
 184 # the check fails and procedure raises error with specified message.
 185 #
 186 # Otherwise the procedure returns false meaning that more iterations are needed.
 187 # Note that false is returned in any case if length of listval is less than 3.
 188 #
 189 # See example of use to check memory leaks in bugs/caf/bug23489
 190 #
 191 proc checktrend {listval delta tolerance message} {
 192     set nbval [llength $listval]
 193     if { $nbval < 3} {
 194         return 0
 195     }
 196
 197     # calculate mean value
 198     set mean 0.
 199     set prev [lindex $listval 0]
 200     foreach val [lrange $listval 1 end] {
 201         set mean [expr $mean + ($val - $prev)]
 202         set prev $val
 203     }
 204     set mean [expr $mean / $nbval]
 205
 206     # calculate dispersion
 207     set sigma 0.
 208     set prev [lindex $listval 0]
 209     foreach val [lrange $listval 1 end] {
 210         set d [expr ($val - $prev) - $mean]
 211         set sigma [expr $sigma + $d * $d]
 212         set prev $val
 213     }
 214     set sigma [expr sqrt ($sigma / ($nbval - 1))]
 215
 216     puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"
 217
 218     # check if deviation is definitely too big
 219     if { abs ($mean - $delta) > 2. * $sigma } {
 220         puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
 221         error $message
 222     }
 223
 224     # check if deviation is clearly within a range
 225     return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
 226 }