| 1 | # This program is under CECILL_B licence. See footer for details. |
|---|
| 2 | |
|---|
| 3 | |
|---|
| 4 | proc grapher_highlight_node {wincan anchor match side index} { |
|---|
| 5 | set a_x [lindex $anchor 0] |
|---|
| 6 | set a_y [lindex $anchor 1] |
|---|
| 7 | |
|---|
| 8 | switch $match { |
|---|
| 9 | "value" { |
|---|
| 10 | set color red |
|---|
| 11 | } |
|---|
| 12 | "children" { |
|---|
| 13 | set color green4 |
|---|
| 14 | } |
|---|
| 15 | |
|---|
| 16 | } |
|---|
| 17 | set h 5 |
|---|
| 18 | $wincan create oval [expr {$a_x-$h}] [expr {$a_y-$h}] [expr {$a_x+$h}] [expr {$a_y+$h}] -outline $color -width 2 -tags "graph $side" |
|---|
| 19 | set h 10 |
|---|
| 20 | canvas_text_vector $wincan [expr {$a_x+$h}] [expr {$a_y+$h}] $index nw 10 0 $color "graph $side" |
|---|
| 21 | } |
|---|
| 22 | |
|---|
| 23 | |
|---|
| 24 | proc grapher_drawnode {wincan anchor maxdepth childnb kinnb dsname dsaddress side value shade {title "notitle"} } { |
|---|
| 25 | |
|---|
| 26 | set color "yellow" |
|---|
| 27 | if {[string is double $value]} {set color "orange"} |
|---|
| 28 | if {[string is integer $value]} {set color "red"} |
|---|
| 29 | if {[llength $value] >1} {set color "blue"} |
|---|
| 30 | if {$value==""} {set color "white"} |
|---|
| 31 | |
|---|
| 32 | set color [shadeColor $color $shade] |
|---|
| 33 | set shadeblack [shadeColor "black" $shade] |
|---|
| 34 | |
|---|
| 35 | set dist [expr {10+pow($maxdepth,1.8)* 2+pow($childnb,0.7)* 2+pow($kinnb,2)* 0.1}] |
|---|
| 36 | set a_x [lindex $anchor 0] |
|---|
| 37 | set a_y [lindex $anchor 1] |
|---|
| 38 | set a_angle [lindex $anchor 2] |
|---|
| 39 | #puts "$a_x+$dist*cos($a_angle*3.1416/180.0)" |
|---|
| 40 | set b_x [expr {$a_x+$dist*cos(($a_angle-90)*3.1416/180.0)}] |
|---|
| 41 | set b_y [expr {$a_y+$dist*sin(($a_angle-90)*3.1416/180.0)}] |
|---|
| 42 | |
|---|
| 43 | set tag "$dsname#$dsaddress" |
|---|
| 44 | $wincan create line $a_x $a_y $b_x $b_y -fill $shadeblack -tags "graph $side" |
|---|
| 45 | |
|---|
| 46 | set h 4 |
|---|
| 47 | #$wincan create oval [expr {$b_x-$h}] [expr {$b_y-$h}] [expr {$b_x+$h}] [expr {$b_y+$h}] -fill $shadeblack -width 0 -tag "$tag handle graph $side" |
|---|
| 48 | set h 3 |
|---|
| 49 | $wincan create oval [expr {$b_x-$h}] [expr {$b_y-$h}] [expr {$b_x+$h}] [expr {$b_y+$h}] -fill $color -width 0 -tag "$tag handle graph $side" |
|---|
| 50 | |
|---|
| 51 | set lastnode [lindex [split $dsaddress "."] end] |
|---|
| 52 | |
|---|
| 53 | set msg [string map { "[" "(" "]" ")" } "$title\n $value" ] |
|---|
| 54 | $wincan bind $tag <Enter> [subst {grapher_showlocation $wincan "$msg" }] |
|---|
| 55 | $wincan bind $tag <Leave> [subst {$wincan delete "pointer"}] |
|---|
| 56 | set new_anchor "$b_x $b_y $a_angle" |
|---|
| 57 | return $new_anchor |
|---|
| 58 | } |
|---|
| 59 | |
|---|
| 60 | proc grapher_children_directions {dsname a_angle dsaddress} { |
|---|
| 61 | upvar $dsname dataset |
|---|
| 62 | set children $dataset($dsaddress-children) |
|---|
| 63 | set list_angle_child "" |
|---|
| 64 | |
|---|
| 65 | if {$a_angle > 0 && $a_angle < 180} { |
|---|
| 66 | set shift 5 |
|---|
| 67 | } elseif {$a_angle < 0} { |
|---|
| 68 | set shift -5 |
|---|
| 69 | } else { |
|---|
| 70 | set shift 0 |
|---|
| 71 | } |
|---|
| 72 | |
|---|
| 73 | if {$children != ""} { |
|---|
| 74 | set nchild [llength $children] |
|---|
| 75 | |
|---|
| 76 | switch $nchild { |
|---|
| 77 | "1" { |
|---|
| 78 | set list_angle_child 0 |
|---|
| 79 | } |
|---|
| 80 | "2" { |
|---|
| 81 | set list_angle_child {-30 +30} |
|---|
| 82 | } |
|---|
| 83 | "3" { |
|---|
| 84 | set list_angle_child {-45 0 45} |
|---|
| 85 | } |
|---|
| 86 | "4" { |
|---|
| 87 | set list_angle_child {-60 -20 20 60} |
|---|
| 88 | } |
|---|
| 89 | "5" { |
|---|
| 90 | set list_angle_child {-90 -45 0 45 90} |
|---|
| 91 | } |
|---|
| 92 | "6" { |
|---|
| 93 | set list_angle_child {-125 -75 -25 25 75 125} |
|---|
| 94 | } |
|---|
| 95 | default { |
|---|
| 96 | set list_angle_child "" |
|---|
| 97 | for {set i 0} {$i < $nchild} {incr i} { |
|---|
| 98 | set angle [expr { -125 + (($i)*1.0/($nchild-1))*2.0*125 }] |
|---|
| 99 | lappend list_angle_child $angle |
|---|
| 100 | } |
|---|
| 101 | } |
|---|
| 102 | } |
|---|
| 103 | set final_list "" |
|---|
| 104 | for {set i 0} {$i < $nchild} {incr i} { |
|---|
| 105 | lappend final_list [expr {$shift + [lindex $list_angle_child $i]}] |
|---|
| 106 | } |
|---|
| 107 | set list_angle_child $final_list |
|---|
| 108 | } |
|---|
| 109 | |
|---|
| 110 | |
|---|
| 111 | return $list_angle_child |
|---|
| 112 | } |
|---|
| 113 | |
|---|
| 114 | proc grapher_trace { address dsname anchor dsaddress side} { |
|---|
| 115 | |
|---|
| 116 | upvar $dsname dataset |
|---|
| 117 | |
|---|
| 118 | global widgetInfo |
|---|
| 119 | |
|---|
| 120 | set wincan $widgetInfo($address-wincan) |
|---|
| 121 | |
|---|
| 122 | set title "" |
|---|
| 123 | if {$dsaddress != "dataset"} { |
|---|
| 124 | set title [grapher_gettitle_of_child dataset "$dsaddress" ] |
|---|
| 125 | } |
|---|
| 126 | |
|---|
| 127 | |
|---|
| 128 | # draw node |
|---|
| 129 | set new_anchor [grapher_drawnode $wincan $anchor $dataset($dsaddress-maxdepth) $dataset($dsaddress-childnb) $dataset($dsaddress-kinnb) $dsname $dsaddress $side $dataset($dsaddress-value) 0.0 $title] |
|---|
| 130 | |
|---|
| 131 | # call iteration for children children |
|---|
| 132 | set children $dataset($dsaddress-children) |
|---|
| 133 | |
|---|
| 134 | set b_x [lindex $new_anchor 0] |
|---|
| 135 | set b_y [lindex $new_anchor 1] |
|---|
| 136 | set a_angle [lindex $new_anchor 2] |
|---|
| 137 | set list_angle_child [grapher_children_directions dataset $a_angle $dsaddress] |
|---|
| 138 | set child_id 0 |
|---|
| 139 | |
|---|
| 140 | |
|---|
| 141 | |
|---|
| 142 | #foreach child $children |
|---|
| 143 | foreach child [grapher_ordered_children dataset $dsaddress all] { |
|---|
| 144 | set anglechild [expr {$a_angle+[lindex $list_angle_child $child_id]}] |
|---|
| 145 | grapher_trace $address dataset "$b_x $b_y $anglechild" "$dsaddress.$child" $side |
|---|
| 146 | incr child_id |
|---|
| 147 | } |
|---|
| 148 | |
|---|
| 149 | } |
|---|
| 150 | |
|---|
| 151 | proc grapher_ordered_children {dsname dsaddress subset} { |
|---|
| 152 | upvar $dsname dataset |
|---|
| 153 | set children $dataset($dsaddress-children) |
|---|
| 154 | if {$subset == "all"} { |
|---|
| 155 | set subset $children |
|---|
| 156 | } |
|---|
| 157 | |
|---|
| 158 | set list_item_childnb "" |
|---|
| 159 | foreach child $dataset($dsaddress-children) { |
|---|
| 160 | if {[lsearch $subset $child ]!= -1} { |
|---|
| 161 | lappend list_item_childnb [list $child $dataset($dsaddress.$child-childnb)] |
|---|
| 162 | } |
|---|
| 163 | } |
|---|
| 164 | set ordered_list_item_childnb [lsort -integer -decreasing -index 1 $list_item_childnb] |
|---|
| 165 | |
|---|
| 166 | set list_pyramid "" |
|---|
| 167 | set side "left" |
|---|
| 168 | foreach pair $ordered_list_item_childnb { |
|---|
| 169 | set child [lindex $pair 0] |
|---|
| 170 | switch $side { |
|---|
| 171 | "left" { |
|---|
| 172 | set list_pyramid [ concat $child $list_pyramid ] |
|---|
| 173 | set side "right" |
|---|
| 174 | } |
|---|
| 175 | "right" { |
|---|
| 176 | set list_pyramid [ concat $list_pyramid $child] |
|---|
| 177 | set side "left" |
|---|
| 178 | } |
|---|
| 179 | } |
|---|
| 180 | } |
|---|
| 181 | return $list_pyramid |
|---|
| 182 | } |
|---|
| 183 | proc grapher_showlocation { wincan msg } { |
|---|
| 184 | |
|---|
| 185 | $wincan delete "pointer" |
|---|
| 186 | set x [$wincan canvasx [expr {[winfo pointerx $wincan ] - [winfo rootx $wincan ]}]] |
|---|
| 187 | set y [$wincan canvasy [expr {[winfo pointery $wincan ] - [winfo rooty $wincan ]}]] |
|---|
| 188 | canvas_text_highlighted $wincan $x $y $msg "pointer" |
|---|
| 189 | } |
|---|
| 190 | |
|---|
| 191 | proc grapher_fill {address dsname dsaddress indent dump} { |
|---|
| 192 | global widgetInfo |
|---|
| 193 | upvar $dsname dataset |
|---|
| 194 | incr indent |
|---|
| 195 | set node [list "$indent" [lindex [split $dsaddress "."] end] "$dataset($dsaddress-value)"] |
|---|
| 196 | set children $dataset($dsaddress-children) |
|---|
| 197 | |
|---|
| 198 | # write array representation |
|---|
| 199 | #################################### |
|---|
| 200 | # for graph issues |
|---|
| 201 | # add the max depth attribute |
|---|
| 202 | # add the number of children |
|---|
| 203 | set dataset($dsaddress-maxdepth) 0 |
|---|
| 204 | set dataset($dsaddress-childnb) 0 |
|---|
| 205 | set fatheraddress [join [lrange [split $dsaddress "."] 0 end-1] "."] |
|---|
| 206 | if {$fatheraddress == ""} { |
|---|
| 207 | set kin 0 |
|---|
| 208 | } else { |
|---|
| 209 | set kin $dataset($fatheraddress-childnb) |
|---|
| 210 | } |
|---|
| 211 | |
|---|
| 212 | set dataset($dsaddress-kinnb) $kin |
|---|
| 213 | |
|---|
| 214 | if {$children != ""} { |
|---|
| 215 | set dataset($dsaddress-childnb) [llength $children] |
|---|
| 216 | set dataset($dsaddress-maxdepth) 1 |
|---|
| 217 | set tmpadr [join [lrange [split $dsaddress "."] 0 end-1] "."] |
|---|
| 218 | set depth 1 |
|---|
| 219 | while {$tmpadr != ""} { |
|---|
| 220 | incr depth |
|---|
| 221 | if {$depth > $dataset($tmpadr-maxdepth)} { |
|---|
| 222 | set dataset($tmpadr-maxdepth) $depth |
|---|
| 223 | } |
|---|
| 224 | set tmpadr [join [lrange [split $tmpadr "."] 0 end-1] "."] |
|---|
| 225 | } |
|---|
| 226 | } |
|---|
| 227 | |
|---|
| 228 | |
|---|
| 229 | #################################### |
|---|
| 230 | |
|---|
| 231 | # probably shoud add number of children here! |
|---|
| 232 | |
|---|
| 233 | |
|---|
| 234 | foreach child $children { |
|---|
| 235 | grapher_fill $address "dataset" "$dsaddress.$child" $indent $dump |
|---|
| 236 | } |
|---|
| 237 | |
|---|
| 238 | return |
|---|
| 239 | } |
|---|
| 240 | |
|---|
| 241 | |
|---|
| 242 | |
|---|
| 243 | |
|---|
| 244 | |
|---|
| 245 | proc grapher_html_write_table { address msg mode {lvl 100} } { |
|---|
| 246 | global widgetInfo |
|---|
| 247 | set folder $widgetInfo($address-folder) |
|---|
| 248 | set filerootname $widgetInfo($address-filerootname) |
|---|
| 249 | |
|---|
| 250 | set promote_begin "" |
|---|
| 251 | set promote_end "" |
|---|
| 252 | |
|---|
| 253 | if {$lvl == 1} { |
|---|
| 254 | set promote_begin "<h2>" |
|---|
| 255 | set promote_end "<\h2>" |
|---|
| 256 | } |
|---|
| 257 | |
|---|
| 258 | if {$lvl == 2} { |
|---|
| 259 | set promote_begin "<h3>" |
|---|
| 260 | set promote_end "<\h3>" |
|---|
| 261 | } |
|---|
| 262 | |
|---|
| 263 | if {$lvl == 3} { |
|---|
| 264 | set promote_begin "<h4>" |
|---|
| 265 | set promote_end "<\h4>" |
|---|
| 266 | } |
|---|
| 267 | if {$lvl == 4} { |
|---|
| 268 | set promote_begin "<h5>" |
|---|
| 269 | set promote_end "<\h5>" |
|---|
| 270 | } |
|---|
| 271 | |
|---|
| 272 | |
|---|
| 273 | |
|---|
| 274 | #add text in html report |
|---|
| 275 | if {$widgetInfo($address-dump)} { |
|---|
| 276 | set htmlfile [open "[file join $folder $filerootname].html" a+] |
|---|
| 277 | switch $mode { |
|---|
| 278 | "start" { |
|---|
| 279 | puts $htmlfile "<table border='0'> <caption> $msg </caption>" |
|---|
| 280 | } |
|---|
| 281 | "end" { |
|---|
| 282 | puts $htmlfile "</table>" |
|---|
| 283 | } |
|---|
| 284 | "headers" { |
|---|
| 285 | puts $htmlfile " <tr>" |
|---|
| 286 | foreach item $msg { |
|---|
| 287 | puts $htmlfile " <th>" |
|---|
| 288 | puts $htmlfile " $item" |
|---|
| 289 | puts $htmlfile " </th>" |
|---|
| 290 | } |
|---|
| 291 | puts $htmlfile " </tr>" |
|---|
| 292 | } |
|---|
| 293 | |
|---|
| 294 | "value" { |
|---|
| 295 | puts $htmlfile " <tr>" |
|---|
| 296 | foreach item $msg { |
|---|
| 297 | puts $htmlfile " <td>" |
|---|
| 298 | |
|---|
| 299 | puts $htmlfile " <span style=\"color:red\"> $promote_begin [limit_string $item 50] $promote_end </span>" |
|---|
| 300 | puts $htmlfile " </td>" |
|---|
| 301 | } |
|---|
| 302 | puts $htmlfile " </tr>" |
|---|
| 303 | } |
|---|
| 304 | "children" { |
|---|
| 305 | puts $htmlfile " <tr>" |
|---|
| 306 | foreach item $msg { |
|---|
| 307 | puts $htmlfile " <td>" |
|---|
| 308 | puts $htmlfile " <span style=\"color:green\"> $promote_begin [limit_string $item 50] $promote_end </span>" |
|---|
| 309 | puts $htmlfile " </td>" |
|---|
| 310 | } |
|---|
| 311 | puts $htmlfile " </tr>" |
|---|
| 312 | } |
|---|
| 313 | default { |
|---|
| 314 | puts $htmlfile " <tr>" |
|---|
| 315 | foreach item $msg { |
|---|
| 316 | puts $htmlfile " <td>" |
|---|
| 317 | puts $htmlfile " $promote_begin [limit_string $item 50] $promote_end" |
|---|
| 318 | puts $htmlfile " </td>" |
|---|
| 319 | } |
|---|
| 320 | puts $htmlfile " </tr>" |
|---|
| 321 | } |
|---|
| 322 | } |
|---|
| 323 | close $htmlfile |
|---|
| 324 | } |
|---|
| 325 | } |
|---|
| 326 | |
|---|
| 327 | |
|---|
| 328 | |
|---|
| 329 | proc grapher_compare {address dsname1 dsname2 dsaddress anchor1 anchor2 } { |
|---|
| 330 | upvar $dsname1 dataset1 |
|---|
| 331 | upvar $dsname2 dataset2 |
|---|
| 332 | global widgetInfo |
|---|
| 333 | |
|---|
| 334 | grapher_setup_XML dataset1 $dsaddress |
|---|
| 335 | |
|---|
| 336 | set wincan $widgetInfo($address-wincan) |
|---|
| 337 | set wintv $widgetInfo($address-wintv) |
|---|
| 338 | set folder $widgetInfo($address-folder) |
|---|
| 339 | |
|---|
| 340 | |
|---|
| 341 | |
|---|
| 342 | set value1 $dataset1($dsaddress-value) |
|---|
| 343 | set value2 $dataset2($dsaddress-value) |
|---|
| 344 | set children1 $dataset1($dsaddress-children) |
|---|
| 345 | set children2 $dataset2($dsaddress-children) |
|---|
| 346 | |
|---|
| 347 | |
|---|
| 348 | |
|---|
| 349 | set shade 0.7 |
|---|
| 350 | set match "match" |
|---|
| 351 | set v1 $value1 |
|---|
| 352 | set v2 "" |
|---|
| 353 | |
|---|
| 354 | if {$value1 != $value2} { |
|---|
| 355 | set match "value" |
|---|
| 356 | incr widgetInfo($address-mismatch) |
|---|
| 357 | set shade 0.0 |
|---|
| 358 | set v1 "($widgetInfo($address-mismatch)) $value1" |
|---|
| 359 | set v2 "($widgetInfo($address-mismatch)) $value2" |
|---|
| 360 | } |
|---|
| 361 | if {$children1 != $children2} { |
|---|
| 362 | set only1 "" |
|---|
| 363 | set only2 "" |
|---|
| 364 | set both "" |
|---|
| 365 | |
|---|
| 366 | if {$match != "value"} { |
|---|
| 367 | incr widgetInfo($address-mismatch) |
|---|
| 368 | } |
|---|
| 369 | |
|---|
| 370 | foreach child $children1 { |
|---|
| 371 | if {[lsearch $children2 $child ] ==-1 } { |
|---|
| 372 | lappend only1 $child |
|---|
| 373 | } else { |
|---|
| 374 | lappend both $child |
|---|
| 375 | } |
|---|
| 376 | } |
|---|
| 377 | |
|---|
| 378 | foreach child $children2 { |
|---|
| 379 | if {[lsearch $children1 $child ] ==-1 } { |
|---|
| 380 | lappend only2 $child |
|---|
| 381 | } |
|---|
| 382 | } |
|---|
| 383 | |
|---|
| 384 | if {$only1 != ""} { |
|---|
| 385 | set v1 "($widgetInfo($address-mismatch)) : [join $only1 ";"]" |
|---|
| 386 | } else { |
|---|
| 387 | set v1 "" |
|---|
| 388 | } |
|---|
| 389 | if {$only2 != ""} { |
|---|
| 390 | set v2 "($widgetInfo($address-mismatch)) : [join $only2 ";"]" |
|---|
| 391 | } else { |
|---|
| 392 | set v2 "" |
|---|
| 393 | } |
|---|
| 394 | set match "children" |
|---|
| 395 | set shade 0.0 |
|---|
| 396 | } |
|---|
| 397 | |
|---|
| 398 | |
|---|
| 399 | |
|---|
| 400 | set title "" |
|---|
| 401 | if {$dsaddress != "dataset"} { |
|---|
| 402 | set title [grapher_gettitle_of_child dataset1 "$dsaddress" ] |
|---|
| 403 | set lvl [llength [split "$dsaddress" "."] ] |
|---|
| 404 | grapher_html_write_table $address [list $title $v1 $v2] $match $lvl |
|---|
| 405 | $wintv insert [crop_address $dsaddress 1] end -id $dsaddress -text "$title" -values [list $v1 $v2] -open $widgetInfo($address-tvopen) -tag $match |
|---|
| 406 | if {$match != "match"} { |
|---|
| 407 | $wintv see $dsaddress |
|---|
| 408 | } |
|---|
| 409 | } |
|---|
| 410 | |
|---|
| 411 | |
|---|
| 412 | # draw node |
|---|
| 413 | set new_anchor1 [grapher_drawnode $wincan $anchor1 $dataset1($dsaddress-maxdepth) $dataset1($dsaddress-childnb) $dataset1($dsaddress-kinnb) $dsname1 $dsaddress left $dataset1($dsaddress-value) $shade $title] |
|---|
| 414 | set new_anchor2 [grapher_drawnode $wincan $anchor2 $dataset2($dsaddress-maxdepth) $dataset2($dsaddress-childnb) $dataset2($dsaddress-kinnb) $dsname2 $dsaddress right $dataset2($dsaddress-value) $shade $title] |
|---|
| 415 | |
|---|
| 416 | |
|---|
| 417 | |
|---|
| 418 | set b1_x [lindex $new_anchor1 0] |
|---|
| 419 | set b1_y [lindex $new_anchor1 1] |
|---|
| 420 | set a1_angle [lindex $new_anchor1 2] |
|---|
| 421 | set list_angle_child1 [grapher_children_directions dataset1 $a1_angle $dsaddress] |
|---|
| 422 | |
|---|
| 423 | set b2_x [lindex $new_anchor2 0] |
|---|
| 424 | set b2_y [lindex $new_anchor2 1] |
|---|
| 425 | set a2_angle [lindex $new_anchor2 2] |
|---|
| 426 | set list_angle_child2 [grapher_children_directions dataset2 $a2_angle $dsaddress] |
|---|
| 427 | |
|---|
| 428 | switch $match { |
|---|
| 429 | "match" { |
|---|
| 430 | set child_id 0 |
|---|
| 431 | foreach child [grapher_ordered_children dataset1 $dsaddress all] { |
|---|
| 432 | set anglechild [expr {$a1_angle+[lindex $list_angle_child1 $child_id]}] |
|---|
| 433 | grapher_compare $address dataset1 dataset2 "$dsaddress.$child" "$b1_x $b1_y $anglechild" "$b2_x $b2_y $anglechild" |
|---|
| 434 | |
|---|
| 435 | incr child_id |
|---|
| 436 | } |
|---|
| 437 | } |
|---|
| 438 | "value" { |
|---|
| 439 | grapher_highlight_node $wincan "$b1_x $b1_y 0" $match left $widgetInfo($address-mismatch) |
|---|
| 440 | grapher_highlight_node $wincan "$b2_x $b2_y 0" $match right $widgetInfo($address-mismatch) |
|---|
| 441 | set child_id 0 |
|---|
| 442 | foreach child [grapher_ordered_children dataset1 $dsaddress all] { |
|---|
| 443 | set anglechild [expr {$a1_angle+[lindex $list_angle_child1 $child_id]}] |
|---|
| 444 | grapher_trace $address dataset1 "$b1_x $b1_y $anglechild" "$dsaddress.$child" left |
|---|
| 445 | incr child_id |
|---|
| 446 | } |
|---|
| 447 | set child_id 0 |
|---|
| 448 | foreach child [grapher_ordered_children dataset2 $dsaddress all] { |
|---|
| 449 | set anglechild [expr {$a2_angle+[lindex $list_angle_child2 $child_id]}] |
|---|
| 450 | grapher_trace $address dataset2 "$b2_x $b2_y $anglechild" "$dsaddress.$child" right |
|---|
| 451 | incr child_id |
|---|
| 452 | } |
|---|
| 453 | } |
|---|
| 454 | "children" { |
|---|
| 455 | |
|---|
| 456 | grapher_highlight_node $wincan "$b1_x $b1_y 0" $match left $widgetInfo($address-mismatch) |
|---|
| 457 | grapher_highlight_node $wincan "$b2_x $b2_y 0" $match right $widgetInfo($address-mismatch) |
|---|
| 458 | set child_id 0 |
|---|
| 459 | foreach child [grapher_ordered_children dataset1 $dsaddress $both] { |
|---|
| 460 | set anglechild [expr {$a1_angle+[lindex $list_angle_child1 $child_id]}] |
|---|
| 461 | grapher_compare $address dataset1 dataset2 "$dsaddress.$child" "$b1_x $b1_y $anglechild" "$b2_x $b2_y $anglechild" |
|---|
| 462 | incr child_id |
|---|
| 463 | } |
|---|
| 464 | foreach child [grapher_ordered_children dataset1 $dsaddress $only1] { |
|---|
| 465 | set anglechild [expr {$a1_angle+[lindex $list_angle_child1 $child_id]}] |
|---|
| 466 | grapher_trace $address dataset1 "$b1_x $b1_y $anglechild" "$dsaddress.$child" left |
|---|
| 467 | incr child_id |
|---|
| 468 | } |
|---|
| 469 | |
|---|
| 470 | set child_id 0 |
|---|
| 471 | foreach child $both { |
|---|
| 472 | incr child_id |
|---|
| 473 | } |
|---|
| 474 | foreach child [grapher_ordered_children dataset2 $dsaddress $only2] { |
|---|
| 475 | set anglechild [expr {$a2_angle+[lindex $list_angle_child2 $child_id]}] |
|---|
| 476 | grapher_trace $address dataset2 "$b2_x $b2_y $anglechild" "$dsaddress.$child" right |
|---|
| 477 | incr child_id |
|---|
| 478 | } |
|---|
| 479 | |
|---|
| 480 | } |
|---|
| 481 | } |
|---|
| 482 | return |
|---|
| 483 | } |
|---|
| 484 | |
|---|
| 485 | |
|---|
| 486 | |
|---|
| 487 | proc grapher_loadfile {dsname filename} { |
|---|
| 488 | upvar $dsname dataset |
|---|
| 489 | |
|---|
| 490 | set chout [ open $filename r ] |
|---|
| 491 | set out [ split [ read $chout] "\n" ] |
|---|
| 492 | close $chout |
|---|
| 493 | |
|---|
| 494 | foreach line $out { |
|---|
| 495 | set linesplit [split $line "="] |
|---|
| 496 | set key [lindex $linesplit 0 ] |
|---|
| 497 | set value [string trim [join [lrange $linesplit 1 end ] "="] " " ] |
|---|
| 498 | set dataset($key) $value |
|---|
| 499 | } |
|---|
| 500 | return |
|---|
| 501 | } |
|---|
| 502 | |
|---|
| 503 | |
|---|
| 504 | proc grapher_zoom {wincan factor} { |
|---|
| 505 | set y0 0 |
|---|
| 506 | set x0 0 |
|---|
| 507 | $wincan scale all $x0 $y0 $factor $factor |
|---|
| 508 | $wincan configure -scrollregion [ $wincan bbox all] |
|---|
| 509 | } |
|---|
| 510 | |
|---|
| 511 | |
|---|
| 512 | |
|---|
| 513 | proc grapher_bboxgraphs {address } { |
|---|
| 514 | global widgetInfo |
|---|
| 515 | |
|---|
| 516 | set wincan $widgetInfo($address-wincan) |
|---|
| 517 | |
|---|
| 518 | set bboxright [$wincan bbox right] |
|---|
| 519 | set bboxleft [$wincan bbox left] |
|---|
| 520 | |
|---|
| 521 | set xml [lindex $bboxleft 0] |
|---|
| 522 | set yml [lindex $bboxleft 1] |
|---|
| 523 | set xpl [lindex $bboxleft 2] |
|---|
| 524 | set ypl [lindex $bboxleft 3] |
|---|
| 525 | |
|---|
| 526 | set dxl [expr {$xpl-$xml}] |
|---|
| 527 | set dyl [expr {$ypl-$yml}] |
|---|
| 528 | set mid_xl [expr {0.5*($xpl+$xml)}] |
|---|
| 529 | set mid_yl [expr {0.5*($ypl+$yml)}] |
|---|
| 530 | |
|---|
| 531 | set hoval 15 |
|---|
| 532 | if {$bboxright != ""} { |
|---|
| 533 | set xmr [lindex $bboxright 0] |
|---|
| 534 | set ymr [lindex $bboxright 1] |
|---|
| 535 | set xpr [lindex $bboxright 2] |
|---|
| 536 | set ypr [lindex $bboxright 3] |
|---|
| 537 | |
|---|
| 538 | |
|---|
| 539 | set dxr [expr {$xpr-$xmr}] |
|---|
| 540 | set dyr [expr {$ypr-$ymr}] |
|---|
| 541 | set mid_xr [expr {0.5*($xpr+$xmr)}] |
|---|
| 542 | set mid_yr [expr {0.5*($ypr+$ymr)}] |
|---|
| 543 | #$wincan create oval [expr {$mid_xr-0.3*$dxr}] [expr {$mid_yr-0.3*$dxr}] [expr {$mid_xr+0.3*$dxr}] [expr {$mid_yr+0.3*$dxr}] -fill [shadeColor [grapher_color right] 0.8] -outline [shadeColor [grapher_color right] 0.5] -tags "right graph circles" |
|---|
| 544 | #$wincan create oval [expr {$mid_xl-0.3*$dxl}] [expr {$mid_yl-0.3*$dxl}] [expr {$mid_xl+0.3*$dxl}] [expr {$mid_yl+0.3*$dxl}] -fill [shadeColor [grapher_color left] 0.8] -outline [shadeColor [grapher_color left] 0.5] -tags "left graph circles" |
|---|
| 545 | $wincan create oval -$hoval -$hoval $hoval $hoval -fill [shadeColor [grapher_color right] 0.8] -outline [shadeColor [grapher_color right] 0.5] -tags "right graph circles" |
|---|
| 546 | $wincan create oval -$hoval -$hoval $hoval $hoval -fill [shadeColor [grapher_color left] 0.8] -outline [shadeColor [grapher_color left] 0.5] -tags "left graph circles" |
|---|
| 547 | |
|---|
| 548 | |
|---|
| 549 | canvas_text_vector $wincan [expr {$mid_xr-0.5*$dxr}] [expr {$mid_yr+0.5*$dyr+ 10}] $widgetInfo($address-filerootname2) ne 10 0 [grapher_color right] "graph right" |
|---|
| 550 | canvas_text_vector $wincan [expr {$mid_xl+0.5*$dxl}] [expr {$mid_yl+0.5*$dyl+ 10}] $widgetInfo($address-filerootname1) nw 10 0 [grapher_color left] "graph left" |
|---|
| 551 | |
|---|
| 552 | # centering graphs |
|---|
| 553 | $wincan move right [expr {-$mid_xr+0.5*$dxr+10}] [expr {-$mid_yr}] |
|---|
| 554 | } else { |
|---|
| 555 | #$wincan create oval [expr {$mid_xl-0.3*$dxl}] [expr {$mid_yl-0.3*$dxl}] [expr {$mid_xl+0.3*$dxl}] [expr {$mid_yl+0.3*$dxl}] -fill [shadeColor black 0.8] -outline [shadeColor black 0.5] -tags "left graph circles" |
|---|
| 556 | $wincan create oval -$hoval -$hoval $hoval $hoval -fill [shadeColor black 0.8] -outline [shadeColor black 0.5] -tags "left graph circles" |
|---|
| 557 | canvas_text_vector $wincan [expr {$mid_xl}] [expr {$mid_yl+0.5*$dyl+ 10}] $widgetInfo($address-filerootname) center 10 0 black "graph left" |
|---|
| 558 | } |
|---|
| 559 | |
|---|
| 560 | # add oval behind |
|---|
| 561 | $wincan lower "circles" |
|---|
| 562 | |
|---|
| 563 | # centering graphs |
|---|
| 564 | $wincan move left [expr {-$mid_xl-0.5*$dxl-10}] [expr {-$mid_yl}] |
|---|
| 565 | |
|---|
| 566 | |
|---|
| 567 | } |
|---|
| 568 | |
|---|
| 569 | proc grapher_color {tag} { |
|---|
| 570 | set color black |
|---|
| 571 | |
|---|
| 572 | switch $tag { |
|---|
| 573 | "left" { |
|---|
| 574 | set color chocolate |
|---|
| 575 | } |
|---|
| 576 | "right" { |
|---|
| 577 | set color purple |
|---|
| 578 | } |
|---|
| 579 | "both" { |
|---|
| 580 | set color grey20 |
|---|
| 581 | } |
|---|
| 582 | "treeval" { |
|---|
| 583 | set color DarkBlue |
|---|
| 584 | } |
|---|
| 585 | |
|---|
| 586 | "default" { |
|---|
| 587 | set color black |
|---|
| 588 | } |
|---|
| 589 | } |
|---|
| 590 | } |
|---|
| 591 | |
|---|
| 592 | |
|---|
| 593 | proc grapher_init_treeview {win address tv type} { |
|---|
| 594 | global widgetInfo |
|---|
| 595 | |
|---|
| 596 | $tv tag configure "value" -background red -foreground white |
|---|
| 597 | $tv tag configure "children" -background green -foreground white |
|---|
| 598 | |
|---|
| 599 | |
|---|
| 600 | # clean treeview |
|---|
| 601 | if {[$tv exists "dataset"]} { |
|---|
| 602 | foreach child [$tv children "dataset"] { |
|---|
| 603 | $tv delete $child |
|---|
| 604 | } |
|---|
| 605 | |
|---|
| 606 | } else { |
|---|
| 607 | $tv insert {} end -id "dataset" -text "dataset" -open true |
|---|
| 608 | } |
|---|
| 609 | |
|---|
| 610 | switch $type { |
|---|
| 611 | "single" { |
|---|
| 612 | set widgetInfo($address-tvopen) "true" |
|---|
| 613 | |
|---|
| 614 | $tv heading 0 -text "Value" |
|---|
| 615 | $tv heading 1 -text "" |
|---|
| 616 | $tv column 0 -anchor center |
|---|
| 617 | $tv column 1 -anchor center |
|---|
| 618 | |
|---|
| 619 | |
|---|
| 620 | } |
|---|
| 621 | "double" { |
|---|
| 622 | set widgetInfo($address-tvopen) "false" |
|---|
| 623 | |
|---|
| 624 | $tv heading 0 -text "Left Value" |
|---|
| 625 | $tv heading 1 -text "Right Value" |
|---|
| 626 | $tv column 0 -anchor center |
|---|
| 627 | $tv column 1 -anchor center |
|---|
| 628 | |
|---|
| 629 | } |
|---|
| 630 | } |
|---|
| 631 | |
|---|
| 632 | } |
|---|
| 633 | |
|---|
| 634 | proc grapher_array_to_treeview {win address tv arrayname dsaddress} { |
|---|
| 635 | global widgetInfo |
|---|
| 636 | upvar $arrayname dataset |
|---|
| 637 | |
|---|
| 638 | grapher_setup_XML dataset $dsaddress |
|---|
| 639 | |
|---|
| 640 | foreach child $dataset($dsaddress-children) { |
|---|
| 641 | |
|---|
| 642 | set title [grapher_gettitle_of_child dataset "$dsaddress.$child" ] |
|---|
| 643 | |
|---|
| 644 | set lvl [llength [split "$dsaddress.$child" "."] ] |
|---|
| 645 | grapher_html_write_table $address [list $title $dataset($dsaddress.$child-value)] default $lvl |
|---|
| 646 | |
|---|
| 647 | $tv insert $dsaddress end -id $dsaddress.$child -text $title -values "{$dataset($dsaddress.$child-value)} {}" -open $widgetInfo($address-tvopen) |
|---|
| 648 | grapher_array_to_treeview $win $address $tv dataset $dsaddress.$child |
|---|
| 649 | } |
|---|
| 650 | |
|---|
| 651 | |
|---|
| 652 | } |
|---|
| 653 | |
|---|
| 654 | proc grapher_gettitle_of_child { arrayname dsaddress } { |
|---|
| 655 | global tmpXMLtree |
|---|
| 656 | upvar $arrayname dataset |
|---|
| 657 | |
|---|
| 658 | # get last item |
|---|
| 659 | set last [lindex [split $dsaddress "."] end] |
|---|
| 660 | |
|---|
| 661 | |
|---|
| 662 | # build XMLaddress |
|---|
| 663 | set XMLaddress "root [dTree_cleanKey [lrange [ split "$dsaddress" "." ] 1 end ]] " |
|---|
| 664 | |
|---|
| 665 | # remove item, a lavel which does not exists in XML tree |
|---|
| 666 | if {[lsearch $XMLaddress "item"]} { |
|---|
| 667 | lremove XMLaddress "item" |
|---|
| 668 | } |
|---|
| 669 | |
|---|
| 670 | # If title exist , set it |
|---|
| 671 | if {[dTree_attrExists $tmpXMLtree $XMLaddress "title"]} { |
|---|
| 672 | set title [dTree_getAttribute $tmpXMLtree $XMLaddress "title"] |
|---|
| 673 | } else { |
|---|
| 674 | #puts "$dsaddress without title" |
|---|
| 675 | set title [string totitle $last] |
|---|
| 676 | } |
|---|
| 677 | |
|---|
| 678 | # case of named nultiple |
|---|
| 679 | if {[lindex [split $last "_"] 0] == "item"} { |
|---|
| 680 | set title "$dataset($dsaddress-value)" |
|---|
| 681 | } |
|---|
| 682 | |
|---|
| 683 | |
|---|
| 684 | return $title |
|---|
| 685 | } |
|---|
| 686 | |
|---|
| 687 | proc grapher_setup_XML {arrayname dsaddress} { |
|---|
| 688 | global tmpXMLtree widgetInfo |
|---|
| 689 | upvar $arrayname dataset |
|---|
| 690 | |
|---|
| 691 | if { $dsaddress == "dataset"} { |
|---|
| 692 | set appli $dataset($dsaddress-children) |
|---|
| 693 | if {$appli in $widgetInfo(applicationList)} { |
|---|
| 694 | log "Loading XML of $appli" |
|---|
| 695 | set modelPath [file join $widgetInfo(libraryPath) $appli XML] |
|---|
| 696 | set dataPath [file join $widgetInfo(libraryPath)] |
|---|
| 697 | set tmpXMLtree "" |
|---|
| 698 | OpenTeaXMLML2tree tmpXMLtree $modelPath $dataPath |
|---|
| 699 | } |
|---|
| 700 | } |
|---|
| 701 | |
|---|
| 702 | } |
|---|
| 703 | |
|---|
| 704 | proc grapher_create { win address wincan wintv folder file1 file2 dump} { |
|---|
| 705 | global widgetInfo |
|---|
| 706 | |
|---|
| 707 | set widgetInfo($address-wincan) $wincan |
|---|
| 708 | set widgetInfo($address-wintv) $wintv |
|---|
| 709 | set widgetInfo($address-folder) $folder |
|---|
| 710 | set widgetInfo($address-dump) $dump |
|---|
| 711 | |
|---|
| 712 | # cleaning |
|---|
| 713 | $wincan delete all |
|---|
| 714 | |
|---|
| 715 | # scroll |
|---|
| 716 | bind $wincan <ButtonPress> [subst {$wincan scan mark %x %y}] |
|---|
| 717 | bind $wincan <B1-Motion> [subst {$wincan scan dragto %x %y 1}] |
|---|
| 718 | |
|---|
| 719 | if {$file1 == $file2} { |
|---|
| 720 | grapher_init_treeview $win $address $wintv "single" |
|---|
| 721 | set widgetInfo($address-filerootname) $file1 |
|---|
| 722 | grapher_html_write_table $address "Exploring simulation" start |
|---|
| 723 | grapher_html_write_table $address "Element $file1 " headers |
|---|
| 724 | |
|---|
| 725 | grapher_loadfile "ds1" [file join $folder "$file1.dat"] |
|---|
| 726 | grapher_array_to_treeview $win $address $wintv "ds1" "dataset" |
|---|
| 727 | grapher_fill $address "ds1" "dataset" 0 1 |
|---|
| 728 | grapher_trace $address "ds1" {0 0 10.0} "dataset" left |
|---|
| 729 | grapher_bboxgraphs $address |
|---|
| 730 | } else { |
|---|
| 731 | grapher_init_treeview $win $address $wintv "double" |
|---|
| 732 | set widgetInfo($address-filerootname) "$file1\_VS_$file2" |
|---|
| 733 | set widgetInfo($address-filerootname1) "$file1" |
|---|
| 734 | set widgetInfo($address-filerootname2) "$file2" |
|---|
| 735 | set widgetInfo($address-mismatch) 0 |
|---|
| 736 | grapher_html_write_table $address "Comparing simulations " start |
|---|
| 737 | grapher_html_write_table $address "Element $file1 $file2" headers |
|---|
| 738 | |
|---|
| 739 | grapher_loadfile "ds1" [file join $folder "$file1.dat"] |
|---|
| 740 | grapher_loadfile "ds2" [file join $folder "$file2.dat"] |
|---|
| 741 | grapher_fill $address "ds1" "dataset" 0 0 |
|---|
| 742 | grapher_fill $address "ds2" "dataset" 0 0 |
|---|
| 743 | grapher_compare $address "ds1" "ds2" "dataset" {0 0 10.0} {0 0 10.0} |
|---|
| 744 | grapher_bboxgraphs $address |
|---|
| 745 | } |
|---|
| 746 | |
|---|
| 747 | grapher_html_write_table $address "" end |
|---|
| 748 | |
|---|
| 749 | |
|---|
| 750 | $wincan raise "handle" |
|---|
| 751 | $wincan configure -scrollregion [ $wincan bbox all] |
|---|
| 752 | |
|---|
| 753 | |
|---|
| 754 | |
|---|
| 755 | |
|---|
| 756 | if {$dump} { |
|---|
| 757 | set jobduration [time { |
|---|
| 758 | set result [canvas_makegif $wincan [file join $folder "$widgetInfo($address-filerootname).gif"]] |
|---|
| 759 | }] |
|---|
| 760 | set jobtime [expr { 1.*[lindex $jobduration 0]/ 1000000}] |
|---|
| 761 | debug "Gif created in $jobtime s" |
|---|
| 762 | } |
|---|
| 763 | |
|---|
| 764 | } |
|---|
| 765 | |
|---|
| 766 | |
|---|
| 767 | |
|---|
| 768 | |
|---|
| 769 | |
|---|
| 770 | |
|---|
| 771 | |
|---|
| 772 | # Copyright CERFACS 2014 |
|---|
| 773 | # |
|---|
| 774 | # antoine.dauptain@cerfacs.fr |
|---|
| 775 | # |
|---|
| 776 | # This software is a computer program whose purpose is to ensure technology |
|---|
| 777 | # transfer between academia and industry. |
|---|
| 778 | # |
|---|
| 779 | # This software is governed by the CeCILL-B license under French law and |
|---|
| 780 | # abiding by the rules of distribution of free software. You can use, |
|---|
| 781 | # modify and/ or redistribute the software under the terms of the CeCILL-B |
|---|
| 782 | # license as circulated by CEA, CNRS and INRIA at the following URL |
|---|
| 783 | # "http://www.cecill.info". |
|---|
| 784 | # |
|---|
| 785 | # As a counterpart to the access to the source code and rights to copy, |
|---|
| 786 | # modify and redistribute granted by the license, users are provided only |
|---|
| 787 | # with a limited warranty and the software's author, the holder of the |
|---|
| 788 | # economic rights, and the successive licensors have only limited |
|---|
| 789 | # liability. |
|---|
| 790 | # |
|---|
| 791 | # In this respect, the user's attention is drawn to the risks associated |
|---|
| 792 | # with loading, using, modifying and/or developing or reproducing the |
|---|
| 793 | # software by the user in light of its specific status of free software, |
|---|
| 794 | # that may mean that it is complicated to manipulate, and that also |
|---|
| 795 | # therefore means that it is reserved for developers and experienced |
|---|
| 796 | # professionals having in-depth computer knowledge. Users are therefore |
|---|
| 797 | # encouraged to load and test the software's suitability as regards their |
|---|
| 798 | # requirements in conditions enabling the security of their systems and/or |
|---|
| 799 | # data to be ensured and, more generally, to use and operate it in the |
|---|
| 800 | # same conditions as regards security. |
|---|
| 801 | # |
|---|
| 802 | # The fact that you are presently reading this means that you have had |
|---|
| 803 | # knowledge of the CeCILL-B license and that you accept its terms. |
|---|
