Algorithm-SixDegrees
view release on metacpan or search on metacpan
(15 years in beta should be enough...?)
0.03 Sun Mar 6 16:45:23 CST 2005 (svn r29)
[ENHANCEMENTS]
Added support for additional arguments to subroutines.
Added simple test for argument support.
Added Build.PL support.
0.02 Thu Mar 3 20:50:00 CST 2005 (svn r21)
[ENHANCEMENTS]
Added error() method.
Optimized the two-source case where the starting and ending
element share a common relationship.
Added two samples.
Made some error messages more descriptive.
Improved documentation.
Added extra test: t/errors.t
Improved test coverage in other tests
[BUGS]
Fixed an issue where the origin keys were polluting internal
tables when an alternate source was defined.
0.01 Sat Feb 5 00:57:45 CST 2005 (svn r6)
[NOTES]
First version, released on an unsuspecting world.
Build.PL
Changes
MANIFEST
Makefile.PL
README
lib/Algorithm/SixDegrees.pm
samples/ljc.pl
samples/movie.pl
t/00.load.t
t/errors.t
t/pod-coverage.t
t/pod.t
t/simple-1source.t
t/simple-2source.t
t/simple-2source-args.t
META.yml Module meta-data (added by MakeMaker)
META.json
lib/Algorithm/SixDegrees.pm view on Meta::CPAN
# If altsource exists, pull the left side main, then pull the right side main,
# and check for middle matches. This reduces database hits as opposed to
# where it's pulled left main - left alt; left alt >= 1 at that point, whereas
# right main on the first loop == 1. Following that, pull the left alt and
# then the right alt, which gets the CHAINLOOP back in synch.
if (defined($altsource)) {
my ($count,$id,$err) = $self->_match('left',$mainsource,$altsource,\%leftside,\%rightside);
if (defined($err)) { $ERROR = $err; return; };
if (defined($id)) { $ERROR = 'Internal error, id cannot match here'; return; };
return if !defined($count) || $count == 0;
($count,$id,$err) = $self->_match('right',$mainsource,$altsource,\%rightside,\%leftside);
if (defined($err)) { $ERROR = $err; return; };
if (defined($id)) {
my @abc = ($leftside{$altsource}{$id},$id,$rightside{$altsource}{$id});
return wantarray ? @abc : \@abc;
};
return if !defined($count) || $count == 0;
($leftcount,$id,$err) = $self->_match('left',$altsource,$mainsource,\%leftside,\%rightside);
if (defined($err)) { $ERROR = $err; return; };
if (defined($id)) { $ERROR = 'Internal error, id cannot match here'; return; };
return if !defined($leftcount) || $leftcount == 0;
($rightcount,$id,$err) = $self->_match('right',$altsource,$mainsource,\%rightside,\%leftside);
if (defined($err)) { $ERROR = $err; return; };
if (defined($id)) {
my $la = $leftside{$mainsource}{$id};
my $lm = $leftside{$altsource}{$la};
my $ra = $rightside{$mainsource}{$id};
my $rm = $rightside{$altsource}{$ra};
unless (defined($la) && defined($lm) && defined($ra) && defined($rm)) {
$ERROR = 'Internal error, identifier not defined';
return;
}
return wantarray ? ($lm,$la,$id,$ra,$rm) : [$lm,$la,$id,$ra,$rm];
};
return if !defined($rightcount) || $rightcount == 0;
}
# There is bias here, but the tie needs to be broken, so in the
# event of a tie, move left to right in the chain.
lib/Algorithm/SixDegrees.pm view on Meta::CPAN
if(defined($id)) {
# If _match returns an id, that means a match was found.
# To get it, we simply have to trace out from the "middle"
# to get the full link.
my @match = ($id);
# middle, building to left.
while($match[0] ne $start) {
unshift(@match,$leftside{$mainsource}{$match[0]});
unshift(@match,$leftside{$altsource}{$match[0]}) if defined($altsource);
if (!defined($match[0])) {
$ERROR = 'Internal error, left identifier was not defined';
return;
}
}
# middle building to right
while($match[-1] ne $end) {
push(@match,$rightside{$mainsource}{$match[-1]});
push(@match,$rightside{$altsource}{$match[-1]}) if defined($altsource);
if (!defined($match[-1])) {
$ERROR = 'Internal error, right identifier was not defined';
return;
}
}
return wantarray ? @match : \@match;
}
if ($leftcount == 0 || $rightcount == 0) {
last CHAINLOOP;
}
redo CHAINLOOP;
}
return wantarray ? () : [];
}
=head2 error
Returns the current value of C<$Algorithm::SixDegrees::ERROR>. See
L</SUBROUTINE RULES>.
=cut
sub error {
return $ERROR;
}
sub _match_two {
my ($self,$side,$mainsource,$altsource,$thisside,$thatside) = @_;
# Assume $self is OK since this is an internal function
my ($count,$id,$err) = $self->_match($side,$mainsource,$altsource,$thisside,$thatside);
return (undef,undef,$err) if defined($err);
return ($count,$id,$err) if defined($id);
return (0,undef,undef) if !defined($count) || $count == 0;
lib/Algorithm/SixDegrees.pm view on Meta::CPAN
sub _match_one {
my ($self,$side,$source,$thisside,$thatside) = @_;
# Assume $self is OK since this is an internal function
return $self->_match($side,$source,$source,$thisside,$thatside);
}
sub _match {
my ($self,$side,$fromsource,$tosource,$thisside,$thatside) = @_;
# Assume $self is OK since this is an internal function
return (undef,undef,'Internal error: missing code') unless reftype($self->{"_source_$side"}{$fromsource}{'sub'}) eq 'CODE';
return (undef,undef,'Internal error: missing side (1)') unless reftype($thisside) eq 'HASH';
return (undef,undef,'Internal error: missing side (2)') unless exists($thisside->{$fromsource});
return (undef,undef,'Internal error: missing side (3)') unless reftype($thatside) eq 'HASH';
return (undef,undef,'Internal error: missing side (4)') unless exists($thatside->{$tosource});
my $newsidecount = 0;
foreach my $id (keys %{$thisside->{$fromsource}}) {
next if exists($self->{"_investigated"}{$fromsource}{$id});
$self->{"_investigated"}{$fromsource}{$id} = 1;
my $use_args = reftype($self->{"_source_$side"}{$fromsource}{'args'}) eq 'ARRAY' ? 1 : 0;
my @ids = &{$self->{"_source_$side"}{$fromsource}{'sub'}}($id,($use_args?@{$self->{"_source_$side"}{$fromsource}{'args'}}:()));
return (undef,undef,$ERROR) if scalar(@ids) == 1 && !defined($ids[0]);
lib/Algorithm/SixDegrees.pm view on Meta::CPAN
link; that is, for an actor/movie relationship, an actor subroutine
should return movies, and a movie subroutine should return actors.
Additional arguments can be provided; these will be stored in the
object and passed through as the second and further arguments to
the subroutine. This may be useful, for example, if you're using
some form of results caching and need to pass a C<tie>d handle
around.
If you return explicit undef, please set C<$Algorithm::SixDegrees::ERROR>
with an error code. Explicit undef means that an error occurred
that should terminate the search; it should be returned as a
one-element list.
=head1 AUTHOR
Peter Krawczyk, C<< <petek@cpan.org> >>
=head1 BUGS
Please report any bugs or feature requests to
samples/movie.pl view on Meta::CPAN
$actorsth->execute($_[0]) or die 'Problem: ' . $actorsth->errstr . "\n";
my $results = $actorsth->fetchall_arrayref;
return map { $_->[0] } @{$results};
}
# Tries looking for an actor if they're not in the database as given
sub suggest_actor {
my $actor = shift;
return $actor if (scalar(&actor_movies($actor)));
my $sth = $dbh->prepare('SELECT actor, min(year), max(year) FROM movact WHERE actor LIKE ? GROUP BY actor')
or die 'sql prepare error';
$sth->execute("$actor\%") or die 'sql execution error';
my $results = $sth->fetchall_arrayref;
$sth->finish;
if (scalar(@{$results}) < 1) {
print "No suggestions for '$actor'\n";
exit(0);
} elsif (scalar(@{$results}) == 1) {
my $new = $results->[0][0];
print "Using '$new' instead of '$actor'\n";
return $new;
}
eval '$sd->data_source(undef,\&one)';
like($@,qr/name/,'data_source dies without a name');
eval '$sd->data_source("t")';
like($@,qr/code/,'data_source dies without a sub');
eval '$sd->data_source("t","t")';
like($@,qr/coderef/,'data_source dies without a coderef');
eval '$sd->data_source("t",{t=>1})';
like($@,qr/coderef/,'data_source dies without a coderef');
is(Algorithm::SixDegrees->make_link("Actor","Bob","Tom"),undef,'make_link without object fails');
like(Algorithm::SixDegrees->error,qr/object/,'make link errors if not called on object');
is(Algorithm::SixDegrees->make_link({},"Actor","Bob","Tom"),undef,'make_link with bad object fails');
like(Algorithm::SixDegrees->error,qr/object/,'make link errors if not called on object');
is($sd->make_link(undef,"Bob","Tom"),undef,'make_link w/o source');
like(Algorithm::SixDegrees->error,qr/name/,'make link errors if called without a source');
is($sd->make_link("Actor",undef,"Tom"),undef,'make_link w/o start');
like(Algorithm::SixDegrees->error,qr/identifier/,'make link errors if called without starting element');
is($sd->make_link("Bob","Tom"),undef,'make_link w/o end');
like(Algorithm::SixDegrees->error,qr/identifier/,'make link errors if called with only two identifiers');
is($sd->make_link("Actor","Bob","Tom"),undef,'make_link without any source');
like(Algorithm::SixDegrees->error,qr/Source/,'make link errors if called without any source');
$sd->data_source("t",\&one);
is($sd->make_link("Actor","Bob","Tom"),undef,'make_link without valid source');
like(Algorithm::SixDegrees->error,qr/Source/,'make link errors if called without valid source');
$sd->data_source("u",\&one);
$sd->data_source("v",\&one);
is($sd->make_link("t","Bob","Tom"),undef,'make_link with three sources');
like(Algorithm::SixDegrees->error,qr/sources/,'make link errors if called with too many sources');
# Object corruption
my $bad_sd = Algorithm::SixDegrees->new();
delete $bad_sd->{'_sources'};
is($bad_sd->make_link("Actor","Bob","Tom"),undef,'make_link w/missing _sources');
like(Algorithm::SixDegrees->error,qr/sources/,'make link errors if sources in object missing');
$bad_sd->{'_sources'}{'Actor'} = '';
is($bad_sd->make_link("Actor","Bob","Tom"),undef,'make_link w/corrupt _sources');
like(Algorithm::SixDegrees->error,qr/sources/,'make link errors if sources in object corrupt');
$bad_sd = new Algorithm::SixDegrees;
$bad_sd->data_source("Actor",\&one);
my $temp = $bad_sd->{'_source_left'};
$bad_sd->{'_source_left'} = '';
is($bad_sd->make_link("Actor","Bob","Tom"),undef,'make_link w/missing _source_left');
like(Algorithm::SixDegrees->error,qr/Source/,'make link errors if sources in object corrupt');
$bad_sd->{'_source_left'} = $temp;
$bad_sd->{'_source_right'} = '';
is($bad_sd->make_link("Actor","Bob","Tom"),undef,'make_link w/missing _source_right');
like(Algorithm::SixDegrees->error,qr/Source/,'make link errors if sources in object corrupt');
$temp = $bad_sd->{'_source_left'}{'Actor'};
$bad_sd->{'_source_left'}{'Actor'} = '';
is($bad_sd->make_link("Actor","Bob","Tom"),undef,'make_link w/missing _source_left/Actor');
like(Algorithm::SixDegrees->error,qr/Source/,'make link errors if sources in object corrupt');
$bad_sd->{'_source_left'}{'Actor'} = $temp;
$bad_sd->{'_source_right'} = {'Actor' => ''};
is($bad_sd->make_link("Actor","Bob","Tom"),undef,'make_link w/missing _source_right/Actor');
like(Algorithm::SixDegrees->error,qr/Source/,'make link errors if sources in object corrupt');
$bad_sd = new Algorithm::SixDegrees;
$bad_sd->data_source("Actor",\&two);
is_deeply([$bad_sd->make_link("Actor","Bob","Tom")],[],'make_link w/error in sub');
is(Algorithm::SixDegrees->error,'testing error','make link puts the error in the object');
$bad_sd = new Algorithm::SixDegrees;
$bad_sd->forward_data_source("Actor",\&one);
$bad_sd->reverse_data_source("Actor",\&two);
is_deeply([$bad_sd->make_link("Actor","Bob","Tom")],[],'make_link w/error in right sub');
is(Algorithm::SixDegrees->error,'testing error','make link puts the error in the object');
exit;
sub one { return ("Mark","John","Seth"); };
sub two { $Algorithm::SixDegrees::ERROR = 'testing error'; return };
t/simple-1source.t view on Meta::CPAN
BEGIN {
use_ok( 'Algorithm::SixDegrees' );
}
my $sd = new Algorithm::SixDegrees;
isa_ok($sd,'Algorithm::SixDegrees');
$sd->data_source( Simple => \&Simple );
is_deeply([$sd->make_link('Simple','one','zero')],[],'No match OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Simple','one','one')],['one'],'Single element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Simple','one','two')],['one','two'],'Double element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Simple','one','three')],['one','two','three'],'Triple element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Simple','one','nine')],['one','two','three','four','five','six','seven','eight','nine'],'9 element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
# Test specifying the forward/reverse manually
my $sd_forward = new Algorithm::SixDegrees;
isa_ok($sd_forward,'Algorithm::SixDegrees');
$sd_forward->forward_data_source( Simple => \&Simple );
$sd_forward->reverse_data_source( Simple => \&Simple );
is_deeply(scalar($sd_forward->make_link('Simple','one','one')),['one'],'Manual single element link OK');
is(Algorithm::SixDegrees->error,undef,'No error during make_link');
is_deeply(scalar($sd_forward->make_link('Simple','one','nine')),['one','two','three','four','five','six','seven','eight','nine'],'Manual 9 element link OK');
is(Algorithm::SixDegrees->error,undef,'No error during make_link');
# Test specifying reverse/forward instead
my $sd_reverse = new Algorithm::SixDegrees;
isa_ok($sd_reverse,'Algorithm::SixDegrees');
$sd_reverse->reverse_data_source( Simple => \&Simple );
$sd_reverse->forward_data_source( Simple => \&Simple );
is_deeply(scalar($sd_reverse->make_link('Simple','one','one')),['one'],'Reversed single element link OK');
is(Algorithm::SixDegrees->error,undef,'No error during make_link');
is_deeply(scalar($sd_reverse->make_link('Simple','one','nine')),['one','two','three','four','five','six','seven','eight','nine'],'Reversed 9 element link OK');
is(Algorithm::SixDegrees->error,undef,'No error during make_link');
exit(0);
sub Simple {
my $element = shift;
return qw/two/ if $element eq 'one';
return qw/one three/ if $element eq 'two';
return qw/two four/ if $element eq 'three';
return qw/three five/ if $element eq 'four';
return qw/four six/ if $element eq 'five';
t/simple-2source-args.t view on Meta::CPAN
my $sd = new Algorithm::SixDegrees;
isa_ok($sd,'Algorithm::SixDegrees');
my $hitcount = 0;
$sd->data_source( Movie => \&Simple_Movie, $movie_actor_hash, \$hitcount );
$sd->data_source( Actor => \&Simple_Actor, $movie_actor_hash, \$hitcount );
is_deeply([$sd->make_link('Actor','Kevin Bacon','Peter Krawczyk')],[],'No match OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Actor','Kevin Bacon','Kevin Bacon')],['Kevin Bacon'],'Single element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Actor','Kevin Bacon','Tom Cruise')],['Kevin Bacon','A Few Good Men','Tom Cruise'],'Double element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Actor','Tom Cruise','Tim Robbins')],
['Tom Cruise','A Few Good Men','Kevin Bacon','Mystic River','Tim Robbins'],
'Triple element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Actor','Tom Cruise','Edward Norton')],
['Tom Cruise', 'A Few Good Men', 'Kevin Bacon', 'Mystic River', 'Tim Robbins', 'Shawshank Redemption, The',
'Morgan Freeman', 'Se7en', 'Brad Pitt', 'Fight Club', 'Edward Norton' ],
'6 element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
cmp_ok($hitcount, '>', 0, 'hitcount was incremented throughout');
exit(0);
sub Simple_Movie {
my $element = shift;
my $movie_actor_hash = shift;
my $hitcount = shift;
${$hitcount}++;
return unless exists($movie_actor_hash->{$element});
t/simple-2source.t view on Meta::CPAN
'Fight Club' => [ 'Brad Pitt', 'Edward Norton' ],
};
my $sd = new Algorithm::SixDegrees;
isa_ok($sd,'Algorithm::SixDegrees');
$sd->data_source( Movie => \&Simple_Movie );
$sd->data_source( Actor => \&Simple_Actor );
is_deeply([$sd->make_link('Actor','Kevin Bacon','Peter Krawczyk')],[],'No match OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Actor','Kevin Bacon','Kevin Bacon')],['Kevin Bacon'],'Single element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Actor','Kevin Bacon','Tom Cruise')],['Kevin Bacon','A Few Good Men','Tom Cruise'],'Double element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Actor','Tom Cruise','Tim Robbins')],
['Tom Cruise','A Few Good Men','Kevin Bacon','Mystic River','Tim Robbins'],
'Triple element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
is_deeply([$sd->make_link('Actor','Tom Cruise','Edward Norton')],
['Tom Cruise', 'A Few Good Men', 'Kevin Bacon', 'Mystic River', 'Tim Robbins', 'Shawshank Redemption, The',
'Morgan Freeman', 'Se7en', 'Brad Pitt', 'Fight Club', 'Edward Norton' ],
'6 element link OK');
is($Algorithm::SixDegrees::ERROR,undef,'No error during make_link');
exit(0);
sub Simple_Movie {
my $element = shift;
return unless exists($movie_actor_hash->{$element});
return @{$movie_actor_hash->{$element}};
}
sub Simple_Actor {
( run in 0.441 second using v1.01-cache-2.11-cpan-65fba6d93b7 )