File Coverage

blib/lib/Graph/Fast.pm

Criterion	Covered	Total	%
statement	103	120	85.8
branch	14	24	58.3
condition	11	14	78.5
subroutine	19	20	95.0
pod	8	12	66.6
total	155	190	81.5

package Graph::Fast;

use strict;
use warnings;
use 5.010;

our $VERSION = "0.02";

use Data::Dumper;
use Storable qw(dclone);
use List::Util qw(min);

use Hash::PriorityQueue;

sub new {
	my ($class, %args) = @_;
	my $queue_maker = exists($args{queue_maker}) ? $args{queue_maker} : sub { Hash::PriorityQueue->new() };
	return bless({
		vertices => {},
		edges => [],
		_queue_maker => $queue_maker,
	}, $class);
}

sub count_edges {
	my ($self) = @_;
	return scalar(@{$self->{edges}});
}

sub count_vertices {
	my ($self) = @_;
	return scalar(keys(%{$self->{vertices}}));
}

sub add_vertex {
	my ($self, $name) = @_;

	if (!exists($self->{vertices}->{$name})) {
		$self->{vertices}->{$name} = { name => $name, edges_in => {}, edges_out => {} };
	}
	return $self->{vertices}->{$name};
}

sub del_vertex {
	my ($self, $name) = @_;

	if (exists($self->{vertices}->{$name})) {
		@{$self->{edges}} = grep { $_->{from} ne $name and $_->{to} ne $name } @{$self->{edges}};
		foreach my $in_edge (keys %{$self->{vertices}->{$name}->{edges_in}}) {
			delete($self->{vertices}->{$in_edge}->{edges_out}->{$name});
		}
		foreach my $out_edge (keys %{$self->{vertices}->{$name}->{edges_out}}) {
			delete($self->{vertices}->{$out_edge}->{edges_in}->{$name});
		}
		delete($self->{vertices}->{$name});
	}
}

sub dijkstra_worker {
	my ($self, $from, $to) = @_;

	my $vert = $self->{vertices};
	my $suboptimal = $self->{_queue_maker}->();
	$suboptimal->insert($_, $self->{d_suboptimal}->{$_}) foreach (keys(%{$self->{d_suboptimal}}));
	$self->{d_dist}->{$_} = -1 foreach (@{$self->{d_unvisited}});
	$self->{d_dist}->{$from} = 0;

	while (1) {
		# find the smallest unvisited node
		my $current = $suboptimal->pop() // last;

		# update all neighbors
		foreach my $edge (values %{$vert->{$current}->{edges_out}}) {
			if (($self->{d_dist}->{$edge->{to}} == -1) ||
			($self->{d_dist}->{$edge->{to}} > ($self->{d_dist}->{$current} + $edge->{weight}) )) {
				$suboptimal->update(
					$edge->{to},
					$self->{d_dist}->{$edge->{to}} = $self->{d_dist}->{$current} + $edge->{weight}
				);
			}
		}
	}

	# trace the path from the destination to the start
	my @path = ();
	my $current = $to;
	NODE: while ($current ne $from) {
		foreach my $edge (values %{$vert->{$current}->{edges_in}}) {
			if ($self->{d_dist}->{$current} == $self->{d_dist}->{$edge->{from}} + $edge->{weight}) {
				$current = $edge->{from};
				unshift(@path, $edge);
				next NODE;
			}
		}
		# getting here means we found no predecessor - there is none.
		# so there's no path.
		return ();
	}

	return @path;
}

sub dijkstra_first {
	my ($self, $from, $to) = @_;
	$self->{d_from} = $from;
	$self->{d_dist} = {};
	$self->{d_unvisited}  = [ grep { $_ ne $from } keys(%{$self->{vertices}}) ];
	$self->{d_suboptimal} = { $from => 0 };

	dijkstra_worker($self, $from, $to);
}

sub dijkstra_continue {
	my ($self, $from, $to, $del_to) = @_;
	# instead of reinitializing, it should invoke the worker after initializing
	# to a state that assumes that an edge to $del_to has just been deleted.
	goto &dijkstra_first;
}

sub dijkstra {
	my ($self, $from, $to, $del_to) = @_;
	if (!defined($self->{d_from}) or $self->{d_from} ne $from) {
		goto &dijkstra_first;
	} else {
		goto &dijkstra_continue;
	}
}

sub recursive_dijkstra {
	my ($self, $from, $to, $level, $del_to) = @_;
	my @d = ([ $self->dijkstra($from, $to, $del_to) ]);

	if (!defined($d[0]->[0])) {
		return ();
	}

	if ($level > 0) {
		foreach (0..(@{$d[0]}-1)) {
			# from copies of the graph, remove one edge from the result path,
			# and continue finding paths on that tree.
			my $ffffuuuu = $self->{_queue_maker};
			$self->{_queue_maker} = "omg";
			my $g2 = dclone($self);
			$g2->{_queue_maker} = $self->{_queue_maker} = $ffffuuuu;

			$g2->del_edge($d[0]->[$_]->{from}, $d[0]->[$_]->{to});
			my @new = $g2->recursive_dijkstra($from, $to, $level - 1, $d[0]->[$_]->{to});

			# add all new paths, unless they are already present in the result set
			foreach my $n (@new) {
				push(@d, $n) unless (grep { $n ~~ $_ } @d);
			}
		}
	}

	@d;
}

sub add_edge {
	my ($self, $from, $to, $weight, $user_data) = @_;
	$self->del_edge($from => $to);

	my $edge = { from => $from, to => $to, weight => $weight, (defined($user_data) ? (user_data => $user_data) : ()) };

	push(@{$self->{edges}}, $edge);
	($self->{vertices}->{$from} // $self->add_vertex($from))->{edges_out}->{$to}   = $edge;
	($self->{vertices}->{$to  } // $self->add_vertex($to  ))->{edges_in }->{$from} = $edge;
}

sub del_edge {
	my ($self, $from, $to) = @_;

	# find the edge. assume it only exists once -> only delete the first.
	# while we're at it, delete the edge from the source vertex...
	my $e = $self->{vertices}->{$from}->{edges_out}->{$to};
	return undef if (!defined($e));
	delete($self->{vertices}->{$from}->{edges_out}->{$to});

	# now search it in the destination vertex' list, delete it there
	# also only delete the first matching one here (though now there
	# shouldn't be any duplicates at all because now we're matching the
	# actual edge, not just its endpoints like above.
	delete($self->{vertices}->{$to}->{edges_in}->{$from});

	# and remove it from the graph's vertex list
	@{$self->{edges}} = grep { $_ != $e } @{$self->{edges}}
}

1;

__END__