#!/usr/bin/perl
use strict;
use warnings;

=head1 NAME

path - Find shortest path between two people in a Redland store.

=head1 SYNOPSIS

 path nick kasei nick libby # find shortest path between two people by nickname
 path mbox greg@evilfunhouse.com nick libby # with one mbox
 path sha1 f80a0f19d2a0897b89f48647b2fb5ca1f0bc1cb8 nick libby # with one mbox_sha1
 path name 'Gregory Williams' nick libby # with name
 path type knows nick kasei nick libby # this is the default
 path type codepiction nick kasei nick libby # by image foaf:depicts

=cut

use DBI;
use Encode;
use RDF::Redland;
use Data::Dumper;
use Carp qw(carp confess);
use Digest::SHA1 qw(sha1_hex);

binmode( \*STDOUT, ':utf8' );
our $debug		= 0;
my $long		= 0;
my $MAXDEPTH	= 5;
my $name		= 'scutter';
my $database	= 'greg';
my $user		= 'greg';
my $pass		= 'xxxxxxxx';
my $storage		= new RDF::Redland::Storage("mysql", $name, qq(host='localhost',database='${database}',user='${user}',password='${pass}',contexts='yes'));
my $model		= new RDF::Redland::Model($storage, "");
my $dbh			= DBI->connect( "DBI:mysql:database=${database}", $user, $pass );



my $getarcs		= \&get_knows_arcs;
my $reltype;
if ($ARGV[0] eq 'type') {
	(undef, my $type)	= splice(@ARGV,0,2,());
	my %map	= (
				knows		=> [ \&get_knows_arcs, 'K' ],
				codepiction	=> [ \&get_photo_arcs, 'C' ],
				photo		=> [ \&get_photo_arcs, 'C' ]
			);
	if (exists($map{ $type })) {
		$getarcs	= $map{ $type }[0];
		$reltype	= $map{ $type }[1];
	}
}

my ($ftype, $fdata)	= splice(@ARGV,0,2,());
my $from	= [ get_people( $model, $ftype, $fdata ) ];	# array of people that match the from criteria
my ($type, $data)	= splice(@ARGV,0,2,());
my $to		= [ get_people( $model, $type, $data ) ];	# array of people that match the to criteria

if ($from and $to and scalar @{ $to }) {
	printf("From : %-30s\n", $fdata);
	printf("To   : %-30s\n\n", $data);
	
	my @paths;
	if ($long) {
		@paths	= grep ref, shortest_path( $dbh, $model, $from, $to, $getarcs, $reltype );
	} else {
		@paths	= grep ref, scalar( shortest_path( $dbh, $model, $from, $to, $getarcs, $reltype ) );
	}
	foreach my $path (@paths) {
		print path_as_string( $model, $path ) . "\n";
	}
} else {
	print "Need two people.\n";
}

######################################################################

sub shortest_path {
	my $dbh		= shift;
	my $model	= shift;
	my $froms	= shift;
	my $tos		= shift;
	my $getarcs	= shift;
	my $reltype	= shift;
	
	foreach my $from (@{ UNIVERSAL::isa($froms, 'ARRAY') ? $froms : [$froms] }) {
		warn "From: " . $from->as_string . "\n" if ($debug);
		my @stack	= ([$from, [[$from, get_name($model, $from)."\n"]]]);
		foreach my $to (@{ UNIVERSAL::isa($tos, 'ARRAY') ? $tos : [$tos] }) {
			warn "To: " . $to->as_string . "\n" if ($debug);
			my @paths;
			if (@paths = get_cached( $dbh, $model, $from, $to, $reltype )) {
				return (wantarray) ? @paths : $paths[0];
			} else {
				my $dist;
				my %seen;
				OUTER: while (my $data = shift(@stack)) {
					my ($current, $path)	= @{ $data };
					my @arcs	= $getarcs->( $model, $current );
					foreach my $arcdata (@arcs) {
						my ($node, $label)	= @{ $arcdata };
						next if ($seen{ $node->as_string }++);
						my $newpath		= [@{ $path }, $arcdata];
						if (@paths and $dist < scalar(@{ $newpath })) {
							last OUTER;
						}
						print "Trying " . path_as_string( $model, $newpath ) . "\n" if ($debug);
						if ($node->equals($to)) {
							print "*** Found shortest path!\n" if ($debug);
							unshift(@paths, $newpath);
							unless (wantarray) {
								last OUTER;
							}
							$dist	= scalar(@{ $newpath });
						}
						cache_path( $dbh, $model, $from, $newpath, $reltype );
						push(@stack, [$node, $newpath]) unless (scalar(@{ $newpath }) == $MAXDEPTH);
					}
				}
			}
			
			if (@paths) {
				return (wantarray) ? @paths : $paths[0];
			}
		}
	}
}

sub get_knows_arcs {
	my $model	= shift;
	my $node	= shift;
	my @out		= $model->targets($node, RDF::Redland::Node->new_from_uri( 'http://xmlns.com/foaf/0.1/knows' ));
	my @in		= $model->sources(RDF::Redland::Node->new_from_uri( 'http://xmlns.com/foaf/0.1/knows' ), $node);
	return map { [ $_, get_name( $model, $_ ) ] } (@out, @in);
}

sub get_photo_arcs {
	my $model	= shift;
	my $node	= shift;
	
	my %seen;
	my @arcs;
	my @images	= $model->sources(RDF::Redland::Node->new_from_uri( 'http://xmlns.com/foaf/0.1/depicts' ), $node);
	foreach my $image (@images) {
		next unless $image->is_resource;
		my @people	= $model->targets($image, RDF::Redland::Node->new_from_uri( 'http://xmlns.com/foaf/0.1/depicts' ));
		foreach my $person (@people) {
			no warnings 'qw';
			next unless ($seen{ $person->as_string }++);
			next unless $model->contains_statement( RDF::Redland::Statement->new( $person, map { RDF::Redland::Node->new_from_uri($_) } qw(http://www.w3.org/1999/02/22-rdf-syntax-ns#type http://xmlns.com/foaf/0.1/Person) ) );
			push(@arcs, [ $person, join(' ', get_name( $model, $person ), $image->as_string) . "\n" ]);
		}
	}
	return @arcs;
}

sub get_name {
	my $model	= shift;
	my $node	= shift;
	my $name	= get_first_literal( $model, $node, [qw(http://xmlns.com/foaf/0.1/name http://xmlns.com/foaf/0.1/nick http://xmlns.com/foaf/0.1/firstName)] )
				|| $node->as_string;
	return $name;
}

sub get_people {
	my $model	= shift;
	my $type	= shift;
	my $data	= shift;
	my $person;
	if ($type eq 'nick') {
		my @people	= $model->sources( RDF::Redland::Node->new_from_uri( "http://xmlns.com/foaf/0.1/nick" ), RDF::Redland::Node->new( $data ) );
		push( @people, $model->sources( RDF::Redland::Node->new_from_uri( "http://xmlns.com/foaf/0.1/nick" ), RDF::Redland::Node->new_literal( $data, undef, 'en' ) ) );
		return @people;
	} elsif ($type eq 'name') {
		my @people	= $model->sources( RDF::Redland::Node->new_from_uri( "http://xmlns.com/foaf/0.1/name" ), RDF::Redland::Node->new( $data ) );
		push( @people, $model->sources( RDF::Redland::Node->new_from_uri( "http://xmlns.com/foaf/0.1/name" ), RDF::Redland::Node->new_literal( $data, undef, 'en' ) ) );
		return @people;
	} elsif ($type eq 'mbox') {
		$data		= "mailto:${data}" unless ($data =~ /^mailto:/);
		my $sha		= sha1_hex( $data );
		my @people	= $model->sources( RDF::Redland::Node->new_from_uri( "http://xmlns.com/foaf/0.1/mbox" ), RDF::Redland::Node->new_from_uri( $data ) );
		my %seen	= map { $_->as_string => 1 } @people;
		push( @people, grep { not $seen{ $_->as_string } } $model->sources( RDF::Redland::Node->new_from_uri( "http://xmlns.com/foaf/0.1/mbox_sha1sum" ), RDF::Redland::Node->new( $sha ) ) );
		return @people;
	} elsif ($type =~ /sha/) {
		my @people	= $model->sources( RDF::Redland::Node->new_from_uri( "http://xmlns.com/foaf/0.1/mbox_sha1sum" ), RDF::Redland::Node->new( $data ) );
		return @people;
	} else {
		return undef;
	}
}

sub path_as_string {
	my $model	= shift;
	my $path	= shift;
	my @path	= ();
	foreach my $data (@{ $path }) {
		my ($node, $label)	= @{ $data };
		$label	||= get_name( $model, $node );
		push(@path, $label);
	}
	return scalar(@path) ? join(' -> ', @path) : "No path";
}

sub get_cached {
	my $dbh		= shift;
	my $model	= shift;
	my $from	= shift;
	my $to		= shift;
	my $reltype	= shift;
	my @paths;
	my (@ids)	= map { get_node_id( $dbh, $_ ) } ($from, $to);
	my $sth		= $dbh->prepare( 'SELECT id FROM path_paths WHERE fromnode = ? AND tonode = ? and type = ?' );
	$sth->execute( @ids, $reltype );
	my $arcs	= $dbh->prepare( 'SELECT pn.node, pa.label FROM path_arcs pa, path_nodes pn WHERE pa.pathid = ? AND pn.id = pa.nodeid ORDER BY pa.seq ASC;' );
	while (my ($pathid) = $sth->fetchrow_array) {
		$arcs->execute( $pathid );
		my @path;
		while (my $data = $arcs->fetchrow_arrayref) {
			my $node	= parse_node( $data->[0] );
			push(@path, [$node, $data->[1]]);
		}
		push(@paths, \@path);
	}
	return @paths;
}

sub cache_path {
	my $dbh		= shift;
	my $model	= shift;
	my $from	= shift;
	my $path	= shift;
	my $type	= shift;
	my $to		= $path->[ $#{ $path } ][0];
	my (@ids)	= map { get_node_id( $dbh, $_ ) } ($from, $to);
	my $sth		= $dbh->prepare( 'SELECT id FROM path_paths WHERE fromnode = ? AND tonode = ? and type = ?' );
	$sth->execute( @ids, $type );
	unless ($sth->fetchrow_arrayref) {
		my $sth		= $dbh->prepare( 'INSERT INTO path_paths (fromnode, tonode, type) VALUES (?,?,?)' );
		$sth->execute( @ids, $type );
		my $pathid	= $dbh->{mysql_insertid};
		
		my $seq		= 1;
		my $insert	= $dbh->prepare( 'INSERT INTO path_arcs (pathid, seq, nodeid, label) VALUES (?,?,?,?)' );
		foreach my $data (@{ $path }) {
			my ($node, $label)	= @{ $data };
			my $nodeid	= get_node_id( $dbh, $node );
			$insert->execute( $pathid, $seq, $nodeid, $label );
		} continue { $seq++ }
		my $update	= $dbh->prepare( 'UPDATE path_paths SET pathlen = ? WHERE id = ?' );
		$update->execute( $seq, $pathid );
		if (scalar(@{ $path }) > 1) {
			my @path	= @{ $path };
			my $last	= pop( @path );
			cache_path( $dbh, $model, $from, \@path, $type );
			push( @path, $last );
			my $first	= shift( @path );
			cache_path( $dbh, $model, $first->[0], \@path, $type );
		}
	}
}

sub get_node_id {
	my $dbh		= shift;
	my $node	= shift;
	my $str		= $node->as_string;
	my $sth		= $dbh->prepare( 'SELECT id FROM path_nodes WHERE node = ?' );
	$sth->execute( $str );
	my ($id)	= $sth->fetchrow_array;
	unless ($id) {
		my $type	= ($node->is_literal) ? 'L' : ($node->is_resource) ? 'R' : 'B';
		my $sth		= $dbh->prepare( 'INSERT INTO path_nodes (node,type) VALUES (?,?)' );
		$sth->execute( $str, $type );
		$id			= $dbh->{mysql_insertid};
	}
	return $id;
}

sub get_first_literal {
	my $node	= get_first_obj( @_ );
	return $node ? decode('utf8', $node->literal_value) : undef;
}

sub get_first_obj {
	my $model	= shift;
	my $node	= shift;
	my $uri		= shift;
	my @uris	= UNIVERSAL::isa($uri, 'ARRAY') ? @{ $uri } : ($uri);
	my @preds	= map { ref($_) ? $_ : RDF::Redland::Node->new_from_uri( $_ ) } @uris;
	foreach my $pred (@preds) {
		my $targets	= $model->targets_iterator( $node, $pred );
		while ($targets and !$targets->end) {
			my $node	= $targets->current;
			return $node if ($node);
		} continue { $targets->next }
	}
}

sub parse_node {
	$_			= shift;
	my $lang	= shift;
	if (/^\[(.*)\]$/) {
		return RDF::Redland::Node->new_from_uri( $1 );
	} elsif (/^\((.*)\)$/) {
		return RDF::Redland::Node->new_from_blank_identifier( $1 );
	} elsif (/^"(.*)"$/ or /^'(.*)'$/) {
		if ($lang) {
			return RDF::Redland::Node->new_literal( $1, undef, $lang );
		} else {
			return RDF::Redland::Node->new( $1 );
		}
	} else {
		warn "Can't work with data: '$_'" if ($debug);
		return undef;
	}
	
}

__END__

