Commit | Line | Data |
---|---|---|
fa920fb1 | 1 | # File : begin |
5ae01c85 | 2 | |
fa920fb1 | 3 | if { [array get Draw_Groups "TOPOLOGY Check commands"] == "" } { |
4 | pload TOPTEST | |
5 | pload VISUALIZATION | |
fa920fb1 | 6 | } |
7 | ||
8 | # to prevent loops limit to 16 minutes | |
9 | cpulimit 1000 | |
10 | ||
7856b126 | 11 | set rel_tol 0 |
12 | set max_rel_tol_diff 0 | |
13 | ||
9753e6de | 14 | # On Windows with VC, in typical configuration gl2ps is built with Release |
15 | # mode only which will fail in Debug mode; add TODO for that case in order | |
16 | # to handle it once for all tests that can use vexport command | |
17 | if { [regexp {Debug mode} [dversion]] } { | |
18 | puts "TODO ?#23540 windows: Error: export of image.*failed" | |
19 | puts "TODO ?#23540 windows: Error: The file has been exported.*different size \[(\]0 " | |
20 | } | |
fa920fb1 | 21 | |
22 | if { [info exists imagedir] == 0 } { | |
23 | set imagedir . | |
24 | } | |
25 | if { [info exists test_image] == 0 } { | |
26 | set test_image photo | |
27 | } | |
28 | ||
91322f44 | 29 | # Procedure to check equality of two reals with tolerance (relative and absolute) |
30 | help checkarea {shape area_expected tol_abs tol_rel} | |
31 | proc checkarea {shape area_expected tol_abs tol_rel} { | |
32 | # compute area with half of the relative tolerance | |
33 | # to be used in comparison; 0.001 is added to avoid zero value | |
34 | set prop [uplevel sprops $shape [expr 0.5 * abs($tol_rel) + 0.001]] | |
35 | ||
36 | # get te value | |
37 | if { ! [regexp {Mass\s*:\s*([0-9.e+-]+)} $prop res area] } { | |
38 | puts "Error: cannot get area of the shape $shape" | |
39 | return | |
40 | } | |
f1aa2b62 | 41 | |
91322f44 | 42 | # compare with expected value |
43 | checkreal "area of $shape" $area $area_expected $tol_abs $tol_rel | |
44 | } | |
f1aa2b62 | 45 | |
deb26df7 RL |
46 | # Procedure to check if sequence of values in listval follows linear trend |
47 | # adding the same delta on each step. | |
48 | # | |
49 | # The function does statistical estimation of the mean variation of the | |
50 | # values of the sequence, and dispersion, and returns true only if both | |
51 | # dispersion and deviation of the mean from expected delta are within | |
52 | # specified tolerance. | |
53 | # | |
54 | # If mean variation differs from expected delta on more than two dispersions, | |
55 | # the check fails and procedure raises error with specified message. | |
56 | # | |
57 | # Otherwise the procedure returns false meaning that more iterations are needed. | |
58 | # Note that false is returned in any case if length of listval is less than 3. | |
59 | # | |
60 | # See example of use to check memory leaks in bugs/caf/bug23489 | |
61 | # | |
62 | proc checktrend {listval delta tolerance message} { | |
63 | set nbval [llength $listval] | |
64 | if { $nbval < 3} { | |
65 | return 0 | |
66 | } | |
fa920fb1 | 67 | |
deb26df7 RL |
68 | # calculate mean value |
69 | set mean 0. | |
70 | set prev [lindex $listval 0] | |
71 | foreach val [lrange $listval 1 end] { | |
72 | set mean [expr $mean + ($val - $prev)] | |
73 | set prev $val | |
74 | } | |
9753e6de | 75 | set mean [expr $mean / ($nbval - 1)] |
fa920fb1 | 76 | |
deb26df7 RL |
77 | # calculate dispersion |
78 | set sigma 0. | |
79 | set prev [lindex $listval 0] | |
80 | foreach val [lrange $listval 1 end] { | |
81 | set d [expr ($val - $prev) - $mean] | |
82 | set sigma [expr $sigma + $d * $d] | |
83 | set prev $val | |
84 | } | |
9753e6de | 85 | set sigma [expr sqrt ($sigma / ($nbval - 2))] |
fa920fb1 | 86 | |
deb26df7 RL |
87 | puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma" |
88 | ||
89 | # check if deviation is definitely too big | |
9753e6de | 90 | if { abs ($mean - $delta) > $tolerance + 2. * $sigma } { |
deb26df7 | 91 | puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta" |
67a1064e | 92 | error "$message" |
deb26df7 RL |
93 | } |
94 | ||
95 | # check if deviation is clearly within a range | |
96 | return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance] | |
97 | } | |
74f764ba | 98 | |
99 | # Check if area of triangles is valid | |
100 | proc CheckTriArea {shape {eps 0}} { | |
101 | upvar #0 $shape result | |
102 | set area [triarea result $eps] | |
103 | set t_area [lindex $area 0] | |
104 | set g_area [expr abs([lindex $area 1])] | |
105 | puts "area by triangles: $t_area" | |
106 | puts "area by geometry: $g_area" | |
107 | expr ($t_area - $g_area) / $g_area * 100 | |
108 | } | |
02effd35 | 109 | |
74da0216 | 110 | # Check expected time |
111 | proc checktime {value expected tol_rel message} { | |
112 | set t1 [expr ${value} - ${expected}] | |
113 | set t2 [expr ${expected} * abs (${tol_rel})] | |
114 | ||
115 | if { abs (${t1}) <= ${t2} } { | |
116 | puts "OK. ${message}, ${value} seconds, is equal to expected time - ${expected} seconds" | |
117 | } elseif {${t1} > ${t2}} { | |
118 | puts "Error. ${message}, ${value} seconds, is more than expected time - ${expected} seconds" | |
119 | } else { | |
120 | puts "Improvement. ${message}, ${value} seconds, is less than expected time - ${expected} seconds" | |
121 | } | |
122 | } |