| 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 | 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] |
| 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 - 1))] |
| 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) > 2. * $sigma } { |
| 236 | puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta" |
| 237 | puts "Error : $message" |
| 238 | } |
| 239 | |
| 240 | # check if deviation is clearly within a range |
| 241 | return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance] |
| 242 | } |