| 1 | # This program is under CECILL_B licence. See footer for details. |
|---|
| 2 | |
|---|
| 3 | # This library is intended to provide a new data structure, the tree, to Tcl 8.5 using dictionaries |
|---|
| 4 | |
|---|
| 5 | ##################### |
|---|
| 6 | # Adresses procedures |
|---|
| 7 | ##################### |
|---|
| 8 | |
|---|
| 9 | proc gui2tree address { |
|---|
| 10 | return [split $address .] |
|---|
| 11 | } |
|---|
| 12 | |
|---|
| 13 | proc tree2gui address { |
|---|
| 14 | return [join $address .] |
|---|
| 15 | } |
|---|
| 16 | |
|---|
| 17 | proc addrGetFather address { |
|---|
| 18 | return [tree2gui [lrange [gui2tree $address] 0 end-1]] |
|---|
| 19 | } |
|---|
| 20 | |
|---|
| 21 | proc addrGetAncestors address { |
|---|
| 22 | set result "" |
|---|
| 23 | while {$address != ""} { |
|---|
| 24 | set address [addrGetFather $address] |
|---|
| 25 | if {$address != ""} { |
|---|
| 26 | lappend result $address |
|---|
| 27 | } |
|---|
| 28 | } |
|---|
| 29 | return $result |
|---|
| 30 | } |
|---|
| 31 | |
|---|
| 32 | # This procedure creates a tree by creating the root node |
|---|
| 33 | proc dTree_init {dtree} { |
|---|
| 34 | upvar $dtree tree |
|---|
| 35 | set tree [dict create] |
|---|
| 36 | dict set tree "root" description "root of the tree" |
|---|
| 37 | dict set tree "root" nodeType "node" |
|---|
| 38 | dict set tree "root" children [list] |
|---|
| 39 | } |
|---|
| 40 | |
|---|
| 41 | |
|---|
| 42 | # This procedure adds a node named node as a children of key in the tree dtree |
|---|
| 43 | proc dTree_addNode {dtree key node} { |
|---|
| 44 | upvar $dtree tree |
|---|
| 45 | |
|---|
| 46 | if {[dict exists $tree $key]} { |
|---|
| 47 | |
|---|
| 48 | if {[dict exists $tree "$key $node"]} { |
|---|
| 49 | error "The node you are trying to add already exists ($key $node)" |
|---|
| 50 | } |
|---|
| 51 | set value [dict get $tree $key children] |
|---|
| 52 | lappend value $node |
|---|
| 53 | dict set tree $key children $value |
|---|
| 54 | lappend key $node |
|---|
| 55 | dict set tree $key children "" |
|---|
| 56 | } else { |
|---|
| 57 | #If the father doesn't exist, let's create it ! |
|---|
| 58 | dTree_addNode tree [lrange $key 0 end-1] [lindex $key end] |
|---|
| 59 | dTree_addNode tree $key $node |
|---|
| 60 | dTree_setAttribute tree "$key" "value" "" |
|---|
| 61 | #error "You're trying to add a node but the father node ($key) doesn't exist" |
|---|
| 62 | } |
|---|
| 63 | } |
|---|
| 64 | |
|---|
| 65 | # used to deref multiple nodes |
|---|
| 66 | proc dTree_cleanKey2 { key } { |
|---|
| 67 | set key2 "" |
|---|
| 68 | foreach key_elt $key { |
|---|
| 69 | if {[string match item_* $key_elt]} { |
|---|
| 70 | lappend key2 "item" |
|---|
| 71 | } else { |
|---|
| 72 | lappend key2 $key_elt |
|---|
| 73 | } |
|---|
| 74 | } |
|---|
| 75 | return $key2 |
|---|
| 76 | } |
|---|
| 77 | |
|---|
| 78 | # fonctionne , mais delicat a cause de l'addresse qui doit etre protégée par des {} |
|---|
| 79 | proc dTree_cleanKey { key } { |
|---|
| 80 | foreach j [lsearch -all $key "item_*"] { |
|---|
| 81 | set key [ lset key $j "item"] |
|---|
| 82 | } |
|---|
| 83 | return $key |
|---|
| 84 | } |
|---|
| 85 | |
|---|
| 86 | proc dTree_setAttribute {dtree key attribute value} { |
|---|
| 87 | upvar $dtree tree |
|---|
| 88 | if {[dict exists $tree $key]} { |
|---|
| 89 | dict set tree $key $attribute $value |
|---|
| 90 | } else { |
|---|
| 91 | #error "You're trying to set an attribute on a node which doesn't exist" |
|---|
| 92 | dTree_addNode tree [lrange $key 0 end-1] [lindex $key end] |
|---|
| 93 | dict set tree $key $attribute $value |
|---|
| 94 | } |
|---|
| 95 | } |
|---|
| 96 | |
|---|
| 97 | |
|---|
| 98 | |
|---|
| 99 | proc dTree_getAttribute_fast {tree key attribute} { |
|---|
| 100 | return [dict get $tree "$key" $attribute] |
|---|
| 101 | } |
|---|
| 102 | |
|---|
| 103 | |
|---|
| 104 | proc dTree_getAttribute {tree key attribute} { |
|---|
| 105 | |
|---|
| 106 | if {[dict exists $tree "$key" $attribute]} { |
|---|
| 107 | return [dict get $tree "$key" $attribute] |
|---|
| 108 | } else { |
|---|
| 109 | set key_clean [dTree_cleanKey $key] |
|---|
| 110 | if {[dict exists $tree $key_clean $attribute]} { |
|---|
| 111 | return [dict get $tree $key_clean $attribute] |
|---|
| 112 | } else { |
|---|
| 113 | error "You're trying to get an attribute which doesn't exist : $key > $attribute" |
|---|
| 114 | } |
|---|
| 115 | } |
|---|
| 116 | |
|---|
| 117 | } |
|---|
| 118 | |
|---|
| 119 | |
|---|
| 120 | proc dTree_tryGetAttribute_fast {tree key attribute default} { |
|---|
| 121 | |
|---|
| 122 | if {[dict exists $tree "$key" $attribute]} { |
|---|
| 123 | return [dict get $tree "$key" $attribute] |
|---|
| 124 | } else { |
|---|
| 125 | return $default |
|---|
| 126 | } |
|---|
| 127 | } |
|---|
| 128 | |
|---|
| 129 | |
|---|
| 130 | proc dTree_tryGetAttribute {tree key attribute default} { |
|---|
| 131 | |
|---|
| 132 | if {[dict exists $tree "$key" $attribute]} { |
|---|
| 133 | return [dict get $tree "$key" $attribute] |
|---|
| 134 | } else { |
|---|
| 135 | set key_clean [dTree_cleanKey $key] |
|---|
| 136 | if {[dict exists $tree $key_clean $attribute]} { |
|---|
| 137 | return [dict get $tree $key_clean $attribute] |
|---|
| 138 | } else { |
|---|
| 139 | return $default |
|---|
| 140 | } |
|---|
| 141 | } |
|---|
| 142 | } |
|---|
| 143 | |
|---|
| 144 | |
|---|
| 145 | |
|---|
| 146 | proc dTree_getAttributes {tree node} { |
|---|
| 147 | set result "" |
|---|
| 148 | dict for {key value} [dict get "$tree" "$node"] { |
|---|
| 149 | if {$key != "children"} {lappend result [list $key $value]} |
|---|
| 150 | } |
|---|
| 151 | return $result |
|---|
| 152 | } |
|---|
| 153 | |
|---|
| 154 | |
|---|
| 155 | proc dTree_getChildren_fast {tree key} { |
|---|
| 156 | return [dict get $tree "$key" "children"] |
|---|
| 157 | } |
|---|
| 158 | |
|---|
| 159 | proc dTree_getChildren {tree key} { |
|---|
| 160 | #return [dict get $tree $key "children"] |
|---|
| 161 | if {[dict exists $tree "$key" "children"]} { |
|---|
| 162 | return [dict get $tree "$key" "children"] |
|---|
| 163 | } else { |
|---|
| 164 | set key_clean [dTree_cleanKey $key] |
|---|
| 165 | if {[dict exists $tree $key_clean "children"]} { |
|---|
| 166 | return [dict get $tree $key_clean "children"] |
|---|
| 167 | } else { |
|---|
| 168 | error "You're trying to get children from a node which doesn't exist : $key " |
|---|
| 169 | } |
|---|
| 170 | } |
|---|
| 171 | } |
|---|
| 172 | |
|---|
| 173 | proc dTree_getUsedChildren {tree key} { |
|---|
| 174 | # This function acts like dTree_getChildren but it returns relevant children only |
|---|
| 175 | # For example, in a xor, only the selected children are returned |
|---|
| 176 | # This procedure should only be used in tmpTree |
|---|
| 177 | global XMLtree widgetInfo |
|---|
| 178 | set cleanKey [dTree_cleanKey $key] |
|---|
| 179 | if {[dTree_attrExists $XMLtree $cleanKey "nodeType"]} { |
|---|
| 180 | set nodeType [dTree_getAttribute_fast $XMLtree $cleanKey "nodeType"] |
|---|
| 181 | switch $nodeType { |
|---|
| 182 | "xor" { |
|---|
| 183 | return [dTree_getAttribute_fast $tree $key "value"] |
|---|
| 184 | } |
|---|
| 185 | default { |
|---|
| 186 | set finalChildren "" |
|---|
| 187 | set children [dTree_getChildren $tree $key] |
|---|
| 188 | foreach child $children { |
|---|
| 189 | if {[info exists widgetInfo([tree2gui "$key $child"]-visible)] == 0} { |
|---|
| 190 | lappend finalChildren $child |
|---|
| 191 | } elseif {$widgetInfo([tree2gui "$key $child"]-visible) == 1} { |
|---|
| 192 | lappend finalChildren $child |
|---|
| 193 | } |
|---|
| 194 | } |
|---|
| 195 | return $finalChildren |
|---|
| 196 | } |
|---|
| 197 | } |
|---|
| 198 | } else { |
|---|
| 199 | #warning "The node $key doesn't have a corresponding node in the XMLtree" |
|---|
| 200 | #eturn [dTree_getChildren $tree $key] |
|---|
| 201 | return "" |
|---|
| 202 | } |
|---|
| 203 | |
|---|
| 204 | } |
|---|
| 205 | |
|---|
| 206 | proc dTree_rmAttribute {dtree key attribute} { |
|---|
| 207 | upvar $dtree tree |
|---|
| 208 | if {[dict exists $tree $key $attribute]} { |
|---|
| 209 | dict unset tree $key $attribute |
|---|
| 210 | } else { |
|---|
| 211 | error 0 "You're trying to remove an attribute which doesn't exist" |
|---|
| 212 | } |
|---|
| 213 | } |
|---|
| 214 | |
|---|
| 215 | proc dTree_rmNode {dtree key} { |
|---|
| 216 | upvar $dtree tree |
|---|
| 217 | if {[dict exists $tree $key]} { |
|---|
| 218 | dict unset tree $key |
|---|
| 219 | set father [lrange $key 0 end-1] |
|---|
| 220 | set child [lrange $key end end] |
|---|
| 221 | set fatherListChildren [dict get $tree $father children] |
|---|
| 222 | set idx [lsearch -exact $fatherListChildren $child] |
|---|
| 223 | set fatherListChildren [lreplace $fatherListChildren $idx $idx] |
|---|
| 224 | dict set tree $father children $fatherListChildren |
|---|
| 225 | } else { |
|---|
| 226 | error "You're trying to remove a node which doesn't exist" |
|---|
| 227 | } |
|---|
| 228 | |
|---|
| 229 | } |
|---|
| 230 | |
|---|
| 231 | proc dTree_rmBranch {dtree node} { |
|---|
| 232 | upvar $dtree tree |
|---|
| 233 | foreach child [dTree_getChildren $tree "$node"] { |
|---|
| 234 | dTree_rmBranch tree "$node $child" |
|---|
| 235 | } |
|---|
| 236 | dTree_rmNode tree "$node" |
|---|
| 237 | } |
|---|
| 238 | |
|---|
| 239 | # behaves like a cp |
|---|
| 240 | # node source adress like : aze rty uio node1 |
|---|
| 241 | # node destination addres like : qsd fgh jkl |
|---|
| 242 | # output is : qsd fgh jkl node1 |
|---|
| 243 | |
|---|
| 244 | # "nodeName" is the future father of the copied node |
|---|
| 245 | # $node_dest $nodeName" is the full address of the copied node |
|---|
| 246 | |
|---|
| 247 | |
|---|
| 248 | proc dTree_copyBranch {dtree_source node_source dtree_dest node_dest} { |
|---|
| 249 | upvar $dtree_source tree1 |
|---|
| 250 | upvar $dtree_dest tree2 |
|---|
| 251 | set nodeName [lindex $node_source end] |
|---|
| 252 | |
|---|
| 253 | if {[dTree_nodeExists $tree1 "$node_source"]==0} { |
|---|
| 254 | warning "Cannot copy branch $nodeName from $dtree_source " |
|---|
| 255 | return |
|---|
| 256 | } |
|---|
| 257 | |
|---|
| 258 | |
|---|
| 259 | |
|---|
| 260 | if {[dTree_nodeExists $tree2 "$node_dest $nodeName"]} { |
|---|
| 261 | dTree_rmBranch tree2 "$node_dest $nodeName" |
|---|
| 262 | } |
|---|
| 263 | dTree_addNode tree2 "$node_dest" $nodeName |
|---|
| 264 | |
|---|
| 265 | foreach attribute [dTree_getAttributes $tree1 $node_source] { |
|---|
| 266 | dTree_setAttribute tree2 "$node_dest $nodeName" [lindex $attribute 0] [lindex $attribute 1] |
|---|
| 267 | } |
|---|
| 268 | |
|---|
| 269 | foreach child [dTree_getChildren $tree1 $node_source] { |
|---|
| 270 | dTree_copyBranch tree1 "$node_source $child" tree2 "$node_dest $nodeName" |
|---|
| 271 | } |
|---|
| 272 | } |
|---|
| 273 | |
|---|
| 274 | # to give to a node the same children as an other node |
|---|
| 275 | proc dTree_duplicateBranch {dtree_source node_source node_dest} { |
|---|
| 276 | upvar $dtree_source tree |
|---|
| 277 | |
|---|
| 278 | set sce_path [lrange $node_source 0 end-1 ] |
|---|
| 279 | set sce_node [lindex $node_source end ] |
|---|
| 280 | set tgt_path [lrange $node_dest 0 end-1 ] |
|---|
| 281 | set tgt_node [lindex $node_dest end ] |
|---|
| 282 | |
|---|
| 283 | |
|---|
| 284 | set value [dTree_getAttribute $tree $node_dest "value" ] |
|---|
| 285 | |
|---|
| 286 | dTree_rmBranch tree "$tgt_path $tgt_node" |
|---|
| 287 | dTree_addNode tree "$tgt_path" $tgt_node |
|---|
| 288 | |
|---|
| 289 | |
|---|
| 290 | foreach attribute [dTree_getAttributes $tree $node_source] { |
|---|
| 291 | dTree_setAttribute tree $node_dest [lindex $attribute 0] [lindex $attribute 1] |
|---|
| 292 | } |
|---|
| 293 | dTree_setAttribute tree $node_dest "value" $value |
|---|
| 294 | |
|---|
| 295 | |
|---|
| 296 | foreach child [dTree_getChildren $tree $node_source] { |
|---|
| 297 | dTree_copyBranch tree "$node_source $child" tree "$node_dest" |
|---|
| 298 | } |
|---|
| 299 | } |
|---|
| 300 | |
|---|
| 301 | |
|---|
| 302 | |
|---|
| 303 | proc dTree_copyRelevantBranch {dtree_source node_source dtree_dest node_dest} { |
|---|
| 304 | # This function acts like copyBranch except, it chooses only used nodes (dtree_source should be tmpTree ...) |
|---|
| 305 | upvar $dtree_source tree1 |
|---|
| 306 | upvar $dtree_dest tree2 |
|---|
| 307 | set nodeName [lindex $node_source end] |
|---|
| 308 | if {[dTree_nodeExists $tree2 "$node_dest $nodeName"]} { |
|---|
| 309 | dTree_rmBranch tree2 "$node_dest $nodeName" |
|---|
| 310 | } |
|---|
| 311 | |
|---|
| 312 | dTree_addNode tree2 "$node_dest" $nodeName |
|---|
| 313 | foreach attribute [dTree_getAttributes $tree1 $node_source] { |
|---|
| 314 | dTree_setAttribute tree2 "$node_dest $nodeName" [lindex $attribute 0] [lindex $attribute 1] |
|---|
| 315 | } |
|---|
| 316 | |
|---|
| 317 | foreach child [dTree_getUsedChildren $tree1 $node_source] { |
|---|
| 318 | dTree_copyRelevantBranch tree1 "$node_source $child" tree2 "$node_dest $nodeName" |
|---|
| 319 | } |
|---|
| 320 | } |
|---|
| 321 | |
|---|
| 322 | |
|---|
| 323 | proc dTree_copyRelevantBranch_ForpartialData {dtree_source node_source dtree_dest node_dest} { |
|---|
| 324 | # This function acts like copyBranch except, it chooses only used nodes (dtree_source should be tmpTree ...) |
|---|
| 325 | upvar $dtree_source tree1 |
|---|
| 326 | upvar $dtree_dest tree2 |
|---|
| 327 | set nodeName [lindex $node_source end] |
|---|
| 328 | #set nodeFather1 "[lrange $node_source 0 end-1]" |
|---|
| 329 | #set nodeFather2 "root [lrange $nodeFather1 2 end]" |
|---|
| 330 | |
|---|
| 331 | |
|---|
| 332 | # $tree1 donnes a charger |
|---|
| 333 | # $tree2 donnes cibles |
|---|
| 334 | |
|---|
| 335 | set node_source2 "$node_source" |
|---|
| 336 | if {[string match "item_*" $nodeName ]} { |
|---|
| 337 | set name1 "[dTree_getAttribute_fast $tree1 "$node_source" "value"]" |
|---|
| 338 | foreach item [dTree_getChildren_fast $tree2 $node_dest] { |
|---|
| 339 | set name2 "[dTree_getAttribute_fast $tree2 "$node_dest $item" "value"]" |
|---|
| 340 | if {$name1 == $name2} { |
|---|
| 341 | set node_source2 "$node_dest $item" |
|---|
| 342 | } |
|---|
| 343 | } |
|---|
| 344 | |
|---|
| 345 | } |
|---|
| 346 | set nodeName2 [lindex $node_source2 end] |
|---|
| 347 | |
|---|
| 348 | # Attributes update |
|---|
| 349 | foreach attribute [dTree_getAttributes $tree1 $node_source] { |
|---|
| 350 | dTree_setAttribute tree2 "$node_dest $nodeName2" [lindex $attribute 0] [lindex $attribute 1] |
|---|
| 351 | } |
|---|
| 352 | |
|---|
| 353 | # Childs Update |
|---|
| 354 | foreach child [dTree_getChildren_fast $tree1 $node_source] { |
|---|
| 355 | dTree_copyRelevantBranch_ForpartialData tree1 "$node_source $child" tree2 "$node_dest $nodeName2" |
|---|
| 356 | } |
|---|
| 357 | } |
|---|
| 358 | |
|---|
| 359 | |
|---|
| 360 | |
|---|
| 361 | |
|---|
| 362 | |
|---|
| 363 | proc dTree_moveBranch {dtree_source node_source dtree_dest node_dest} { |
|---|
| 364 | upvar $dtree_source tree1 |
|---|
| 365 | upvar $dtree_dest tree2 |
|---|
| 366 | dTree_copyBranch tree1 "$node_source" tree2 "$node_dest" |
|---|
| 367 | dTree_rmBranch tree1 "$node_source" |
|---|
| 368 | } |
|---|
| 369 | |
|---|
| 370 | proc dTree_searchAddress {dtree pattern} { |
|---|
| 371 | set pattern "*[join [split $pattern { }] *]*" |
|---|
| 372 | set addresses "" |
|---|
| 373 | set result "" |
|---|
| 374 | dict for {node subdict} $dtree { |
|---|
| 375 | dict for {attr value} $subdict { |
|---|
| 376 | lappend addresses "$node $attr" |
|---|
| 377 | } |
|---|
| 378 | } |
|---|
| 379 | foreach address $addresses { |
|---|
| 380 | if {[string match -nocase $pattern $address]} { |
|---|
| 381 | lappend result $address |
|---|
| 382 | } |
|---|
| 383 | } |
|---|
| 384 | |
|---|
| 385 | return $result |
|---|
| 386 | } |
|---|
| 387 | |
|---|
| 388 | proc dTree_searchNode {dtree pattern} { |
|---|
| 389 | # Two types of pattern can be read here : |
|---|
| 390 | # -> One with no spaces, it's strict, the function will look for *pattern |
|---|
| 391 | # -> If spaces in the pattern, the function searches for all addresses which |
|---|
| 392 | # contain every element of the pattern in the order of the pattern |
|---|
| 393 | |
|---|
| 394 | if {[regexp {\s} $pattern]} { |
|---|
| 395 | set pattern [split $pattern { }] |
|---|
| 396 | set pattern "*[join [lrange $pattern 0 end-1] *]* [lindex $pattern end]" |
|---|
| 397 | } else { |
|---|
| 398 | set pattern "* [split $pattern {.}]" |
|---|
| 399 | } |
|---|
| 400 | set addresses "" |
|---|
| 401 | set result "" |
|---|
| 402 | dict for {node subdict} $dtree { |
|---|
| 403 | lappend addresses "$node" |
|---|
| 404 | } |
|---|
| 405 | foreach address $addresses { |
|---|
| 406 | if {[string match -nocase $pattern $address]} { |
|---|
| 407 | lappend result $address |
|---|
| 408 | } |
|---|
| 409 | } |
|---|
| 410 | return $result |
|---|
| 411 | } |
|---|
| 412 | |
|---|
| 413 | proc dTree_searchNode_old {dtree pattern} { |
|---|
| 414 | set pattern "*$pattern" |
|---|
| 415 | set addresses "" |
|---|
| 416 | set result "" |
|---|
| 417 | dict for {node subdict} $dtree { |
|---|
| 418 | lappend addresses "$node" |
|---|
| 419 | } |
|---|
| 420 | foreach address $addresses { |
|---|
| 421 | if {[string match -nocase $pattern $address]} { |
|---|
| 422 | lappend result $address |
|---|
| 423 | } |
|---|
| 424 | } |
|---|
| 425 | return $result |
|---|
| 426 | } |
|---|
| 427 | |
|---|
| 428 | proc dTree_nodeExists {tree key} { |
|---|
| 429 | |
|---|
| 430 | return [dict exists $tree $key] |
|---|
| 431 | |
|---|
| 432 | } |
|---|
| 433 | |
|---|
| 434 | |
|---|
| 435 | proc dTree_attrExists_fast {tree key attribute} { |
|---|
| 436 | if {[dict exists $tree "$key" $attribute]} { |
|---|
| 437 | return 1 |
|---|
| 438 | } else { |
|---|
| 439 | return 0 |
|---|
| 440 | } |
|---|
| 441 | } |
|---|
| 442 | |
|---|
| 443 | proc dTree_attrExists {tree key attribute} { |
|---|
| 444 | if {[dict exists $tree "$key" $attribute]} { |
|---|
| 445 | return 1 |
|---|
| 446 | } else { |
|---|
| 447 | if {[dict exists $tree "[dTree_cleanKey $key]" $attribute]} { |
|---|
| 448 | return 1 |
|---|
| 449 | } else { |
|---|
| 450 | return 0 |
|---|
| 451 | } |
|---|
| 452 | } |
|---|
| 453 | } |
|---|
| 454 | |
|---|
| 455 | proc dTree_puts {args} { |
|---|
| 456 | set tree [lindex $args 0] |
|---|
| 457 | set node [lindex $args 1] |
|---|
| 458 | set indent [lindex $args 2] |
|---|
| 459 | if {$node == ""} {set node root} |
|---|
| 460 | puts "$indent ### [lindex $node end]" |
|---|
| 461 | foreach attr [dTree_getAttributes $tree "$node"] { |
|---|
| 462 | puts "$indent > [lindex $attr 0]\t: [lindex $attr 1]" |
|---|
| 463 | } |
|---|
| 464 | set indent "$indent " |
|---|
| 465 | foreach child [dTree_getChildren_fast $tree "$node"] { |
|---|
| 466 | dTree_puts $tree "$node $child" $indent |
|---|
| 467 | } |
|---|
| 468 | } |
|---|
| 469 | |
|---|
| 470 | proc dTree_compareBranch {tree1 tree2 node relevantNodes listDifferentNodes} { |
|---|
| 471 | # This function compare two trees beginning from 'node' |
|---|
| 472 | # If the trees are identical, it returns 1 |
|---|
| 473 | # If they are not, it returns 0 and the list of the nodes where the differences begin are stored in 'listDifferentNodes' |
|---|
| 474 | # In listDifferentNodes, the first element stores the nodes with a difference in the node (arguments are different) |
|---|
| 475 | # The second element stores the nodes existing in tree2 and not in tree1 |
|---|
| 476 | # The third element stores the nodes existing in tree1 and not in tree2 |
|---|
| 477 | # The fourth element stores the parents of the second and third ones (children are different) |
|---|
| 478 | |
|---|
| 479 | #Pour tester : |
|---|
| 480 | # set l "{} {} {}" |
|---|
| 481 | # puts [dTree_compareBranch $DStree $tmpTree "root" l] |
|---|
| 482 | |
|---|
| 483 | # foreach el [lindex $l 0] {puts "!= $el} |
|---|
| 484 | # foreach el [lindex $l 1] {puts "++ $el} |
|---|
| 485 | # foreach el [lindex $l 2] {puts "-- $el} |
|---|
| 486 | |
|---|
| 487 | #debug "Comparing $node " |
|---|
| 488 | upvar $listDifferentNodes listNodes |
|---|
| 489 | if {$listNodes == ""} {set listNodes "{} {} {} {}"} |
|---|
| 490 | set status 1 |
|---|
| 491 | |
|---|
| 492 | # Retrieve children list |
|---|
| 493 | if {$relevantNodes != 1} { |
|---|
| 494 | set children1 [lsort [dTree_getChildren $tree1 $node]] |
|---|
| 495 | set children2 [lsort [dTree_getChildren $tree2 $node]] |
|---|
| 496 | } else { |
|---|
| 497 | set children1 [lsort [dTree_getUsedChildren $tree1 $node]] |
|---|
| 498 | set children2 [lsort [dTree_getUsedChildren $tree2 $node]] |
|---|
| 499 | } |
|---|
| 500 | |
|---|
| 501 | # Retrieve arguments |
|---|
| 502 | set attributes1 [lsort -index 0 [dTree_getAttributes $tree1 $node]] |
|---|
| 503 | set attributes2 [lsort -index 0 [dTree_getAttributes $tree2 $node]] |
|---|
| 504 | |
|---|
| 505 | # Compare, if not the same, return false, no need to test the children ... |
|---|
| 506 | if {$attributes1 != $attributes2 } { |
|---|
| 507 | #debug "attributes1 : $attributes1" |
|---|
| 508 | #debug "attributes2 : $attributes2" |
|---|
| 509 | |
|---|
| 510 | set tmpList [lindex $listNodes 0] |
|---|
| 511 | lappend tmpList "$node" |
|---|
| 512 | lset listNodes 0 $tmpList |
|---|
| 513 | |
|---|
| 514 | return 0 |
|---|
| 515 | } |
|---|
| 516 | |
|---|
| 517 | if { $children1 != $children2 } { |
|---|
| 518 | |
|---|
| 519 | set childrenToTest "" |
|---|
| 520 | |
|---|
| 521 | set tmpList [lindex $listNodes 3] |
|---|
| 522 | lappend tmpList "$node" |
|---|
| 523 | lset listNodes 3 $tmpList |
|---|
| 524 | |
|---|
| 525 | foreach child $children1 { |
|---|
| 526 | if {$child ni $children2} { |
|---|
| 527 | set tmpList [lindex $listNodes 2] |
|---|
| 528 | lappend tmpList "$node $child" |
|---|
| 529 | lset listNodes 2 $tmpList |
|---|
| 530 | } else { |
|---|
| 531 | lappend childrenToTest $child |
|---|
| 532 | } |
|---|
| 533 | } |
|---|
| 534 | |
|---|
| 535 | foreach child $children2 { |
|---|
| 536 | if {$child ni $children1} { |
|---|
| 537 | set tmpList [lindex $listNodes 1] |
|---|
| 538 | lappend tmpList "$node $child" |
|---|
| 539 | lset listNodes 1 $tmpList |
|---|
| 540 | |
|---|
| 541 | # lremove |
|---|
| 542 | set idx [lsearch -exact $childrenToTest $child] |
|---|
| 543 | set childrenToTest [lreplace $childrenToTest $idx $idx] |
|---|
| 544 | } |
|---|
| 545 | } |
|---|
| 546 | |
|---|
| 547 | foreach child $childrenToTest { |
|---|
| 548 | lappend childrenStatus [dTree_compareBranch $tree1 $tree2 "$node $child" $relevantNodes listNodes] |
|---|
| 549 | } |
|---|
| 550 | |
|---|
| 551 | return 0 |
|---|
| 552 | } |
|---|
| 553 | |
|---|
| 554 | # If no children and status is 1, comparison is OK, return is possible |
|---|
| 555 | if {[llength $children1] == 0} { |
|---|
| 556 | return 1 |
|---|
| 557 | } |
|---|
| 558 | |
|---|
| 559 | # From now, nodes are the same and there are children (which are the same) |
|---|
| 560 | set childrenStatus "" |
|---|
| 561 | foreach child $children1 { |
|---|
| 562 | lappend childrenStatus [dTree_compareBranch $tree1 $tree2 "$node $child" $relevantNodes listNodes] |
|---|
| 563 | } |
|---|
| 564 | |
|---|
| 565 | |
|---|
| 566 | return [expr min([join $childrenStatus ,])] |
|---|
| 567 | } |
|---|
| 568 | |
|---|
| 569 | #proc saveTree_old {file tree} { |
|---|
| 570 | # set fileId [open $file w] |
|---|
| 571 | # puts $fileId $tree |
|---|
| 572 | # close $fileId |
|---|
| 573 | #} |
|---|
| 574 | |
|---|
| 575 | proc saveXMLnode {fileId tree currentSaveNode indentation} { |
|---|
| 576 | set indentation "$indentation " |
|---|
| 577 | |
|---|
| 578 | # Calculates list of children to know if there are some |
|---|
| 579 | set childrenList [dTree_getChildren $tree $currentSaveNode] |
|---|
| 580 | |
|---|
| 581 | puts -nonewline $fileId "$indentation<[lindex $currentSaveNode end]" |
|---|
| 582 | |
|---|
| 583 | #foreach attribute write it |
|---|
| 584 | foreach attribute [dTree_getAttributes $tree $currentSaveNode] { |
|---|
| 585 | puts -nonewline $fileId " [lindex $attribute 0]=\"[lindex $attribute 1]\"" |
|---|
| 586 | } |
|---|
| 587 | |
|---|
| 588 | # makes a simple element if no children |
|---|
| 589 | if {[llength $childrenList] == 0} { |
|---|
| 590 | puts -nonewline $fileId " /" |
|---|
| 591 | } |
|---|
| 592 | puts $fileId ">" |
|---|
| 593 | |
|---|
| 594 | #write the XMLContent |
|---|
| 595 | |
|---|
| 596 | #foreach child, add indentation, write child |
|---|
| 597 | foreach child $childrenList { |
|---|
| 598 | set childNode "$currentSaveNode $child" |
|---|
| 599 | saveXMLnode $fileId $tree $childNode $indentation |
|---|
| 600 | } |
|---|
| 601 | |
|---|
| 602 | #close tag |
|---|
| 603 | if {[llength $childrenList] > 0} { |
|---|
| 604 | puts $fileId "$indentation</[lindex $currentSaveNode end]>" |
|---|
| 605 | } |
|---|
| 606 | |
|---|
| 607 | } |
|---|
| 608 | |
|---|
| 609 | |
|---|
| 610 | |
|---|
| 611 | #proc loadTree_old {file itree} { |
|---|
| 612 | # upvar $itree tree |
|---|
| 613 | # set fileId [open $file r] |
|---|
| 614 | # set result [read $fileId] |
|---|
| 615 | # close $fileId |
|---|
| 616 | # set tree $result |
|---|
| 617 | # #dict for {node subdict} $tree { |
|---|
| 618 | # # dict for {attr value} $subdict { |
|---|
| 619 | # # debug "\ngenerate <<treeChange-[join $node {.}].$attr>>" |
|---|
| 620 | # # event generate . <<treeChange-[join $node {.}].$attr>> |
|---|
| 621 | # # } |
|---|
| 622 | # #} |
|---|
| 623 | # event generate . <<InitializeGUI>> |
|---|
| 624 | #} |
|---|
| 625 | # |
|---|
| 626 | #proc initializeNode {itree node} { |
|---|
| 627 | # upvar $itree tree |
|---|
| 628 | # global widgetInfo |
|---|
| 629 | # foreach child [dTree_getChildren $tree [join [split $node "."] " "]] { |
|---|
| 630 | # set address "[join $node .].$child" |
|---|
| 631 | # |
|---|
| 632 | # # Check if the child is a widget or a container |
|---|
| 633 | # if {[array names widgetInfo -exact "$address-require"] == ""} { |
|---|
| 634 | # #child is a container |
|---|
| 635 | # event generate . <<treeChange-$address>> |
|---|
| 636 | # initializeNode tree $address |
|---|
| 637 | # |
|---|
| 638 | # } else { |
|---|
| 639 | # #child is a widget |
|---|
| 640 | # if {$widgetInfo($address-require) == ""} { |
|---|
| 641 | # #child is an independant widget |
|---|
| 642 | # |
|---|
| 643 | # event generate . <<treeChange-$address>> |
|---|
| 644 | # initializeNode tree $address |
|---|
| 645 | # } else { |
|---|
| 646 | # initializeNode tree $widgetInfo($address-requirelist) |
|---|
| 647 | # initializeNode tree $address |
|---|
| 648 | # } |
|---|
| 649 | # } |
|---|
| 650 | # |
|---|
| 651 | # |
|---|
| 652 | # } |
|---|
| 653 | #} |
|---|
| 654 | # |
|---|
| 655 | #proc loadXMLProject {file} { |
|---|
| 656 | # global DStree |
|---|
| 657 | # global metaTree |
|---|
| 658 | # global loadedProject |
|---|
| 659 | # global widgetInfo |
|---|
| 660 | # global workingDir |
|---|
| 661 | # dTree_init loadTree |
|---|
| 662 | # dTree_init dummyTree |
|---|
| 663 | # |
|---|
| 664 | # |
|---|
| 665 | # |
|---|
| 666 | #} |
|---|
| 667 | # |
|---|
| 668 | #proc loadXMLDataset {file} { |
|---|
| 669 | # |
|---|
| 670 | #} |
|---|
| 671 | |
|---|
| 672 | proc xml2tree {file itree xmlType} { |
|---|
| 673 | |
|---|
| 674 | upvar $itree tree |
|---|
| 675 | parseFile $file tree "" "DStree" |
|---|
| 676 | } |
|---|
| 677 | |
|---|
| 678 | proc csv2tree {file itree} { |
|---|
| 679 | upvar $itree tree |
|---|
| 680 | |
|---|
| 681 | # open file |
|---|
| 682 | set data [read [open $file]] |
|---|
| 683 | set data [split $data \n] |
|---|
| 684 | |
|---|
| 685 | # Foreach line |
|---|
| 686 | foreach line $data { |
|---|
| 687 | |
|---|
| 688 | set line [split $line ";"] |
|---|
| 689 | if {[string trim [lindex $line 0]] == ""} { continue} |
|---|
| 690 | # Create address |
|---|
| 691 | set addressNode "root [join [split [lindex $line 0] {.}] { }]" |
|---|
| 692 | |
|---|
| 693 | # Read attribute |
|---|
| 694 | set attr [join [lrange $line 1 end] ";"] |
|---|
| 695 | |
|---|
| 696 | # Create node |
|---|
| 697 | if {[catch {dTree_addNode tree [lrange $addressNode 0 end-1] [lindex $addressNode end]} fid]} { |
|---|
| 698 | error "Error reading the CSV file : Make sure all the parents of $addressNode have been set" |
|---|
| 699 | } |
|---|
| 700 | |
|---|
| 701 | # Add attribute |
|---|
| 702 | #if {$attr != ""} { |
|---|
| 703 | dTree_setAttribute tree $addressNode "value" "$attr" |
|---|
| 704 | #} |
|---|
| 705 | } |
|---|
| 706 | } |
|---|
| 707 | |
|---|
| 708 | proc tree2xml {file tree} { |
|---|
| 709 | set fileId [open $file w] |
|---|
| 710 | puts $fileId {<?xml version="1.0" encoding="UTF-8"?>} |
|---|
| 711 | set indentation "" |
|---|
| 712 | # save the tree under the root node |
|---|
| 713 | set childrenList [dTree_getChildren $tree "root"] |
|---|
| 714 | foreach child $childrenList { |
|---|
| 715 | set childNode "root $child" |
|---|
| 716 | saveXMLnode $fileId $tree $childNode $indentation |
|---|
| 717 | } |
|---|
| 718 | close $fileId |
|---|
| 719 | } |
|---|
| 720 | |
|---|
| 721 | proc tree2csv {args} { |
|---|
| 722 | if {[llength $args] == 3} { |
|---|
| 723 | set file [lindex $args 0] |
|---|
| 724 | set tree [lindex $args 1] |
|---|
| 725 | set node [lindex $args 2] |
|---|
| 726 | } elseif {[llength $args] == 2} { |
|---|
| 727 | set file [lindex $args 0] |
|---|
| 728 | set tree [lindex $args 1] |
|---|
| 729 | set node "" |
|---|
| 730 | } else { |
|---|
| 731 | error "Error with arguments ([llength $args]) : $args" |
|---|
| 732 | } |
|---|
| 733 | |
|---|
| 734 | if {$node == ""} { |
|---|
| 735 | # Begin the process |
|---|
| 736 | set node root |
|---|
| 737 | set fileId [open $file w] |
|---|
| 738 | |
|---|
| 739 | set childrenList [dTree_getChildren $tree "root"] |
|---|
| 740 | foreach child $childrenList { |
|---|
| 741 | set childNode "root $child" |
|---|
| 742 | tree2csv $fileId $tree $childNode |
|---|
| 743 | } |
|---|
| 744 | |
|---|
| 745 | close $fileId |
|---|
| 746 | } else { |
|---|
| 747 | ###### recursive process |
|---|
| 748 | |
|---|
| 749 | # Write node |
|---|
| 750 | puts -nonewline $file "[join [lrange $node 1 end] {.}]" |
|---|
| 751 | |
|---|
| 752 | # Write attributes |
|---|
| 753 | foreach attribute [dTree_getAttributes $tree $node] { |
|---|
| 754 | puts -nonewline $file ";[lindex $attribute 1]" |
|---|
| 755 | } |
|---|
| 756 | puts $file "" |
|---|
| 757 | |
|---|
| 758 | # Write every child |
|---|
| 759 | set childrenList [dTree_getChildren $tree "$node"] |
|---|
| 760 | foreach child $childrenList { |
|---|
| 761 | set childNode "$node $child" |
|---|
| 762 | tree2csv $file $tree $childNode |
|---|
| 763 | } |
|---|
| 764 | } |
|---|
| 765 | } |
|---|
| 766 | |
|---|
| 767 | |
|---|
| 768 | # Copyright CERFACS 2014 |
|---|
| 769 | # |
|---|
| 770 | # antoine.dauptain@cerfacs.fr |
|---|
| 771 | # |
|---|
| 772 | # This software is a computer program whose purpose is to ensure technology |
|---|
| 773 | # transfer between academia and industry. |
|---|
| 774 | # |
|---|
| 775 | # This software is governed by the CeCILL-B license under French law and |
|---|
| 776 | # abiding by the rules of distribution of free software. You can use, |
|---|
| 777 | # modify and/ or redistribute the software under the terms of the CeCILL-B |
|---|
| 778 | # license as circulated by CEA, CNRS and INRIA at the following URL |
|---|
| 779 | # "http://www.cecill.info". |
|---|
| 780 | # |
|---|
| 781 | # As a counterpart to the access to the source code and rights to copy, |
|---|
| 782 | # modify and redistribute granted by the license, users are provided only |
|---|
| 783 | # with a limited warranty and the software's author, the holder of the |
|---|
| 784 | # economic rights, and the successive licensors have only limited |
|---|
| 785 | # liability. |
|---|
| 786 | # |
|---|
| 787 | # In this respect, the user's attention is drawn to the risks associated |
|---|
| 788 | # with loading, using, modifying and/or developing or reproducing the |
|---|
| 789 | # software by the user in light of its specific status of free software, |
|---|
| 790 | # that may mean that it is complicated to manipulate, and that also |
|---|
| 791 | # therefore means that it is reserved for developers and experienced |
|---|
| 792 | # professionals having in-depth computer knowledge. Users are therefore |
|---|
| 793 | # encouraged to load and test the software's suitability as regards their |
|---|
| 794 | # requirements in conditions enabling the security of their systems and/or |
|---|
| 795 | # data to be ensured and, more generally, to use and operate it in the |
|---|
| 796 | # same conditions as regards security. |
|---|
| 797 | # |
|---|
| 798 | # The fact that you are presently reading this means that you have had |
|---|
| 799 | # knowledge of the CeCILL-B license and that you accept its terms. |
|---|
