view release on metacpan or  search on metacpan

lib/Genealogy/Relationship.pm  view on Meta::CPAN

  my ($person1, $person2) = @_;

  # If the two people are the same person, then return (0, 0).
  return (0, 0)
    if $person1->$identifier_field_name eq $person2->$identifier_field_name;

  my $map1 = $self->_ancestor_map($person1);
  my $map2 = $self->_ancestor_map($person2);

  my ($best_i, $best_j, $best_total);

  for my $id (keys %$map1) {
    if (exists $map2->{$id}) {
      my $i     = $map1->{$id}{distance};
      my $j     = $map2->{$id}{distance};
      my $total = $i + $j;
      if (!defined $best_total || $total < $best_total) {
        $best_total = $total;
        $best_i     = $i;
        $best_j     = $j;
      }
    }
  }

  die "Can't work out the relationship.\n" unless defined $best_total;

  return ($best_i, $best_j);
}

=head2 get_relationship_ancestors

Given two people, returns lists of people linking those two people
to their most recent common ancestor.

The return value is a reference to an array containing two array
references. The first referenced array contains the person1 and
all their ancestors up to and including the most recent common
ancestor. The second list does the same for person2.

When a person has two parents, the shortest path to the common ancestor
is used.

=cut

method get_relationship_ancestors {
  my ($person1, $person2) = @_;

  my $mrca = $self->most_recent_common_ancestor($person1, $person2)
    or die "There is no most recent common ancestor\n";

  return [
    $self->_path_to_ancestor($person1, $mrca),
    $self->_path_to_ancestor($person2, $mrca),
  ];
}

=head2 _path_to_ancestor

Internal method. Given a person object and a target ancestor object, returns
an array reference containing the shortest path from the person to the
ancestor (inclusive of both endpoints). Uses breadth-first search so that
the shortest path is always found, even when a person has two parents.

=cut

method _path_to_ancestor {
  my ($person, $target) = @_;

  my $target_id = $target->$identifier_field_name;
  my $person_id = $person->$identifier_field_name;

  return [$person] if $person_id eq $target_id;

  # BFS to find the shortest path
  my @queue   = ([$person]);
  my %visited = ($person_id => 1);

  while (@queue) {
    my $path    = shift @queue;
    my $current = $path->[-1];

    for my $parent ($self->_get_parents($current)) {
      my $parent_id = $parent->$identifier_field_name;
      next if $visited{$parent_id}++;

      my $new_path = [@$path, $parent];
      return $new_path if $parent_id eq $target_id;
      push @queue, $new_path;
    }
  }

  die "No path found to ancestor\n";
}

=head1 AUTHOR

Dave Cross <dave@perlhacks.com>

=head1 SEE ALSO

perl(1)

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2018-2026, Magnum Solutions Ltd.  All Rights Reserved.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;