> Long time no genealogy, and Happy New Year from Australia...
Hi Ron and all,
I'll second on both counts, substituting California for Australia...
About a decade ago I created a couple of additional subroutines for
perl-gedcom Individual.pm which worked very nicely for me. They include
trees of both descendants and ancestors. I took it so far as to
dynamically creating trees using the pictures of the individuals and
formatting them using HTML tables.
At some point I had a major server issue and never got around to
reconstructing my genealogy website, so this is directly from a very old
backup and will only do the basic no-frills ASCII trees which must be
formatted with monospace characters i.e. using <PRE> </PRE> in HTML to
make any sense.
I never published the routines, as I wanted to remove some limitations
first (see below). As I don't see myself touching the code in the
foreseeable future, here it is.
Hope it helps!
Michael
# Copyright 2002-2011, Michael Ionescu (m...@ionescu.de)
# This software is free. It is licensed under the same terms as Perl
itself.
# Written to be appended to the package Gedcom::Individual
# Thanks goes to Paul Johnson for Perl-Gedcom and to Berry B. and
Christian V. for their help!
# Should you use or amend the code, I'd love to hear about it. I do not,
however intend to carry out any code maintenance.
sub life
{
my $self = shift;
my ($birt,undef) = map { $_->date } $self->birt;
my ($deat,undef) = map { $_->date } $self->deat;
$birt=(defined $birt)?"*$birt":'';
$deat=(defined $deat)?"+$deat":'';
my $life=join(" ",$birt,$deat);
$life eq " "?'':$life;
}
sub half_siblings
{
my $self = shift;
my @all_siblings_multiple = map { $_->children } ( map { $_->fams }
$self->parents );
my @excludelist = ($self, $self->siblings);
my @a = grep {
my $cur = $_;
my $half_sibling=1;
foreach my $test(@excludelist){
if($cur->{xref} eq $test->{xref} ){
$half_sibling=0;
last;
}
}
push @excludelist, $cur if($half_sibling); # in order to avoid
multiple output
$half_sibling;
} @all_siblings_multiple;
wantarray ? @a : $a[0]
}
sub half_brothers
{
my $self = shift;
my @a = grep { $_->tag_value("SEX") !~ /^F/i } $self->half_siblings;
wantarray ? @a : $a[0]
}
sub half_sisters
{
my $self = shift;
my @a = grep { $_->tag_value("SEX") !~ /^M/i } $self->half_siblings;
wantarray ? @a : $a[0]
}
sub collapsed_descendant_tree
{
my $self = shift;
my ($generations, $pattern, $prefix) = @_;
$pattern = '' unless $pattern;
$prefix = '' unless $prefix;
$generations = 0 unless $generations;
sub inspatt
{
my ($pattern, $self) = @_;
my @output=();
if($pattern){
my @out=();
foreach my $element (split(//,$pattern)){
if($element eq 'X'){...@out=$self->{xref}
}elsif($element eq 'C'){...@out=$self->cased_name
}elsif($element eq 'N'){...@out=$self->name
}elsif($element eq 'O'){...@out=($self->occu or "?")
}elsif($element eq 'L'){...@out=$self->life
}el...@out=$element
}
push @output, @out;
}
}else{
push @output, "$self->{xref} ", $self->cased_name;
}
@output;
}
my @output=();
return unless $generations > -1;
my @kids = $self->children;
my $kids = scalar @kids;
my $currentkid = 0;
push @output, ${prefix}, ($prefix ne ''?"\\__":"___"),
inspatt($pattern,$self),"\n";
return join "", @output unless $generations > 0;
foreach my $fam ( $self->fams ){
my $printspouse=1;
foreach my $child ( $fam->children ){
++$currentkid;
if($printspouse){
my $spouse=$self->sex eq 'M'?$fam->wife:$fam->husband;
push @output, "${prefix} &", inspatt($pattern,$spouse), "\n";
$printspouse=0;
}
push @output, $child->collapsed_descendant_tree(
$generations-1, $pattern, $prefix.($currentkid==$kids?" ":" |")
);
}
}
join "", @output;
}
sub collapsed_ancestor_tree
{
my $self = shift;
my ($generations, $pattern, $prefix, $lastsex) = @_;
$generations = 0 unless $generations;
$prefix = ' ' unless $prefix;
$lastsex = '' unless $lastsex;
$pattern = '' unless $pattern;
my $thissex = $self->sex;
my @output =();
return unless $generations > -1;
my $giveprefix=$prefix;
if($thissex eq $lastsex){
$prefix=~s/^(.*).(.{4})$/$1 $2/;
}
if($generations){
push @output, map {
$_->collapsed_ancestor_tree($generations-1,$pattern,$prefix."
|",$thissex)
} $self->father;
}
my $outprefix=$prefix;
$outprefix=~s/(.*)./$1 /;
push @output,"${outprefix}", ($lastsex?($thissex eq 'M'?'/':'\\'):' ');
if($pattern){
my @out;
foreach my $element (split(//,$pattern)){
if($element eq 'X'){...@out=$self->{xref}
}elsif($element eq 'C'){...@out=$self->cased_name
}elsif($element eq 'N'){...@out=$self->name
}elsif($element eq 'O'){...@out=($self->occu or "?")
}elsif($element eq 'L'){...@out=$self->life
}el...@out=$element
}
push @output,@out;
}
push @output,"\n";
}else{
push @output,
$self->{xref}," ", $self->cased_name, "\n";
}
if($generations){
push @output, map {
$_->collapsed_ancestor_tree($generations-1,$pattern,$prefix."
|",$thissex)
} $self->mother;
}
join "", @output;
}
=head2 Additional Individual functions
my $text = $i->life;
my @rel = $i->half_siblings;
my @rel = $i->half_brothers;
my @rel = $i->half_sisters;
=head2 ASCII-Art Family Trees
my $str = $i->collapsed_descendant_tree(maxgenerations[,pattern])
my $str = $i->collapsed_ancestor_tree(maxgenerations[,pattern])
These functions will output a string containing an ASCII-art family tree
going up or down at most maxgenerations generations from the individual.
The initial output per individual may be customized using a pattern
string. The string may consist of arbitrary characters including the
following symbols:
X for XREF
C for cased name
N for name
O for occupation
L for life (*date of birth +deceased date)
Where a pattern of "C (L)[X]" would yield something like "John DOE
(*30.1.1777 +20.12.1800)[I6543]".
The idea behind outputting an XREF is that you may want to pass the tree
through a filter to alter
the family members' representations while keeping the tree-part intact.
$str =~ s/^(.*?)I(\d+) (.*)$/$1<a href=\"I$2.html\">I$2 $3<\/a>/mg;
This would give each individual in the tree a weblink.
Caveat: These functions currently work only on unambiguous traditional
gedcom families
(i.e. when there is exactly one female and one male spouse individual
linked to a family - no more, no less)
