1package SpringGraph; 2 3=head1 NAME 4 5SpringGraph - Directed Graph alternative to GraphViz 6 7=head1 SYNOPSIS 8 9use SpringGraph qw(calculate_graph draw_graph); 10 11 12## object oriented interface ## 13 14my $graph = new SpringGraph; 15 16# add a node to the graph (with optional label) 17 18$graph->add_node('Paris', label =>'City of Love'); 19 20# add an edge to the graph (with optional label, and directed) 21 22$graph->add_edge('London' => 'New York', label => 'Far', dir=>1); 23 24# output the graph to a file 25 26$graph->as_png($filename); 27 28# get the graph as GD image object 29 30$graph->as_gd; 31 32## procedural interface ## 33 34my %node = ( 35 london => { label => 'London (Waterloo)'}, 36 paris => { label => 'Paris' }, 37 brussels => { label => 'Brussels'}, 38 ); 39 40my %link = ( 41 london => { paris => {style => 'dotted'}, 'new york' => {} }, # non-directed, dotted and plain lines 42 paris => { brussels => { dir => 1} }, # directed from paris to brussels 43 ); 44 45my $graph = calculate_graph(\%node,\%link); 46 47draw_graph($filename,\%node,\%link); 48 49=head1 DESCRIPTION 50 51SpringGraph.pm is a rewrite of the springgraph.pl script, which provides similar functionality to Neato and can read some/most dot files. 52 53The goal of this module is to provide a compatible interface to VCG and/or GraphViz perl modules on CPAN. This module will also provide some extra features to provide more flexibility and power. 54 55=head1 METHODS 56 57=cut 58 59use strict; 60use Data::Dumper; 61use GD; 62 63our @ISA = qw(Exporter); 64our @EXPORT_OK = qw(&calculate_graph &draw_graph); 65our $VERSION = 0.05; 66 67use constant PI => 3.141592653589793238462643383279502884197169399375105; 68 69=head1 Class Methods 70 71=head2 new 72 73Constructor for the class, returns a new SpringGraph object 74 75my $graph = SpringGraph->new; 76 77=cut 78 79sub new { 80 my ($class) = @_; 81 my $self = bless( {scale=> 1,nodes => {}, links=>{} }, ref $class || $class); 82 return $self; 83} 84 85=head2 calculate_graph 86 87returns a hashref of the nodes in the graph, populated with coordinates 88 89my $graph = calculate_graph(\%node,\%link); 90 91=cut 92 93sub calculate_graph { 94 my ($nodes,$links) = @_; 95# warn "calculate_graph called with : ", @_, "\n"; 96 my $scale = 1; 97 my $push = 450; 98 my $pull = .080; 99 my $maxiter = 100; 100 my $rate = 0.8; 101 my $done = 0.3; 102 my $continue = 5; 103 my $iter = 0; 104 my $movecount; 105 106 my $self = bless ({}, 'SpringGraph'); 107 my %node = %{$self->_position_nodes_in_tree ($nodes,$links)}; 108 my %link = %$links; 109 110 while($continue && ($iter <= $maxiter) ) { 111 $continue = 0; 112 $iter++; 113 my ($xmove,$ymove) = (0,0); 114# warn "iter : $iter\n"; 115 foreach my $nodename (keys %$nodes) { 116# warn "-- nodename : $nodename\n"; 117# warn "x : $node{$nodename}{x} --- y : $node{$nodename}{y}\n"; 118 $node{$nodename}{oldx} = $node{$nodename}{x}; 119 $node{$nodename}{oldy} = $node{$nodename}{'y'}; 120 } 121 122 foreach my $source (keys %$nodes) { 123 my $movecount = 0; 124 my ($pullmove,$pushmove); 125 foreach my $dest (keys %$nodes) { 126 my $xdist = $node{$source}{oldx} - $node{$dest}{oldx}; 127 my $ydist = $node{$source}{oldy} - $node{$dest}{oldy}; 128 my $dist = sqrt(abs($xdist)**2 + abs($ydist)**2); 129 next if ($source eq $dest); 130# warn "--- source : $source / dest : $dest \n"; 131 my $wantdist = $dist; 132 if ($dist <= 65) { 133 $wantdist = $push * 2; 134# print "pushing apart $source and $dest - current dist : $dist, want dist $wantdist\n"; 135 } else { 136 if ($link{$source}{$dest} || $link{$dest}{$source}) { 137 # $wantdist = $dist + ($push / ($dist + 5)); 138 if ($link{$source}{$dest}) { 139 $wantdist = $wantdist - ($pull * $dist); 140 } 141 if ($link{$dest}{$source}) { 142 $wantdist = $wantdist - ($pull * $dist); 143 } 144 } else { 145 $wantdist = $push * (0.65 - $pull) unless ($dist > 150); 146 next if ($dist > 200); 147 } 148 } 149# warn "xdist : $xdist / wantdist :$wantdist\n"; 150 my $percent = ($wantdist/($dist+1)); 151 my $wantxdist = ($xdist * $percent); 152 my $wantydist = ($ydist * $percent ) + 5; 153# warn "percent : $percent / want x dist :$wantxdist / want y dist :$wantydist\n"; 154 $xmove += ($xdist - $wantxdist)*$rate; 155 $ymove += ($ydist - $wantydist)*$rate; 156# warn "xmove : $xmove / ymove : $ymove\n"; 157 $movecount++; 158 } 159 $xmove = $xmove / $movecount if ($movecount); 160 $ymove = $ymove / $movecount if ($movecount); 161# warn "xmove : $xmove / ymove : $ymove\n"; 162 $node{$source}{x} -= $xmove; 163 $node{$source}{'y'} -= $ymove; 164 if ($xmove >= $done or $ymove >= $done) { 165 if ($xmove > $continue) { 166 $continue = $xmove; 167 } 168 if ($ymove > $continue) { 169 $continue = $ymove; 170 } 171 } 172 } 173 } 174 foreach my $source (keys %$nodes) { 175 foreach my $color ('r', 'g', 'b') { 176 $node{$source}{$color} = 255 unless (defined $node{$source}{$color}); 177 } 178 } 179 return \%node; 180} 181 182 183=head2 draw_graph 184 185outputs the graph as a png file either to the file specified by the filename or to STDOUT 186 187takes filename, hashref of nodes and list of edges 188 189draw_graph($filename,\%node,\%link); 190 191 192=cut 193 194sub draw_graph { 195 my ($filename,$nodes,$links) = @_; 196 &draw(1,$nodes,$links,filename=>$filename); 197 return; 198} 199 200=head1 Object Methods 201 202=head2 add_node 203 204adds a node to a graph 205 206takes the name of the node and any attributes such as label 207 208# just like GraphViz.pm :) 209$graph->add_node('Paris', label =>'City of Love'); 210 211=cut 212 213sub add_node { 214 my ($self,$name,%attributes) = @_; 215 ($attributes{height},$attributes{width}) = get_node_size($attributes{type},$attributes{label}||$name); 216 if ( ref $self->{nodes}{$name}) { 217 foreach (keys %attributes) { 218 $self->{nodes}{$name}{$_} = $attributes{$_}; 219 } 220 } else { 221 $self->{nodes}{$name} = { %attributes }; 222 } 223 $self->{nodes}{$name}{label} ||= $name; 224 $self->{nodes}{$name}{type} ||= 'plain'; 225 $self->{nodes}{$name}{name} = $name; 226 $self->{nodes}{$name}{weight} ||= 1; 227 228 ($self->{nodes}{$name}{height},$self->{nodes}{$name}{width}) = get_node_size($self->{nodes}{$name}{type},$self->{nodes}{$name}{label}); 229 230 return; 231} 232 233=head2 add_edge 234 235adds an edge to a graph 236 237takes the source and destination of the edge and 238attributes such as style (dotted or dashed), or 239if the line is directed or not 240 241$graph->add_edge('London' => 'New York', dir => 1, style=>'dashed'); 242 243=cut 244 245sub add_edge { 246 my ($self,$source,$dest,%attributes) = @_; 247 $self->add_node($source) unless ($self->{nodes}{$source}); 248 $self->add_node($dest) unless ($self->{nodes}{$dest}); 249 $self->{links}{$source}{$dest} = {%attributes}; 250 $self->{nodes}{$dest}{weight}++; 251 return; 252} 253 254 255=head2 as_png 256 257prints the image of the graph in PNG format 258 259takes an optional filename or outputs directly to STDOUT 260 261$graph->as_png($filename); 262 263=cut 264 265sub as_png { 266 my ($self,$filename) = @_; 267 calculate_graph($self->{nodes},$self->{links}); 268 draw(1,$self->{nodes},$self->{links},filename=>$filename); 269 return; 270} 271 272=head2 as_gd 273 274returns the GD image object of the graph 275 276my $gd_im = $graph->as_gd; 277 278=cut 279 280sub as_gd { 281 my $self = shift; 282 calculate_graph($self->{nodes},$self->{links}); 283 my $im = draw(1,$self->{nodes},$self->{links},gd=>1); 284 return $im; 285} 286 287=head2 as_gd 288 289returns the image of the graph in a string in the format specified or PNG 290 291my $graph_png = $graph->as_image('png'); 292 293=cut 294 295sub as_image { 296 my ($self,$format) = @_; 297 calculate_graph($self->{nodes},$self->{links}); 298 my $im = draw(1,$self->{nodes},$self->{links},image=>1,image_format=>$format); 299 return $im; 300} 301 302################################################################################ 303# internal functions 304 305sub draw { 306 my ($scale,$nodes,$links,%options) = @_; 307 my %node = %$nodes; 308 my %link = %$links; 309 310 my ($maxx,$maxy); 311 my ($minx,$miny); 312 my ($maxxlength,$minxlength); 313 my ($maxylength,$minylength); 314 my $margin = 20; 315 my $nodesize = 40; 316 my @point = (); 317 318 foreach my $nodename (keys %node) { 319# warn "getting maxx/minx for $nodename\n"; 320# warn Dumper($nodename=>$node{$nodename}); 321 if (!(defined $maxx) or (($node{$nodename}{x} + (length($node{$nodename}{'label'}) * 8 + 16)/2) > $maxx + (length($node{$nodename}{'label'}) * 8 + 16)/2)) { 322 $maxx = $node{$nodename}{x}; 323 $maxxlength = (length($node{$nodename}{'label'}) * 8 + 16)/2; 324 } 325 if (!(defined $minx) or (($node{$nodename}{x} - (length($node{$nodename}{'label'}) * 8 + 16)/2) < $minx - (length($node{$nodename}{'label'}) * 8 + 16)/2)) { 326 $minx = $node{$nodename}{x}; 327 $minxlength = (length($node{$nodename}{'label'}) * 8 + 16)/2; 328 } 329 330 $maxy = $node{$nodename}{'y'} if (!(defined $maxy) or $node{$nodename}{'y'} > $maxy); 331 $miny = $node{$nodename}{'y'} if (!(defined $miny) or $node{$nodename}{'y'} < $miny); 332 } 333 334 foreach my $nodename (keys %node) { 335 $node{$nodename}{x} = ($node{$nodename}{x} - $minx) * $scale + $minxlength -1 ; 336 $node{$nodename}{'y'} = ($node{$nodename}{'y'} - $miny) * $scale + $nodesize/2 - 1; 337 } 338 339 $maxx = (($maxx - $minx) * $scale + $minxlength + $maxxlength) * 1.25; 340 $maxy = (($maxy - $miny) * $scale + $nodesize/2*2 + 40) * 1.2; 341 my $im = new GD::Image($maxx,$maxy); 342 my $white = $im->colorAllocate(255,255,255); 343 my $blue = $im->colorAllocate(0,0,255); 344 my $powderblue = $im->colorAllocate(176,224,230); 345 my $black = $im->colorAllocate(0,0,0); 346 my $darkgrey = $im->colorAllocate(169,169,169); 347 $im->transparent($white); # make white transparent 348 349 foreach my $node (keys %node) { 350 my $color = $white; 351 if (defined $node{$node}{r} and defined $node{$node}{g} and defined $node{$node}{b}) { 352 $color = $im->colorResolve($node{$node}{r}, $node{$node}{g}, $node{$node}{b}); 353 } 354 if (defined $node{$node}{shape} and $node{$node}{shape} eq 'record') { 355 $node{$node}{boundary} = addRecordNode ($im,$node{$node}{x},$node{$node}{'y'},$node{$node}{'label'},$maxx,$maxy); 356 } else { 357 addPlainNode($im,$node{$node}{x},$node{$node}{'y'},$node{$node}{'label'}); 358 } 359 } 360 361 # draw lines 362 foreach my $source (keys %node) { 363 my ($topy,$boty) = ($node{$source}{'y'} -20,$node{$source}{'y'} + 20); 364 foreach my $dest (keys %{$link{$source}}) { 365# warn "source : $source / dest : $dest"; 366 my ($destx,$desty) = ($node{$dest}{x},$node{$dest}{'y'}) ; 367 my ($sourcex,$sourcey) = ($node{$source}{x}, ( $node{$source}{'y'} < $node{$dest}{'y'} ) ? $boty : $topy ); 368 my $colour = $darkgrey; 369 if ( defined $link{$source}{$dest}{style}) { 370 $im->setStyle( getLineStyle($link{$source}{$dest}{style},$colour) ); 371 $colour = gdStyled; 372 } 373 374 if (defined $node{$dest}{boundary}) { 375 $destx = ( $node{$source}{x} < $node{$dest}{x} ) 376 ? $node{$dest}{boundary}[0] : $node{$dest}{boundary}[2] ; 377 $desty = ( $node{$source}{'y'} < $node{$dest}{'y'} ) 378 ? $node{$dest}{boundary}[1] : $node{$dest}{boundary}[3] ; 379 } else { 380 $desty = $node{$dest}{'y'}; 381 382 } 383 384 # position start of line if source is record node 385 if ($node{$source}{width} and $node{$source}{shape} eq 'record') { 386# warn "source node $source is a record and has a width of $node{$source}{width}\n"; 387 my ($width,$height) = ($node{$source}{width},$node{$source}{height}); 388# warn "got width ($width) and height ($height) for source\n"; 389 if ($node{$source}{x} - ($height/2) < 0) { 390 $node{$source}{x} = 5 + $height/2; 391 } 392# warn "source node has x of $node{$source}{x} and y of $node{$source}{'y'}\n"; 393 my $ydiff = ( $desty - $node{$source}{'y'} ) ? $node{$source}{'y'} - $desty: $desty - $node{$source}{'y'}; 394 my $xdiff = ( $destx < $node{$source}{x} ) ? $node{$source}{x} - $destx : $destx - $node{$source}{x}; 395# warn "xdiff : $xdiff, ydiff : $ydiff\n"; 396 my $tan_theta = ($desty - $node{$source}{'y'}) / ( $destx - $node{$source}{x} ); 397# warn "got tan of angle : $tan_theta : which is ($desty - $node{$source}{y}) / ( $destx - $node{$source}{x} ) \n"; 398 399 400 my $xx = ( $node{$source}{x} > $destx) ? ( 0 - ($width / 2)) : ( 0 + ($width / 2)); 401 my $yy = ( $node{$source}{'y'} > $desty) ? ( 0 - ($height / 2)) : ( 0 + ($height / 2)); 402 403# warn "xx : $xx, yy : $yy\n"; 404 405 my $exitx = $yy / $tan_theta ; 406 407# warn "got exitx : $exitx\n"; 408 if (($xx > 0 and $exitx > $xx) or (($xx < 0) and $exitx < $xx) ) { 409 $tan_theta = ($destx - $node{$source}{x}) / ( $desty - $node{$source}{'y'} ); 410 my $exity = $xx / $tan_theta; 411# warn "got exity : $exity\n"; 412 $sourcex = $node{$source}{x} + $xx; 413 if ($xx > 0) { $sourcex+=2; } else { $sourcex-=2; } 414 $sourcey = int($node{$source}{'y'} + $exity); 415 } else { 416 $sourcex = int($node{$source}{x} + $exitx); 417 $sourcey = $node{$source}{'y'} + $yy; 418 if ($yy > 0) { $sourcey+=2; } else { $sourcey-=2; } 419 } 420# warn "sourcex : $sourcex / sourcey : $sourcey\n"; 421 422 } 423 # draw line 424 $im->line($sourcex,$sourcey, $destx, $desty, $colour); 425 unless (defined $node{$dest}{boundary}) { # cheat and redraw plain node over line 426 addPlainNode($im,$node{$dest}{x},$node{$dest}{'y'},$node{$dest}{'label'}); 427 } 428 429 # add arrowhead 430 if ($link{$source}{$dest}{dir}) { 431 addArrowHead ($im,$sourcex,$destx,$sourcey,$desty,$node{$dest}{shape},$node{$dest}{'label'}); 432 } 433 } 434 } 435 436 # output the image 437 if ($options{gd}) { 438 return $im; 439 } 440 if ($options{image}) { 441 if ($im->can($options{image_format})) { 442 my $format = $options{image_format}; 443 return $im->$format(); 444 } else { 445 return $im->png; 446 } 447 } 448 if ($options{filename}) { 449 open (OUTFILE,">$options{filename}") or die "couldn't open $options{filename} : $!\n"; 450 binmode OUTFILE; 451 print OUTFILE $im->png; 452 close OUTFILE; 453 } else { 454 binmode STDOUT; 455 print $im->png; 456 } 457 return; # maybe we should return something.. nah 458} 459 460 461sub addRecordNode { 462 my ($im,$x,$y,$string,$maxx,$maxy) = @_; 463 my $white = $im->colorAllocate(255,255,255); 464 my $blue = $im->colorAllocate(0,0,255); 465 my $powderblue = $im->colorAllocate(176,224,230); 466 my $black = $im->colorAllocate(0,0,0); 467 my $darkgrey = $im->colorAllocate(169,169,169); 468 my $red = $im->colorAllocate(255,0,0); 469 470 # split text on newline, or | 471 my @record_lines = split(/\s*([\n\|])\s*/,$string); 472 473 my $margin = 3; 474 my ($height,$width) = (0,0); 475 foreach my $line (@record_lines) { 476 LINE: { 477 if ($line eq '|') { 478 $height += 4; 479 last LINE; 480 } 481 if ($line eq "\n") { 482 last LINE; 483 } 484 $height += 18; 485 my $this_width = get_width($line); 486 $width = $this_width if ($width < $this_width ); 487 } # end of LINE 488 } 489 490 $height += $margin * 2; 491 $width += $margin * 2; 492 493 my $topx = $x - ($width / 2); 494 my $topy = $y - ($height / 2); 495 $topy = 5 if ($topy <= 0); 496 $topx = 5 if ($topx <= 0); 497 498 if (($topy + $height ) > $maxy) { 499 $topy = $maxy - $height; 500 } 501 502# warn "height : $height, width : $width, start x : $topx, start y : $topy\n"; 503 504 # notes (gdSmallFont): 505 # - 5px wide, 1px gap between words 506 # - 2px up, 2px down, 6px middle 507 508 $im->rectangle($topx,$topy,$topx+$width,$topy+$height,$black); 509 $im->fillToBorder($x, $y, $black, $white); 510 511 my ($curx,$cury) = ($topx + $margin, $topy + $margin); 512 foreach my $line (@record_lines) { 513 next if ($line =~ /\n/); 514# warn "line : $line \n"; 515 if ($line eq '|') { 516 $im->line($topx,$cury,$topx+$width,$cury,$black); 517 $cury += 4; 518 } else { 519 $im->string(gdLargeFont,$curx,$cury,$line,$black); 520 $cury += 18; 521 } 522# warn "current x : $curx, current y : $cury\n"; 523 } 524 525 # Put a black frame around the picture 526 my $boundary = [$topx,$topy,$topx+$width,$topy+$height]; 527 return $boundary; 528} 529 530sub get_width { 531# warn "get_width called with ", @_, "\n"; 532 my $string = shift; 533 my $width = ( length ($string) * 9) - 2; 534# warn "width : $width\n"; 535 return $width; 536} 537 538 539sub get_node_size { 540 my ($type,$string) = @_; 541 # split text on newline, or | 542 my ($height,$width); 543 if ( lc($type) eq 'record' ) { 544 my @record_lines = split(/\s*([\n\|])\s*/,$string); 545 my $margin = 3; 546 my ($height,$width) = (0,0); 547 foreach my $line (@record_lines) { 548 LINE: { 549 if ($line eq '|') { 550 $height += 4; 551 last LINE; 552 } 553 if ($line eq "\n") { 554 last LINE; 555 } 556 $height += 18; 557 my $this_width = get_width($line); 558 $width = $this_width if ($width < $this_width ); 559 } # end of LINE 560 } 561 562 $height += $margin * 2; 563 $width += $margin * 2; 564 } else { 565 my $longeststring = 1; 566 my @lines = split(/\s*\n\s*/,$string); 567 foreach (@lines) { 568 $longeststring = length($_) if (length($_) > $longeststring ); 569 } 570 $height = 40 + (18 * (scalar @lines - 1)); 571 $width = length($longeststring) * 8 + 16; 572 } 573 return ($height,$width); 574} 575 576sub addPlainNode { 577 my ($im,$x,$y,$string,$color) = @_; 578 my $white = $im->colorAllocate(255,255,255); 579 my $blue = $im->colorAllocate(0,0,255); 580 my $powderblue = $im->colorAllocate(176,224,230); 581 my $black = $im->colorAllocate(0,0,0); 582 my $darkgrey = $im->colorAllocate(169,169,169); 583 584 $color ||= $white; 585 $im->arc($x,$y,(length($string) * 8 + 16),40,0,360,$black); 586 $im->fillToBorder($x, $y, $black, $color); 587 $im->string( gdLargeFont, ($x - (length($string)) * 8 / 2), $y-8, $string, $black); 588 return; 589} 590 591 592sub addArrowHead { 593 my ($im,$sourcex,$destx,$sourcey,$desty,$nodetype,$nodetext) = @_; 594 my @point = (); 595 my $darkgrey = $im->colorAllocate(169,169,169); 596 my $white = $im->colorAllocate(255,255,255); 597 my $blue = $im->colorAllocate(0,0,255); 598 my $powderblue = $im->colorAllocate(176,224,230); 599 my $black = $im->colorAllocate(0,0,0); 600 my $red = $im->colorAllocate(255,0,0); 601 602 my $arrowlength = 10; # pixels 603 my $arrowwidth = 10; 604 my $height = (defined $nodetype and $nodetype eq 'record') ? 5 : 20 ; 605 my $width = (defined $nodetype and $nodetype eq 'record') ? 5 : (length($nodetext) * 8 + 16)/2;; 606 607 # I'm pythagorus^Wspartacus! 608 my $xdist = $sourcex - $destx; 609 my $ydist = $sourcey - $desty; 610 my $dist = sqrt( abs($xdist)**2 + abs($ydist)**2 ); 611 my $angle = &acos($xdist/$dist); 612 613 $dist = sqrt( ($height**2 * $width**2) / ( ($height**2 * (cos($angle)**2) ) + ($width**2 * (sin($angle)**2) ) )); 614 615 my ($x,$y); 616 my $xmove = cos($angle)*($dist+$arrowlength-3); 617 my $ymove = sin($angle)*($dist+$arrowlength-3); 618 619 if (defined $nodetype and $nodetype eq 'record') { 620 $point[2]{x} = $xmove; 621 $point[2]{'y'} = $ymove; 622 623 $dist = 4; 624 $xmove = $xmove + cos($angle)*$dist; 625 $ymove = $ymove + sin($angle)*$dist; 626 627 $angle = $angle + PI/2; 628 $dist = $arrowwidth/2; 629 $xmove = $xmove + cos($angle)*$dist; 630 $ymove = $ymove + sin($angle)*$dist; 631 632 $point[0]{x} = $xmove; 633 $point[0]{'y'} = $ymove; 634 635 $angle = $angle + PI; 636 $dist = $arrowwidth; 637 $xmove = $xmove + cos($angle)*$dist; 638 $ymove = $ymove + sin($angle)*$dist; 639 $point[1]{x} = $xmove; 640 $point[1]{'y'} = $ymove; 641 642 foreach my $num (0 .. 2) { 643 $point[$num]{'y'} = - $point[$num]{'y'} if $ydist < 0; 644 } 645 646 $im->line( $destx, $desty, $destx+$point[0]{x}, $desty+$point[0]{'y'}, $darkgrey ); 647 $im->line( $destx+$point[0]{x}, $desty+$point[0]{'y'}, $destx+$point[1]{x}, $desty+$point[1]{'y'}, $darkgrey ); 648 $im->line( $destx+$point[1]{x}, $desty+$point[1]{'y'},$destx, $desty, $darkgrey); 649 650 $x = int(($point[1]{x} + $point[0]{x}) / 2.5); 651 $y = int(($point[1]{'y'} + $point[0]{'y'}) / 2.5); 652 # $im->setPixel($destx + $x, $desty + $y, $red); 653 654 } else { 655 $dist = sqrt( abs($sourcex - $destx)**2 + abs($sourcey-$desty)**2 ); 656 $xdist = $sourcex - $destx; 657 $ydist = $sourcey - $desty; 658 $angle = &acos($xdist/$dist); 659 $dist = sqrt( ($height**2 * $width**2) / ( ($height**2 * (cos($angle)**2) ) + ($width**2 * (sin($angle)**2) ) )); 660 $xmove = cos($angle)*$dist; 661 $ymove = sin($angle)*$dist; 662 663 $point[0]{x} = $xmove; 664 $point[0]{'y'} = $ymove; 665 666 $xmove = cos($angle)*($dist+$arrowlength-3); 667 $ymove = sin($angle)*($dist+$arrowlength-3); 668 $point[3]{x} = $xmove; 669 $point[3]{'y'} = $ymove; 670 671 $dist = 4; 672 $xmove = $xmove + cos($angle)*$dist; 673 $ymove = $ymove + sin($angle)*$dist; 674 675 $angle = $angle + PI/2; 676 $dist = $arrowwidth/2; 677 $xmove = $xmove + cos($angle)*$dist; 678 $ymove = $ymove + sin($angle)*$dist; 679 680 $point[1]{x} = $xmove; 681 $point[1]{'y'} = $ymove; 682 $angle = $angle + PI; 683 $dist = $arrowwidth; 684 $xmove = $xmove + cos($angle)*$dist; 685 $ymove = $ymove + sin($angle)*$dist; 686 687 $point[2]{x} = $xmove; 688 $point[2]{'y'} = $ymove; 689 for my $num (0 .. 3) 690 { 691 $point[$num]{'y'} = - $point[$num]{'y'} if $ydist < 0; 692 } 693 $im->line($destx+$point[0]{x},$desty+$point[0]{'y'},$destx+$point[1]{x},$desty+$point[1]{'y'},$darkgrey); 694 $im->line($destx+$point[1]{x},$desty+$point[1]{'y'},$destx+$point[2]{x},$desty+$point[2]{'y'},$darkgrey); 695 $im->line($destx+$point[2]{x},$desty+$point[2]{'y'},$destx+$point[0]{x},$desty+$point[0]{'y'},$darkgrey); 696 697 $x = int(($point[0]{x} + $point[1]{x} + $point[2]{x}) / 3.1); 698 $y = int(($point[0]{'y'} + $point[1]{'y'} + $point[2]{'y'}) / 3.1); 699 } 700# $im->setPixel($destx + $x, $desty + $y, $red); 701 $im->fillToBorder($destx + $x, $desty + $y, $darkgrey, $darkgrey); 702 return; 703} 704 705sub getLineStyle { 706 my ($style,$colour) = (lc(shift),@_); 707 708 my @colors = (); 709 STYLE: { 710 if ($style eq 'dashed') { 711 @colors = ($colour,$colour,$colour,$colour,$colour,gdTransparent,gdTransparent); 712 last; 713 } 714 if ($style eq 'dotted') { 715 @colors = ($colour,$colour,gdTransparent,gdTransparent); 716 last; 717 } 718 warn "unrecognised line style : $style\n"; 719 } 720 return @colors; 721} 722 723# from perlfunc(1) 724sub acos { atan2( sqrt(1 - $_[0] * $_[0]), $_[0] ) } 725 726sub _position_nodes_in_tree { 727 my ($self,$nodes,$links) = @_; 728# warn "calculate_graph called with : ", @_, "\n"; 729 my %node = %$nodes; 730 my %link = %$links; 731 732 my @edges = (); 733 my @rows = (); 734 my @row_heights = (); 735 my @row_widths = (); 736 737 foreach my $nodename (keys %node) { 738# warn "handling node : $nodename\n"; 739 $node{$nodename}{label} ||= $nodename; 740 # count methods and attributes to give height 741 my @record_lines = split(/\s*([\n\|])\s*/,$node{$nodename}{label}); 742 my $margin = 3; 743 my ($height,$width) = (0,0); 744 foreach my $line (@record_lines) { 745 LINE: { 746 if ($line eq '|') { 747 $height += 4; 748 last LINE; 749 } 750 if ($line eq "\n") { 751 last LINE; 752 } 753 $height += 18; 754 my $this_width = get_width($line); 755 $width = $this_width if ($width < $this_width ); 756 } # end of LINE 757 } 758 759 $node{$nodename}{height} = $height; 760 $node{$nodename}{width} = $width; 761 $node{$nodename}{children} = []; 762 $node{$nodename}{parents} = []; 763 $node{$nodename}{center} = []; 764 $node{$nodename}{weight} = 0; 765 } 766 767# warn "getting links..\n"; 768 foreach my $source (keys %link) { 769# warn "source : $source\n"; 770 foreach my $dest (keys %{$link{$source}}) { 771# warn "dest : $dest\n"; 772# warn "dest node : $node{$dest} -- source node : $node{$source}\n"; 773 push (@edges, { to => $dest, from => $source }); 774 } 775 } 776 777 # first pass (build network of edges to and from each node) 778 foreach my $edge (@edges) { 779 my ($from,$to) = ($edge->{from},$edge->{to}); 780# warn "handling edge : $edge -- from : $from / to : $to\n"; 781 push(@{$node{$to}{parents}},$from); 782 push(@{$node{$from}{children}},$to); 783 } 784 785 # second pass (establish depth ( ie verticle placement of each node ) 786# warn "getting depths for nodes\n"; 787 foreach my $node (keys %node) { 788# warn ".. node : $node\n"; 789 my $depth = 0; 790 foreach my $parent (@{$node{$node}{parents}}) { 791# warn "parent : $parent\n"; 792 my $newdepth = get_depth($parent,$node,\%node); 793 $depth = $newdepth if ($depth < $newdepth); 794 } 795 $node{$node}{depth} = $depth; 796# warn "depth for node $node : $depth\n"; 797 push(@{$rows[$depth]},$node) 798 } 799 800 # calculate height and width of diagram in discrete steps 801 my $i = 0; 802 my $widest_row = 0; 803 my $total_height = 0; 804 my $total_width = 0; 805 my @fixedrows = (); 806 foreach my $row (@rows) { 807 unless (ref $row) { $row = []; next } 808 my $tallest_node_height = 0; 809 my $widest_node_width = 0; 810 $widest_row = scalar @$row if ( scalar @$row > $widest_row ); 811 my @newrow = (); 812# warn Dumper(ThisRow=>$row); 813 foreach my $node (@$row) { 814# warn " adding $node node to row \n"; 815 next unless (defined $node && defined $node{$node}); 816 $tallest_node_height = $node{$node}{height} if ($node{$node}{height} > $tallest_node_height); 817 $widest_node_width = $node{$node}{width} if ($node{$node}{width} > $widest_node_width); 818 push (@newrow,$node); 819 } 820 push(@fixedrows,\@newrow); 821 $row_heights[$i] = $tallest_node_height + 0.5; 822 $row_widths[$i] = $widest_node_width; 823 $total_height += $tallest_node_height + 0.5 ; 824 $total_width += $widest_node_width; 825 $i++; 826 } 827 @rows = @fixedrows; 828 829 # prepare table of available positions 830 my @positions; 831 foreach (@rows) { 832 my %available; 833 @available{(0 .. ($widest_row + 1))} = 1 x ($widest_row + 1); 834 push (@positions,\%available); 835 } 836 837 my %done = (); 838 $self->{_dia_done} = \%done; 839 $self->{_dia_nodes} = \%node; 840 $self->{_dia_positions} = \@positions; 841 $self->{_dia_rows} = \@rows; 842 $self->{_dia_row_heights} = \@row_heights; 843 $self->{_dia_row_widths} = \@row_widths; 844 $self->{_dia_total_height} = $total_height; 845 $self->{_dia_total_width} = $total_width; 846 $self->{_dia_widest_row} = $widest_row; 847 848 # 849 # plot (relative) position of nodes (left to right, follow branch) 850 my $side; 851 return 0 unless (ref $rows[0]); 852 853 my $row_count = 0; 854 foreach my $row (@rows) { 855 my @thisrow = sort {$node{$b}{weight} <=> $node{$a}{weight} } @{$row}; 856 unshift (@thisrow, pop(@thisrow)) unless (scalar @thisrow < 3); 857 my $increment = $widest_row / ((scalar @thisrow || scalar $rows[$row_count + 1]) + 1 ); 858 my $pos = $increment; 859# warn "widest_row : $widest_row // pos : $pos // incremenet : $increment\n"; 860# warn "total height : $self->{_dia_total_height}\n"; 861 my $y = 40 + ( ( $self->{_dia_total_height} / 2) - 5 ); 862 863 foreach my $node ( @thisrow ) { 864 next if ($self->{_dia_done}{$node}); 865# warn "handling node ($node) in row $row_count \n"; 866# warn "( $self->{_dia_row_widths}[$row_count] * $self->{_dia_widest_row} / 2) + ($pos * $self->{_dia_row_widths}[$row_count])\n"; 867 my $x = ($self->{_dia_row_widths}[$row_count] * $self->{_dia_widest_row} / 2) + ($pos * $self->{_dia_row_widths}[$row_count]); 868 $node{$node}{x} = $x; 869 $node{$node}{'y'} = $y; 870# warn Dumper(nodex=>$node{$node}{x},nodey=>$node{$node}{'y'}); 871 if (ref $rows[$row_count + 1] && scalar @{$node{$node}{children}} && scalar @{$rows[$row_count + 1]}) { 872 my @sorted_children = sort { 873 $node{$b}{weight} <=> $node{$a}{weight} 874 } @{$node{$node}{children}}; 875 unshift (@sorted_children, pop(@sorted_children)); 876 my $child_increment = $widest_row / (scalar @{$rows[$row_count + 1]}); 877# warn "child_increment : $child_increment = $widest_row / ".scalar @{$rows[$row_count + 1]}."\n"; 878 my $childpos = $child_increment; 879 foreach my $child (@sorted_children) { 880# warn "child : $child\n"; 881 next unless ($child); 882 my $side; 883 if ($childpos <= ( $widest_row * 0.385 ) ) { 884 $side = 'left'; 885 } elsif ( $childpos <= ($widest_row * 0.615 ) ) { 886 $side = 'center'; 887 } else { 888 $side = 'right'; 889 } 890 plot_branch($self,$node{$child},$childpos,$side); 891 $childpos += $child_increment; 892 } 893 } 894 $node{$node}{pos} = $pos; 895# warn "position for node $node : $pos\n"; 896 $pos += $increment; 897 $self->{_dia_done}{$node} = 1; 898 } 899 } 900 return \%node; 901} 902 903# 904## Functions used by _layout_dia_new method 905# 906 907# recursively calculate the depth of a node by following edges to its parents 908sub get_depth { 909 my ($node,$child,$nodes) = @_; 910 my $depth = 0; 911 $nodes->{$node}{weight}++; 912 if (exists $nodes->{$node}{depth}) { 913 $depth = $nodes->{$node}{depth} + 1; 914 } else { 915 $nodes->{$node}{depth} = 1; 916 my @parents = @{$nodes->{$node}{parents}}; 917 if (scalar @parents > 0) { 918 foreach my $parent (@parents) { 919 my $newdepth = get_depth($parent,$node,$nodes); 920 $depth = $newdepth if ($depth < $newdepth); 921 } 922 $depth++; 923 } else { 924# $depth = 1; 925 $nodes->{$node}{depth} = 0; 926 } 927 } 928 return $depth; 929} 930 931# recursively plot the branches of a tree 932sub plot_branch { 933 my ($self,$node,$pos,$side) = @_; 934# warn "plotting branch : $node->{label} , $pos, $side\n"; 935 936 my $depth = $node->{depth}; 937# warn "depth : $depth\n"; 938 my $offset = rand(40); 939 my $h = 0; 940 while ( $h < $depth ) { 941# warn "row $h height : $self->{_dia_row_heights}[$h]\n"; 942 $offset += ($self->{_dia_row_heights}[$h++] || 40 ) + 10; 943# warn "offset now $offset\n"; 944 } 945 946 # warn Dumper(node=>$node); 947 my ($parents,$children) = ($node->{parents},$node->{children}); 948 if ( $self->{_dia_done}{$node->{name}} && (scalar @$children < 1) ) { 949 if (scalar @$parents > 1 ) { 950 $self->{_dia_done}{$node}++; 951 my $sum = 0; 952 foreach my $parent (@$parents) { 953# warn "[ plot branch ] parent : $parent \n"; 954 return 0 unless (exists $self->{_dia_nodes}{$parent}{pos}); 955 $sum += $self->{_dia_nodes}{$parent}{pos}; 956 } 957 $self->{_dia_positions}[$depth]{int($pos)} = 1; 958 my $newpos = ( $sum / scalar @$parents ); 959 unless (exists $self->{_dia_positions}[$depth]{int($newpos)}) { 960 # use wherever is free if position already taken 961 my $best_available = $pos; 962 my $diff = ($best_available > $newpos ) 963 ? $best_available - $newpos : $newpos - $best_available ; 964 foreach my $available (keys %{$self->{_dia_positions}[$depth]}) { 965 my $newdiff = ($available > $newpos ) ? $available - $newpos : $newpos - $available ; 966 if ($newdiff < $diff) { 967 $best_available = $available; 968 $diff = $newdiff; 969 } 970 } 971 $pos = $best_available; 972 } else { 973 $pos = $newpos; 974 } 975 } 976 my $y = 40 + ( ( $self->{_dia_total_height} / 2) - 4 ) + $offset; 977# print "y : $y\n"; 978 my $x = ( $self->{_dia_row_widths}[$depth] * $self->{_dia_widest_row} / 2) 979 + ($pos * $self->{_dia_row_widths}[$depth]); 980 # my $x = 0 - ( $self->{_dia_widest_row} / 2) + ($pos * $self->{_dia_row_widths}[$depth]); 981 $node->{x} = int($x); 982 $node->{'y'} = int($y); 983 $node->{pos} = $pos; 984 delete $self->{_dia_positions}[$depth]{int($pos)}; 985 return 0; 986 } elsif ($self->{_dia_done}{$node}) { 987 return 0; 988 } 989 990 unless (exists $self->{_dia_positions}[$depth]{int($pos)}) { 991 my $best_available; 992 my $diff = $self->{_dia_widest_row} + 5; 993 foreach my $available (keys %{$self->{_dia_positions}[$depth]}) { 994 $best_available ||= $available; 995 my $newdiff = ($available > $pos ) ? $available - $pos : $pos - $available ; 996 if ($newdiff < $diff) { 997 $best_available = $available; 998 $diff = $newdiff; 999 } 1000 } 1001 $pos = $best_available; 1002 } 1003 1004 delete $self->{_dia_positions}[$depth]{int($pos)}; 1005 1006 my $y = 15 + rand(15) + ( ( $self->{_dia_total_height} / 2) - 1 ) + $offset; 1007 my $x = 0 + ( $self->{_dia_row_widths}[0] * $self->{_dia_widest_row} / 2) 1008 + ($pos * $self->{_dia_row_widths}[0]); 1009 # my $x = 0 - ( $self->{_dia_widest_row} / 2) + ($pos * $self->{_dia_row_widths}[$depth]); 1010 # my $x = 0 - ( ( $pos * $self->{_dia_row_widths}[0] ) / 2); 1011 $node->{x} = int($x); 1012 $node->{'y'} = int($y); 1013 1014 $self->{_dia_done}{$node} = 1; 1015 $node->{pos} = $pos; 1016 1017 if (scalar @{$node->{children}}) { 1018 my @sorted_children = sort { 1019 $self->{_dia_nodes}{$b}{weight} <=> $self->{_dia_nodes}{$a}{weight} 1020 } @{$node->{children}}; 1021 unshift (@sorted_children, pop(@sorted_children)); 1022 my $child_increment = (ref $self->{_dia_rows}[$depth + 1]) ? $self->{_dia_widest_row} / (scalar @{$self->{_dia_rows}[$depth + 1]}): 0 ; 1023 my $childpos = 0; 1024 if ( $side eq 'left' ) { 1025 $childpos = 0 1026 } elsif ( $side eq 'center' ) { 1027 $childpos = $pos; 1028 } else { 1029 $childpos = $pos + $child_increment; 1030 } 1031 foreach my $child (@{$node->{children}}) { 1032 $childpos += $child_increment if (plot_branch($self,$self->{_dia_nodes}{$child},$childpos,$side)); 1033 } 1034 } elsif ( scalar @$parents == 1 ) { 1035 my $y = 0 + ( ( $self->{_dia_total_height} / 2) - 1 ) + $offset; 1036 my $x = 0 + ( $self->{_dia_row_widths}[0] * $self->{_dia_widest_row} / 2) 1037 + ($pos * $self->{_dia_row_widths}[0]); 1038 # my $x = 0 - ( $self->{_dia_widest_row} / 2) + ($pos * $self->{_dia_row_widths}[$depth]); 1039 # my $x = 0 - ( ( $pos * $self->{_dia_row_widths}[0] ) / 2); 1040 $node->{x} = int($x); 1041 $node->{'y'} = int($y); 1042 } 1043 return 1; 1044} 1045 1046 1047############################################################ 1048 1049=head1 SEE ALSO 1050 1051GraphViz 1052 1053springgraph.pl 1054 1055http://www.chaosreigns.com/code/springgraph/ 1056 1057GD 1058 1059=head1 AUTHOR 1060 1061Aaron Trevena, based on original script by 'Darxus' 1062 1063=head1 COPYRIGHT 1064 1065Original Copyright 2002 Darxus AT ChaosReigns DOT com 1066 1067Amendments and further development copyright 2004 Aaron Trevena 1068 1069This software is free software. It is made available and licensed under the GNU GPL. 1070 1071=cut 1072 1073################################################################################ 1074 10751; 1076 1077