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