Main Page | Namespace List | Class Hierarchy | Alphabetical List | Class List | File List | Namespace Members | Class Members | File Members | Related Pages

allhierarchies.tcl

00001 # Copyright (C) 1997-2004 The CDG Team <cdg@nats.informatik.uni-hamburg.de> 00002 # 00003 # This file is free software; as a special exception the author gives 00004 # unlimited permission to copy and/or distribute it, with or without 00005 # modifications, as long as this notice is preserved. 00006 # 00007 # This program is distributed in the hope that it will be useful, but 00008 # WITHOUT ANY WARRANTY, to the extent permitted by law; without even the 00009 # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00010 00011 ## ---------------------------------------------------------------------------- 00012 ## AllHierarchies - manage all hierarchies. 00013 ## 00014 ## \todo Variable and function naming is a complete mess here. Til now I 00015 ## just fixed the declarations to match the implementations. Furtheron all 00016 ## underscore/capitalized namings should be unified. No interface variable 00017 ## should only be named \c id. When it is a hierarchy's id call it for example 00018 ## \c hierId. 00019 ## \todo the TclArray called \c hier is cononfusing me with the TclArray \c hierarchy. 00020 ## I know they contain different stuff but again: the naming is extraordinary bad. 00021 ## \todo the TclArray \c hier is overloaded: its information should be split into 00022 ## several arrays named by the third argument of the hier array. 00023 ## \todo the methods C_to_Tcllist() and ldelete() are not related to AllHierarchies. 00024 ## \todo private varialbes should be named starting with and underscore 00025 ## 00026 ## \author Dietmar Fünning, Kilian A. Foth (see also AUTHORS and THANKS for more) 00027 ## $Id: allhierarchies.tcl,v 1.34 2004/10/11 13:50:05 micha Exp $ 00028 ## ---------------------------------------------------------------------------- 00029 class AllHierarchies { 00030 inherit ::itk::Widget 00031 00032 00033 # public methods 00034 public method init_data {} 00035 public method getAllHierarchyIds {}; 00036 00037 constructor {args} {}; ## \type TclList 00038 00039 # private methods 00040 private method C_to_Tcllist {list}; ## \type List 00041 private method _init_data {} 00042 private method balanceNode {id type_id}; ## \type TclString, TclString 00043 private method center {id level}; ## \type TclString, TclNumber 00044 private method compute_fathers_and_sons {hierarchy type_id}; ## \type Hierarchy, TclString 00045 private method compute_graph {id}; ## \type TclString 00046 private method compute_hierarchy {hierarchy}; ## \type Hierarchy 00047 private method compute_positions {id}; ## \type TclString 00048 private method display_graph {id level nodes_current_lvl x_start y_start counter}; ## \type TclString, TclNumber, TclList, TclNumber, TclNumber, TclNumber 00049 private method drawHierarchy {id}; ## \type TclString 00050 private method drawSort {id type_id}; ## \type TclString, TclString 00051 private method labelEnter {w pointerx pointery}; ## \type TclCommand, TclNumber, TclNumber 00052 private method labelLeave {w}; ## \type TclCommand 00053 private method importNode {id type_id}; ## \type TclString, TclString 00054 private method initial_x_pos {id level}; ## \type TclString, TclNumber 00055 private method initialize_depth {id type_id}; ## \type TclString, TclString 00056 private method is_hierarchy_a_tree {hierarchy type_id}; ## \type Hierarchy, TclString 00057 private method ldelete {list type_id} ; ## \type TclList, TclString 00058 private method leaves_right {id String}; ## \type TclString, TclString 00059 private method max_type_depth {id type_id depth}; ## \type TclString, TclString, TclNumber 00060 private method new_order {id String}; ## \type TclString, TclString 00061 private method number_of_fathers_and_sons {hierarchy type_id}; ## \type Hierarchy, TclString 00062 private method position_leaves {id level}; ## \type TclString, TclNumber 00063 private method position_leaves2 {id type_id}; ## \type TclString, TclString 00064 private method position_of_type {hierarchy type_id}; ## \type Hierarchy, TclString 00065 private method set_level_array {id type_id}; ## \type TclString, TclString 00066 private method stringlength {id type_id}; ## \type TclString, TclString 00067 private method xpixels_per_character {id}; ## \type TclString 00068 00069 # private variables 00070 private variable hierarchies; ## \type TclArray 00071 private variable maxlength 0 00072 private variable maxdepth 0 00073 private variable widths; ## \type TclArray 00074 private variable levels; ## \type TclArray 00075 private variable hier; ## \type TclArray 00076 private variable unit 10 00077 00078 private variable canvas ""; ## \type TclCommand 00079 private variable recurse_necessary 0 00080 private variable current_y 1 00081 private variable current_x 1 00082 private variable max_y 1 00083 }; 00084 00085 ## ---------------------------------------------------------------------------- 00086 ## constructor 00087 ## ---------------------------------------------------------------------------- 00088 body AllHierarchies::constructor {args} { 00089 00090 itk_component add frame { 00091 frame $itk_interior.frame \ 00092 -borderwidth 2 \ 00093 -relief flat 00094 } { keep -cursor } 00095 00096 # tabnotebook of canvases 00097 itk_component add tabno { 00098 iwidgets::tabnotebook $itk_component(frame).tabno \ 00099 -borderwidth 0 00100 } { 00101 keep -background -cursor 00102 keep -angle -bevelamount -equaltabs -raiseselect -tabbackground 00103 keep -backdrop -tabpos 00104 } 00105 00106 # packing 00107 pack $itk_component(frame) -fill both -expand 1 00108 pack $itk_component(tabno) -fill both -expand 1 -side top 00109 00110 # get the initial data 00111 _init_data 00112 00113 eval itk_initialize $args 00114 } 00115 00116 ## ---------------------------------------------------------------------------- 00117 ## call _init_data if necessary. 00118 ## ---------------------------------------------------------------------------- 00119 body AllHierarchies::init_data {} { 00120 00121 if {[InputStruct_xcdghierarchiesToDate_get [inputCurrentGrammar_get]]} { 00122 return 00123 } 00124 00125 .cdgmain busy compute "Init Hierarchies" [code $this _init_data] 00126 00127 } 00128 00129 ## ---------------------------------------------------------------------------- 00130 ## get data from the cdg tool. 00131 ## ---------------------------------------------------------------------------- 00132 body AllHierarchies::_init_data {} { 00133 00134 00135 set tabno $itk_component(tabno) 00136 00137 # empty notebook 00138 catch {$tabno delete 0 end} 00139 foreach id [array names hierarchies] { 00140 unset hierarchies($id) 00141 } 00142 00143 # import data to Tcl 00144 set hash [InputStruct_hierarchies_get [inputCurrentGrammar_get]] 00145 set m [hashListOfKeys $hash] 00146 for {set l $m} { $l != "NULL" } { set l [listNext $l ] } { 00147 set id [listElement $l] 00148 set h [hashGet $hash $id] 00149 set id [HierarchyStruct_id_get $h] 00150 set hierarchies($id) $h 00151 compute_hierarchy $h 00152 } 00153 listDelete $m 00154 00155 # allocate one page per hierarchy 00156 foreach id [array names hierarchies] { 00157 set h $hierarchies($id) 00158 set page [$tabno add -label $id] 00159 itk_component add $id { 00160 iwidgets::scrolledcanvas $page.cs 00161 } {} 00162 pack $itk_component($id) -fill both -side top -expand 1 00163 drawHierarchy $id 00164 00165 # fast scanning 00166 set canvas [$itk_component($id) component canvas] 00167 bind $canvas <ButtonPress-2> [code $canvas scan mark %x %y] 00168 bind $canvas <B2-Motion> [code $canvas scan dragto %x %y] 00169 } 00170 00171 # select first page 00172 if {[array names hierarchies] == "" } { 00173 # add an empty tab 00174 set page [$tabno add -label ""] 00175 set dummy [iwidgets::scrolledcanvas $page.cs] 00176 pack $dummy -fill both -side top -expand 1 00177 } 00178 $tabno select 0 00179 InputStruct_xcdghierarchiesToDate_set [inputCurrentGrammar_get] 1 00180 } 00181 00182 ## ---------------------------------------------------------------------------- 00183 ## gather all relevant data for displaying a hierarchy. 00184 ## ---------------------------------------------------------------------------- 00185 body AllHierarchies::compute_hierarchy {hierarchy} { 00186 00187 compute_fathers_and_sons $hierarchy top 00188 number_of_fathers_and_sons $hierarchy top 00189 set id [HierarchyStruct_id_get $hierarchy] 00190 set hier($id,is_a_tree) 1 00191 is_hierarchy_a_tree $hierarchy top 00192 initialize_depth $id top 00193 max_type_depth $id top 0 00194 stringlength $id top 00195 } 00196 00197 ## ---------------------------------------------------------------------------- 00198 ## stores types stringlength. 00199 ## ---------------------------------------------------------------------------- 00200 body AllHierarchies::stringlength {id type_id} { 00201 00202 if { $type_id == "" } { 00203 set hier($id,$type_id,stringlength) 0.2 00204 } else { 00205 set hier($id,$type_id,stringlength) [string length $type_id] 00206 } 00207 00208 # recurse: 00209 foreach value $hier($id,$type_id,sons) { 00210 stringlength $id $value 00211 } 00212 } 00213 00214 ## ---------------------------------------------------------------------------- 00215 ## initialize the depth information. 00216 ## This method recurses over all types in a hierarchy and sets their 00217 ## depth information to zero. 00218 ## ---------------------------------------------------------------------------- 00219 body AllHierarchies::initialize_depth {id type_id} { 00220 00221 set hier($id,$type_id,max_type_depth) 0 00222 00223 # recurse 00224 foreach value $hier($id,$type_id,sons) { 00225 initialize_depth $id $value 00226 } 00227 } 00228 00229 ## ---------------------------------------------------------------------------- 00230 ## compute maximal distance between type and 'top'. 00231 ## This function finds a type's depth in trees, and the length 00232 ## of the longest path from top to the type for non-trees: 00233 ## ---------------------------------------------------------------------------- 00234 body AllHierarchies::max_type_depth {id type_id depth} { 00235 00236 if {$depth > $hier($id,$type_id,max_type_depth)} { 00237 set hier($id,$type_id,max_type_depth) $depth 00238 } 00239 incr depth 00240 00241 # recurse 00242 foreach value $hier($id,$type_id,sons) { 00243 max_type_depth $id $value $depth 00244 } 00245 } 00246 00247 ## ---------------------------------------------------------------------------- 00248 ## compute tree property. 00249 ## This method computes whether a hierarchy is a tree. 00250 ## This function is traversing recursivly the complete 00251 ## hierarchy in the following way: 00252 ## - if the number of fathers is greater than one then the hierarchy 00253 ## is not a tree. 00254 ## \param hierarchy a pointer to a HierarchyStruct 00255 ## \param type_id an entry in the hierarchy 00256 ## ---------------------------------------------------------------------------- 00257 body AllHierarchies::is_hierarchy_a_tree {hierarchy type_id} { 00258 00259 set id [HierarchyStruct_id_get $hierarchy] 00260 if {$hier($id,$type_id,number_fathers) > 1} { 00261 set hier($id,is_a_tree) 0 00262 return 0 00263 } 00264 00265 # recurse 00266 foreach value $hier($id,$type_id,sons) { 00267 is_hierarchy_a_tree $hierarchy $value 00268 } 00269 } 00270 00271 ## ---------------------------------------------------------------------------- 00272 ## stores the number of successors and predecessors each type has 00273 ## ---------------------------------------------------------------------------- 00274 body AllHierarchies::number_of_fathers_and_sons {hierarchy type_id} { 00275 00276 set id [HierarchyStruct_id_get $hierarchy] 00277 set hier($id,$type_id,number_sons) [llength $hier($id,$type_id,sons)] 00278 set hier($id,$type_id,number_fathers) [llength $hier($id,$type_id,fathers)] 00279 00280 # recurse 00281 foreach value $hier($id,$type_id,sons) { 00282 number_of_fathers_and_sons $hierarchy $value 00283 } 00284 } 00285 00286 ## ---------------------------------------------------------------------------- 00287 ## Converts a C-list of types into a Tcl-list of type-ids and filters out 'bot'. 00288 ## Only this function and position_of_type work with C-data structures. 00289 ## ---------------------------------------------------------------------------- 00290 body AllHierarchies::C_to_Tcllist {list} { 00291 00292 set result "" 00293 while {$list != "NULL"} { 00294 set item [pointer2string [listElement $list]] 00295 if {[string compare $item bot] != 0} { 00296 lappend result $item 00297 } 00298 set list [listNext $list] 00299 } 00300 return $result 00301 } 00302 00303 ## ---------------------------------------------------------------------------- 00304 ## This is the interface to functions.i 00305 ## \todo the documentation does not match the intension of this function 00306 ## ---------------------------------------------------------------------------- 00307 body AllHierarchies::position_of_type {hierarchy type_id} { 00308 00309 set list_of_types [hashListOfKeys [HierarchyStruct_types_get $hierarchy]] 00310 set type_coord 0 00311 while {$list_of_types != "NULL"} { 00312 set type_string [pointer2string [listElement $list_of_types]] 00313 if {[string compare $type_string $type_id] == 0} { 00314 break 00315 } 00316 incr type_coord 00317 set list_of_types [listNext $list_of_types] 00318 } 00319 if {$list_of_types == "NULL"} { 00320 puts "function position_of_type: type '$type_id not' found!" 00321 } 00322 return $type_coord 00323 } 00324 00325 ## ---------------------------------------------------------------------------- 00326 ## find a types sons and fathers in the hierarchy. 00327 ## (uses the C-function listOfSons) 00328 ## ---------------------------------------------------------------------------- 00329 body AllHierarchies::compute_fathers_and_sons {hierarchy type_id} { 00330 00331 set id [HierarchyStruct_id_get $hierarchy] 00332 set hier($id,top,fathers) "" 00333 set type_coord [position_of_type $hierarchy $type_id] 00334 set help [listOfSons $hierarchy $type_coord] 00335 set hier($id,$type_id,sons) [C_to_Tcllist $help] 00336 set childlist $hier($id,$type_id,sons) 00337 00338 # recurse 00339 foreach value $childlist { 00340 compute_fathers_and_sons $hierarchy $value 00341 } 00342 foreach value $childlist { 00343 lappend hier($id,$value,fathers) $type_id 00344 } 00345 } 00346 00347 ## ---------------------------------------------------------------------------- 00348 ## draw hierarchy on its associated canvas 00349 ## ---------------------------------------------------------------------------- 00350 body AllHierarchies::drawHierarchy {id} { 00351 00352 # clear indices 00353 foreach x [array names widths] { unset widths($x) } 00354 foreach x [array names levels] { unset levels($x) } 00355 set maxlength 0 00356 set maxdepth 0 00357 00358 # which canvas are we working on? 00359 set canvas $itk_component($id) 00360 00361 # bind to event 00362 $canvas bind "label" <Any-Enter> [code $this labelEnter %W %X %Y] 00363 $canvas bind "label" <Any-Leave> [code $this labelLeave %W] 00364 00365 # cdg's internal structure 00366 set h $hierarchies($id) 00367 00368 # we want to re-arrange the tree for displaying, 00369 # but xcdg shouldn't disturb cdg's data structures. 00370 # So we import the tree wholesale. 00371 importNode $id top 00372 00373 if {$hier($id,is_a_tree)} { 00374 set_level_array $id top 00375 xpixels_per_character $id 00376 leaves_right $id top 00377 new_order $id top 00378 00379 # print id and filename 00380 # set id [HierarchyStruct_id_get $h] 00381 # regexp "\[^/\]*$" [HierarchyStruct_filename_get $h] basename 00382 # $canvas create text 1 1 -anchor w -text "Hierarchy $id ($basename):" 00383 00384 compute_positions $id 00385 drawSort $id top 00386 } else { 00387 set_level_array $id top 00388 xpixels_per_character $id 00389 compute_graph $id 00390 } 00391 } 00392 00393 ## ---------------------------------------------------------------------------- 00394 ## fills global arrays with data from cdg. 00395 ## ---------------------------------------------------------------------------- 00396 body AllHierarchies::importNode {id type_id} { 00397 00398 set l [string length $type_id] 00399 if {$l>$maxlength} {set maxlength $l} 00400 00401 # check maximal tree depth 00402 set depth $hier($id,$type_id,max_type_depth) 00403 if { $depth > $maxdepth } { set maxdepth $depth } 00404 foreach value $hier($id,$type_id,sons) { 00405 importNode $id $value 00406 } 00407 } 00408 00409 ## ---------------------------------------------------------------------------- 00410 ## populate the array levels. 00411 ## ---------------------------------------------------------------------------- 00412 body AllHierarchies::set_level_array {id type_id} { 00413 00414 if {[string compare $type_id top] == 0} { 00415 for {set i 0} {$i <= $maxdepth} {incr i} { 00416 set levels($i) "" 00417 } 00418 } 00419 set level $hier($id,$type_id,max_type_depth) 00420 if {[lsearch $levels($level) $type_id] == -1} { 00421 lappend levels($level) $type_id 00422 } 00423 00424 # recurse 00425 foreach value $hier($id,$type_id,sons) { 00426 set_level_array $id $value 00427 } 00428 } 00429 00430 ## ---------------------------------------------------------------------------- 00431 ## rearrange children of a node so that wide nodes alternate with narrow nodes. 00432 ## ---------------------------------------------------------------------------- 00433 body AllHierarchies::balanceNode {id type_id} { 00434 00435 # populate local arrays 00436 set i 0 00437 set min 99999 00438 set max 0 00439 foreach s $hier($id,$type_id,sons) { 00440 set desc($i) $s 00441 set w $hier($id,$s,number_sons) 00442 set widths($s) $w 00443 if {$w > $max} { set max $w } 00444 if {$w < $min} { set min $w } 00445 incr i 00446 } 00447 00448 # populate global array levels 00449 set depth $hier($id,$type_id,max_type_depth) 00450 00451 lappend levels($depth) $type_id 00452 00453 # avoid unnecessary effort 00454 if { $max > $min } { 00455 00456 # desc() := sort(desc()) 00457 set maxi [expr $i-1] 00458 for { set i 0 } { $i <= $maxi } { incr i } { 00459 for { set j $i } { $j <= $maxi } { incr j } { 00460 set a $desc($i) 00461 set b $desc($j) 00462 if { $widths($a) < $widths($b)} { 00463 set desc($i) $b 00464 set desc($j) $a 00465 } 00466 } 00467 } 00468 00469 # dsce() := shuffle(desc()) 00470 for { set i 0 } { $i <= $maxi } { incr i } { 00471 if { [expr 2 * ($i / 2)] == $i } \ 00472 then { set j [expr $i / 2]} \ 00473 else { set j [expr $maxi - ($i/2)]} 00474 set dsce($i) $desc($j) 00475 } 00476 00477 # register rearranged order of children 00478 set l "" 00479 for { set i 0 } { $i <= $maxi } { incr i } { 00480 append l " $dsce($i)" 00481 } 00482 set hier($id,$type_id,sons) $l 00483 } 00484 00485 # recurse 00486 foreach value $hier($id,$type_id,sons) { 00487 balanceNode $id $value 00488 } 00489 } 00490 00491 ## ---------------------------------------------------------------------------- 00492 ## draw one sort on the canvas. 00493 ## This method is only called when the hierarchy is a tree. 00494 ## \note No check prevents us from calling this method on a non-tree hierarchy. 00495 ## ---------------------------------------------------------------------------- 00496 body AllHierarchies::drawSort {id type_id} { 00497 00498 set levelheight 60 00499 00500 set x $hier($id,$type_id,x_to) 00501 set x [expr 1.2 * $x] 00502 set hier($id,$type_id,x_to) $x 00503 00504 set x $hier($id,$type_id,x_from) 00505 set x [expr 1.2 * $x] 00506 set hier($id,$type_id,x_from) $x 00507 00508 set y [expr $levelheight * $hier($id,$type_id,max_type_depth)] 00509 00510 # draw sort 00511 $canvas create text $x $y -font {Helvetica -12 bold} -text "$type_id" -anchor w 00512 00513 # root? 00514 if {$hier($id,$type_id,max_type_depth) != 0} { 00515 00516 # link to parent 00517 set parent $hier($id,$type_id,fathers) 00518 set x1 $hier($id,$parent,x_from) 00519 set y1 [expr $levelheight * $hier($id,$parent,max_type_depth)] 00520 set x [expr ( $hier($id,$type_id,x_from) + $hier($id,$type_id,x_to) ) / 2] 00521 set x1 [expr ( $hier($id,$parent,x_from) + $hier($id,$parent,x_to) ) / 2] 00522 $canvas create line $x [expr $y - 10] $x1 [expr $y1 + 10] 00523 } 00524 00525 # recurse 00526 foreach value $hier($id,$type_id,sons) { 00527 drawSort $id $value 00528 } 00529 } 00530 00531 ## ---------------------------------------------------------------------------- 00532 ## calls initial_x_pos and center. 00533 ## ---------------------------------------------------------------------------- 00534 body AllHierarchies::compute_positions {id} { 00535 00536 for {set i 0} {$i <= $maxdepth} {incr i} { 00537 initial_x_pos $id $i 00538 } 00539 for {set i 1} {$i <= $maxdepth} {incr i} { 00540 center $id $i 00541 } 00542 00543 # Some nodes are still not positioned correctly. 00544 # start with lvl 1 00545 position_leaves $id 1 00546 00547 # Leaves should be moved between their siblings 00548 # for better results: 00549 position_leaves2 $id top 00550 } 00551 00552 ## ---------------------------------------------------------------------------- 00553 ## sort's initial position. 00554 ## ---------------------------------------------------------------------------- 00555 body AllHierarchies::initial_x_pos {id level} { 00556 00557 set help $levels($level) 00558 set maxlistindex [expr [llength $help] - 1] 00559 set type [lindex $help 0] 00560 set hier($id,$type,x_from) 0 00561 set hier($id,$type,x_to) [expr $unit * ($hier($id,$type,stringlength) + 1)] 00562 set nextpos $hier($id,$type,x_to) 00563 for {set i 1} {$i <= $maxlistindex} {incr i} { 00564 set type [lindex $help $i] 00565 set hier($id,$type,x_from) $nextpos 00566 set hier($id,$type,x_to) \ 00567 [expr $nextpos + $unit * ($hier($id,$type,stringlength) + 1)] 00568 set nextpos $hier($id,$type,x_to) 00569 } 00570 } 00571 00572 ## ---------------------------------------------------------------------------- 00573 ## find sort's final x-coordinate. 00574 ## ---------------------------------------------------------------------------- 00575 body AllHierarchies::center {id level} { 00576 00577 set help $levels($level) 00578 set fathers $levels([expr $level - 1]) 00579 00580 # Which indices have the sons? 00581 set index -1 00582 foreach father $fathers { 00583 if {$hier($id,$father,number_sons) == 0} {continue} 00584 set lastson($father) [expr $index + $hier($id,$father,number_sons)] 00585 set firstson($father) \ 00586 [expr $lastson($father) + 1 - $hier($id,$father,number_sons)] 00587 set index $lastson($father) 00588 } 00589 00590 # Which shift-operation is necessary? Will the predecessor be 00591 # shifted to the right above it`s successors, or the successors 00592 # to the right beneath their predecessor? 00593 foreach father $fathers { 00594 if {$hier($id,$father,number_sons) == 0} {continue} 00595 set fathers_index [lsearch -exact $fathers $father] 00596 set fathers_center \ 00597 [expr ($hier($id,$father,x_from) + $hier($id,$father,x_to)) / 2] 00598 set leftson($father) [lindex $help $firstson($father)] 00599 set rightson($father) [lindex $help $lastson($father)] 00600 if {$leftson($father) == ""} {continue} 00601 if {$rightson($father) == ""} { 00602 set sons_center [expr ($hier($id,$leftson($father),x_from) \ 00603 + $hier($id,$leftson($father),x_to)) / 2] 00604 } else { 00605 set sons_center [expr ($hier($id,$leftson($father),x_from) \ 00606 + $hier($id,$rightson($father),x_to)) / 2] 00607 } 00608 if {$fathers_center < $sons_center} { 00609 00610 # center fathers 00611 set recurse_necessary 1 00612 set new_x_from \ 00613 [expr $sons_center - $unit * $hier($id,$father,stringlength) / 2] 00614 set how_far [expr $new_x_from - $hier($id,$father,x_from)] 00615 foreach father [lrange $fathers $fathers_index end] { 00616 set hier($id,$father,x_from) \ 00617 [expr $hier($id,$father,x_from) + $how_far] 00618 set hier($id,$father,x_to) [expr $hier($id,$father,x_to) + $how_far] 00619 } 00620 } else { 00621 00622 # center sons 00623 set how_far [expr ( $fathers_center - $sons_center ) / $unit ] 00624 set index [lsearch -exact $levels($level) $firstson($father)] 00625 foreach type [lrange $levels($level) $index end] { 00626 set hier($id,$type,x_from) [expr $hier($id,$type,x_from) + $how_far] 00627 set hier($id,$type,x_to) [expr $hier($id,$type,x_to) + $how_far] 00628 } 00629 } 00630 } 00631 set i [expr $level - 1] 00632 if {$recurse_necessary != 0} { 00633 if {$i > 0} { 00634 center $id $i 00635 } 00636 } 00637 set recurse_necessary 0 00638 } 00639 00640 ## ---------------------------------------------------------------------------- 00641 ## move leaves to the rightmost possible position. 00642 ## Leaves are positioned right beside their non-leaf-siblings 00643 ## ---------------------------------------------------------------------------- 00644 body AllHierarchies::leaves_right {id type_id} { 00645 00646 set help $hier($id,$type_id,sons) 00647 foreach son $help { 00648 if {$hier($id,$son,number_sons) == 0} { 00649 set hier($id,$type_id,sons) [ldelete $hier($id,$type_id,sons) $son] 00650 lappend hier($id,$type_id,sons) $son 00651 } 00652 } 00653 00654 # recurse: 00655 foreach son $hier($id,$type_id,sons) { 00656 leaves_right $id $son 00657 } 00658 } 00659 00660 ## ---------------------------------------------------------------------------- 00661 ## store the new order in 'levels(level)' 00662 ## ---------------------------------------------------------------------------- 00663 body AllHierarchies::new_order {id type_id} { 00664 00665 set hier($id,top,max_type_depth) 0 00666 if {[string compare $type_id top] == 0} { 00667 for {set i 0} {$i <= $maxdepth} {incr i} { 00668 set levels($i) "" 00669 } 00670 } 00671 set level $hier($id,$type_id,max_type_depth) 00672 lappend levels($level) $type_id 00673 00674 # recurse 00675 foreach value $hier($id,$type_id,sons) { 00676 new_order $id $value 00677 } 00678 } 00679 00680 ## ---------------------------------------------------------------------------- 00681 ## deletes a string from a list. 00682 ## \todo this method is in no way specific to AllHierarchies 00683 ## ---------------------------------------------------------------------------- 00684 body AllHierarchies::ldelete { list type_id } { 00685 00686 set ix [lsearch -exact $list $type_id] 00687 if {$ix >= 0} { 00688 return [lreplace $list $ix $ix] 00689 } else { 00690 return $list 00691 } 00692 } 00693 00694 ## ---------------------------------------------------------------------------- 00695 ## some nodes are still not correctly positioned. 00696 ## ---------------------------------------------------------------------------- 00697 body AllHierarchies::position_leaves {id level} { 00698 00699 set currentnode [lrange $levels($level) end end] 00700 set father $hier($id,$currentnode,fathers) 00701 set fathers_center \ 00702 [expr ($hier($id,$father,x_from) + $hier($id,$father,x_to)) / 2] 00703 set leftson [lindex $hier($id,$father,sons) 0] 00704 set rightson [lindex $hier($id,$father,sons) end] 00705 set sons_center \ 00706 [expr ($hier($id,$leftson,x_from) + $hier($id,$rightson,x_to)) / 2] 00707 if {$sons_center < $fathers_center} { 00708 set how_far [expr $fathers_center - $sons_center] 00709 foreach son $hier($id,$father,sons) { 00710 set hier($id,$son,x_from) [expr $hier($id,$son,x_from) + $how_far] 00711 set hier($id,$son,x_to) [expr $hier($id,$son,x_to) + $how_far] 00712 } 00713 } 00714 00715 # recurse 00716 incr level 00717 if {$level <= $maxdepth} { 00718 position_leaves $id $level 00719 } 00720 } 00721 00722 ## ---------------------------------------------------------------------------- 00723 ## position leaves between their siblings 00724 ## \todo bad method name 00725 ## ---------------------------------------------------------------------------- 00726 body AllHierarchies::position_leaves2 {id type_id} { 00727 00728 # Find the leaf with greatest stringlength 00729 # Don't use this procedure with an empty list ! 00730 00731 proc leaf_max_stringlength {list_of_leaves} {; ## \type TclList 00732 upvar id id 00733 upvar hier hier 00734 set help [lindex $list_of_leaves 0] 00735 set leaf $help 00736 set stringlength $hier($id,$help,stringlength) 00737 foreach value $list_of_leaves { 00738 set help $hier($id,$value,stringlength) 00739 if {$help > $stringlength} { 00740 set stringlength $help 00741 set leaf $value 00742 } 00743 } 00744 return $leaf 00745 } 00746 00747 # register leaves and non-leaves 00748 set leaves "" 00749 set nonleaves "" 00750 foreach son $hier($id,$type_id,sons) { 00751 if {$hier($id,$son,number_sons) == 0} { 00752 lappend leaves $son 00753 } else { 00754 lappend nonleaves $son 00755 } 00756 } 00757 00758 # if leaves is empty, nothing is to be done except recurse 00759 # if the number of nonleaves is less than two, nothing is 00760 # to be done except recurse 00761 if {[llength $leaves] != 0 && [llength $nonleaves] > 1} { 00762 set help [lindex $leaves 0] 00763 00764 # needed later 00765 set leaves_started_at $hier($id,$help,x_from) 00766 00767 # register the spaces the leaves will be moved to as array new_home 00768 for {set i 0} {$i < [expr [llength $nonleaves] - 1]} {incr i} { 00769 set left [lindex $nonleaves $i] 00770 set right [lindex $nonleaves [expr $i + 1]] 00771 set from [expr $hier($id,$left,x_to) - $unit] 00772 set to $hier($id,$right,x_from) 00773 set remaining_space [expr $to - $from] 00774 set new_home($i,from) $from 00775 set new_home($i,to) $to 00776 set new_home($i,remaining_space) $remaining_space 00777 set new_home($i,nodes) "" 00778 set lastindex $i 00779 } 00780 00781 # enforce the first iteration: 00782 set something_changed 1 00783 while {$something_changed == 1} { 00784 set something_changed 0 00785 00786 # find the largest space 00787 set index_largest_space 0 00788 set space $new_home(0,remaining_space) 00789 for {set i 1} {$i <= $lastindex} {incr i} { 00790 set help $new_home($i,remaining_space) 00791 if {$help > $space} { 00792 set space $help 00793 set index_largest_space $i 00794 } 00795 } 00796 00797 # index_largest_space is the index of the space to work with 00798 set helplist $leaves 00799 while {$helplist != ""} { 00800 set node [leaf_max_stringlength $helplist] 00801 set helplist [ldelete $helplist $node] 00802 set need [expr $hier($id,$node,x_to) - $hier($id,$node,x_from)] 00803 set remaining $new_home($index_largest_space,remaining_space) 00804 if {$need <= $remaining} { 00805 set new_home($index_largest_space,remaining_space) \ 00806 [expr $remaining - $need] 00807 lappend new_home($index_largest_space,nodes) $node 00808 set leaves [ldelete $leaves $node] 00809 set something_changed 1 00810 } 00811 } 00812 } 00813 00814 # find the leaves' new positions 00815 foreach value $leaves { 00816 set howfar [expr $leaves_started_at - $hier($id,$value,x_from)] 00817 set hier($id,$value,x_from) $leaves_started_at 00818 set hier($id,$value,x_to) [expr $hier($id,$value,x_to) + $howfar] 00819 set leaves_started_at $hier($id,$value,x_to) 00820 } 00821 for {set i 0} {$i <= $lastindex} {incr i} { 00822 set number_of_leaves [llength $new_home($i,nodes)] 00823 set available_space [expr $new_home($i,to) - $new_home($i,from)] 00824 foreach value $new_home($i,nodes) { 00825 set available_space \ 00826 [expr $available_space - $hier($id,$value,stringlength) * $unit] 00827 } 00828 set between [expr floor($available_space / ($number_of_leaves + 1))] 00829 set starting_position [expr $new_home($i,from) + $between] 00830 foreach value $new_home($i,nodes) { 00831 set howfar [expr $starting_position - $hier($id,$value,x_from)] 00832 set hier($id,$value,x_from) [expr $hier($id,$value,x_from) + $howfar] 00833 set hier($id,$value,x_to) [expr $hier($id,$value,x_to) + $howfar] 00834 set starting_position [expr $hier($id,$value,x_to) + $between] 00835 } 00836 } 00837 } 00838 00839 # recurse 00840 foreach value $hier($id,$type_id,sons) { 00841 position_leaves2 $id $value 00842 } 00843 } 00844 00845 ## ---------------------------------------------------------------------------- 00846 ## This function is used only for nontree-graphs. 00847 ## ---------------------------------------------------------------------------- 00848 body AllHierarchies::compute_graph {id} { 00849 00850 set yunit 16 00851 set xunit [expr 2 * $unit] 00852 00853 # can range from 0 (one node is allways printed) to 38 00854 set maxnodes 34 00855 00856 for {set level 0} {$level < $maxdepth} {incr level} { 00857 set counter 0 00858 set help $levels($level) 00859 set first_iteration 1 00860 while {$help != ""} { 00861 set fathers "" 00862 set nodes_current_lvl "" 00863 set sons "" 00864 set leaves "" 00865 foreach value $help { 00866 if {$hier($id,$value,number_sons) == 0} { 00867 lappend leaves $value 00868 } else { 00869 lappend fathers $value 00870 } 00871 } 00872 set lonely_father [lindex $fathers 0] 00873 set maxindex [expr [llength $fathers] - 1] 00874 for {set index 0} {$index <= $maxindex} {incr index} { 00875 set father [lindex $fathers $index] 00876 set count 0 00877 foreach son $hier($id,$father,sons) { 00878 if {[lsearch $sons $son] == -1} { 00879 lappend sons $son 00880 incr count 00881 } 00882 } 00883 set helpint \ 00884 [expr 1 + $count + [llength $nodes_current_lvl] + [llength $sons]] 00885 if {$helpint <= $maxnodes} { 00886 lappend nodes_current_lvl $father 00887 set help [ldelete $help $father] 00888 } 00889 } 00890 00891 if {[llength $nodes_current_lvl] == 0} { 00892 00893 # No father was attached to list nodes_current_lvl, because it 00894 # wouldn't fit on the screen with all of it's direct successors. 00895 # Nevertheless, at least one node should be printed: 00896 lappend nodes_current_lvl $lonely_father 00897 set help [ldelete $help $lonely_father] 00898 } 00899 00900 # Fathers that don't introduce new sons can still be attached to list 00901 # nodes_current_lvl. 00902 set max_additional_nodes [llength $sons] 00903 while {$max_additional_nodes > 0 && $index <= $maxindex} { 00904 set father [lindex $fathers $index] 00905 set attach 1 00906 foreach son $hier($id,$father,sons) { 00907 if {[lsearch $sons $son] == -1} { 00908 set attach 0 00909 } 00910 } 00911 if {$attach == 1} { 00912 lappend nodes_current_lvl $father 00913 set help [ldelete $help $father] 00914 set max_additional_nodes [expr $max_additional_nodes - 1] 00915 } 00916 incr index 00917 } 00918 00919 # Put the leaves at the end of the first column: 00920 foreach leaf $leaves { 00921 lappend nodes_current_lvl $leaf 00922 set help [ldelete $help $leaf] 00923 } 00924 if {$first_iteration == 1} { 00925 $canvas create text 1 $current_y -anchor w \ 00926 -text "Level $level and direct successors" 00927 set current_y [expr $current_y + 2 * $yunit] 00928 } 00929 display_graph \ 00930 $id $level $nodes_current_lvl $current_x $current_y $counter 00931 set first_iteration 0 00932 incr counter 00933 } 00934 set current_y [expr $max_y + 2 * $yunit] 00935 set current_x 1 00936 } 00937 } 00938 00939 ## ---------------------------------------------------------------------------- 00940 ## display nontree-graphs. 00941 ## This function is used only for nontree-graphs 00942 ## ---------------------------------------------------------------------------- 00943 body AllHierarchies::display_graph {id level nodes_current_lvl x_start y_start counter} { 00944 00945 upvar yunit yunit 00946 upvar xunit xunit 00947 set fathers "" 00948 set leaves "" 00949 set sons "" 00950 00951 # Ugly patch. Should somehow be removed later: 00952 foreach value $nodes_current_lvl { 00953 if {$hier($id,$value,number_sons) == 0} { 00954 lappend leaves $value 00955 } else { 00956 lappend fathers $value 00957 } 00958 } 00959 00960 # assemble list of sons: 00961 foreach father $fathers { 00962 foreach son $hier($id,$father,sons) { 00963 if {[lsearch -exact $sons $son] == -1} { 00964 lappend sons $son 00965 } 00966 } 00967 } 00968 00969 # vertical lines: 00970 set draw_to_y \ 00971 [expr $current_y + ([llength $fathers] + [llength $sons] - 1) * $yunit] 00972 00973 # Needed later: 00974 set keep_y $y_start 00975 00976 set max_x 0 00977 00978 # Needed for the horizontal lines: 00979 set index 0 00980 00981 # sons' starting-position: 00982 set sons_start 0 00983 00984 # Write this levels' nodes (except for the leaves) to the canvas: 00985 foreach node $fathers { 00986 00987 # $level and $counter are appended to the labels to make the 00988 # different graphs on the canvas independent of each other 00989 set fatherstag father_ 00990 append fatherstag $node $level $counter 00991 00992 # build list of sons 00993 set list_o_sons "" 00994 foreach son $hier($id,$node,sons) { 00995 set sonstag son_ 00996 append sonstag $son $level $counter 00997 if {[lsearch -exact $list_o_sons $sonstag] == -1} { 00998 lappend list_o_sons $sonstag 00999 } 01000 } 01001 01002 set father_taglist [linsert $list_o_sons 0 $fatherstag] 01003 01004 $canvas create text $current_x $current_y -anchor w \ 01005 -text "$node" -tags [linsert $father_taglist 1 "label"] 01006 set help [expr $current_x + $hier($id,$node,stringlength) * $unit] 01007 01008 01009 if {$help > $max_x} { 01010 set max_x $help 01011 } 01012 01013 # create this nodes horizontal and vertical lines (if it is no leaf): 01014 if {$hier($id,$node,number_sons) != 0} { 01015 set draw_from_x [expr ($hier($id,$node,stringlength) + 2) \ 01016 * $unit + $x_start - 5] 01017 set draw_to_x \ 01018 [expr $maxlength * $unit + $x_start + ($index + 1) * $xunit] 01019 01020 # The first fathers draw_to_x is needed for the sons' horizontal lines 01021 if {[lsearch $fathers $node] == 0} { 01022 set sons_draw_from_x $draw_to_x 01023 } 01024 01025 # horizontal line: 01026 $canvas create line $draw_from_x $current_y $draw_to_x $current_y \ 01027 -tags $father_taglist 01028 01029 # starting-position for the sons: 01030 if {$draw_to_x > $sons_start} { 01031 set sons_start $draw_to_x 01032 } 01033 01034 # vertical line: 01035 $canvas create line $draw_to_x $current_y $draw_to_x $draw_to_y \ 01036 -tags $father_taglist 01037 01038 # store information for the drawing and tagging of the dots: 01039 set x($node) $draw_to_x 01040 set dot($node,x) $draw_to_x 01041 } 01042 set current_y [expr $current_y + $yunit] 01043 incr index 01044 } 01045 set sons_x [expr $sons_start + 20] 01046 set sons_y_start_at $current_y 01047 01048 # write the leaves to the canvas: 01049 foreach node $leaves { 01050 $canvas create text $x_start $current_y -anchor w -text "$node" 01051 set help [expr $x_start + $hier($id,$node,stringlength) * $unit] 01052 if {$help > $max_x} { 01053 set max_x $help 01054 } 01055 set current_y [expr $current_y + $yunit] 01056 if {$current_y > $max_y} { 01057 set max_y $current_y 01058 } 01059 } 01060 set current_y $sons_y_start_at 01061 for {set i $level} {$i <= $maxdepth} {incr i} { 01062 set offset [expr ($i - $level) * 20] 01063 01064 # write the sons to the canvas 01065 foreach node $sons { 01066 set sonstag son_ 01067 append sonstag $node $level $counter 01068 01069 if {$hier($id,$node,max_type_depth) == $i} { 01070 01071 # build list of fathers 01072 set list_o_fathers "" 01073 foreach father $hier($id,$node,fathers) { 01074 set fatherstag father_ 01075 append fatherstag $father $level $counter 01076 if {$hier($id,$father,max_type_depth) == $level} { 01077 if {[lsearch -exact $list_o_fathers $fatherstag] == -1} { 01078 lappend list_o_fathers $fatherstag 01079 } 01080 } 01081 } 01082 01083 set sons_taglist [linsert $list_o_fathers 0 $sonstag] 01084 01085 $canvas create text \ 01086 [expr $sons_x + $offset] $current_y -anchor w -text "$node" \ 01087 -tags [linsert $sons_taglist 1 "label"] 01088 01089 $canvas create line $sons_draw_from_x $current_y \ 01090 [expr $sons_x + $offset - 10] $current_y \ 01091 -tags $sons_taglist 01092 01093 # store information for the drawing of the dots: 01094 set dot($node,y) $current_y 01095 set help \ 01096 [expr $sons_x + $offset + $hier($id,$node,stringlength) * $unit] 01097 if {$help > $max_x} { 01098 set max_x $help 01099 } 01100 set current_y [expr $current_y + $yunit] 01101 set sons [ldelete $sons $node] 01102 if {$current_y > $max_y} { 01103 set max_y $current_y 01104 } 01105 } 01106 } 01107 } 01108 01109 # print and label the dots: 01110 foreach father $fathers { 01111 foreach son $hier($id,$father,sons) { 01112 set fatherstag father_ 01113 append fatherstag $father $level $counter 01114 set sonstag son_ 01115 append sonstag $son $level $counter 01116 set dotx $dot($father,x) 01117 set doty $dot($son,y) 01118 $canvas create oval [expr $dotx - 2] [expr $doty - 2] \ 01119 [expr $dotx + 2] [expr $doty + 2] \ 01120 -fill black -width 0 -tags [list $fatherstag $sonstag] 01121 } 01122 } 01123 set current_x [expr $max_x + 50] 01124 set current_y $keep_y 01125 } 01126 01127 ## ---------------------------------------------------------------------------- 01128 ## How many pixels are to be used for a character ? 01129 ## ---------------------------------------------------------------------------- 01130 body AllHierarchies::xpixels_per_character {id} { 01131 01132 set teststring [lindex $levels(1) 0] 01133 set length $hier($id,$teststring,stringlength) 01134 $canvas create text 2 2 -anchor w -text "$teststring" -tag remove 01135 set help [$canvas bbox remove] 01136 scan $help "%f %f %f %f" x1 y1 x2 y2 01137 $canvas delete remove 01138 set help [expr ($x2 - $x1) / $length] 01139 set unit [expr ceil($help)] 01140 } 01141 01142 ## ---------------------------------------------------------------------------- 01143 ## command bound to Enter-event. 01144 ## ---------------------------------------------------------------------------- 01145 body AllHierarchies::labelEnter {w pointerx pointery} { 01146 01147 set tags [$w gettags current] 01148 set relevant_label [lindex $tags 0] 01149 $w itemconfigure $relevant_label -fill red 01150 } 01151 01152 ## ---------------------------------------------------------------------------- 01153 ## command bound to Leave-event. 01154 ## ---------------------------------------------------------------------------- 01155 body AllHierarchies::labelLeave {w} { 01156 01157 set tags [$w gettags current] 01158 set relevant_label [lindex $tags 0] 01159 $w itemconfigure $relevant_label -fill black 01160 } 01161 01162 ## ---------------------------------------------------------------------------- 01163 ## Return list of all hierarchies' names 01164 ## ---------------------------------------------------------------------------- 01165 body AllHierarchies::getAllHierarchyIds {} { 01166 init_data 01167 return [array names hierarchies] 01168 }

XCDG 0.95 (20 Oct 2004)