1############################################################################# 2# A group of nodes. Part of Graph::Easy. 3# 4############################################################################# 5 6package Graph::Easy::Group; 7 8use Graph::Easy::Group::Cell; 9use Graph::Easy; 10use Scalar::Util qw/weaken/; 11 12@ISA = qw/Graph::Easy::Node Graph::Easy/; 13$VERSION = '0.76'; 14 15use strict; 16use warnings; 17 18use Graph::Easy::Util qw(ord_values); 19 20############################################################################# 21 22sub _init 23 { 24 # generic init, override in subclasses 25 my ($self,$args) = @_; 26 27 $self->{name} = 'Group #'. $self->{id}; 28 $self->{class} = 'group'; 29 $self->{_cells} = {}; # the Group::Cell objects 30# $self->{cx} = 1; 31# $self->{cy} = 1; 32 33 foreach my $k (sort keys %$args) 34 { 35 if ($k !~ /^(graph|name)\z/) 36 { 37 require Carp; 38 Carp::confess ("Invalid argument '$k' passed to Graph::Easy::Group->new()"); 39 } 40 $self->{$k} = $args->{$k}; 41 } 42 43 $self->{nodes} = {}; 44 $self->{groups} = {}; 45 $self->{att} = {}; 46 47 $self; 48 } 49 50############################################################################# 51# accessor methods 52 53sub nodes 54 { 55 my $self = shift; 56 57 wantarray ? ( ord_values ( $self->{nodes} ) ) : scalar keys %{$self->{nodes}}; 58 } 59 60sub edges 61 { 62 # edges leading from/to this group 63 my $self = shift; 64 65 wantarray ? ( ord_values ( $self->{edges} ) ) : scalar keys %{$self->{edges}}; 66 } 67 68sub edges_within 69 { 70 # edges between nodes inside this group 71 my $self = shift; 72 73 wantarray ? ( ord_values ( $self->{edges_within} ) ) : 74 scalar keys %{$self->{edges_within}}; 75 } 76 77sub _groups_within 78 { 79 my ($self, $level, $max_level, $cur) = @_; 80 81 no warnings 'recursion'; 82 83 push @$cur, ord_values ( $self->{groups} ); 84 85 return if $level >= $max_level; 86 87 for my $g (ord_values ( $self->{groups} )) 88 { 89 $g->_groups_within($level+1,$max_level, $cur) if scalar keys %{$g->{groups}} > 0; 90 } 91 } 92 93############################################################################# 94 95sub set_attribute 96 { 97 my ($self, $name, $val, $class) = @_; 98 99 $self->SUPER::set_attribute($name, $val, $class); 100 101 # if defined attribute "nodeclass", put our nodes into that class 102 if ($name eq 'nodeclass') 103 { 104 my $class = $self->{att}->{nodeclass}; 105 for my $node (ord_values ( $self->{nodes} ) ) 106 { 107 $node->sub_class($class); 108 } 109 } 110 $self; 111 } 112 113sub shape 114 { 115 my ($self) = @_; 116 117 # $self->{att}->{shape} || $self->attribute('shape'); 118 ''; 119 } 120 121############################################################################# 122# node handling 123 124sub add_node 125 { 126 # add a node to this group 127 my ($self,$n) = @_; 128 129 if (!ref($n) || !$n->isa("Graph::Easy::Node")) 130 { 131 if (!ref($self->{graph})) 132 { 133 return $self->error("Cannot add non node-object $n to group '$self->{name}'"); 134 } 135 $n = $self->{graph}->add_node($n); 136 } 137 $self->{nodes}->{ $n->{name} } = $n; 138 139 # if defined attribute "nodeclass", put our nodes into that class 140 $n->sub_class($self->{att}->{nodeclass}) if exists $self->{att}->{nodeclass}; 141 142 # register ourselves with the member 143 $n->{group} = $self; 144 145 # set the proper attribute (for layout) 146 $n->{att}->{group} = $self->{name}; 147 148 # Register the nodes and the edge with our graph object 149 # and weaken the references. Be careful to not needlessly 150 # override and weaken again an already existing reference, this 151 # is an O(N) operation in most Perl versions, and thus very slow. 152 153 # If the node does not belong to a graph yet or belongs to another 154 # graph, add it to our own graph: 155 weaken($n->{graph} = $self->{graph}) unless 156 $n->{graph} && $self->{graph} && $n->{graph} == $self->{graph}; 157 158 $n; 159 } 160 161sub add_member 162 { 163 # add a node or group to this group 164 my ($self,$n) = @_; 165 166 if (!ref($n) || !$n->isa("Graph::Easy::Node")) 167 { 168 if (!ref($self->{graph})) 169 { 170 return $self->error("Cannot add non node-object $n to group '$self->{name}'"); 171 } 172 $n = $self->{graph}->add_node($n); 173 } 174 return $self->_add_edge($n) if $n->isa("Graph::Easy::Edge"); 175 return $self->add_group($n) if $n->isa('Graph::Easy::Group'); 176 177 $self->{nodes}->{ $n->{name} } = $n; 178 179 # if defined attribute "nodeclass", put our nodes into that class 180 my $cl = $self->attribute('nodeclass'); 181 $n->sub_class($cl) if $cl ne ''; 182 183 # register ourselves with the member 184 $n->{group} = $self; 185 186 # set the proper attribute (for layout) 187 $n->{att}->{group} = $self->{name}; 188 189 # Register the nodes and the edge with our graph object 190 # and weaken the references. Be careful to not needlessly 191 # override and weaken again an already existing reference, this 192 # is an O(N) operation in most Perl versions, and thus very slow. 193 194 # If the node does not belong to a graph yet or belongs to another 195 # graph, add it to our own graph: 196 weaken($n->{graph} = $self->{graph}) unless 197 $n->{graph} && $self->{graph} && $n->{graph} == $self->{graph}; 198 199 $n; 200 } 201 202sub del_member 203 { 204 # delete a node or group from this group 205 my ($self,$n) = @_; 206 207 # XXX TOOD: groups vs. nodes 208 my $class = 'nodes'; my $key = 'name'; 209 if ($n->isa('Graph::Easy::Group')) 210 { 211 # XXX TOOD: groups vs. nodes 212 $class = 'groups'; $key = 'id'; 213 } 214 delete $self->{$class}->{ $n->{$key} }; 215 delete $n->{group}; # unregister us 216 217 if ($n->isa('Graph::Easy::Node')) 218 { 219 # find all edges that mention this node and drop them from the group 220 my $edges = $self->{edges_within}; 221 for my $e (ord_values ( $edges)) 222 { 223 delete $edges->{ $e->{id} } if $e->{from} == $n || $e->{to} == $n; 224 } 225 } 226 227 $self; 228 } 229 230sub del_node 231 { 232 # delete a node from this group 233 my ($self,$n) = @_; 234 235 delete $self->{nodes}->{ $n->{name} }; 236 delete $n->{group}; # unregister us 237 delete $n->{att}->{group}; # delete the group attribute 238 239 # find all edges that mention this node and drop them from the group 240 my $edges = $self->{edges_within}; 241 for my $e (ord_values ( $edges)) 242 { 243 delete $edges->{ $e->{id} } if $e->{from} == $n || $e->{to} == $n; 244 } 245 246 $self; 247 } 248 249sub add_nodes 250 { 251 my $self = shift; 252 253 # make a copy in case of scalars 254 my @arg = @_; 255 foreach my $n (@arg) 256 { 257 if (!ref($n) && !ref($self->{graph})) 258 { 259 return $self->error("Cannot add non node-object $n to group '$self->{name}'"); 260 } 261 return $self->error("Cannot add group-object $n to group '$self->{name}'") 262 if $n->isa('Graph::Easy::Group'); 263 264 $n = $self->{graph}->add_node($n) unless ref($n); 265 266 $self->{nodes}->{ $n->{name} } = $n; 267 268 # set the proper attribute (for layout) 269 $n->{att}->{group} = $self->{name}; 270 271# XXX TODO TEST! 272# # if defined attribute "nodeclass", put our nodes into that class 273# $n->sub_class($self->{att}->{nodeclass}) if exists $self->{att}->{nodeclass}; 274 275 # register ourselves with the member 276 $n->{group} = $self; 277 278 # Register the nodes and the edge with our graph object 279 # and weaken the references. Be careful to not needlessly 280 # override and weaken again an already existing reference, this 281 # is an O(N) operation in most Perl versions, and thus very slow. 282 283 # If the node does not belong to a graph yet or belongs to another 284 # graph, add it to our own graph: 285 weaken($n->{graph} = $self->{graph}) unless 286 $n->{graph} && $self->{graph} && $n->{graph} == $self->{graph}; 287 288 } 289 290 @arg; 291 } 292 293############################################################################# 294 295sub _del_edge 296 { 297 # delete an edge from this group 298 my ($self,$e) = @_; 299 300 delete $self->{edges_within}->{ $e->{id} }; 301 delete $e->{group}; # unregister us 302 303 $self; 304 } 305 306sub _add_edge 307 { 308 # add an edge to this group (e.g. when both from/to of this edge belong 309 # to this group) 310 my ($self,$e) = @_; 311 312 if (!ref($e) || !$e->isa("Graph::Easy::Edge")) 313 { 314 return $self->error("Cannot add non edge-object $e to group '$self->{name}'"); 315 } 316 $self->{edges_within}->{ $e->{id} } = $e; 317 318 # if defined attribute "edgeclass", put our edges into that class 319 my $edge_class = $self->attribute('edgeclass'); 320 $e->sub_class($edge_class) if $edge_class ne ''; 321 322 # XXX TODO: inline 323 $self->add_node($e->{from}); 324 $self->add_node($e->{to}); 325 326 # register us, but don't do weaken() if the ref was already set 327 weaken($e->{group} = $self) unless defined $e->{group} && $e->{group} == $self; 328 329 $e; 330 } 331 332sub add_edge 333 { 334 # Add an edge to the graph of this group, then register it with this group. 335 my ($self,$from,$to) = @_; 336 337 my $g = $self->{graph}; 338 return $self->error("Cannot add edge to group '$self->{name}' without graph") 339 unless defined $g; 340 341 my $edge = $g->add_edge($from,$to); 342 343 $self->_add_edge($edge); 344 } 345 346sub add_edge_once 347 { 348 # Add an edge to the graph of this group, then register it with this group. 349 my ($self,$from,$to) = @_; 350 351 my $g = $self->{graph}; 352 return $self->error("Cannot non edge to group '$self->{name}' without graph") 353 unless defined $g; 354 355 my $edge = $g->add_edge_once($from,$to); 356 # edge already exists => so fetch it 357 $edge = $g->edge($from,$to) unless defined $edge; 358 359 $self->_add_edge($edge); 360 } 361 362############################################################################# 363 364sub add_group 365 { 366 # add a group to us 367 my ($self,$group) = @_; 368 369 # group with that name already exists? 370 my $name = $group; 371 $group = $self->{groups}->{ $group } unless ref $group; 372 373 # group with that name doesn't exist, so create new one 374 $group = $self->{graph}->add_group($name) unless ref $group; 375 376 # index under the group name for easier lookup 377 $self->{groups}->{ $group->{name} } = $group; 378 379 # make attribute->('group') work 380 $group->{att}->{group} = $self->{name}; 381 382 # register group with the graph and ourself 383 $group->{graph} = $self->{graph}; 384 $group->{group} = $self; 385 { 386 no warnings; # don't warn on already weak references 387 weaken($group->{graph}); 388 weaken($group->{group}); 389 } 390 $self->{graph}->{score} = undef; # invalidate last layout 391 392 $group; 393 } 394 395# cell management - used by the layouter 396 397sub _cells 398 { 399 # return all the cells this group currently occupies 400 my $self = shift; 401 402 $self->{_cells}; 403 } 404 405sub _clear_cells 406 { 407 # remove all belonging cells 408 my $self = shift; 409 410 $self->{_cells} = {}; 411 412 $self; 413 } 414 415sub _add_cell 416 { 417 # add a cell to the list of cells this group covers 418 my ($self,$cell) = @_; 419 420 $cell->_update_boundaries(); 421 $self->{_cells}->{"$cell->{x},$cell->{y}"} = $cell; 422 $cell; 423 } 424 425sub _del_cell 426 { 427 # delete a cell from the list of cells this group covers 428 my ($self,$cell) = @_; 429 430 delete $self->{_cells}->{"$cell->{x},$cell->{y}"}; 431 delete $cell->{group}; 432 433 $self; 434 } 435 436sub _find_label_cell 437 { 438 # go through all cells of this group and find one where to attach the label 439 my $self = shift; 440 441 my $g = $self->{graph}; 442 443 my $align = $self->attribute('align'); 444 my $loc = $self->attribute('labelpos'); 445 446 # depending on whether the label should be on top or bottom: 447 my $match = qr/^\s*gt\s*\z/; 448 $match = qr/^\s*gb\s*\z/ if $loc eq 'bottom'; 449 450 my $lc; # the label cell 451 452 for my $c (ord_values ( $self->{_cells} )) 453 { 454 # find a cell where to put the label 455 next unless $c->{cell_class} =~ $match; 456 457 if (defined $lc) 458 { 459 if ($align eq 'left') 460 { 461 # find top-most, left-most cell 462 next if $lc->{x} < $c->{x} || $lc->{y} < $c->{y}; 463 } 464 elsif ($align eq 'center') 465 { 466 # just find any top-most cell 467 next if $lc->{y} < $c->{y}; 468 } 469 elsif ($align eq 'right') 470 { 471 # find top-most, right-most cell 472 next if $lc->{x} > $c->{x} || $lc->{y} < $c->{y}; 473 } 474 } 475 $lc = $c; 476 } 477 478 # find the cell mostly near the center in the found top-row 479 if (ref($lc) && $align eq 'center') 480 { 481 my ($left, $right); 482 # find left/right most coordinates 483 for my $c (ord_values ( $self->{_cells} )) 484 { 485 next if $c->{y} != $lc->{y}; 486 $left = $c->{x} if !defined $left || $left > $c->{x}; 487 $right = $c->{x} if !defined $right || $right < $c->{x}; 488 } 489 my $center = int(($right - $left) / 2 + $left); 490 my $min_dist; 491 # find the cell mostly near the center in the found top-row 492 for my $c (ord_values ( $self->{_cells} )) 493 { 494 next if $c->{y} != $lc->{y}; 495 # squared to get rid of sign 496 my $dist = ($center - $c->{x}); $dist *= $dist; 497 next if defined $min_dist && $dist > $min_dist; 498 $min_dist = $dist; $lc = $c; 499 } 500 } 501 502 print STDERR "# Setting label for group '$self->{name}' at $lc->{x},$lc->{y}\n" 503 if $self->{debug}; 504 505 $lc->_set_label() if ref($lc); 506 } 507 508sub layout 509 { 510 my $self = shift; 511 512 $self->_croak('Cannot call layout() on a Graph::Easy::Group directly.'); 513 } 514 515sub _layout 516 { 517 my $self = shift; 518 519 ########################################################################### 520 # set local {debug} for groups 521 local $self->{debug} = $self->{graph}->{debug}; 522 523 $self->SUPER::_layout(); 524 } 525 526sub _set_cell_types 527 { 528 my ($self, $cells) = @_; 529 530 # Set the right cell class for all of our cells: 531 for my $cell (ord_values ( $self->{_cells} )) 532 { 533 $cell->_set_type($cells); 534 } 535 536 $self; 537 } 538 5391; 540__END__ 541 542=head1 NAME 543 544Graph::Easy::Group - A group of nodes (aka subgraph) in Graph::Easy 545 546=head1 SYNOPSIS 547 548 use Graph::Easy; 549 550 my $bonn = Graph::Easy::Node->new('Bonn'); 551 552 $bonn->set_attribute('border', 'solid 1px black'); 553 554 my $berlin = Graph::Easy::Node->new( name => 'Berlin' ); 555 556 my $cities = Graph::Easy::Group->new( 557 name => 'Cities', 558 ); 559 $cities->set_attribute('border', 'dashed 1px blue'); 560 561 $cities->add_nodes ($bonn); 562 # $bonn will be ONCE in the group 563 $cities->add_nodes ($bonn, $berlin); 564 565 566=head1 DESCRIPTION 567 568A C<Graph::Easy::Group> represents a group of nodes in an C<Graph::Easy> 569object. These nodes are grouped together on output. 570 571=head1 METHODS 572 573=head2 new() 574 575 my $group = Graph::Easy::Group->new( $options ); 576 577Create a new, empty group. C<$options> are the possible options, see 578L<Graph::Easy::Node> for a list. 579 580=head2 error() 581 582 $last_error = $group->error(); 583 584 $group->error($error); # set new messages 585 $group->error(''); # clear error 586 587Returns the last error message, or '' for no error. 588 589=head2 as_ascii() 590 591 my $ascii = $group->as_ascii(); 592 593Return the group as a little box drawn in ASCII art as a string. 594 595=head2 name() 596 597 my $name = $group->name(); 598 599Return the name of the group. 600 601=head2 id() 602 603 my $id = $group->id(); 604 605Returns the group's unique ID number. 606 607=head2 set_attribute() 608 609 $group->set_attribute('border-style', 'none'); 610 611Sets the specified attribute of this (and only this!) group to the 612specified value. 613 614=head2 add_member() 615 616 $group->add_member($node); 617 $group->add_member($group); 618 619Add the specified object to this group and returns this member. If the 620passed argument is a scalar, will treat it as a node name. 621 622Note that each object can only be a member of one group at a time. 623 624=head2 add_node() 625 626 $group->add_node($node); 627 628Add the specified node to this group and returns this node. 629 630Note that each object can only be a member of one group at a time. 631 632=head2 add_edge(), add_edge_once() 633 634 $group->add_edge($edge); # Graph::Easy::Edge 635 $group->add_edge($from, $to); # Graph::Easy::Node or 636 # Graph::Easy::Group 637 $group->add_edge('From', 'To'); # Scalars 638 639If passed an Graph::Easy::Edge object, moves the nodes involved in 640this edge to the group. 641 642if passed two nodes, adds these nodes to the graph (unless they already 643exist) and adds an edge between these two nodes. See L<add_edge_once()> 644to avoid creating multiple edges. 645 646This method works only on groups that are part of a graph. 647 648Note that each object can only be a member of one group at a time, 649and edges are automatically a member of a group if and only if both 650the target and the destination node are a member of the same group. 651 652=head2 add_group() 653 654 my $inner = $group->add_group('Group name'); 655 my $nested = $group->add_group($group); 656 657Add a group as subgroup to this group and returns this group. 658 659=head2 del_member() 660 661 $group->del_member($node); 662 $group->del_member($group); 663 664Delete the specified object from this group. 665 666=head2 del_node() 667 668 $group->del_node($node); 669 670Delete the specified node from this group. 671 672=head2 del_edge() 673 674 $group->del_edge($edge); 675 676Delete the specified edge from this group. 677 678=head2 add_nodes() 679 680 $group->add_nodes($node, $node2, ... ); 681 682Add all the specified nodes to this group and returns them as a list. 683 684=head2 nodes() 685 686 my @nodes = $group->nodes(); 687 688Returns a list of all node objects that belong to this group. 689 690=head2 edges() 691 692 my @edges = $group->edges(); 693 694Returns a list of all edge objects that lead to or from this group. 695 696Note: This does B<not> return edges between nodes that are inside the group, 697for this see L<edges_within()>. 698 699=head2 edges_within() 700 701 my @edges_within = $group->edges_within(); 702 703Returns a list of all edge objects that are I<inside> this group, in arbitrary 704order. Edges are automatically considered I<inside> a group if their starting 705and ending node both are in the same group. 706 707Note: This does B<not> return edges between this group and other groups, 708nor edges between this group and nodes outside this group, for this see 709L<edges()>. 710 711=head2 groups() 712 713 my @groups = $group->groups(); 714 715Returns the contained groups of this group as L<Graph::Easy::Group> objects, 716in arbitrary order. 717 718=head2 groups_within() 719 720 # equivalent to $group->groups(): 721 my @groups = $group->groups_within(); # all 722 my @toplevel_groups = $group->groups_within(0); # level 0 only 723 724Return the groups that are inside this group, up to the specified level, 725in arbitrary order. 726 727The default level is -1, indicating no bounds and thus all contained 728groups are returned. 729 730A level of 0 means only the direct children, and hence only the toplevel 731groups will be returned. A level 1 means the toplevel groups and their 732toplevel children, and so on. 733 734=head2 as_txt() 735 736 my $txt = $group->as_txt(); 737 738Returns the group as Graph::Easy textual description. 739 740=head2 _find_label_cell() 741 742 $group->_find_label_cell(); 743 744Called by the layouter once for each group. Goes through all cells of this 745group and finds one where to attach the label to. Internal usage only. 746 747=head2 get_attributes() 748 749 my $att = $object->get_attributes(); 750 751Return all effective attributes on this object (graph/node/group/edge) as 752an anonymous hash ref. This respects inheritance and default values. 753 754See also L<raw_attributes()>. 755 756=head2 raw_attributes() 757 758 my $att = $object->get_attributes(); 759 760Return all set attributes on this object (graph/node/group/edge) as 761an anonymous hash ref. This respects inheritance, but does not include 762default values for unset attributes. 763 764See also L<get_attributes()>. 765 766=head2 attribute related methods 767 768You can call all the various attribute related methods like C<set_attribute()>, 769C<get_attribute()>, etc. on a group, too. For example: 770 771 $group->set_attribute('label', 'by train'); 772 my $attr = $group->get_attributes(); 773 774You can find more documentation in L<Graph::Easy>. 775 776=head2 layout() 777 778This routine should not be called on groups, it only works on the graph 779itself. 780 781=head2 shape() 782 783 my $shape = $group->shape(); 784 785Returns the shape of the group as string. 786 787=head2 has_as_successor() 788 789 if ($group->has_as_successor($other)) 790 { 791 ... 792 } 793 794Returns true if C<$other> (a node or group) is a successor of this group, e.g. 795if there is an edge leading from this group to C<$other>. 796 797=head2 has_as_predecessor() 798 799 if ($group->has_as_predecessor($other)) 800 { 801 ... 802 } 803 804Returns true if the group has C<$other> (a group or node) as predecessor, that 805is if there is an edge leading from C<$other> to this group. 806 807=head2 root_node() 808 809 my $root = $group->root_node(); 810 811Return the root node as L<Graph::Easy::Node> object, if it was 812set with the 'root' attribute. 813 814=head1 EXPORT 815 816None by default. 817 818=head1 SEE ALSO 819 820L<Graph::Easy>, L<Graph::Easy::Node>, L<Graph::Easy::Manual>. 821 822=head1 AUTHOR 823 824Copyright (C) 2004 - 2008 by Tels L<http://bloodgate.com> 825 826See the LICENSE file for more details. 827 828=cut 829