File Coverage

lib/Graph/Easy/Layout.pm
Criterion Covered Total %
statement 323 379 85.2
branch 147 228 64.4
condition 56 87 64.3
subroutine 18 21 85.7
pod 1 1 100.0
total 545 716 76.1


line stmt bran cond sub pod time code
1             #############################################################################
2             # Layout directed graphs on a flat plane. Part of Graph::Easy.
3             #
4             # (c) by Tels 2004-2008.
5             #############################################################################
6              
7             package Graph::Easy::Layout;
8              
9             $VERSION = '0.75';
10              
11             #############################################################################
12             #############################################################################
13              
14             package Graph::Easy;
15              
16 49     49   101818 use strict;
  49         102  
  49         2158  
17 49     49   261 use warnings;
  49         109  
  49         2571  
18             require Graph::Easy::Node::Cell;
19 49         7961 use Graph::Easy::Edge::Cell qw/
20             EDGE_HOR EDGE_VER
21             EDGE_CROSS
22             EDGE_TYPE_MASK EDGE_MISC_MASK EDGE_NO_M_MASK
23             EDGE_SHORT_CELL
24 49     49   29294 /;
  49         243  
25              
26             use constant {
27 49         4860 ACTION_NODE => 0, # place node somewhere
28             ACTION_TRACE => 1, # trace path from src to dest
29             ACTION_CHAIN => 2, # place node in chain (with parent)
30             ACTION_EDGES => 3, # trace all edges (shortes connect. first)
31             ACTION_SPLICE => 4, # splice in the group fillers
32 49     49   340 };
  49         97  
33              
34             require Graph::Easy::Layout::Chain; # chain management
35 49     49   29089 use Graph::Easy::Layout::Scout; # pathfinding
  49         176  
  49         2102  
36 49     49   100292 use Graph::Easy::Layout::Repair; # group cells and splicing/repair
  49         173  
  49         3183  
37 49     49   303848 use Graph::Easy::Layout::Path; # path management
  49         183  
  49         8737  
38              
39 49     49   725 use Graph::Easy::Util qw(ord_values);
  49         108  
  49         38621  
40              
41             #############################################################################
42              
43             sub _assign_ranks
44             {
45             # Assign a rank to each node/group.
46              
47             # Afterwards, every node has a rank, these range from 1..infinite for
48             # user supplied ranks, and -1..-infinite for automatically found ranks.
49             # This lets us later distinguish between autoranks and userranks, while
50             # still being able to sort nodes based on their (absolute) rank.
51 502     502   1389 my $self = shift;
52              
53             # a Heap to keep the todo-nodes (aka rank auto or explicit)
54 502         6884 my $todo = Graph::Easy::Heap->new();
55             # sort entries based on absolute value
56 502     0   5372 $todo->sort_sub( sub ($$) { abs($_[0]) <=> abs($_[1]) } );
  0         0  
57              
58             # a list of all other nodes
59 502         954 my @also;
60              
61             # XXX TODO:
62             # gather elements todo:
63             # graph: contained groups, plus non-grouped nodes
64             # groups: contained groups, contained nodes
65              
66             # sort nodes on their ID to get some basic order
67 502         3042 my @N = $self->sorted_nodes('id');
68 502         5254 push @N, $self->groups();
69              
70 502         3300 my $root = $self->root_node();
71              
72 502 50       2006 $todo->add([$root->{rank} = -1,$root]) if ref $root;
73              
74             # Gather all nodes that have outgoing connections, but no incoming:
75 502         1901 for my $n (@N)
76             {
77             # we already handled the root node above
78 2112 50 33     5825 next if $root && $n == $root;
79              
80             # if no rank set, use 0 as default
81 2112         25047 my $rank_att = $n->raw_attribute('rank');
82              
83 2112 50 66     6607 $rank_att = undef if defined $rank_att && $rank_att eq 'auto';
84             # XXX TODO: this should not happen, the parser should assign an
85             # automatic rank ID
86 2112 50 66     5662 $rank_att = 0 if defined $rank_att && $rank_att eq 'same';
87              
88             # user defined ranks range from 1..inf
89 2112 100       4634 $rank_att++ if defined $rank_att;
90              
91             # assign undef or 0, 1 etc
92 2112         5426 $n->{rank} = $rank_att;
93              
94             # user defined ranks are "1..inf", while auto ranks are -1..-inf
95 2112 100 100     13022 $n->{rank} = -1 if !defined $n->{rank} && $n->predecessors() == 0;
96              
97             # push "rank: X;" nodes, or nodes without predecessors
98 2112 100       12458 $todo->add([$n->{rank},$n]) if defined $n->{rank};
99 2112 100       9730 push @also, $n unless defined $n->{rank};
100             }
101              
102             # print STDERR "# Ranking:\n";
103             # for my $n (@{$todo->{_heap}})
104             # {
105             # print STDERR "# $n->[1]->{name} $n->[0] $n->[1]->{rank}:\n";
106             # }
107             # print STDERR "# Leftovers in \@also:\n";
108             # for my $n (@also)
109             # {
110             # print STDERR "# $n->{name}:\n";
111             # }
112              
113             # The above step will create a list of todo nodes that start a chain, but
114             # it will miss circular chains like CDEC (e.g. only A appears in todo):
115             # A -> B; C -> D -> E -> C;
116             # We fix this as last step
117              
118 502   100     2941 while ((@also != 0) || $todo->elements() != 0)
119             {
120             # while we still have nodes to follow
121 528         2994 while (my $elem = $todo->extract_top())
122             {
123 2112         3948 my ($rank,$n) = @$elem;
124              
125 2112         3665 my $l = $n->{rank};
126              
127             # If the rank comes from a user-supplied rank, make the next node
128             # have an automatic rank (e.g. 4 => -4)
129 2112 100       5990 $l = -$l if $l > 0;
130             # -4 > -5
131 2112         2732 $l--;
132              
133 2112         9577 for my $o ($n->successors())
134             {
135 1466 100       6139 if (!defined $o->{rank})
136             {
137             # print STDERR "# set rank $l for $o->{name}\n";
138 1159         3225 $o->{rank} = $l;
139 1159         4955 $todo->add([$l,$o]);
140             }
141             }
142             }
143              
144 528 100       2340 last unless @also;
145              
146 479         1927 while (@also)
147             {
148 1191         1936 my $n = shift @also;
149             # already done? so skip it
150 1191 100       7512 next if defined $n->{rank};
151              
152 32         98 $n->{rank} = -1;
153 32         215 $todo->add([-1, $n]);
154             # leave the others for later
155 32         160 last;
156             }
157              
158             } # while still something todo
159              
160             # print STDERR "# Final ranking:\n";
161             # for my $n (@N)
162             # {
163             # print STDERR "# $n->{name} $n->{rank}:\n";
164             # }
165              
166 502         4484 $self;
167             }
168              
169             sub _follow_chain
170             {
171             # follow the chain from the node
172 791     791   1278 my ($node) = @_;
173              
174 791         1787 my $self = $node->{graph};
175              
176 49     49   353 no warnings 'recursion';
  49         109  
  49         298307  
177              
178 791   50     5070 my $indent = ' ' x (($node->{_chain}->{id} || 0) + 1);
179 791 50       2101 print STDERR "#$indent Tracking chain from $node->{name}\n" if $self->{debug};
180              
181             # create a new chain and point it to the start node
182 791         5162 my $chain = Graph::Easy::Layout::Chain->new( start => $node, graph => $self );
183 791         14138 $self->{chains}->{ $chain->{id} } = $chain;
184              
185 791         1487 my $first_node = $node;
186 791         1594 my $done = 1; # how many nodes did we process?
187             NODE:
188 791         915 while (3 < 5)
189             {
190             # Count "unique" successsors, ignoring selfloops, multiedges and nodes
191             # in the same chain.
192              
193 1145         2727 my $c = $node->{_chain};
194              
195 1145         2598 local $node->{_c} = 1; # stop back-ward loops
196              
197 1145         1448 my %suc;
198              
199 1145         3966 for my $e (ord_values ( $node->{edges} ))
200             {
201 1752         3403 my $to = $e->{to};
202              
203             # ignore self-loops
204 1752 100       11459 next if $e->{from} == $e->{to};
205              
206             # XXX TODO
207             # skip links from/to groups
208 1721 50 33     24060 next if $e->{to}->isa('Graph::Easy::Group') ||
209             $e->{from}->isa('Graph::Easy::Group');
210              
211             # print STDERR "# bidi $e->{from}->{name} to $e->{to}->{name}\n" if $e->{bidirectional} && $to == $node;
212              
213             # if it is bidirectional, and points the "wrong" way, turn it around
214 1721 100 100     4882 $to = $e->{from} if $e->{bidirectional} && $to == $node;
215              
216             # edge leads to this node instead from it?
217 1721 100       4629 next if $to == $node;
218              
219             # print STDERR "# edge_flow for edge $e", $e->edge_flow() || 'undef' ,"\n";
220             # print STDERR "# flow for edge $e", $e->flow() ,"\n";
221              
222             # If any of the leading out edges has a flow, stop the chain here
223             # This prevents a chain on an edge w/o a flow to be longer and thus
224             # come first instead of a flow-edge. But don't stop if there is only
225             # one edge:
226              
227 886 100       5648 if (defined $e->edge_flow())
228             {
229 11         44 %suc = ( $to->{name} => $to ); # empy any possible chain info
230 11         20 last;
231             }
232              
233 875 100       2626 next if exists $to->{_c}; # backloop into current branch?
234              
235 863 100 100     3353 next if defined $to->{_chain} && # ignore if it points to the same
236             $to->{_chain} == $c; # chain (backloop)
237              
238             # if the next node's grandparent is the same as ours, it depends on us
239 853 100       3132 next if $to->find_grandparent() == $node->find_grandparent();
240              
241             # ignore multi-edges by dropping
242 771         3531 $suc{$to->{name}} = $to; # duplicates
243             }
244              
245 1145 100       5268 last if keys %suc == 0; # the chain stopped here
246              
247 567 100       1406 if (scalar keys %suc == 1) # have only one unique successor?
248             {
249 441         1174 my ($key) = keys(%suc);
250 441         2956 my $s = $suc{ $key };
251              
252 441 100       1520 if (!defined $s->{_chain}) # chain already done?
253             {
254 354         2097 $c->add_node( $s );
255              
256 354         547 $node = $s; # next node
257              
258 354 50       1290 print STDERR "#$indent Skipping ahead to $node->{name}\n" if $self->{debug};
259              
260 354         612 $done++; # one more
261 354         3420 next NODE; # skip recursion
262             }
263             }
264              
265             # Select the longest chain from the list of successors
266             # and join it with the current one:
267              
268 213         346 my $max = -1;
269 213         255 my $next; # successor
270 213         276 my $next_chain = undef;
271              
272 213 50       572 print STDERR "#$indent $node->{name} successors: \n" if $self->{debug};
273              
274 213         296 my @rc;
275              
276             # for all successors
277             #for my $s (sort { $a->{name} cmp $b->{name} || $a->{id} <=> $b->{id} } values %suc)
278 213         751 for my $s (ord_values ( \%suc))
279             {
280 404 50 0     1046 print STDERR "# suc $s->{name} chain ", $s->{_chain} || 'undef',"\n" if $self->{debug};
281              
282 404 100       1584 $done += _follow_chain($s) # track chain
283             if !defined $s->{_chain}; # if not already done
284              
285 404 50       1019 next if $s->{_chain} == $c; # skip backlinks
286              
287 404         618 my $ch = $s->{_chain};
288              
289 404         1108 push @rc, [ $ch, $s ];
290             # point node to new next node
291 404 100       1748 ($next_chain, $max, $next) =
292             ($ch, $ch->{len}, $s) if $ch->{len} > $max;
293             }
294              
295 213 50 33     1241 if (defined $next_chain && $self->{debug})
296             {
297 0         0 print STDERR "# results of tracking successors:\n";
298 0         0 for my $ch (@rc)
299             {
300 0         0 my ($c,$s) = @$ch;
301 0         0 my $len = $c->length($s);
302 0         0 print STDERR "# chain $c->{id} starting at $c->{start}->{name} (len $c->{len}) ".
303             " pointing to node $s->{name} (len from there: $len)\n";
304             }
305 0         0 print STDERR "# Max chain length is $max (chain id $next_chain->{id})\n";
306             }
307              
308 213 50       667 if (defined $next_chain)
309             {
310 213 50       743 print STDERR "#$indent $node->{name} next: " . $next_chain->start()->{name} . "\n" if $self->{debug};
311              
312 213 50       500 if ($self->{debug})
313             {
314 0         0 print STDERR "# merging chains\n";
315 0         0 $c->dump(); $next_chain->dump();
  0         0  
316             }
317              
318 213 100       1252 $c->merge($next_chain, $next) # merge the two chains
319             unless $next == $self->{_root} # except if the next chain starts with
320             # the root node (bug until v0.46)
321             ;# || $next_chain->{start} == $self->{_root}; # or the first chain already starts
322             # with the root node (bug until v0.47)
323              
324 213 100       842 delete $self->{chains}->{$next_chain->{id}} if $next_chain->{len} == 0;
325             }
326              
327 213         1145 last;
328             }
329            
330 791 50       2859 print STDERR "#$indent Chain $node->{_chain} ended at $node->{name}\n" if $self->{debug};
331              
332 791         1936 $done; # return nr of done nodes
333             }
334              
335             sub _find_chains
336             {
337             # Track all node chains (A->B->C etc), trying to find the longest possible
338             # node chain. Returns (one of) the root node(s) of the graph.
339 280     280   804 my $self = shift;
340              
341 280 50       1077 print STDERR "# Tracking chains\n" if $self->{debug};
342              
343             # drop all old chain info
344 280         1444 $self->{_chains} = { };
345 280         1733 $self->{_chain} = 0; # new chain ID
346              
347             # For all not-done-yet nodes, track the chain starting with that node.
348              
349             # compute predecessors for all nodes: O(1)
350 280         428 my $p;
351 280         496 my $has_origin = 0;
352 280         1179 foreach my $n (ord_values ( $self->{nodes} ), ord_values ( $self->{groups} ))
353             # for my $n (ord_values ( $self->{nodes} ))
354             {
355 1175         3318 $n->{_chain} = undef; # reset chain info
356 1175         2055 $has_origin = 0;
357 1175 100 66     4038 $has_origin = 1 if defined $n->{origin} && $n->{origin} != $n;
358 1175         4050 $p->{$n->{name}} = [ $n->has_predecessors(), $has_origin, abs($n->{rank}) ];
359             }
360              
361 280         1421 my $done = 0; my $todo = scalar keys %{$self->{nodes}};
  280         526  
  280         899  
362              
363             # the node where the layout should start, as name
364 280         1241 my $root_name = $self->{attr}->{root};
365 280         802 $self->{_root} = undef; # as ref to a Node object
366              
367             # Start at nodes with no predecessors (starting points) and then do the rest:
368 280         1526 for my $name ($root_name, sort {
  1830         3166  
369             my $aa = $p->{$a};
370 1830         2866 my $bb = $p->{$b};
371              
372             # sort first on rank
373 1830 50 100     11982 $aa->[2] <=> $bb->[2] ||
      100        
374             # nodes that have an origin come last
375             $aa->[1] <=> $bb->[1] ||
376             # nodes with no predecessorts are to be prefered
377             $aa->[0] <=> $bb->[0] ||
378             # last resort, alphabetically sorted
379             $a cmp $b
380             } keys %$p)
381             {
382 1071 100       2823 next unless defined $name; # in case no root was set, first entry
383             # will be undef and must be skipped
384 791         2299 my $n = $self->{nodes}->{$name};
385              
386             # print STDERR "# tracing chain from $name (", join(", ", @{$p->{$name}}),")\n";
387              
388             # store root node unless already found, is accessed in _follow_chain()
389 791 100       2353 $self->{_root} = $n unless defined $self->{_root};
390              
391 791 100       2088 last if $done == $todo; # already processed all nodes?
392              
393             # track the chain unless already done and count number of nodes done
394 563 100       2777 $done += _follow_chain($n) unless defined $n->{_chain};
395             }
396              
397 280 50 66     1522 print STDERR "# Oops - done only $done nodes, but should have done $todo.\n" if $done != $todo && $self->{debug};
398 280 50 66     2855 print STDERR "# Done all $todo nodes.\n" if $done == $todo && $self->{debug};
399              
400 280         1735 $self->{_root};
401             }
402              
403             #############################################################################
404             # debug
405              
406             sub _dump_stack
407             {
408 0     0   0 my ($self, @todo) = @_;
409              
410 0         0 print STDERR "# Action stack contains ", scalar @todo, " steps:\n";
411 0         0 for my $action (@todo)
412             {
413 0         0 my $action_type = $action->[0];
414 0 0       0 if ($action_type == ACTION_NODE)
    0          
    0          
    0          
    0          
415             {
416 0         0 my ($at,$node,$try,$edge) = @$action;
417 0 0       0 my $e = ''; $e = " on edge $edge->{id}" if defined $edge;
  0         0  
418 0         0 print STDERR "# place '$node->{name}' with try $try$e\n";
419             }
420             elsif ($action_type == ACTION_CHAIN)
421             {
422 0         0 my ($at, $node, $try, $parent, $edge) = @$action;
423 0 0       0 my $id = 'unknown'; $id = $edge->{id} if ref($edge);
  0         0  
424 0         0 print STDERR
425             "# chain '$node->{name}' from parent '$parent->{name}' with try $try (for edge id $id)'\n";
426             }
427             elsif ($action_type == ACTION_TRACE)
428             {
429 0         0 my ($at,$edge) = @$action;
430 0         0 my ($src,$dst) = ($edge->{from}, $edge->{to});
431 0         0 print STDERR
432             "# trace '$src->{name}' to '$dst->{name}' via edge $edge->{id}\n";
433             }
434             elsif ($action_type == ACTION_EDGES)
435             {
436 0         0 my $at = shift @$action;
437 0         0 print STDERR
438             "# tracing the following edges, shortest and with flow first:\n";
439              
440             }
441             elsif ($action_type == ACTION_SPLICE)
442             {
443 0         0 my ($at) = @$action;
444 0         0 print STDERR
445             "# splicing in group filler cells\n";
446             }
447             }
448             }
449              
450             sub _action
451             {
452             # generate an action for the action stack toplace a node
453 2127     2127   5307 my ($self, $action, $node, @params) = @_;
454              
455             # mark the node as already done
456 2127         6044 delete $node->{_todo};
457              
458             # mark all children of $node as processed, too, because they will be
459             # placed at the same time:
460 2127 100       3156 $node->_mark_as_placed() if keys %{$node->{children}} > 0;
  2127         9107  
461              
462 2127         11571 [ $action, $node, @params ];
463             }
464              
465             #############################################################################
466             # layout the graph
467              
468             # The general layout routine for the entire graph:
469              
470             sub layout
471             {
472 279     279 1 835 my $self = shift;
473              
474             # ( { type => 'force' } )
475 279         594 my $args = $_[0];
476             # ( type => 'force' )
477 279 50       1138 $args = { @_ } if @_ > 1;
478              
479 279         612 my $type = 'adhoc';
480 279 50 33     1623 $type = 'force' if $args->{type} && $args->{type} eq 'force';
481              
482             # protect the layout with a timeout, unless run under the debugger:
483 279         682 eval {
484 279     0   7052 local $SIG{ALRM} = sub { die "layout did not finish in time\n" };
  0         0  
485 279 50 0     1253 alarm(abs( $args->{timeout} || $self->{timeout} || 5))
486             unless defined $DB::single; # no timeout under the debugger
487              
488 279 50       1047 print STDERR "#\n# Starting $type-based layout.\n" if $self->{debug};
489              
490             # Reset the sequence of the random generator, so that for the same
491             # seed, the same layout will occur. Both for testing and repeatable
492             # layouts based on max score.
493 279         5124 srand($self->{seed});
494              
495 279 50       1027 if ($type eq 'force')
496             {
497 0         0 require Graph::Easy::Layout::Force;
498 0         0 $self->error("Force-directed layouts are not yet implemented.");
499 0         0 $self->_layout_force();
500             }
501             else
502             {
503 279         3451 $self->_edges_into_groups();
504              
505 279         1511 $self->_layout();
506             }
507              
508             }; # eval {}; -- end of timeout protected code
509              
510 279         3598 alarm(0); # disable alarm
511              
512             # cleanup
513 279         973 $self->{chains} = undef; # drop chain info
514 279         2140 foreach my $n (ord_values ( $self->{nodes} ), ord_values ( $self->{groups} ))
515             {
516             # drop old chain info
517 1173         1985 $n->{_next} = undef;
518 1173         3910 delete $n->{_chain};
519 1173         1991 delete $n->{_c};
520             }
521              
522 279         1299 delete $self->{_root};
523              
524 279 50       1971 die $@ if $@; # propagate errors
525             }
526              
527             sub _drop_caches
528             {
529             # before the layout phase, we drop cached information from the last run
530 280     280   539 my $self = shift;
531              
532 280         1224 for my $n (ord_values ( $self->{nodes} ))
533             {
534             # XXX after we laid out the individual groups:
535             # skip nodes that are not part of the current group
536             #next if $n->{group} && !$self->{graph};
537              
538             # empty the cache of computed values (flow, label, border etc)
539 1133         3245 $n->{cache} = {};
540              
541 1133         4098 $n->{x} = undef; $n->{y} = undef; # mark every node as not placed yet
  1133         2490  
542 1133         1772 $n->{w} = undef; # force size recalculation
543 1133         2722 $n->{_todo} = undef; # mark as todo
544             }
545 280         1730 for my $g (ord_values ( $self->{groups} ))
546             {
547 42         97 $g->{x} = undef; $g->{y} = undef; # mark every group as not placed yet
  42         121  
548 42         206 $g->{_todo} = undef; # mark as todo
549             }
550             }
551              
552             sub _layout
553             {
554 280     280   1098 my $self = shift;
555              
556             ###########################################################################
557             # do some assorted stuff beforehand
558              
559 280 0       1159 print STDERR "# Doing layout for ",
    50          
560             (defined $self->{name} ? 'group ' . $self->{name} : 'main graph'),
561             "\n" if $self->{debug};
562              
563             # XXX TODO:
564             # for each primary group
565             # my @groups = $self->groups_within(0);
566             #
567             # if (@groups > 0 && $self->{debug})
568             # {
569             # print STDERR "# Found the following top-level groups:\n";
570             # for my $g (@groups)
571             # {
572             # print STDERR "# $g $g->{name}\n";
573             # }
574             # }
575             #
576             # # layout each group on its own, recursively:
577             # foreach my $g (@groups)
578             # {
579             # $g->_layout();
580             # }
581              
582             # finally assembly everything together
583              
584 280         1304 $self->_drop_caches();
585              
586 280         612 local $_; $_->_grow() for ord_values ( $self->{nodes} );
  280         1356  
587              
588 280         2598 $self->_assign_ranks();
589              
590             # find (longest possible) chains of nodes to "straighten" graph
591 280         1288 my $root = $self->_find_chains();
592              
593             ###########################################################################
594             # prepare our stack of things we need to do before we are finished
595              
596             # action stack, place root 1st if it is known
597 280 100       2260 my @todo = $self->_action( ACTION_NODE, $root, 0 ) if ref $root;
598              
599 280 50       1147 if ($self->{debug})
600             {
601 0         0 print STDERR "# Generated the following chains:\n";
602 0 0       0 for my $chain (
  0         0  
603 0         0 sort { $a->{len} <=> $b->{len} || $a->{start}->{name} cmp $b->{start}->{name} }
604             values %{$self->{chains}})
605             {
606 0         0 $chain->dump(' ');
607             }
608             }
609              
610             # mark all edges as unprocessed, so that we do not process them twice
611 280         1324 for my $edge (ord_values ( $self->{edges} ))
612             {
613 901         3175 $edge->_clear_cells();
614 901         2308 $edge->{_todo} = undef; # mark as todo
615             }
616              
617             # XXX TODO:
618             # put all chains on heap (based on their len)
619             # take longest chain, resolve it and all "connected" chains, repeat until
620             # heap is empty
621              
622 280 50 100     865 for my $chain (sort {
  579   100     4471  
623              
624             # chain starting at root first
625 280         1895 (($b->{start} == $root) <=> ($a->{start} == $root)) ||
626              
627             # longest chains first
628             ($b->{len} <=> $a->{len}) ||
629              
630             # chains on nodes that do have an origin come later
631             (defined($a->{start}->{origin}) <=> defined ($b->{start}->{origin})) ||
632              
633             # last resort, sort on name of the first node in chain
634             ($a->{start}->{name} cmp $b->{start}->{name})
635              
636             } values %{$self->{chains}})
637             {
638 605 50       2117 print STDERR "# laying out chain $chain->{id} (len $chain->{len})\n" if $self->{debug};
639              
640             # layout the chain nodes, then resolve inter-chain links, then traverse
641             # chains recursively
642 605 100       1875 push @todo, @{ $chain->layout() } unless $chain->{_done};
  440         3387  
643             }
644              
645 280 50       1324 print STDERR "# Done laying out all chains, doing left-overs:\n" if $self->{debug};
646              
647 280 50       963 $self->_dump_stack(@todo) if $self->{debug};
648              
649             # After laying out all chained nodes and their links, we need to resolve
650             # left-over edges and links. We do this for each node, and then for each of
651             # its edges, but do the edges shortest-first.
652            
653 280         1195 for my $n (ord_values ( $self->{nodes} ))
654             {
655 1133         2769 push @todo, $self->_action( ACTION_NODE, $n, 0 ); # if exists $n->{_todo};
656              
657             # gather to-do edges
658 1133         1803 my @edges = ();
659 1133         1331 for my $e (sort { $a->{to}->{name} cmp $b->{to}->{name} } values %{$n->{edges}})
  1012         3164  
  1133         4432  
660             # for my $e (ord_values ( $n->{edges} ))
661             {
662             # edge already done?
663 1769 100       7448 next unless exists $e->{_todo};
664              
665             # skip links from/to groups
666 66 50 33     866 next if $e->{to}->isa('Graph::Easy::Group') ||
667             $e->{from}->isa('Graph::Easy::Group');
668              
669 66         231 push @edges, $e;
670 66         235 delete $e->{_todo};
671             }
672             # XXX TODO: This does not work, since the nodes are not yet laid out
673             # sort them on their shortest distances
674             # @edges = sort { $b->_distance() <=> $a->_distance() } @edges;
675              
676             # put them on the action stack in that order
677 1133         3299 for my $e (@edges)
678             {
679 66         281 push @todo, [ ACTION_TRACE, $e ];
680             # print STDERR "do $e->{from}->{name} to $e->{to}->{name} ($e->{id} " . $e->_distance().")\n";
681             # push @todo, [ ACTION_CHAIN, $e->{to}, 0, $n, $e ];
682             }
683             }
684              
685 280 50       1586 print STDERR "# Done laying out left-overs.\n" if $self->{debug};
686              
687             # after laying out all inter-group nodes and their edges, we need to splice in the
688             # group cells
689 280 100       1275 if (scalar $self->groups() > 0)
690             {
691 31 50       106 push @todo, [ ACTION_SPLICE ] if scalar $self->groups();
692              
693             # now do all group-to-group and node-to-group and group-to-node links:
694 31         140 for my $n (ord_values ( $self->{groups} ))
695             {
696             }
697             }
698              
699 280 50       1488 $self->_dump_stack(@todo) if $self->{debug};
700              
701             ###########################################################################
702             # prepare main backtracking-loop
703              
704 280         547 my $score = 0; # overall score
705 280         1324 $self->{cells} = { }; # cell array (0..x,0..y)
706 280         1097 my $cells = $self->{cells};
707              
708 280 50       904 print STDERR "# Start\n" if $self->{debug};
709              
710 280         804 $self->{padding_cells} = 0; # set to false (no filler cells yet)
711              
712 280         905 my @done = (); # stack with already done actions
713 280         568 my $step = 0;
714 280         481 my $tries = 16;
715              
716             # store for each rank the initial row/coluumn
717 280         941 $self->{_rank_pos} = {};
718             # does rank_pos store rows or columns?
719 280         806 $self->{_rank_coord} = 'y';
720 280         2277 my $flow = $self->flow();
721 280 100 100     1947 $self->{_rank_coord} = 'x' if $flow == 0 || $flow == 180;
722              
723             TRY:
724 280         1811 while (@todo > 0) # all actions on stack done?
725             {
726 3057         4546 $step ++;
727              
728 3057 50 33     8914 if ($self->{debug} && ($step % 1)==0)
729             {
730 0         0 my ($nodes,$e_nodes,$edges,$e_edges) = $self->_count_done_things();
731 0         0 print STDERR "# Done $nodes nodes and $edges edges.\n";
732             #$self->{debug} = 2 if $nodes > 243;
733 0 0       0 return if ($nodes > 230);
734             }
735              
736             # pop one action and mark it as done
737 3057         5309 my $action = shift @todo; push @done, $action;
  3057         4963  
738              
739             # get the action type (ACTION_NODE etc)
740 3057         5037 my $action_type = $action->[0];
741              
742 3057         3777 my ($src, $dst, $mod, $edge);
743              
744 3057 100       9907 if ($action_type == ACTION_NODE)
    100          
    100          
    50          
745             {
746 1508         3120 my (undef, $node,$try,$edge) = @$action;
747 1508 50       4258 print STDERR "# step $step: action place '$node->{name}' (try $try)\n" if $self->{debug};
748              
749 1508 100       4282 $mod = 0 if defined $node->{x};
750             # $action is node to be placed, generic placement at "random" location
751 1508 100       6693 $mod = $self->_find_node_place( $node, $try, undef, $edge) unless defined $node->{x};
752             }
753             elsif ($action_type == ACTION_CHAIN)
754             {
755 619         1777 my (undef, $node,$try,$parent, $edge) = @$action;
756 619 50       1784 print STDERR "# step $step: action chain '$node->{name}' from parent '$parent->{name}'\n" if $self->{debug};
757              
758 619 100       2012 $mod = 0 if defined $node->{x};
759 619 100       3910 $mod = $self->_find_node_place( $node, $try, $parent, $edge ) unless defined $node->{x};
760             }
761             elsif ($action_type == ACTION_TRACE)
762             {
763             # find a path to the target node
764 899         2980 ($action_type,$edge) = @$action;
765              
766 899         2632 $src = $edge->{from}; $dst = $edge->{to};
  899         1807  
767              
768 899 50       2840 print STDERR "# step $step: action trace '$src->{name}' => '$dst->{name}'\n" if $self->{debug};
769              
770 899 100       3426 if (!defined $dst->{x})
771             {
772             # warn ("Target node $dst->{name} not yet placed");
773 2         13 $mod = $self->_find_node_place( $dst, 0, undef, $edge );
774             }
775 899 100       2348 if (!defined $src->{x})
776             {
777             # warn ("Source node $src->{name} not yet placed");
778 1         8 $mod = $self->_find_node_place( $src, 0, undef, $edge );
779             }
780              
781             # find path (mod is score modifier, or undef if no path exists)
782 899         4311 $mod = $self->_trace_path( $src, $dst, $edge );
783             }
784             elsif ($action_type == ACTION_SPLICE)
785             {
786             # fill in group info and return
787 31 50       310 $self->_fill_group_cells($cells) unless $self->{error};
788 31         122 $mod = 0;
789             }
790             else
791             {
792 0         0 require Carp;
793 0         0 Carp::confess ("Illegal action $action->[0] on TODO stack");
794             }
795              
796 3057 50       7714 if (!defined $mod)
797             {
798             # rewind stack
799 0 0 0     0 if (($action_type == ACTION_NODE || $action_type == ACTION_CHAIN))
800             {
801 0 0       0 print STDERR "# Step $step: Rewind stack for $action->[1]->{name}\n" if $self->{debug};
802              
803             # undo node placement and free all cells
804 0 0       0 $action->[1]->_unplace() if defined $action->[1]->{x};
805 0         0 $action->[2]++; # increment try for placing
806 0         0 $tries--;
807 0 0       0 last TRY if $tries == 0;
808             }
809             else
810             {
811 0 0       0 print STDERR "# Step $step: Rewind stack for path from $src->{name} to $dst->{name}\n" if $self->{debug};
812            
813             # if we couldn't find a path, we need to rewind one more action (just
814             # redoing the path would would fail again!)
815              
816             # unshift @todo, pop @done;
817             # unshift @todo, pop @done;
818              
819             # $action = $todo[0];
820             # $action_type = $action->[0];
821              
822             # $self->_dump_stack(@todo);
823             #
824             # if (($action_type == ACTION_NODE || $action_type == ACTION_CHAIN))
825             # {
826             # # undo node placement
827             # $action->[1]->_unplace();
828             # $action->[2]++; # increment try for placing
829             # }
830 0         0 $tries--;
831 0 0       0 last TRY if $tries == 0;
832 0         0 next TRY;
833             }
834 0         0 unshift @todo, $action;
835 0         0 next TRY;
836             }
837              
838 3057         4269 $score += $mod;
839 3057 50       13404 print STDERR "# Step $step: Score is $score\n\n" if $self->{debug};
840             }
841              
842 280         844 $self->{score} = $score; # overall score
843              
844             # if ($tries == 0)
845             {
846 280         576 my ($nodes,$e_nodes,$edges,$e_edges) = $self->_count_done_things();
  280         1492  
847 280 100 66     2357 if ( ($nodes != $e_nodes) ||
848             ($edges != $e_edges) )
849             {
850 3         59 $self->warn( "Layouter could only place $nodes nodes/$edges edges out of $e_nodes/$e_edges - giving up");
851             }
852             else
853             {
854 277         1239 $self->_optimize_layout();
855             }
856             }
857             # all things on the stack were done, or we encountered an error
858             }
859              
860             sub _count_done_things
861             {
862 280     280   616 my $self = shift;
863              
864             # count placed nodes
865 280         517 my $nodes = 0;
866 280         490 my $i = 1;
867 280         1696 for my $n (ord_values ( $self->{nodes} ))
868             {
869 1133 50       5629 $nodes++ if defined $n->{x};
870             }
871 280         877 my $edges = 0;
872 280         471 $i = 1;
873             # count fully routed edges
874 280         1197 for my $e (ord_values ( $self->{edges} ))
875             {
876 901 100 66     10273 $edges++ if scalar @{$e->{cells}} > 0 && !exists $e->{_todo};
  901         8549  
877             }
878 280         669 my $e_nodes = scalar keys %{$self->{nodes}};
  280         848  
879 280         536 my $e_edges = scalar keys %{$self->{edges}};
  280         724  
880 280         997 return ($nodes,$e_nodes,$edges,$e_edges);
881             }
882              
883             my $size_name = {
884             EDGE_HOR() => [ 'cx', 'x' ],
885             EDGE_VER() => [ 'cy', 'y' ]
886             };
887              
888             sub _optimize_layout
889             {
890 277     277   627 my $self = shift;
891              
892             # optimize the finished layout
893              
894 277         669 my $all_cells = $self->{cells};
895              
896             ###########################################################################
897             # for each edge, compact HOR and VER stretches of cells
898 277         1075 for my $e (ord_values ( $self->{edges} ))
899             {
900 885         1565 my $cells = $e->{cells};
901              
902             # there need to be at least two cells for us to be able to combine them
903 885 100       3091 next if @$cells < 2;
904              
905 239 50       842 print STDERR "# Compacting edge $e->{from}->{name} to $e->{to}->{name}\n"
906             if $self->{debug};
907              
908 239         509 my $f = $cells->[0]; my $i = 1;
  239         325  
909 239         296 my ($px, $py); # coordinates of the placeholder cell
910 239         649 while ($i < @$cells)
911             {
912 1102         1797 my $c = $cells->[$i++];
913              
914             # print STDERR "# at $f->{type} $f->{x},$f->{y} (next: $c->{type} $c->{x},$c->{y})\n";
915              
916 1102         1761 my $t1 = $f->{type} & EDGE_NO_M_MASK;
917 1102         1763 my $t2 = $c->{type} & EDGE_NO_M_MASK;
918              
919             # > 0: delete that cell: 1 => reverse order, 2 => with hole
920 1102         1181 my $delete = 0;
921              
922             # compare $first to $c
923 1102 50 66     3624 if ($t1 == $t2 && ($t1 == EDGE_HOR || $t1 == EDGE_VER))
      66        
924             {
925             # print STDERR "# $i: Combining them.\n";
926              
927             # check that both pieces are continues (e.g. with a cross section,
928             # the other edge has a hole in the cell array)
929              
930             # if the second cell has a misc (label, short) flag, carry it over
931 515         1036 $f->{type} += $c->{type} & EDGE_MISC_MASK;
932              
933             # which size/coordinate to modify
934 515         539 my ($m,$co) = @{ $size_name->{$t1} };
  515         1491  
935              
936             # print STDERR "# Combining edge cells $f->{x},$f->{y} and $c->{x},$c->{y}\n";
937              
938             # new width/height is the combined size
939 515   100     3092 $f->{$m} = ($f->{$m} || 1) + ($c->{$m} || 1);
      50        
940              
941             # print STDERR "# Result $f->{x},$f->{y} ",$f->{cx}||1," ", $f->{cy}||1,"\n";
942              
943             # drop the reference from the $cells array for $c
944 515         2182 delete $all_cells->{ "$c->{x},$c->{y}" };
945              
946 515         1384 ($px, $py) = ($c->{x}, $c->{y});
947 515 100       1695 if ($f->{$co} > $c->{$co})
948             {
949             # remember coordinate of the moved cell for the placeholder
950 127         324 ($px, $py) = ($f->{x}, $f->{y});
951              
952             # move $f to the new place if it was modified
953 127         315 delete $all_cells->{ "$f->{x},$f->{y}" };
954             # correct start coordinate for reversed order
955 127   50     546 $f->{$co} -= ($c->{$m} || 1);
956              
957 127         556 $all_cells->{ "$f->{x},$f->{y}" } = $f;
958             }
959              
960 515         900 $delete = 1; # delete $c
961             }
962              
963             # remove that cell, but start combining at next
964             # print STDERR "# found hole at $i\n" if $c->{type} == EDGE_HOLE;
965              
966 1102 100       2325 $delete = 2 if $c->{type} == EDGE_HOLE;
967 1102 100       2107 if ($delete)
968             {
969 525         671 splice (@{$e->{cells}}, $i-1, 1); # remove from the edge
  525         1209  
970 525 100       1025 if ($delete == 1)
971             {
972 515         893 my $xy = "$px,$py";
973             # replace with placeholder (important for HTML output)
974 515 50       2517 $all_cells->{$xy} = Graph::Easy::Edge::Cell::Empty->new (
975             x => $px, y => $py,
976             ) unless $all_cells->{$xy};
977              
978 515         731 $i--; $c = $f; # for the next statement
  515         813  
979             }
980 10         31 else { $c = $cells->[$i-1]; }
981             }
982 1102         4996 $f = $c;
983             }
984              
985             # $i = 0;
986             # while ($i < @$cells)
987             # {
988             # my $c = $cells->[$i];
989             # print STDERR "# $i: At $c->{type} $c->{x},$c->{y} ", $c->{cx}||1, " ", $c->{cy} || 1,"\n";
990             # $i++;
991             # }
992              
993             }
994 277 50       10549 print STDERR "# Done compacting edges.\n" if $self->{debug};
995              
996             }
997              
998             1;
999             __END__