relation.pl

#!/usr/bin/perl -w

# This program was generated by lines2perl, which is part of Gedcom.pm.
# Gedcom.pm is Copyright 1999-2005, Paul Johnson (pjcj@cpan.org)
# Version 1.1502 - 20th December 2005

# Gedcom.pm is free.  It is licensed under the same terms as Perl itself.

# The latest version of Gedcom.pm should be available from my homepage:
# http://www.pjcj.net

use strict;

require 5.005;

use diagnostics;
use integer;

use Getopt::Long;

use Gedcom::LifeLines 1.15;

my $Ged;                                                         # Gedcom object
my %Opts;                                                              # options
my $_Traverse_sub;                                     # subroutine for traverse

sub out  { print  STDERR @_ unless $Opts{quiet} }
sub outf { printf STDERR @_ unless $Opts{quiet} }

sub initialise ()
{
  die "usage: $0 -gedcom_file file.ged\n"
    unless GetOptions(\%Opts,
                      "gedcom_file=s",
                      "quiet!",
                      "validate!",
                     ) and defined $Opts{gedcom_file};
  local $SIG{__WARN__} = sub { out "\n@_" };
  out "reading...";
  $Ged = Gedcom->new
  (
    gedcom_file  => $Opts{gedcom_file},
    callback     => sub { out "." }
  );
  if ($Opts{validate})
  {
    out "\nvalidating...";
    my %x;
    my $vcb = sub
    {
     my ($r) = @_;
     my $t = $r->{xref};
     out "." if $t && !$x{$t}++;
    };
    $Ged->validate($vcb);
  }
  out "\n";
  set_ged($Ged);
}

$SIG{__WARN__} = sub
{
  out $_[0] unless $_[0] =~ /^Use of uninitialized value/
};

# /*
# relation - a LifeLines relation computing program
#         by Jim Eggert (eggertj@atc.ll.mit.edu)
#         Version 1,  21 November 1992
#         Version 2,  23 November 1992 (completely revamped)
#         Version 3,  (changed format slightly, modified code somewhat)
#         Version 4,   6 July 1993 (added English language)
#         Version 5,   6 September 1993 (generified language)
# 
# This program calculates the relationship between individuals in a
# database.  It does so in three modes.  Mode 1 just does one pair of
# individuals and then exits.  Mode 2 does any number of pairs with a
# common "from" person.  Mode 3 does all pairs with a common "from"
# person.  In general, mode 1 is fastest for simple relationships, but
# if you want one complicated relationship, you may as well do them all.
# 
# Each computed relation is composed of the minimal combination of
# parent (fm), sibling (bsS), child (zdC), and spouse (hw) giving the
# relational path from the "from" person to the "to" person.  Each
# incremental relationship (or hop) is coded as follows, with the
# capital letters denoting a person of unknown gender:
#         father  f
#         mother  m
#         parent  P (not used)
#         brother b
#         sister  s
#         sibling S
#         son     z (sorry)
#         daughtr d
#         child   C
#         husband h
#         wife    w
#         spouse  O (sorry again, but usually not possible)
# 
# The report gives the steps required to go from the first person to
# the second person.  Thus the printout
#         I93 John JONES fmshwz I95 Fred SMITH
# means that John Jones' father's mother's sister's husband's wife's son
# is Fred Smith.  Notice in this case, the sister's husband's wife is
# not the same as the sister, and the husband's wife's son is not the
# same as the husband's son.  Thus in more understandable English, John
# Jones' paternal grandmother's sister's husband's wife's son from
# another marriage is Fred Smith.
# 
# The program will do a trivial parsing of the path string.  You can
# change the language_table to have it print in different languages, as
# long as the word order is unchanged.
# 
# If there is no relation, the program says so.  That at least should be
# easy to explain.  Mode 3 only prints out those individuals who are
# related to the "from" individual.
# */
my $plist;
my $hlist;
my $mark;
my $keys;
my $found;
my $do_names;
my $language;
my $language_table;
my $token;
my $untoken;
sub include ($$$$$)
{
  my($person, $hops, $keypath, $path, $pathend) = @_;
  my $and;
  my $entry;
  my $eq;
  my $pkey;
  if (($person && ($found == 0)))
  {
    $pkey = &key($person);
    if ($entry = $mark->{$pkey})
    {
      if ((&strcmp($entry, "is not related to") == 0))
      {
        $found = 1;
        $plist = [];
        $hlist = [];
        $mark->{&save($pkey)} = &save(&concat($path, $pathend));
        $keys->{&save($pkey)} = &save(&concat(&concat($keypath, "@"), $pkey));
      }
    }
    else
    {
      push @$plist, &save($pkey);
      push @$hlist, $hops;
      $mark->{&save($pkey)} = &save(&concat($path, $pathend));
      $keys->{&save($pkey)} = &save(&concat(&concat($keypath, "@"), $pkey));
    }
  }
  undef
}

sub get_token ($)
{
  my($input) = @_;
  my $eq;
  my $first_delim;
  my $not;
  # /*  Parse a token from the input string.
  #     Tokens are separated by one or more "@"s.
  #     Set global parameter token to the first token string.
  #     Set global parameter untoken to the rest of the string after first token.
  # */
  # /* strip leading @s */
  #     
  $untoken = &save($input);
  $first_delim = &index($untoken, "@", 1);
  LOOP: while (($first_delim == 1))
  {
    $untoken = &save(&substring($untoken, 2, &strlen($untoken)));
    $first_delim = &index($untoken, "@", 1);
  }
  # /* get token and untoken */
  #     
  if ((! $first_delim))
  {
    $token = &save($untoken);
    $untoken = &save("");
  }
  else
  {
    $token = &save(&substring($untoken, 1, ($first_delim - 1)));
    $untoken = &save(&substring($untoken, ($first_delim + 1), &strlen($untoken)));
  }
  undef
}

sub parse_relation ($$)
{
  my($relation, $keypath) = @_;
  my $charcounter;
  my $le;
  my $not;
  my $strlen;
  if ((! $language))
  {
    display " ";
    display $relation;
    if ($do_names)
    {
      $untoken = $keypath;
      display &get_token($untoken);
      LOOP: while (&strlen($untoken))
      {
        display &get_token($untoken);
        display " ";
        display $token;
        display " ";
        display &name(&indi($token));
      }
    }
    display " ";
  }
  else
  {
    $charcounter = 1;
    $untoken = $keypath;
    display &get_token($untoken);
    LOOP: while (($charcounter <= &strlen($relation)))
    {
      display $language_table->{&substring($relation, $charcounter, $charcounter)};
      if ($do_names)
      {
        display &get_token($untoken);
        display " ";
        display $token;
        display " ";
        display &name(&indi($token));
      }
      $charcounter = ($charcounter + 1);
    }
    display " is ";
  }
  undef
}

sub main ()
{
  my $child;
  my $cnum;
  my $eq;
  my $fam;
  my $female;
  my $from_key;
  my $from_person;
  my $hopcount;
  my $keypath;
  my $male;
  my $mode;
  my $ne;
  my $num;
  my $path;
  my $pathend;
  my $person;
  my $pkey;
  my $pnum;
  my $prev_hopcount;
  my $spouse;
  my $strcmp;
  my $to_key;
  my $to_person;
  my $want_another;
  $mark = {};
  $keys = {};
  $plist = [];
  $hlist = [];
  $language_table = {};
  $language_table->{"f"} = "'s father";
  $language_table->{"m"} = "'s mother";
  $language_table->{"P"} = "'s parent";
  $language_table->{"b"} = "'s brother";
  $language_table->{"s"} = "'s sister";
  $language_table->{"S"} = "'s sibling";
  $language_table->{"z"} = "'s son";
  $language_table->{"d"} = "'s daughter";
  $language_table->{"C"} = "'s child";
  $language_table->{"h"} = "'s husband";
  $language_table->{"w"} = "'s wife";
  $language_table->{"O"} = "'s spouse";
  display &getindimsg($from_person, "Enter person to compute relation from:");
  $from_key = &save(&key($from_person));
  $hopcount = 0;
  $prev_hopcount = (- 1);
  $found = 0;
  display &include($from_person, $hopcount, "", "", "");
  display &getintmsg($mode, "Enter 1 for a single relation, 2 for several, 3 for all:");
  display &getintmsg($language, "Enter 0 for brief, 1 for English-language relationships:");
  display &getintmsg($do_names, "Enter 0 to omit, 1 to output names of all intervening relatives:");
  if (($mode == 1))
  {
    display &getindimsg($to_person, "Enter one person to compute relation to:");
    $to_key = &save(&key($to_person));
    if (&strcmp($from_key, $to_key))
    {
      $mark->{$to_key} = "is not related to";
    }
    else
    {
      $plist = [];
      $hlist = [];
    }
  }
  LOOP: while ($pkey = (shift @$plist))
  {
    $person = &indi($pkey);
    $hopcount = (shift @$hlist);
    $path = $mark->{$pkey};
    $keypath = $keys->{$pkey};
    if (($hopcount != $prev_hopcount))
    {
      display &print(".");
      $prev_hopcount = $hopcount;
    }
    $hopcount = ($hopcount + 1);
    display &include(&father($person), $hopcount, $keypath, $path, "f");
    display &include(&mother($person), $hopcount, $keypath, $path, "m");
    $cnum = 0;
    LOOP: for $child ( do { my $e = &parents($person); $e ? $e->children : ()} )
    {
      $cnum++;
        if (&male($child))
        {
          $pathend = "b";
        }
        elsif (&female($child))
        {
          $pathend = "s";
        }
        else
        {
          $pathend = "S";
        }
        display &include($child, $hopcount, $keypath, $path, $pathend);
    }
    $pnum = 0;
    LOOP: for $fam ($person->fams)
    {
      for $spouse ($fam->parents || undef)
      {
        next if $spouse && $spouse->xref eq $person->xref;
        $pnum++;
        if (&male($spouse))
        {
          $pathend = "h";
        }
        elsif (&female($spouse))
        {
          $pathend = "w";
        }
        else
        {
          $pathend = "O";
        }
        display &include($spouse, $hopcount, $keypath, $path, $pathend);
        $cnum = 0;
        LOOP: for $child ( do { my $e = $fam; $e ? $e->children : ()} )
        {
          $cnum++;
            if (&male($child))
            {
              $pathend = "z";
            }
            elsif (&female($child))
            {
              $pathend = "d";
            }
            else
            {
              $pathend = "C";
            }
            display &include($child, $hopcount, $keypath, $path, $pathend);
        }
      }
    }
  }
  if (($mode == 1))
  {
    display $from_key;
    display " ";
    display &name(&indi($from_key));
    display &parse_relation(&save($mark->{$to_key}), $keys->{$to_key});
    display $to_key;
    display " ";
    display &name(&indi($to_key));
    display "\n";
  }
  if (($mode == 2))
  {
    $want_another = 1;
    LOOP: while ($want_another)
    {
      display &getindimsg($to_person, "Enter person to compute relation to:");
      $to_key = &save(&key($to_person));
      display $from_key;
      display " ";
      display &name(&indi($from_key));
      if ($path = $mark->{$to_key})
      {
        display &parse_relation(&save($path), $keys->{$to_key});
      }
      else
      {
        display " is not related to ";
      }
      display $to_key;
      display " ";
      display &name($to_person);
      display "\n";
      display &getintmsg($want_another, "Enter 0 if done, 1 if you want another to person:");
    }
  }
  if (($mode == 3))
  {
    display $from_key;
    display " ";
    display &name(&indi($from_key));
    display " --->\n";
    $num = 0;
    LOOP: for $to_person ($Ged->individuals)
    {
      $num++;
      $to_key = &save(&key($to_person));
      if ($path = $mark->{$to_key})
      {
        display &parse_relation(&save($path), $keys->{$to_key});
        display $to_key;
        display " ";
        display &name($to_person);
        display "\n";
      }
    }
  }
  undef
}


initialise();
main();
flush();
0

__END__

Original LifeLines program follows:

/*
relation - a LifeLines relation computing program
        by Jim Eggert (eggertj@atc.ll.mit.edu)
        Version 1,  21 November 1992
        Version 2,  23 November 1992 (completely revamped)
        Version 3,  (changed format slightly, modified code somewhat)
        Version 4,   6 July 1993 (added English language)
        Version 5,   6 September 1993 (generified language)

This program calculates the relationship between individuals in a
database.  It does so in three modes.  Mode 1 just does one pair of
individuals and then exits.  Mode 2 does any number of pairs with a
common "from" person.  Mode 3 does all pairs with a common "from"
person.  In general, mode 1 is fastest for simple relationships, but
if you want one complicated relationship, you may as well do them all.

Each computed relation is composed of the minimal combination of
parent (fm), sibling (bsS), child (zdC), and spouse (hw) giving the
relational path from the "from" person to the "to" person.  Each
incremental relationship (or hop) is coded as follows, with the
capital letters denoting a person of unknown gender:
        father  f
        mother  m
        parent  P (not used)
        brother b
        sister  s
        sibling S
        son     z (sorry)
        daughtr d
        child   C
        husband h
        wife    w
        spouse  O (sorry again, but usually not possible)

The report gives the steps required to go from the first person to
the second person.  Thus the printout
        I93 John JONES fmshwz I95 Fred SMITH
means that John Jones' father's mother's sister's husband's wife's son
is Fred Smith.  Notice in this case, the sister's husband's wife is
not the same as the sister, and the husband's wife's son is not the
same as the husband's son.  Thus in more understandable English, John
Jones' paternal grandmother's sister's husband's wife's son from
another marriage is Fred Smith.

The program will do a trivial parsing of the path string.  You can
change the language_table to have it print in different languages, as
long as the word order is unchanged.

If there is no relation, the program says so.  That at least should be
easy to explain.  Mode 3 only prints out those individuals who are
related to the "from" individual.
*/

global(plist)
global(hlist)
global(mark)
global(keys)
global(found)
global(do_names)
global(language)
global(language_table)
global(token)
global(untoken)

proc include(person,hops,keypath,path,pathend)
{
    if (and(person,eq(found,0))) {
        set(pkey,key(person))
        if (entry,lookup(mark,pkey)) {
            if (eq(strcmp(entry,"is not related to"),0)) {
                set(found,1)
                list(plist)
                list(hlist)
                insert(mark,save(pkey),save(concat(path,pathend)))
                insert(keys,save(pkey),save(concat(concat(keypath,"@"),pkey)))
            }
        }
        else {
            enqueue(plist,save(pkey))
            enqueue(hlist,hops)
            insert(mark,save(pkey),save(concat(path,pathend)))
            insert(keys,save(pkey),save(concat(concat(keypath,"@"),pkey)))
        }
    }
}

proc get_token(input) {
/*  Parse a token from the input string.
    Tokens are separated by one or more "@"s.
    Set global parameter token to the first token string.
    Set global parameter untoken to the rest of the string after first token.
*/
/* strip leading @s */
    set(untoken,save(input))
    set(first_delim,index(untoken,"@",1))
    while (eq(first_delim,1)) {
        set(untoken,save(substring(untoken,2,strlen(untoken))))
        set(first_delim,index(untoken,"@",1))
    }
/* get token and untoken */
    if (not(first_delim)) {
        set(token,save(untoken))
        set(untoken,save(""))
    }
    else {
        set(token,save(substring(untoken,1,sub(first_delim,1))))
        set(untoken,save(
            substring(untoken,add(first_delim,1),strlen(untoken))))
    }
}

proc parse_relation(relation,keypath) {
    if (not(language)) {
        " " relation
        if (do_names) {
            set(untoken,keypath)
            call get_token(untoken)
            while(strlen(untoken)) {
                call get_token(untoken)
                " " token " " name(indi(token))
            }
        }
        " "
    }
    else {
        set(charcounter,1)
        set(untoken,keypath)
        call get_token(untoken)
        while (le(charcounter,strlen(relation))) {
            lookup(language_table,substring(relation,charcounter,charcounter))
            if (do_names) {
                call get_token(untoken)
                " " token " " name(indi(token))
            }
            set(charcounter,add(charcounter,1))
        }
        " is "
    }
}

proc main ()
{
    table(mark)
    table(keys)
    list(plist)
    list(hlist)

    table(language_table)
    insert(language_table,"f","'s father")
    insert(language_table,"m","'s mother")
    insert(language_table,"P","'s parent")
    insert(language_table,"b","'s brother")
    insert(language_table,"s","'s sister")
    insert(language_table,"S","'s sibling")
    insert(language_table,"z","'s son")
    insert(language_table,"d","'s daughter")
    insert(language_table,"C","'s child")
    insert(language_table,"h","'s husband")
    insert(language_table,"w","'s wife")
    insert(language_table,"O","'s spouse")

    getindimsg(from_person,
        "Enter person to compute relation from:")
    set(from_key,save(key(from_person)))
    set(hopcount,0)
    set(prev_hopcount,neg(1))
    set(found,0)
    call include(from_person,hopcount,"","","")
    getintmsg(mode,"Enter 1 for a single relation, 2 for several, 3 for all:")
    getintmsg(language,
        "Enter 0 for brief, 1 for English-language relationships:")
    getintmsg(do_names,
        "Enter 0 to omit, 1 to output names of all intervening relatives:")
    if (eq(mode,1)) {
        getindimsg(to_person,
            "Enter one person to compute relation to:")
        set(to_key,save(key(to_person)))
        if (strcmp(from_key,to_key)) {
            insert(mark,to_key,"is not related to")
        }
        else {
            list(plist)
            list(hlist)
        }
    }
    while (pkey,dequeue(plist)) {
        set(person,indi(pkey))
        set(hopcount,dequeue(hlist))
        set(path,lookup(mark,pkey))
        set(keypath,lookup(keys,pkey))
        if (ne(hopcount,prev_hopcount)) {
            print(".")
            set(prev_hopcount,hopcount)
        }
        set(hopcount,add(hopcount,1))
        call include(father(person),hopcount,keypath,path,"f")
        call include(mother(person),hopcount,keypath,path,"m")
        children(parents(person),child,cnum) {
            if (male(child)) { set(pathend,"b") }
            elsif (female(child)) { set(pathend,"s") }
            else { set(pathend,"S") }
            call include(child,hopcount,keypath,path,pathend)
        }
        families(person,fam,spouse,pnum) {
            if (male(spouse)) { set(pathend,"h") }
            elsif (female(spouse)) { set(pathend,"w") }
            else { set(pathend,"O") }
            call include(spouse,hopcount,keypath,path,pathend)
            children(fam,child,cnum) {
                if (male(child)) { set(pathend,"z") }
                elsif (female(child)) { set(pathend,"d") }
                else { set(pathend,"C") }
                call include(child,hopcount,keypath,path,pathend)
            }
        }
    }
    if (eq(mode,1)) {
        from_key " " name(indi(from_key))
        call parse_relation(save(lookup(mark,to_key)),lookup(keys,to_key))
        to_key   " " name(indi(to_key)) "\n"
    }
    if (eq(mode,2)) {
        set(want_another,1)
        while (want_another) {
            getindimsg(to_person,"Enter person to compute relation to:")
            set(to_key,save(key(to_person)))
            from_key " " name(indi(from_key))
            if (path,lookup(mark,to_key)) {
                call parse_relation(save(path),lookup(keys,to_key))
            }
            else { " is not related to " }
            to_key  " "  name(to_person) "\n"
            getintmsg(want_another,
                  "Enter 0 if done, 1 if you want another to person:")
        }
    }
    if (eq(mode,3)) {
        from_key " " name(indi(from_key)) " --->\n"
        forindi(to_person,num) {
            set(to_key,save(key(to_person)))
            if (path,lookup(mark,to_key)) {
                call parse_relation(save(path),lookup(keys,to_key))
                to_key " " name(to_person) "\n"
            }
        }
    }
}