summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/scripts/pedigree-perl
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2012-04-13 23:09:10 +0000
committerKarl Berry <karl@freefriends.org>2012-04-13 23:09:10 +0000
commit2d9b64e84ae06eba8f2f5d0e958f4f2f335de076 (patch)
treee49120eb2857c9aa1a11ca26cda4d3ba5db6b8b6 /Master/texmf-dist/scripts/pedigree-perl
parent1c08c44c738be3e43fc4411812e7484d2471de7e (diff)
new pstricks+script pedigree-perl (16mar12)
git-svn-id: svn://tug.org/texlive/trunk@25962 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/texmf-dist/scripts/pedigree-perl')
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree.pm112
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/AbortionNode.pm148
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/Area.pm452
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/ChildlessNode.pm150
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/Language.pm459
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/MarriageNode.pm346
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/Node.pm1240
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/Parser.pm237
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/PersonNode.pm389
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/TwinsNode.pm172
-rwxr-xr-xMaster/texmf-dist/scripts/pedigree-perl/pedigree.pl544
11 files changed, 4249 insertions, 0 deletions
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree.pm
new file mode 100644
index 00000000000..c92a027b865
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree.pm
@@ -0,0 +1,112 @@
+=pod
+
+=head1 NAME
+
+Pedigree - the main library for Pedigree.
+
+=head1 SYNOPSIS
+
+use Pedigree;
+
+$node = Pedigree->MakeNode($params);
+
+=head1 DESCRIPTION
+
+This is the main package for pedigree construction. It calls other
+libraries in the Pedigree:: family
+
+=over 4
+
+=cut
+
+
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree;
+use Pedigree::AbortionNode;
+use Pedigree::Area;
+use Pedigree::ChildlessNode;
+use Pedigree::Language;
+use Pedigree::MarriageNode;
+use Pedigree::Node;
+use Pedigree::Parser;
+use Pedigree::PersonNode;
+use Pedigree::TwinsNode;
+use strict;
+
+####################################################################
+# MakeNode #
+####################################################################
+
+=pod
+
+=item B<MakeNode>(I<$params>);
+
+Construct a new node from the given parameters. Check what kind of node
+should we construct.
+
+=cut
+
+sub MakeNode {
+ my ($class,$params)=@_;
+
+ my $self;
+
+ if ($params->{'Name'} =~ s/^\#//) {
+ if ($params->{'Name'} eq 'abortion') {
+ $self=new Pedigree::AbortionNode(%{$params});
+ } elsif ($params->{'Name'} eq 'childless') {
+ $self=new Pedigree::ChildlessNode(%{$params});
+ } else {
+ print STDERR "Unknown special name: ", $params->{'Name'},
+ "\n";
+ }
+ } else {
+ $self=new Pedigree::PersonNode(%{$params});
+ }
+ return $self;
+
+}
+
+
+
+
+####################################################################
+# THE END #
+####################################################################
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+=head1 SEE ALSO
+
+pedigree(1),
+Pedigree::AbortionNode(3),
+Pedigree::Area(3),
+Pedigree::ChildlessNode(3),
+Pedigree::Language(3),
+Pedigree::MarriageNode(3),
+Pedigree::Node(3),
+Pedigree::Parser(3),
+Pedigree::PersonNode(3),
+Pedigree::TwinsNode(3),
+
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2007
+
+
+
+=cut
+
+1;
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree/AbortionNode.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/AbortionNode.pm
new file mode 100644
index 00000000000..df56988c16d
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/AbortionNode.pm
@@ -0,0 +1,148 @@
+=pod
+
+=head1 NAME
+
+Pedigree::AbortionNode - an abortion in a pedigree
+
+=head1 SYNOPSIS
+
+use Pedigree::AbortionNode;
+
+$node = new Pedigree::AbortionNode(I<%params>);
+
+$node->DrawNode(I<$xidst>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+$node->PrintLegend(I<$land>, I<@fields>);
+
+=head1 DESCRIPTION
+
+This package contains data about an abortion. Abortion is like a person,
+but it cannot have kids, and it is drawn differently
+
+=over 4
+
+=cut
+
+
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree::AbortionNode;
+use Pedigree;
+use strict;
+our @ISA=('Pedigree::PersonNode');
+
+
+
+####################################################################
+# DrawNode #
+####################################################################
+
+=pod
+
+=item B<DrawNode>(I<$xdist>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+Output the command to draw this node. The parameters are
+distances between the nodes (in cm) and fields for abovetext.
+
+=cut
+
+sub DrawNode {
+ my $self=shift;
+ my ($xdist, $ydist, $belowtextfont, $abovetextfont, @fieldsfornode) = @_;
+ my $result = '\rput('.($xdist*$self->GetAbsX()).", ".
+ ($ydist*$self->GetAbsY()).'){\pstAbortion[';
+ my @opts=($self->Condition(),
+ 'belowtext={'."$belowtextfont ".$self->GetGenName().'}');
+ if ($self->Type() eq 'sab') {
+ push @opts, 'sab';
+ }
+ my @abovetext;
+ if ($self->Sex() ne 'unknown') {
+ push @abovetext, $self->Sex();
+ }
+ foreach my $field (@fieldsfornode) {
+ if (($field ne 'Sex') && ($field ne 'Name')) {
+ push @abovetext, $self->{$field};
+ }
+ }
+ if (scalar @abovetext) {
+ push @opts,'abovetext={'."$abovetextfont ".join('; ',@abovetext).'}';
+ }
+ $result .= join(', ',@opts);
+ $result .= ']{'.$self->Id()."}}\n";
+ return $result;
+}
+
+####################################################################
+# PrintLegend #
+####################################################################
+
+=pod
+
+=item B<PrintLegend>(I<$lang>, I<@fields>);
+
+Print the legend for the given node, including I<@fields> in the given
+language I<$lang>, and excluding the fields, that have no meaning for
+this node.
+
+
+=cut
+
+sub PrintLegend {
+ my ($self, $lang, @fields) = @_;
+ my $result = '\item['.$self->GetGenName().'] ';
+ my @desc;
+ foreach my $field (@fields) {
+ if (exists $self->{$field} && ($field ne 'DoD') &&
+ ($field ne 'AgeAtDeath')) {
+ my $res = $lang->PrintField($field, $self->{$field});
+ if (length($res)>0) {
+ push @desc, $res;
+ }
+ }
+ }
+ $result .= join ("; ",@desc);
+ $result .= ".\n";
+ #
+ # We print only the nodes, for which there is an information
+ #
+ if (scalar @desc) {
+ return $result;
+ }
+ return;
+}
+
+
+
+####################################################################
+# THE END #
+####################################################################
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+=head1 SEE ALSO
+
+pedigree(1), Pedigree(3)
+
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2007
+
+
+
+=cut
+
+1;
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Area.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Area.pm
new file mode 100644
index 00000000000..12cda99deb9
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Area.pm
@@ -0,0 +1,452 @@
+=pod
+
+=head1 NAME
+
+Pedigree::Area - Calculate the area taken by a tree or a clump
+
+=head1 SYNOPSIS
+
+use Pedigree::Area;
+
+$area = new Pedigree::Area($node);
+
+$Ymin=$area->GetYmin();
+
+$area->SetYmin($Ymin);
+
+$Ymax=$area->GetYmax();
+
+$area->SetYmax($Ymax);
+
+$Xmin=$area->GetXmin($y);
+
+$area->SetXmin($y,$x);
+
+$Xmax=$area->GetXmax($y);
+
+$area->SetXmax($y,$x);
+
+$area->AddRight($otherarea);
+
+$area->AddLeft($otherarea);
+
+$rootnode=$area->GetRootNode();
+
+$area->MoveLowerLayers($x);
+
+=head1 DESCRIPTION
+
+The algorithm of pedigree(1) uses the notion of area: a part of
+a picture taken by a tree or a clump. This package implements this
+notion.
+
+Each Area has B<rootnode> - the reference node for all calculations.
+All distances are calculated as relative to the coordinates of the
+B<rootnode>.
+
+The units are distances between the nodes in X and Y direction. The
+Y axis is I<downward>: the earlier generations have smaller Y
+coordinates.
+
+=over 4
+
+=cut
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree::Area;
+use strict;
+
+
+####################################################################
+# new #
+####################################################################
+
+=pod
+
+=item B<new>(I<$rootnode>);
+
+Construct a new area around the given rootnode
+
+=cut
+
+sub new {
+ my ($class, $node) = @_;
+ my $self={};
+ #
+ # Top and bottom in the Y direction
+ #
+ $self->{'Ymin'}=0;
+ $self->{'Ymax'}=0;
+ #
+ # Hashes of Xmin and Xmax
+ #
+ $self->{'Xmin'}->{0}=0;
+ $self->{'Xmax'}->{0}=0;
+ $self->{'RootNode'}=$node;
+ bless ($self, $class);
+ return $self;
+
+}
+
+####################################################################
+# GetYmin #
+####################################################################
+
+=pod
+
+=item B<GetYmin>();
+
+Get the lower bound of the area.
+
+=cut
+
+sub GetYmin {
+ my $self = shift;
+ return $self->{'Ymin'};
+}
+
+####################################################################
+# SetYmin #
+####################################################################
+
+=pod
+
+=item B<SetYmin>(I<$y>);
+
+Set the lower bound of the area.
+
+=cut
+
+sub SetYmin {
+ my $self = shift;
+ my $y=shift;
+ $self->{'Ymin'}=$y;
+ return $y;
+}
+
+####################################################################
+# GetYmax #
+####################################################################
+
+=pod
+
+=item B<GetYmax>();
+
+Get the upper bound of the area.
+
+=cut
+
+sub GetYmax {
+ my $self = shift;
+ return $self->{'Ymax'};
+}
+
+####################################################################
+# SetYmax #
+####################################################################
+
+=pod
+
+=item B<SetYmax>(I<$y>);
+
+Set the upper bound of the area.
+
+=cut
+
+sub SetYmax {
+ my $self = shift;
+ my $y=shift;
+ $self->{'Ymax'}=$y;
+ return $y;
+}
+
+####################################################################
+# GetXmin #
+####################################################################
+
+=pod
+
+=item B<GetXmin>(I<$y>);
+
+Get the minimal X coordinate of the area on the level Y.
+
+=cut
+
+sub GetXmin {
+ my $self = shift;
+ my $y=shift;
+ return $self->{'Xmin'}->{$y};
+}
+
+####################################################################
+# SetXmin #
+####################################################################
+
+=pod
+
+=item B<SetXmin>(I<$y, $x>);
+
+Set the minimal X coordinate of the area on the level Y.
+
+=cut
+
+sub SetXmin {
+ my $self = shift;
+ my $y=shift;
+ my $x=shift;
+ $self->{'Xmin'}->{$y}=$x;
+ return $x;
+}
+
+####################################################################
+# GetXmax #
+####################################################################
+
+=pod
+
+=item B<GetXmax>(I<$y>);
+
+Get the maximal X coordinate of the area the the level Y.
+
+=cut
+
+sub GetXmax {
+ my $self = shift;
+ my $y=shift;
+ return $self->{'Xmax'}->{$y};
+}
+
+####################################################################
+# SetXmax #
+####################################################################
+
+=pod
+
+=item B<SetXmax>(I<$y, $x>);
+
+Set the maximal X coordinate of the area the the level Y.
+
+=cut
+
+sub SetXmax {
+ my $self = shift;
+ my $y=shift;
+ my $x=shift;
+ $self->{'Xmax'}->{$y}=$x;
+ return $x;
+}
+
+
+####################################################################
+# AddRight #
+####################################################################
+
+=pod
+
+=item B<AddRight>(I<$otherarea>);
+
+Add the new area I<$otherarea> to the given area at the right. The
+"other area" should have a root node that is relative to our root
+node. The relative Y of the other root node is used, the relative
+X is set.
+
+=cut
+
+sub AddRight {
+ my ($self, $other) = @_;
+ my $deltaY = $other->GetRootNode()->GetRelY();
+
+ #
+ # First, we calculate the intersection of two areas
+ # It is between max(Y_{min,1}, Y_{min,2}+deltaY)
+ # and min(Y_{max,1}, Y_{max,2}+deltaY)
+ #
+ my $intMin=$self->GetYmin();
+ if ($other->GetYmin()+$deltaY > $intMin) {
+ $intMin = $other->GetYmin()+$deltaY;
+ }
+ my $intMax = $self->GetYmax();
+ if ($other->GetYmax()+$deltaY < $intMax) {
+ $intMax=$other->GetYmax()+$deltaY;
+ }
+
+ #
+ # Now we are ready to calculate relative X shift
+ #
+ my $deltaX=0;
+ for (my $y=$intMin; $y<=$intMax; $y++) {
+ my $x0 = $self->GetXmax($y);
+ my $x1 = $other->GetXmin($y-$deltaY);
+ if ($x1 + $deltaX - $x0 <1) {
+ $deltaX = 1 + $x0 - $x1;
+ }
+ }
+ #
+ # And set the relative X
+ #
+ $other->GetRootNode()->SetRelX($deltaX);
+
+ #
+ # Now we recalculate our area
+ #
+ for (my $y=$intMin; $y<=$intMax; $y++) {
+ $self->SetXmax($y, $other->GetXmax($y-$deltaY) + $deltaX);
+ }
+ if ($other->GetYmin()+$deltaY < $self->GetYmin()) {
+ for (my $y=$other->GetYmin()+$deltaY; $y<$self->GetYmin(); $y++) {
+ $self->SetXmin($y, $other->GetXmin($y-$deltaY)+$deltaX);
+ $self->SetXmax($y, $other->GetXmax($y-$deltaY)+$deltaX);
+ }
+ $self->SetYmin($other->GetYmin()+$deltaY);
+ }
+ if ($other->GetYmax()+$deltaY > $self->GetYmax()) {
+ for (my $y=$self->GetYmax()+1; $y<=$other->GetYmax()+$deltaY; $y++) {
+ $self->SetXmin($y, $other->GetXmin($y-$deltaY)+$deltaX);
+ $self->SetXmax($y, $other->GetXmax($y-$deltaY)+$deltaX);
+ }
+ $self->SetYmax($other->GetYmax()+$deltaY);
+ }
+}
+
+####################################################################
+# AddLeft #
+####################################################################
+
+=pod
+
+=item B<AddLeft>(I<$otherarea>);
+
+Add the new area I<$otherarea> to the given area at the left. The
+"other area" should have a root node that is relative to our root
+node. The relative Y of the other root node is used, the relative
+X is set.
+
+=cut
+
+sub AddLeft {
+ my ($self, $other) = @_;
+ my $deltaY = $other->GetRootNode()->GetRelY();
+
+ #
+ # First, we calculate the intersection of two areas
+ # It is between max(Y_{min,1}, Y_{min,2}+deltaY)
+ # and min(Y_{max,1}, Y_{max,2}+deltaY)
+ #
+ my $intMin=$self->GetYmin();
+ if ($other->GetYmin()+$deltaY > $intMin) {
+ $intMin = $other->GetYmin()+$deltaY;
+ }
+ my $intMax = $self->GetYmax();
+ if ($other->GetYmax()+$deltaY < $intMax) {
+ $intMax=$other->GetYmax()+$deltaY;
+ }
+
+ #
+ # Now we are ready to calculate relative X shift
+ #
+ my $deltaX=0;
+ for (my $y=$intMin; $y<=$intMax; $y++) {
+ my $x0 = $other->GetXmax($y-$deltaY);
+ my $x1 = $self->GetXmin($y);
+ if ($x1 + $deltaX - $x0 <1) {
+ $deltaX = 1 + $x0 - $x1;
+ }
+ }
+ #
+ # And set the relative X
+ #
+ $other->GetRootNode()->SetRelX(-$deltaX);
+
+ #
+ # Now we recalculate our area
+ #
+ for (my $y=$intMin; $y<=$intMax; $y++) {
+ $self->SetXmin($y, $other->GetXmin($y-$deltaY) - $deltaX);
+ }
+ if ($other->GetYmin()+$deltaY < $self->GetYmin()) {
+ for (my $y=$other->GetYmin()+$deltaY; $y<$self->GetYmin(); $y++) {
+ $self->SetXmin($y, $other->GetXmin($y-$deltaY)-$deltaX);
+ $self->SetXmax($y, $other->GetXmax($y-$deltaY)-$deltaX);
+ }
+ $self->SetYmin($other->GetYmin()+$deltaY);
+ }
+ if ($other->GetYmax()+$deltaY > $self->GetYmax()) {
+ for (my $y=$self->GetYmax()+1; $y<=$other->GetYmax()+$deltaY; $y++) {
+ $self->SetXmin($y, $other->GetXmin($y-$deltaY)-$deltaX);
+ $self->SetXmax($y, $other->GetXmax($y-$deltaY)-$deltaX);
+ }
+ $self->SetYmax($other->GetYmax()+$deltaY);
+ }
+}
+
+####################################################################
+# GetRootNode #
+####################################################################
+
+=pod
+
+=item B<GetRootNode>();
+
+Return the root node of the area.
+
+=cut
+
+sub GetRootNode {
+ my $self = shift;
+ return $self->{'RootNode'};
+}
+
+####################################################################
+# MoveLowerLayers #
+####################################################################
+
+=pod
+
+=item B<MoveLowerLayers>(I<$x>);
+
+Shift the lower layers (>0) of the area in the X direction by I<$x>
+
+=cut
+
+sub MoveLowerLayers {
+ my $self = shift;
+ my $x=shift;
+ for (my $y=-1; $y>=$self->GetYmin; $y--) {
+ $self->SetXmin($y, $self->GetXmin($y)+$x);
+ $self->SetXmax($y, $self->GetXmax($y)+$x);
+ }
+ return 0;
+}
+
+
+
+####################################################################
+# THE END #
+####################################################################
+
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+=head1 SEE ALSO
+
+pedigree(1), Pedigree(3)
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2006, 2007
+
+
+
+=cut
+
+1;
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree/ChildlessNode.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/ChildlessNode.pm
new file mode 100644
index 00000000000..db4b1c985b6
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/ChildlessNode.pm
@@ -0,0 +1,150 @@
+=pod
+
+=head1 NAME
+
+Pedigree::ChildlessNode - an abortion in a pedigree
+
+=head1 SYNOPSIS
+
+use Pedigree::ChildlessNode;
+
+$node = new Pedigree::ChildlessNode(I<%params>);
+
+$node->DrawNode(I<$xidst>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+$node->PrintLegend(I<$land>, I<@fields>);
+
+
+=head1 DESCRIPTION
+
+This package contains data about a "childlessness" node. This node
+is not numbered in pedigree.
+
+=over 4
+
+=cut
+
+
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree::ChildlessNode;
+use Pedigree;
+use strict;
+our @ISA=('Pedigree::PersonNode');
+
+####################################################################
+# new #
+####################################################################
+
+=pod
+
+=item B<new>(I<%params>);
+
+Construct a new node from the given parameters.
+
+=cut
+
+sub new {
+ my ($class,%params)=@_;
+ my $self=$class->SUPER::new(%params);
+ if (!ref($self)) {
+ return 0;
+ }
+
+ #
+ # These nodes are NOT numbered in pedigrees
+ #
+
+ $self->{'Numbered'}=0;
+
+ return $self;
+
+}
+
+
+####################################################################
+# DrawNode #
+####################################################################
+
+=pod
+
+=item B<DrawNode>(I<$xdist>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+Output the command to draw this node. The parameters are
+distances between the nodes (in cm) and fields for abovetext (not used
+here). We only print the Comment field below the node, and draw this
+node higher than other nodes.
+
+=cut
+
+sub DrawNode {
+ my $self=shift;
+ my ($xdist, $ydist, $belowtextfont, $abovetextfont, @fieldsfornode) = @_;
+ my $result = '\rput('.($xdist*$self->GetAbsX()).", ".
+ ($ydist*($self->GetAbsY()+0.6)).'){\pstChildless[';
+ my @opts=('belowtextrp=t');
+ if ($self->{'Comment'}) {
+ push @opts,
+ 'belowtext={'."$belowtextfont ".$self->{'Comment'}.'}';
+ }
+ if ($self->Type() eq 'infertile') {
+ push @opts, 'infertile';
+ }
+ if (scalar @opts) {
+ $result .= join(', ',@opts);
+ }
+ $result .= ']{'.$self->Id()."}}\n";
+ return $result;
+}
+
+####################################################################
+# PrintLegend #
+####################################################################
+
+=pod
+
+=item B<PrintLegend>(I<$lang>, I<@fields>);
+
+This subroutine does nothing since childlessness has no legend.
+
+=cut
+
+sub PrintLegend {
+
+ return;
+}
+
+
+
+####################################################################
+# THE END #
+####################################################################
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+=head1 SEE ALSO
+
+pedigree(1), Pedigree(3)
+
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2007
+
+
+
+=cut
+
+1;
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Language.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Language.pm
new file mode 100644
index 00000000000..bcae95d3074
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Language.pm
@@ -0,0 +1,459 @@
+=pod
+
+=head1 NAME
+
+Pedigree::Language - encapsulating language issues for pedigree library
+
+=head1 SYNOPSIS
+
+use Pedigree::Language;
+
+$lang = new Pedigree::Language(I<$language>[, I<$encoding>]);
+
+$lang->Header();
+
+$lang->Language();
+
+$lang->Encoding();
+
+$lang->GetFieldNames();
+
+$lang->GetValues();
+
+$lang->GetSpecialNames();
+
+$lang->PrintField(I<$field>, $<$value>);
+
+
+=head1 DESCRIPTION
+
+This package defines the language-dependent parts of the pedigree
+library. The idea is to gather everything about language here, so adding
+a new language should be (presumably) be easy.
+
+=over 4
+
+=cut
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree::Language;
+use strict;
+
+#
+# And package methods
+#
+
+
+####################################################################
+# new #
+####################################################################
+
+=pod
+
+
+=item B<new>(I<$language>[, I<$encoding>]);
+
+Construct the new interpreter from the given language and encoding names.
+
+=cut
+
+
+sub new {
+ my $self={};
+ my ($class,$language,$encoding)=@_;
+ $self->{'language'}=$language;
+ if (!defined($encoding) && ($language eq 'russian')) {
+ $encoding='cp1251';
+ }
+ if (defined($encoding)) {
+ $self->{encoding}=$encoding;
+ }
+ bless $self, $class;
+ return ($self);
+}
+
+
+####################################################################
+# Header #
+####################################################################
+
+
+=pod
+
+=item B<Header> ()
+
+Print the language-related lines of the document preamble
+
+=cut
+
+sub Header {
+ my $self=shift;
+ my $result;
+ if ($self->Encoding()) {
+ $result .= '\usepackage['.$self->Encoding().']{inputenc}'."\n";
+ }
+ if (!($self->Language() eq 'english')) {
+ $result .= '\usepackage['.$self->Language().']{babel}'."\n";
+ }
+ return $result;
+
+}
+
+
+####################################################################
+# Language #
+####################################################################
+
+
+=pod
+
+=item B<Language> ()
+
+Print the current language
+
+=cut
+
+sub Language {
+ my $self=shift;
+ return $self->{'language'};
+}
+
+####################################################################
+# Encoding #
+####################################################################
+
+
+=pod
+
+=item B<Encoding> ()
+
+Print the current encoding
+
+=cut
+
+sub Encoding {
+ my $self=shift;
+ return $self->{'encoding'};
+}
+
+
+####################################################################
+# GetFieldNames #
+####################################################################
+
+
+=pod
+
+=item B<GetFieldNames>();
+
+Outputs a reference to a hash
+"field_name_in_this_language"=>"field_name_in_English"
+
+=cut
+
+sub GetFieldNames() {
+ my $self=shift;
+ my %result=();
+
+ #
+ # The English names are default
+ #
+ %result=(
+ 'Id'=>'Id',
+ 'Name'=>'Name',
+ 'Sex'=>'Sex',
+ 'DoB'=>'DoB',
+ 'DoD'=>'DoD',
+ 'Mother'=>'Mother',
+ 'Father'=>'Father',
+ 'Proband'=>'Proband',
+ 'Condition'=>'Condition',
+ 'Type'=>'Type',
+ 'Twins'=>'Twins',
+ 'Comment'=>'Comment',
+ 'SortOrder'=>'SortOrder',
+ 'Sort'=>'SortOrder');
+
+ #
+ # Russian names depend on the encoding
+ #
+ if (($self->Language() eq 'russian') && ($self->Encoding() eq 'koi8-r')) {
+ $result{'éÄÅÎÔ'}='Id';
+ $result{'æéï'}='Name';
+ $result{'ðÏÌ'}='Sex';
+ $result{'òÏÖÄ'}='DoB';
+ $result{'õÍÅÒ'}='DoD';
+ $result{'íÁÔØ'}='Mother';
+ $result{'ïÔÅÃ'}='Father';
+ $result{'ðÒÏÂÁÎÄ'}='Proband';
+ $result{'óÏÓÔÏÑÎÉÅ'}='Condition';
+ $result{'ôÉÐ'}='Type';
+ $result{'âÌÉÚÎÅÃÙ'}='Twins';
+ $result{'ëÏÍÍÅÎÔÁÒÉÊ'}='Comment';
+ $result{'ðÏÒÑÄÏËóÏÒÔÉÒÏ×ËÉ'}='SortOrder';
+ $result{'óÏÒÔ'}='SortOrder';
+ }
+ if (($self->Language() eq 'russian') && ($self->Encoding() eq 'cp1251')) {
+ $result{'Èäåíò'}='Id';
+ $result{'ÔÈÎ'}='Name';
+ $result{'Ïîë'}='Sex';
+ $result{'Ðîæä'}='DoB';
+ $result{'Óìåð'}='DoD';
+ $result{'Ìàòü'}='Mother';
+ $result{'Îòåö'}='Father';
+ $result{'Ïðîáàíä'}='Proband';
+ $result{'Ñîñòîÿíèå'}='Condition';
+ $result{'Òèï'}='Type';
+ $result{'×íêÿïåçý'}='Twins';
+ $result{'Êîììåíòàðèé'}='Comment';
+ $result{'ÏîðÿäîêÑîðòèðîâêè'}='SortOrder';
+ $result{'Ñîðò'}='SortOrder';
+ }
+
+
+ return \%result;
+}
+
+####################################################################
+# GetValues #
+####################################################################
+
+
+=pod
+
+=item B<GetValues>();
+
+Outputs a reference to a hash
+"field_value_in_this_language"=>"field_value_in_English"
+
+=cut
+
+sub GetValues {
+ my $self=shift;
+ my %result=();
+
+ #
+ # The English values are default
+ #
+ %result=(
+ 'male'=>'male',
+ 'female'=>'female',
+ 'unknown'=>'unknown',
+ 'yes'=>1,
+ 'no'=>0,
+ 'normal'=>'normal',
+ 'obligatory'=>'obligatory',
+ 'oblig'=>'obligatory',
+ 'asymptomatic'=>'asymptomatic',
+ 'asymp'=>'asymptomatic',
+ 'affected'=>'affected',
+ 'affect'=>'affected',
+ 'infertile'=>'infertile',
+ 'Infertile'=>'infertile',
+ 'sab'=>'sab',
+ 'Sab'=>'sab',
+ 'monozygotic'=>'monozygotic',
+ 'monozygot'=>'monozygotic',
+ 'qzygotic'=>'qzygotic',
+ 'qzygot'=>'qzygotic',
+ '?'=>'qzygotic',
+ );
+
+ #
+ # Russian names depend on the encoding
+ #
+ if (($self->Language() eq 'russian') && ($self->Encoding() eq 'koi8-r')) {
+ $result{'ÍÕÖ'} = 'male';
+ $result{'ÖÅÎ'} = 'female';
+ $result{'Í'} = 'male';
+ $result{'Ö'} = 'female';
+ $result{'ÎÅÉÚ×'} = 'unknown';
+ $result{'ÎÅÉÚ×ÅÓÔÎÏ'} = 'unknown';
+ $result{'ÄÁ'} = 1;
+ $result{'ÎÅÔ'} = 0;
+ $result{'äÁ'} = 1;
+ $result{'îÅÔ'} = 0;
+ $result{'ÎÏÒÍ'} = 'normal';
+ $result{'ÚÄÏÒÏ×'} = 'normal';
+ $result{'ÏÂÌÉÇÁÔ'} = 'obligatory';
+ $result{'ÁÓÉÍÐ'} = 'asymptomatic';
+ $result{'ÂÏÌØÎ'} = 'affected';
+ $result{'ÂÏÌÅÎ'} = 'affected';
+ $result{'ÂÅÓÐÌÏÄÎ'} = 'infertile';
+ $result{'×ÙËÉÄÙÛ'} = 'sab';
+ $result{'ÏÄÎÏÑÊÃÅ×'} = 'monozygotic';
+ $result{'ÍÏÎÏÚÉÇÏÔÎ'} = 'monozygotic';
+ $result{'ÍÏÎÏÚÉÇ'} = 'monozygotic';
+ $result{'ÄÉÚÉÇ'} = '';
+ }
+
+ if (($self->Language() eq 'russian') && ($self->Encoding() eq 'cp1251')) {
+ $result{'ìóæ'} = 'male';
+ $result{'æåí'} = 'female';
+ $result{'ì'} = 'male';
+ $result{'æ'} = 'female';
+ $result{'íåèçâ'} = 'unknown';
+ $result{'íåèçâåñòíî'} = 'unknown';
+ $result{'äà'} = 1;
+ $result{'íåò'} = 0;
+ $result{'Äà'} = 1;
+ $result{'Íåò'} = 0;
+ $result{'íîðì'} = 'normal';
+ $result{'ÿäðôðþ'} = 'normal';
+ $result{'îáëèãàò'} = 'obligatory';
+ $result{'àñèìï'} = 'asymptomatic';
+ $result{'áîëüí'} = 'affected';
+ $result{'÷ðíåï'} = 'affected';
+ $result{'÷åõòíðäï'} = 'infertile';
+ $result{'þýìêäýù'} = 'sab';
+ $result{'ðäïðóëçåþ'} = 'monozygotic';
+ $result{'îðïðÿêúðæï'} = 'monozygotic';
+ $result{'îðïðÿêú'} = 'monozygotic';
+ $result{'äêÿêú'} = '';
+ }
+
+ return \%result;
+}
+
+####################################################################
+# GetSpecialNames #
+####################################################################
+
+
+=pod
+
+=item B<GetSpecialNames>();
+
+Some values for the 'Name' field start with C<#>. They are special.
+This subroutine outputs a reference to a hash
+"special_name_in_this_language"=>"special_name"
+
+=cut
+
+sub GetSpecialNames {
+ my $self=shift;
+ my %result=();
+
+ #
+ # The English values are default
+ #
+ %result=(
+ 'abort'=>'abortion',
+ 'childless'=>'childless',
+ );
+
+ #
+ # Russian names depend on the encoding
+ #
+ if (($self->Language() eq 'russian') && ($self->Encoding() eq 'koi8-r')) {
+ $result{'ÁÂÏÒÔ'} = 'abortion';
+ $result{'ÂÅÚÄÅÔÎ'} = 'childless';
+ }
+
+ if (($self->Language() eq 'russian') && ($self->Encoding() eq 'cp1251')) {
+ $result{'â÷ðôæ'} = 'abortion';
+ $result{'÷åÿäåæï'} = 'childless';
+ }
+
+ return \%result;
+}
+
+
+
+####################################################################
+# PrintField #
+####################################################################
+
+
+=pod
+
+=item B<PrintField>(I<$field>, I<$value>);
+
+Formats the value I<$value> of the given field I<$field> according
+to the rules of the given language.
+
+=cut
+
+sub PrintField {
+ my $self=shift;
+ my ($field, $value) = @_;
+
+
+ #
+ # The English values are default
+ #
+
+ if ($self->Language() eq 'english') {
+ if ($field eq 'DoB' ) {
+ return "born: $value";
+ }
+ if ($field eq 'DoD' ) {
+ return "died: $value";
+ }
+ if ($field eq 'AgeAtDeath') {
+ return "age at death: $value";
+ }
+ }
+
+ if ($self->Language() eq 'russian') {
+ if ($value eq 'unknown') {
+ $value = '{\cyr\cyrn\cyre\cyri\cyrz\cyrv.}';
+ }
+ if ($field eq 'DoB' ) {
+ return '{\cyr\cyrr\cyro\cyrd.}'." $value";
+ }
+ if ($field eq 'DoD') {
+ return '{\cyr\cyru\cyrm.}'." $value";
+ }
+ if ($field eq 'AgeAtDeath') {
+ return '{\cyr\cyru\cyrm. \cyrv{} \cyrv\cyro\cyrz\cyrr. }'." $value";
+ }
+ #
+ # Special name
+ #
+ if ($field eq 'Name' && $value eq 'abortion') {
+ return '{\cyr\cyra\cyrb\cyro\cyrr\cyrt}';
+ }
+ }
+
+
+ #
+ # The last resort
+ #
+ return $value;
+
+
+}
+
+
+
+####################################################################
+# THE END #
+####################################################################
+
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+=head1 SEE ALSO
+
+pedigree(1), Pedigree(3)
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2006, 2007
+
+
+
+=cut
+
+1;
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree/MarriageNode.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/MarriageNode.pm
new file mode 100644
index 00000000000..39e20bf58f9
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/MarriageNode.pm
@@ -0,0 +1,346 @@
+=pod
+
+=head1 NAME
+
+Pedigree::MarriageNode - a marriage in a pedigree
+
+=head1 SYNOPSIS
+
+use Pedigree::MarriageNode;
+
+$node = new Pedigree::MarriageNode(I<%params>);
+
+$FSpouse = $node->FSpouse();
+
+$MSpouse = $node->MSpouse();
+
+$consang = $self->isConsanguinic();
+
+$area = $node->SetArea();
+
+$node->CalcAbsCoord(I<$x>, I<$y>);
+
+$node->DrawNode(I<$xidst>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+$node->DrawConnections();
+
+
+=head1 DESCRIPTION
+
+This package contains data about a marriage.
+
+=over 4
+
+=cut
+
+
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree::MarriageNode;
+use Pedigree;
+use strict;
+our @ISA=('Pedigree::Node');
+
+
+####################################################################
+# new #
+####################################################################
+
+=pod
+
+=item B<new>(I<%params>);
+
+Construct a new node from the given parameters.
+
+=cut
+
+sub new {
+ my ($class,%params)=@_;
+ my $self=$class->SUPER::new(%params);
+ if (!ref($self)) { # Bad node
+ return 0;
+ }
+
+ bless ($self,$class);
+
+ #
+ # Normally marriage nodes are not consanguinic
+ #
+ if (!exists($self->{'Consanguinic'})) {
+ $self->{'Consanguinic'} = 0;
+ }
+
+ # After we constructed the node, we want to move the kids
+ # from the parent nodes to the marriage node
+
+ my $selfId = $self->{'Id'};
+ if (exists($self->{'FSpouse'}) && exists($self->{'MSpouse'})) {
+ my $fspouse = $self->{'FSpouse'};
+ my $fspouseId = $fspouse->Id();
+ my $mspouse = $self->{'MSpouse'};
+ my $mspouseId = $mspouse->Id();
+
+
+ foreach my $kidId (keys %{$self->{'kids_by_parent_id'}->{$fspouseId}}) {
+ if ($main::DEBUG) {
+ print STDERR "Checking kid $kidId for $selfId\n";
+ }
+ if (exists ($self->{'kids_by_parent_id'}->{$mspouseId}->{$kidId})) {
+ if ($main::DEBUG) {
+ print STDERR
+ "Moving $kidId from $fspouseId and $mspouseId to ".
+ "$selfId\n";
+ }
+ delete $self->{'kids_by_parent_id'}->{$mspouseId}->{$kidId};
+ delete $self->{'kids_by_parent_id'}->{$fspouseId}->{$kidId};
+ $self->{'kids_by_parent_id'}->{$selfId}->{$kidId}=1;
+ }
+ }
+ }
+
+ return $self;
+}
+
+
+####################################################################
+# FSpouse #
+####################################################################
+
+=pod
+
+=item B<FSpouse>();
+
+Get female spouse of a node.
+
+=cut
+
+sub FSpouse {
+ my $self = shift;
+ return $self->{'FSpouse'};
+}
+
+
+####################################################################
+# MSpouse #
+####################################################################
+
+=pod
+
+=item B<MSpouse>();
+
+Get female spouse of a node.
+
+=cut
+
+sub MSpouse {
+ my $self = shift;
+ return $self->{'MSpouse'};
+}
+
+####################################################################
+# isConsanguinic #
+####################################################################
+
+=pod
+
+=item B<isConsanguinic>();
+
+Check whether the node is consanguinic
+
+=cut
+
+sub isConsanguinic {
+ my $self = shift;
+ return $self->{'Consanguinic'};
+}
+
+
+####################################################################
+# SetArea #
+####################################################################
+
+=pod
+
+=item B<SetArea>();
+
+Calculate relative coordinates for all nodes, that are descendants of
+the given node I<and> the spouses that form the marriage. We create a
+Pedigree::Area(3) around the given node and recursively apply the
+function to all descendants. The subroutine
+returns the reference to the created area.
+
+=cut
+
+sub SetArea {
+ my $self = shift;
+ my $area = $self->SUPER::SetArea();
+
+ #
+ # Female is to the right, male is to the left unless we have
+ # Sort Order set for anybody. If it is set, the order
+ # is OPPOSITE to the SortOrder
+ #
+ my ($left,$right) = ($self->MSpouse(), $self->FSpouse());
+ if ($left->SortOrder() <=> $right->SortOrder()) {
+ ($left,$right) =
+ sort {$a->SortOrder() <=> $b->SortOrder()} ($left,$right);
+ }
+ my ($rightRoot,$gen) = @{$right->FindRoot(0,-1)};
+ $rightRoot->SetRelY($gen);
+ my $rightArea=$rightRoot->SetArea();
+ $area->AddRight($rightArea);
+
+ my ($leftRoot,$gen) = @{$left->FindRoot(0,1)};
+ $leftRoot->SetRelY($gen);
+ my $leftArea=$leftRoot->SetArea();
+ $area->AddLeft($leftArea);
+
+ $self->{'Area'}=$area;
+
+ if ($main::DEBUG) {
+ print STDERR "Setting area for marriage node ",$self->Id(),"\n";
+ for (my $y=$area->GetYmin(); $y<=$area->GetYmax(); $y++) {
+ print STDERR "\t$y: ", $area->GetXmin($y), ", ",
+ $area->GetXmax($y), "\n";
+ }
+ }
+
+
+ return $area;
+}
+
+
+####################################################################
+# CalcAbsCoor #
+####################################################################
+
+=pod
+
+=item B<CalcAbsCoor>(I<$x>, $<y>);
+
+Set the absolute coordinates of the given node, if the absolute
+coordinates of the parent node are (I<$x>, I<$y>), and recursively
+do this for all descendants of this node, and right and left clumps.
+
+=cut
+
+sub CalcAbsCoor {
+ my $self=shift;
+ my ($x,$y) = @_;
+ $self->SUPER::CalcAbsCoor($x, $y);
+ $x += $self->GetRelX();
+ $y += $self->GetRelY();
+
+ my ($FRoot,undef) = @{$self->FSpouse()->FindRoot(0)};
+ $FRoot->CalcAbsCoor($x, $y);
+
+ my ($MRoot,undef) = @{$self->MSpouse()->FindRoot(0)};
+ $MRoot->CalcAbsCoor($x, $y);
+
+ return 0;
+}
+
+
+####################################################################
+# DrawNode #
+####################################################################
+
+=pod
+
+=item B<DrawNode>(I<$xdist>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+Output the command to draw this node. The parameters are
+distances between the nodes (in cm).
+
+=cut
+
+sub DrawNode {
+ my $self=shift;
+ my ($xdist, $ydist, $belowtextfont, $abovetextfont, @fieldsfornode) = @_;
+ my $result = '\rput('.($xdist*$self->GetAbsX()).", ".
+ ($ydist*$self->GetAbsY()).'){\pnode{'.
+ $self->Id()."}}\n";
+ return $result;
+}
+
+####################################################################
+# DrawConnections #
+####################################################################
+
+=pod
+
+=item B<DrawConnections>();
+
+Draw the connections from the given node to its descendants and
+the spouses
+
+=cut
+
+sub DrawConnections {
+ my $self = shift;
+ my $xdist = shift;
+ my $ydist = shift;
+ my $result = $self->SUPER::DrawConnections($xdist, $ydist);
+ my $Id=$self->Id();
+ my $style="";
+ if ($self->isConsanguinic()) {
+ $style='doubleline=true, ';
+ }
+ foreach my $spouse ($self->FSpouse(), $self->MSpouse()) {
+ if (!ref($spouse)) {
+ next;
+ }
+ my $sId=$spouse->Id();
+ # Check whether spouse nodes are adjacent to the marriage node.
+ # We do this check only for non-consanguinic unions
+ if (!($self->isConsanguinic()) &&
+ (abs($self->GetIndexX() - $spouse->GetIndexX()) > 1)) {
+ my ($nodeA,$nodeB) = sort
+ {$a->GetIndexX() <=> $b->GetIndexX()} ($spouse, $self);
+ my $IdA=$nodeA->Id();
+ my $IdB=$nodeB->Id();
+ $result .=
+ "\\ncloop[$style angleA=0, angleB=180, loopsize=".
+ 0.4*$ydist . ', arm=' . 0.4*$xdist .
+ ']{'.$IdA.'}{'.$IdB.'}'."\n";
+ } else {
+ $result .= "\\ncline[$style]{".$Id.'}{'.$sId.'}'."\n";
+ }
+ }
+ return $result;
+}
+
+
+
+
+####################################################################
+# THE END #
+####################################################################
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+=head1 SEE ALSO
+
+pedigree(1), Pedigree(3)
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2006, 2007
+
+
+
+=cut
+
+1;
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Node.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Node.pm
new file mode 100644
index 00000000000..445f92abafb
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Node.pm
@@ -0,0 +1,1240 @@
+=pod
+
+=head1 NAME
+
+Pedigree::Node - the base package for nodes in pedigree charts
+
+=head1 SYNOPSIS
+
+use Pedigree::Node;
+
+$node = new Pedigree::Node(I<%params>);
+
+$node->CheckAllParents();
+
+$Id = $node->Id();
+
+$node->SetSortOrder(-1|0|1);
+
+$result = $node->SortOrder();
+
+$is_numbered=$node->isNumbered();
+
+$type = $node->Type();
+
+$Kids = $node->Kids();
+
+$node->GetAndSortKids();
+
+($root, $newgen) = $node->FindRoot(I<$generation>, [I<$sort_order>]);
+
+$x = $node->GetRelX();
+
+$y = $node->GetRelY();
+
+$node->SetRelX(I<$x>);
+
+$node->SetRelX(I<$y>);
+
+$x = $node->GetAbsX();
+
+$y = $node->GetAbsY();
+
+$node->SetIndexX(I<$n>);
+
+$node->SetAbsX(I<$x>);
+
+$node->SetAbsY(I<$y>);
+
+$n = $node->GetIndexX();
+
+$area = $node->SetArea();
+
+$delta = $node->CenterKids();
+
+
+$node->CalcAbsCoord(I<$x>, I<$y>);
+
+$node->AddConsanguinicMarriages();
+
+$node->AddTwins($ydist);
+
+$frame = $node->SetFrame(I<$xdist>, I<$ydist>);
+
+
+$node->DrawAll(I<$xdist>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+ I<@fieldsfornode>);
+
+$node->DrawConnections();
+
+$node->PrintAllLegends(I<$land>, I<@fields>);
+
+$node->PrintLegend(I<$land>, I<@fields>);
+
+=head1 DESCRIPTION
+
+This is the basic package that defines nodes for pedigrees.
+Pedigree::PersonNode(3) and Pedigree::MarriageNode(3) inherit from
+this package.
+
+=over 4
+
+=cut
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree::Node;
+use strict;
+use Pedigree;
+
+####################################################################
+# package variables #
+####################################################################
+
+#
+# The pool: %node_by_id keeps the relation between
+# nodes and references
+#
+
+our %node_by_id;
+
+#
+# The hash %node_by_gen is a hash of hasehs. The keys
+# are generation numbers (with zero being the root of pedigree),
+# and the values are the hashes Id->node
+#
+our %node_by_gen;
+
+#
+# The hash %kids_by_parent_id is a hash of hashes. The keys are
+# Ids of parents. The hashes are $kid->1, where $kid is the kid id
+# (NOT the kid node due to limitations of Perl)
+#
+our %kids_by_parent_id;
+
+#
+# The array @twin_sets lists all twin nodes. Each twin node is
+# a has with entries 'Type' and 'KidIds'. They store
+# twins type (monozygotic, qzygotic or empty) and Ids of the
+# kid nodes correspondingly (KidIds is actually a hash of
+# node Ids).
+#
+our @twin_sets;
+
+####################################################################
+# And package methods #
+####################################################################
+
+####################################################################
+# new #
+####################################################################
+
+=pod
+
+=item B<new>(I<%params>);
+
+Construct a new node from the given parameters. If a node with
+the give Id exists, add new information to the node.
+
+=cut
+
+sub new {
+ my ($class,%params)=@_;
+
+ if (!exists($params{'Id'})) {
+ print STDERR "Warning: cannot create node from %params\n";
+ return 0;
+ }
+
+ my $Id=$params{'Id'};
+ my $self;
+ if (exists($node_by_id{$Id})) {
+ $self=$node_by_id{$Id};
+ } else {
+ $self={};
+ bless ($self,$class);
+ $node_by_id{$Id}=$self;
+ }
+
+ foreach my $key (keys %params) {
+ $self->{$key} = $params{$key};
+ }
+
+ #
+ # Calculate age at death
+ #
+ if (exists($self->{'DoB'}) && exists($self->{'DoD'})) {
+ $self->{'AgeAtDeath'} = 'unknown';
+ if (($self->{'DoB'} ne 'unknown') &&
+ ($self->{'DoD'} ne 'unknown')) {
+ my ($y1, $m1, $d1) = split /\./, $self->{'DoB'};
+ my ($y2, $m2, $d2) = split /\./, $self->{'DoD'};
+ $self->{'AgeAtDeath'} = int(($y2-$y1) + ($m2-$m1)/12
+ + ($d2-$d1)/12/30);
+ }
+ }
+
+
+ #
+ # Only Person Nodes are numbered in pedigrees
+ #
+ $self->{'Numbered'}=0;
+
+ #
+ # The field 'Kids' is special. This is a reference
+ # to an array filled by GetAndSortKids()
+ #
+ if (!exists($self->{'Kids'})) {
+ $self->{'Kids'}=[];
+ }
+
+ #
+ # Hashes %kids_by_parent_id
+ #
+ if (exists($self->{'Mother'})) {
+ my $parent = $self->{'Mother'};
+ $kids_by_parent_id{$parent}->{$self->Id()}=1;
+ }
+ if (exists($self->{'Father'})) {
+ my $parent = $self->{'Father'};
+ $kids_by_parent_id{$parent}->{$self->Id()}=1;
+ }
+
+ #
+ # Add references to the hashes
+ #
+
+ $self->{'node_by_id'} = \%node_by_id;
+ $self->{'node_by_gen'} = \%node_by_gen;
+ $self->{'kids_by_parent_id'} = \%kids_by_parent_id;
+ $self->{'twin_sets'} = \@twin_sets;
+
+ #
+ # Initially the nodes are sorted by age only
+ #
+ if (!($self->{'SortOrder'})) {
+ $self->{'SortOrder'} = 0;
+ }
+
+
+ return $self;
+
+}
+
+####################################################################
+# CheckAllParents #
+####################################################################
+
+=pod
+
+=item B<CheckAllParents>();
+
+Check whether mothers and fathers of all nodes exist
+
+=cut
+
+sub CheckAllParents {
+ my $self = shift;
+
+ foreach my $parentId (keys %kids_by_parent_id) {
+ if (!exists($node_by_id{$parentId}) ) {
+ print STDERR
+ "Node $parentId does not exist and is listed as parent for nodes";
+ foreach my $kidId (keys %{$kids_by_parent_id{$parentId}}) {
+ print STDERR " ", $kidId;
+ my $kid = $node_by_id{$kidId};
+ if ($kid->{'Mother'} eq $parentId) {
+ delete $kid->{'Mother'};
+ }
+ if ($kid->{'Father'} eq $parentId) {
+ delete $kid->{'Father'};
+ }
+ }
+ print STDERR ". Deleting\n";
+ delete $kids_by_parent_id{$parentId};
+ } elsif ($main::DEBUG) {
+ print STDERR "Node $parentId is OK\n";
+ }
+ }
+
+ return 0;
+}
+
+
+####################################################################
+# Id #
+####################################################################
+
+=pod
+
+=item B<Id>();
+
+Get Id of a node. Note that there is no way to set an Id of a node
+that was already created.
+
+=cut
+
+sub Id {
+ my $self = shift;
+ return $self->{'Id'};
+}
+
+####################################################################
+# SetSortOrder #
+####################################################################
+
+=pod
+
+=item B<SetSortOrder>(I<-1|0|1>);
+
+Normally the sibs nodes are sorted by age. However, if the nodes or
+their descendants are connected by a marriage line, we must sort them
+in the special way: all way to the left or all way to the right. The
+procedure B<SetSortOrder> sets this flag for the node or deletes it
+depending on the argument.
+
+=cut
+
+sub SetSortOrder {
+ my $self = shift;
+ my $order = shift;
+ $self->{'SortOrder'}=$order;
+ return $order;
+}
+
+####################################################################
+# SortOrder #
+####################################################################
+
+=pod
+
+=item B<SortOrder>();
+
+Normally the sibs nodes are sorted by age. However, if the nodes or
+their descendants are connected by a marriage line, we must sort them
+in the special way: all way to the left or all way to the right. The
+procedure B<SortOrder> checks this flag.
+
+=cut
+
+sub SortOrder {
+ my $self = shift;
+ return $self->{'SortOrder'};
+}
+
+####################################################################
+# isNumbered #
+####################################################################
+
+=pod
+
+=item B<isNumbered>();
+
+Check whether the node should be numbered in pedigree
+
+=cut
+
+sub isNumbered {
+ my $self = shift;
+ return $self->{'Numbered'};
+}
+
+####################################################################
+# Type #
+####################################################################
+
+=pod
+
+=item B<Type>()
+
+Return node type.
+
+=cut
+
+sub Type {
+ my $self=shift;
+ return $self->{'Type'};
+}
+
+
+
+####################################################################
+# Kids #
+####################################################################
+
+=pod
+
+=item B<Kids>();
+
+Get the reference to the array of kids
+
+=cut
+
+sub Kids {
+ my $self = shift;
+ return $self->{'Kids'};
+}
+
+
+####################################################################
+# GetAndSortKids #
+####################################################################
+
+=pod
+
+=item B<GetAndSortKids>();
+
+Apply sort the array of kids for the given node
+
+=cut
+
+sub GetAndSortKids {
+ my $self=shift;
+ my @kids;
+ my $Id = $self->Id();
+ foreach my $kidId (keys %{$self->{'kids_by_parent_id'}->{$Id}}) {
+ push @kids, $self->{'node_by_id'}->{$kidId};
+ }
+ @kids = sort by_sibs_order @kids;
+ $self->{'Kids'}=\@kids;
+ if ($main::DEBUG) {
+ print STDERR "Node ",$self->Id(),", Kids: ";
+ foreach my $kid (@{$self->Kids()}) {
+ print STDERR $kid->Id(), " ";
+ }
+ print STDERR "\n";
+ }
+ return 0;
+}
+
+####################################################################
+# FindRoot #
+####################################################################
+
+=pod
+
+=item B<FindRoot>(I<$generation>, [I<$sort_order>]);
+
+Finds the root of the tree to which the current node belongs.
+Takes the current generation number and returns the root and its
+generation number. Here generation numbers go "backwards": the older
+generations have higher numbers. The found node is assigned sort order
+I<$sort_order>.
+
+=cut
+
+sub FindRoot {
+ my ($self,$gen,$sort)=@_;
+
+ if (defined $sort && !($self->SortOrder())) {
+ $self->SetSortOrder($sort);
+ }
+
+ # If there are no parents, I am the root
+ if (!exists($self->{'Mother'}) && !exists($self->{'Father'})) {
+ my @result=($self,$gen);
+ return \@result;
+ }
+
+ # If there are both parents, their union is the root
+ if (exists($self->{'Mother'}) && exists($self->{'Father'})) {
+ my $motherId=$self->{'Mother'};
+ my $mother=$node_by_id{$motherId};
+ my $fatherId=$self->{'Father'};
+ my $father=$node_by_id{$fatherId};
+
+
+ my $marriageId = $fatherId."_m_".$motherId;
+ my $marriage =
+ new Pedigree::MarriageNode (
+ 'Id'=>$marriageId,
+ 'MSpouse'=>$father,
+ 'FSpouse'=>$mother
+ );
+ if (defined $sort) {
+ $marriage->SetSortOrder($sort);
+ }
+ my @result = ($marriage,$gen+1);
+ return \@result;
+ }
+
+ # Ok, only one parent is there. The search goes further
+
+ my $parentId;
+ if (exists($self->{'Mother'})) {
+ $parentId=$self->{'Mother'};
+ } else {
+ $parentId=$self->{'Father'};
+ }
+ my $parent=$node_by_id{$parentId};
+ return $parent->FindRoot($gen+1,$sort);
+}
+
+####################################################################
+# GetRelX #
+####################################################################
+
+=pod
+
+=item B<GetRelX>();
+
+Find the relative x coordinate of the node. The coordinate is
+relative to the precedessor or to the marriage node, which connects
+this node to the proband
+
+=cut
+
+sub GetRelX {
+ my $self = shift;
+ return $self->{'RelX'};
+}
+
+####################################################################
+# GetRelY #
+####################################################################
+
+=pod
+
+=item B<GetRelY>();
+
+Find the relative Y coordinate of the node. The coordinate is
+relative to the precedessor or to the marriage node, which connects
+this node to the proband. Note that the Y axis is down.
+
+=cut
+
+sub GetRelY {
+ my $self = shift;
+ return $self->{'RelY'};
+}
+
+
+####################################################################
+# SetRelX #
+####################################################################
+
+=pod
+
+=item B<SetRelX>(I<$x>);
+
+Set the relative x coordinate of the node. The coordinate is
+relative to the precedessor or to the marriage node, which connects
+this node to the proband.
+
+=cut
+
+sub SetRelX {
+ my ($self, $x) = @_;
+ $self->{'RelX'} = $x;
+ return 0;
+}
+
+####################################################################
+# SetRelY #
+####################################################################
+
+=pod
+
+=item B<SetRelY>(I<$y>);
+
+Set the relative y coordinate of the node. The coordinate is
+relative to the precedessor or to the marriage node, which connects
+this node to the proband. Note that the Y axis is down.
+
+=cut
+
+sub SetRelY {
+ my ($self, $y) = @_;
+ $self->{'RelY'} = $y;
+ return 0;
+}
+
+####################################################################
+# GetAbsX #
+####################################################################
+
+=pod
+
+=item B<GetAbsX>();
+
+Find the absolute x coordinate of the node.
+
+=cut
+
+sub GetAbsX {
+ my $self = shift;
+ return $self->{'AbsX'};
+}
+
+####################################################################
+# GetAbsY #
+####################################################################
+
+=pod
+
+=item B<GetAbsY>();
+
+Find the absolute Y coordinate of the node.
+
+=cut
+
+sub GetAbsY {
+ my $self = shift;
+ return $self->{'AbsY'};
+}
+
+####################################################################
+# GetIndexX #
+####################################################################
+
+=pod
+
+=item B<GetIndexX>();
+
+Find the number of the node in the given generation.
+
+=cut
+
+sub GetIndexX {
+ my $self = shift;
+ return $self->{'IndexX'};
+}
+
+
+
+####################################################################
+# SetAbsX #
+####################################################################
+
+=pod
+
+=item B<SetAbsX>(I<$x>);
+
+Set the absolute x coordinate of the node.
+
+=cut
+
+sub SetAbsX {
+ my ($self, $x) = @_;
+ $self->{'AbsX'} = $x;
+ return 0;
+}
+
+####################################################################
+# SetAbsY #
+####################################################################
+
+=pod
+
+=item B<SetAbsY>(I<$y>);
+
+Set the absolute y coordinate of the node.
+
+=cut
+
+sub SetAbsY {
+ my ($self, $y) = @_;
+ $self->{'AbsY'} = $y;
+ return 0;
+}
+
+
+####################################################################
+# SetIndexX #
+####################################################################
+
+=pod
+
+=item B<SetIndexX>(I<$n>);
+
+Set the number of the node in the given generation.
+
+=cut
+
+sub SetIndexX {
+ my ($self, $n) = @_;
+ $self->{'IndexX'} = $n;
+ return 0;
+}
+
+
+
+####################################################################
+# SetArea #
+####################################################################
+
+=pod
+
+=item B<SetArea>();
+
+Calculate relative coordinates for all nodes, that are descendants of
+the given node. We create a Pedigree::Area(3) around the given node
+and recursively apply the function to all descendants. The subroutine
+returns the reference to the created area.
+
+=cut
+
+sub SetArea {
+ my $self = shift;
+ $self->GetAndSortKids();
+ my $area = new Pedigree::Area ($self);
+ foreach my $kid (@{$self->Kids()}) {
+ my $kidarea = $kid->SetArea();
+ $kid->SetRelY(-1);
+ $area->AddRight($kidarea);
+ }
+ #
+ # We want the node to be the center of siblings
+ # subtrees
+ #
+ my $deltaX=$self->CenterKids();
+ $area->MoveLowerLayers($deltaX);
+ if ($main::DEBUG) {
+ print STDERR "Setting area for ",$self->Id(),"\n";
+ for (my $y=$area->GetYmin(); $y<=$area->GetYmax(); $y++) {
+ print STDERR "\t$y: ", $area->GetXmin($y), ", ",
+ $area->GetXmax($y), "\n";
+ }
+ }
+ $self->{'Area'} = $area;
+ return $area;
+}
+
+####################################################################
+# CenterKids #
+####################################################################
+
+=pod
+
+=item B<CenterKids>();
+
+Move the relative coordinates of all the kids of the given node
+so the given node is centered in relation to the kids. Returns
+the shift to be applied to the Pedigree::Area(3).
+
+=cut
+
+sub CenterKids {
+ my $self=shift;
+ my $nKids=scalar @{$self->Kids()};
+ if ($nKids < 2) { # One or no kids - no need to center
+ return 0;
+ }
+ my $x0 = $self->Kids()->[0]->GetRelX();
+ my $x1 = $self->Kids()->[$nKids-1]->GetRelX();
+ my $delta = -($x0+$x1)/2;
+ foreach my $kid (@{$self->Kids()}) {
+ $kid->SetRelX($kid->GetRelX()+$delta);
+ }
+ return $delta;
+}
+
+
+####################################################################
+# CalcAbsCoor #
+####################################################################
+
+=pod
+
+=item B<CalcAbsCoor>(I<$x>, $<y>);
+
+Set the absolute coordinates of the given node, if the absolute
+coordinates of the parent node are (I<$x>, I<$y>), and recursively
+do this for all descendants of this node. Additionally set up
+B<%node_by_gen>.
+
+=cut
+
+sub CalcAbsCoor {
+ my $self=shift;
+ my ($x,$y) = @_;
+ $x += $self->GetRelX();
+ $y += $self->GetRelY();
+ #
+ # Consanguinic kids may be already set
+ #
+ if (!exists($self->{'AbsY'}) || $self->{'AbsY'} > $y) {
+ $self->SetAbsX($x);
+ $self->SetAbsY($y);
+ foreach my $kid (@{$self->Kids()}) {
+ $kid->CalcAbsCoor($x,$y);
+ }
+ $node_by_gen{$y}->{$self->Id()}= $self;
+ if ($main::DEBUG) {
+ print STDERR "Abs Coords for ", $self->Id(), ": $x, $y\n";
+ }
+ } else {
+ if ($main::DEBUG) {
+ print STDERR "Not setting abs coords for ",$self->Id(),"\n";
+ }
+ }
+
+ return 0;
+}
+
+
+####################################################################
+# AddConsanguinicMarriages #
+####################################################################
+
+=pod
+
+=item B<AddConsanguinicMarriages>();
+
+Check the pedigree and add consanguinic marriages to it. Note
+that this procedure must be called B<after> L<SetAbsCoor>, so
+the coordinates of all nodes are set.
+
+=cut
+
+#
+# This is rather a hack. Basically we think that a union is
+# consanguinic if the spouses are already set in the pedigree.
+# We check all kids which are in the pedigree and add those
+# who have both mother and father that list them as kids.
+#
+
+sub AddConsanguinicMarriages {
+ my $self = shift;
+ foreach my $gen (keys %node_by_gen) {
+ foreach my $kid (values %{$node_by_gen{$gen}}) {
+ if (!exists($kid->{'Mother'}) ||
+ !exists($kid->{'Father'})) {
+ next; # kid
+ }
+ my $motherId=$kid->MotherId();
+ my $fatherId=$kid->FatherId();
+ my $mother=$node_by_id{$motherId};
+ my $father=$node_by_id{$fatherId};
+ if (!exists($mother->{'AbsX'}) ||
+ !exists($father->{'AbsX'})) {
+ next; # kid
+ }
+ if (exists($node_by_id{$fatherId."_m_".$motherId})) {
+ next; # kid
+ }
+ #
+ # If we are here, we found a consangunic marriage!
+ #
+ if ($main::DEBUG) {
+ print STDERR "Found a consanguinic marriage between ",
+ "$fatherId and $motherId. The kid is ",
+ $kid->Id(), "\n";
+ }
+ my $marriageId=$fatherId."_m_".$motherId;
+ my $marriage=
+ new Pedigree::MarriageNode (
+ Id=>$marriageId,
+ 'Consanguinic'=>1,
+ 'FSpouse'=>$mother,
+ 'MSpouse'=>$father
+ );
+ #
+ # We set up this node in the middle between father
+ # and mother
+ #
+ $marriage->SetAbsX(($father->GetAbsX()+$mother->GetAbsX())/2);
+ $marriage->SetAbsY(($father->GetAbsY()+$mother->GetAbsY())/2);
+ $node_by_gen{$marriage->GetAbsY()}->{$marriageId}= $marriage;
+
+ #
+ # Repopulate parents' kids
+ #
+ $mother->GetAndSortKids();
+ $father->GetAndSortKids();
+
+ #
+ # We would like to make the kids to belong to this marriage,
+ # but it might be wrong: it might be in the wrong generation!
+ # Let is check it
+ if (($marriage->GetAbsY() - $kid->GetAbsY()) == 1) {
+ $marriage->GetAndSortKids();
+ } else {
+ #
+ # Ok, we need an additional node. It has the same
+ # abscissa as $marriage, but is one generation above kids
+ #
+ my $marriage1Id=$fatherId."_m1_".$motherId;
+ my $marriage1 =
+ new Pedigree::MarriageNode (
+ Id=>$marriage1Id,
+ 'Consanguinic'=>1,
+ );
+ $marriage1->SetAbsX($marriage->GetAbsX());
+ $marriage1->SetAbsY(1+$kid->GetAbsY());
+ $node_by_gen{$marriage1->GetAbsY()}->{$marriage1Id}=
+ $marriage1;
+ #
+ # Now we transfer kids
+ #
+ $kids_by_parent_id{$marriage1Id} =
+ $kids_by_parent_id{$marriageId};
+ delete $kids_by_parent_id{$marriageId};
+ $kids_by_parent_id{$marriageId}->{$marriage1Id}=1;
+ $marriage->GetAndSortKids();
+ $marriage1->GetAndSortKids();
+ }
+ }
+ }
+}
+
+
+####################################################################
+# AddTwins #
+####################################################################
+
+=pod
+
+=item B<AddTwins>(I<$ydist>);
+
+Check the pedigree and add twin nodes. Note
+that this procedure must be called B<after> L<SetAbsCoor> and
+L<AddConsanguinicMarriages>.
+
+=cut
+
+sub AddTwins {
+ my $self = shift;
+ my $ydist= shift;
+ #
+ # First, delete all kids from $twin_sets, for which there
+ # are no nodes
+ #
+ foreach my $set (@twin_sets) {
+ foreach my $kidId (keys %{$set->{'KidIds'}}) {
+ if (!exists($node_by_id{$kidId})) {
+ delete $set->{'KidIds'}->{$kidId};
+ if ($main::DEBUG) {
+ print STDERR "Bad node \"$kidId\" in twin sets\n";
+ }
+ }
+ }
+ }
+
+ #
+ # Now we are ready to check for twins
+ #
+ foreach my $gen (keys %node_by_gen) {
+ foreach my $parentId (keys %{$node_by_gen{$gen}}) {
+ foreach my $kidId (keys %{$kids_by_parent_id{$parentId}}) {
+ for (my $i=0; $i<scalar @twin_sets; $i++) {
+ if (exists $twin_sets[$i]->{'KidIds'}->{$kidId}) {
+ my @kidIds = keys %{$twin_sets[$i]->{'KidIds'}};
+ my $type = $twin_sets[$i]->{'Type'};
+ my $twinsId = 't_'.join('_',@kidIds);
+ my $twinsNode =
+ Pedigree::TwinsNode->new (
+ 'Id'=>$twinsId,
+ 'Type'=>$type,
+ 'ParentId'=>$parentId,
+ 'KidIds'=>
+ $twin_sets[$i]->{'KidIds'}
+ );
+ #
+ # Change kids
+ #
+ my $parent = $node_by_id{$parentId};
+ $parent->GetAndSortKids();
+ $twinsNode->GetAndSortKids();
+
+ #
+ # Now the coordinates of the node.
+ # It is centered over kids nodes and 0.24 $ydist above
+ #
+ my @kids = sort {$a->GetAbsX() <=>
+ $b->GetAbsX()}
+ @{$twinsNode->Kids()};
+ my $leftKid=$kids[0];
+ my $rightKid=$kids[scalar(@kids)-1];
+ $twinsNode->SetAbsX(($leftKid->GetAbsX() +
+ $rightKid->GetAbsX())/2.0);
+ $twinsNode->SetAbsY($leftKid->GetAbsY() +
+ 0.2*$ydist);
+ $node_by_gen{$twinsNode->GetAbsY()}->
+ {$twinsId}= $twinsNode;
+
+ #
+ # There is no need to keep this in the twins set
+ #
+ splice @twin_sets, $i,1;
+ last; # twin_sets
+ }
+ }
+ }
+ }
+ }
+ return 0;
+}
+
+
+
+
+
+####################################################################
+# SetFrame #
+####################################################################
+
+=pod
+
+=item B<SetFrame>(I<$xidst>, I<$ydist>);
+
+Calculate the frame: coordinates of the lower left and upper right
+corners of the picture (in ps units). As a side effect, add generation
+numbers to each person node and calculate the X index of each node.
+
+=cut
+
+sub SetFrame {
+ my $self=shift;
+ my ($xdist, $ydist) = @_;
+
+ my $xmin=0;
+ my $xmax=0;
+
+ my @sorted_gens = sort {$b <=> $a} keys %node_by_gen;
+ my $ymin=$sorted_gens[(scalar @sorted_gens) -1];
+ my $ymax=$sorted_gens[0];
+ #
+ # The names of the nodes look like I:1, V:5. Let the
+ # first number be $i, and the second one be $j.
+ # IndexX is different from $j by the fact that marriage nodes
+ # are not skipped.
+ #
+ my $i=1;
+ foreach my $gen (@sorted_gens) {
+ my $roman=roman_num($i);
+ my @sorted_nodes =
+ sort {$a->GetAbsX() <=> $b->GetAbsX()} values %{$node_by_gen{$gen}};
+ my $num_nodes= scalar @sorted_nodes;
+ if ($sorted_nodes[0]->GetAbsX()<$xmin) {
+ $xmin=$sorted_nodes[0]->GetAbsX();
+ }
+ if ($sorted_nodes[$num_nodes-1]->GetAbsX()>$xmax) {
+ $xmax=$sorted_nodes[$num_nodes-1]->GetAbsX();
+ }
+ my $j=1;
+ my $indexX=1;
+ foreach my $node (@sorted_nodes) {
+ $node->SetIndexX($indexX);
+ if ($main::DEBUG) {
+ print STDERR "Node ", $node->Id(), ", index ",
+ $node->GetIndexX(), "\n";
+ }
+ $indexX++;
+ if ($node->isNumbered()) {
+ $node->SetGenName("$roman:$j");
+ if ($main::DEBUG) {
+ print STDERR $node->Id(), ": ", $node->GetGenName(),
+ "\n";
+ }
+ $j++;
+ }
+ }
+ #
+ # The fractional "generations" are for twin nodes
+ # and consanguinic marriage nodes.
+ #
+ if ($gen == int($gen)) {
+ $i++;
+ }
+ }
+ my @result = ($xdist*($xmin-1), $ydist*($ymin-1),
+ $xdist*($xmax+1), $ydist*($ymax+1));
+ return \@result;
+}
+
+
+
+####################################################################
+# DrawConnections #
+####################################################################
+
+=pod
+
+=item B<DrawConnections>();
+
+Draw the connections from the given node to its descendants
+
+=cut
+
+sub DrawConnections {
+ my $self = shift;
+ my $xdist = shift;
+ my $ydist = shift;
+ my $result;
+ my $Id=$self->Id;
+ foreach my $kid (@{$self->Kids()}) {
+ my $kidId = $kid->Id();
+ $result .= '\pstDescent{'.$Id.'}{'.$kidId.'}'."\n";
+ }
+ return $result;
+}
+
+
+
+
+
+####################################################################
+# DrawAll #
+####################################################################
+
+=pod
+
+=item B<DrawAll>(I<$xdist>, I<$ydist>, I<$belowtextfont>,
+ I<$abovetextfont>, I<@fieldsfornode>);
+
+Draw all nodes and connections in the form suitable for
+pspicture
+
+=cut
+
+sub DrawAll {
+ my ($self, $xdist, $ydist, $belowtextfont,
+ $abovetextfont, @fieldsfornode) = @_;
+
+ #
+ # Commands to draw nodes
+ #
+ my $nodes;
+
+ #
+ # Commands to draw connections
+ #
+ my $connections;
+
+
+ foreach my $gen (keys %node_by_gen) {
+ foreach my $node (values %{$node_by_gen{$gen}}) {
+ #
+ # We draw only the nodes, who belong to the right
+ # generation (consanguinity may lead to duplicate nodes
+ #
+ #
+ if ($node->GetAbsY() <=> $gen) {
+ delete $node_by_gen{$gen}->{$node->Id()};
+ next;
+ }
+
+ $nodes .= $node->DrawNode($xdist, $ydist,
+ $belowtextfont, $abovetextfont,
+ @fieldsfornode);
+ $connections .=$node->DrawConnections($xdist, $ydist);
+ }
+ }
+ return $nodes.$connections;
+}
+
+####################################################################
+# PrintAllLegends #
+####################################################################
+
+=pod
+
+=item B<PrintAllLegends>(I<$lang>, I<@fields>);
+
+Print legend for all the nodes. The first parameter is the
+language, the other is the fields to be included in the legend.
+
+=cut
+
+sub PrintAllLegends {
+ my ($self, $lang, @fields) = @_;
+
+ my $result="\n\\begin{description}\n";
+
+ foreach my $gen (sort {$b <=> $a} keys(%node_by_gen)) {
+ foreach my $node
+ (sort {$a->GetIndexX() <=> $b->GetIndexX()}
+ values(%{$node_by_gen{$gen}})) {
+ $result .= $node->PrintLegend($lang,@fields);
+ }
+ }
+
+ $result .= "\\end{description}\n";
+
+ return $result;
+}
+
+
+####################################################################
+# PrintLegend #
+####################################################################
+
+=pod
+
+=item B<PrintLegend>(I<$lang>, I<@fields>);
+
+This subroutine does nothing: a generic node has no legend. It
+is overriden by Pedigree::PersonNode(3) and Pedigree::AbortionNode(3).
+
+=cut
+
+sub PrintLegend {
+
+ return;
+}
+
+
+
+
+####################################################################
+# by_sibs_order #
+####################################################################
+
+#
+# Internal procedure for sorting kids
+#
+
+sub by_sibs_order {
+ #
+ # We compare sort order, and if it is the same, DoB
+ #
+ return ($a->SortOrder() <=> $b->SortOrder()) ||
+ ($a->DoB() cmp $b->DoB());
+}
+
+####################################################################
+# roman_num #
+####################################################################
+
+#
+# Internal procedure for roman numerals
+#
+
+sub roman_num {
+ my $i=shift;
+ my @nums=qw(0 I II III IV V VI VII VIII IX X XI XII XIII XIV XV
+ XVI XVII XVIII XIX XX XXI XXII XXIII XXIV);
+ return $nums[$i];
+}
+
+
+####################################################################
+# THE END #
+####################################################################
+
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+=head1 SEE ALSO
+
+pedigree(1), Pedigree(3)
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2006, 2007
+
+
+
+=cut
+
+1;
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Parser.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Parser.pm
new file mode 100644
index 00000000000..7978064f473
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Parser.pm
@@ -0,0 +1,237 @@
+=pod
+
+=head1 NAME
+
+Pedigree::Parser - parser for the input file
+
+=head1 SYNOPSIS
+
+use Pedigree::Parser;
+
+$parser = new Pedigree::Parser(I{$inputline>, I<$lang>)
+
+$parser->Parse($inputline);
+
+
+=head1 DESCRIPTION
+
+This package parses input for the pedigree library and is used to
+define nodes.
+
+=over 4
+
+=cut
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree::Parser;
+use strict;
+
+####################################################################
+# package variables #
+####################################################################
+
+#
+# %fields_to_convert: the hash of fields that contain limited
+# number of values and the default value for such field
+#
+
+my %fields_to_convert = (
+ 'Sex'=>'unknown',
+ 'Proband'=>0,
+ 'Condition'=>'normal',
+ 'Type' => ''
+);
+
+
+####################################################################
+# And package methods #
+####################################################################
+
+####################################################################
+# new #
+####################################################################
+
+=pod
+
+=item B<new>(I<$inputline>, I<$lang>);
+
+Construct a new parser from the pipe-separated line at input
+
+=cut
+
+sub new {
+ my ($class,$inputline,$lang)=@_;
+ my $self={};
+
+ #
+ # The hash $self->{fields} is the main stored data structure.
+ # The key is the field, the value is the number of the field
+ # in the input lines.
+ #
+ my %fieldnames=%{$lang->GetFieldNames()};
+ chomp $inputline;
+ $inputline =~ s/^\s+//;
+ $inputline =~ s/\s+$//;
+ my @input = split /\s*\|\s*/, $inputline;
+ for (my $i=0; $i<scalar @input; $i++) {
+ my $name=$input[$i];
+ if (exists $fieldnames{$name}) {
+ my $field=$fieldnames{$name};
+ $self->{fields}->{$field}=$i;
+ } else {
+ print STDERR "Warning: unknown field $name\n";
+ }
+ }
+
+ if ($main::DEBUG) {
+ print STDERR "Field names:\n";
+ foreach my $key (keys %fieldnames) {
+ my $field=$fieldnames{$key};
+ my $pos=$self->{fields}->{$field};
+ print STDERR "\t$key\t$field\t$pos\n";
+ }
+ }
+
+ #
+ # The hash $self->{values} contains values for fields
+ # with closed sets of values.
+ #
+ my %values=%{$lang->GetValues()};
+ $self->{values}=\%values;
+
+ if ($main::DEBUG) {
+ print STDERR "Field values:\n";
+ foreach my $key (keys %values) {
+ my $value=$values{$key};
+ print STDERR "\t$key\t$value\n";
+ }
+ }
+
+
+ #
+ # The hash $self->{special_names} contains special values
+ # for the 'Name' field
+ #
+ my %special=%{$lang->GetSpecialNames()};
+ $self->{'special_names'}=\%special;
+
+ if ($main::DEBUG) {
+ print STDERR "Special names:\n";
+ foreach my $key (keys %special) {
+ my $value=$special{$key};
+ print STDERR "\t$key\t$value\n";
+ }
+ }
+
+ if ($main::DEBUG) {
+ print STDERR "Special fields:\n";
+ foreach my $key (keys %fields_to_convert) {
+ my $value=$fields_to_convert{$key};
+ print STDERR "\t$key\t$value\n";
+ }
+ }
+
+ bless ($self,$class);
+ return $self;
+}
+
+
+####################################################################
+# Parse #
+####################################################################
+
+=pod
+
+=item B<Parse>(I<$inputline>);
+
+Take a line of comma-separated values; return a reference to a
+hash of parsed values
+
+=cut
+
+sub Parse {
+ my ($self,$inputline)=@_;
+ chomp $inputline;
+ $inputline =~ s/^\s+//;
+ $inputline =~ s/\s+$//;
+ my @input = split /\s*\|\s*/, $inputline;
+ if ($main::DEBUG) {
+ print STDERR "Parsing line:$inputline\n";
+ }
+
+ my %result;
+
+ foreach my $field (keys %{$self->{fields}}) {
+ my $i=$self->{fields}->{$field};
+ my $value=$input[$i];
+ #
+ # Special fields...
+ #
+ if (exists $self->{values}->{$value}) {
+ $value=$self->{values}->{$value};
+ }
+ if (exists $fields_to_convert{$field}) {
+ if (length($value) == 0 ) {
+ $value=$fields_to_convert{$field};
+ }
+ }
+ #
+ # Dropping empty fields
+ #
+ if (length($value) == 0 ) {
+ next;
+ }
+
+ #
+ # Converting Name field
+ #
+ if (($field eq 'Name') && ($value =~ /^\#/)) {
+ foreach my $regexp (keys %{$self->{'special_names'}}) {
+ my $name=$self->{'special_names'}->{$regexp};
+ $value =~ s/^(\#$regexp.*)/\#$name/i;
+ }
+ }
+
+ #
+ # And finishing
+ #
+ $result{$field}=$value;
+ if ($main::DEBUG) {
+ print STDERR "\t$field\t$value\n";
+ }
+ }
+
+ return \%result;
+
+}
+
+####################################################################
+# THE END #
+####################################################################
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+=head1 SEE ALSO
+
+pedigree(1), Pedigree(3)
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2006, 2007
+
+
+
+=cut
+
+1;
+
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree/PersonNode.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/PersonNode.pm
new file mode 100644
index 00000000000..6d341cb7157
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/PersonNode.pm
@@ -0,0 +1,389 @@
+=pod
+
+=head1 NAME
+
+Pedigree::PersonNode - a person in a pedigree
+
+=head1 SYNOPSIS
+
+use Pedigree::PersonNode;
+
+$node = new Pedigree::PersonNode(I<%params>);
+
+$Id = $node->MotherId();
+$Id = $node->FatherId();
+
+$isProband = $node->isProband();
+
+$sex = $node->Sex();
+
+$DoB = $node->DoB();
+
+$DoD = $node->DoD();
+
+$cond = $node->Condition();
+
+$GenName = $node->GetGenName();
+
+$node->SetGenName(I<$name>);
+
+$node->DrawNode(I<$xidst>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+$node->PrintLegend(I<$land>, I<@fields>);
+
+=head1 DESCRIPTION
+
+This package contains data about a person.
+
+=over 4
+
+=cut
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree::PersonNode;
+use Pedigree;
+use strict;
+our @ISA=('Pedigree::Node');
+
+####################################################################
+# new #
+####################################################################
+
+=pod
+
+=item B<new>(I<%params>);
+
+Construct a new node from the given parameters.
+
+=cut
+
+sub new {
+ my ($class,%params)=@_;
+ my $self=$class->SUPER::new(%params);
+
+ if (!ref($self)) {
+ return 0;
+ }
+
+ #
+ # Only Person Nodes are numbered in pedigrees
+ #
+
+ $self->{'Numbered'}=1;
+
+ #
+ # Now Twins...
+ #
+
+ if (exists $self->{'Twins'}) {
+ my $Id=$self->{'Id'};
+ my $string = $self->{'Twins'};
+ $string =~ s/^\s*//;
+ $string =~ s/\s*$//;
+ my @twinIds=($Id, split (/[\s,;]+/, $string));
+ if ($main::DEBUG) {
+ print STDERR "Found twins: ", join(', ',@twinIds), "\n";
+ }
+ my $found=0;
+ for (my $i=0; $i<scalar @{$self->{'twin_sets'}}; $i++) {
+ if (exists $self->{'twin_sets'}->[$i]->{'KidIds'}->{$Id}) {
+ $found=1;
+ foreach my $kidId (@twinIds) {
+ $self->{'twin_sets'}->[$i]->{'KidIds'}->{$kidId}=1;
+ }
+ if ($main::DEBUG) {
+ print STDERR "Added to twin set number $i\n";
+ }
+ last; # twin_set
+ }
+ }
+ if (!$found) { # Add twin set
+ my $set;
+ $set->{'Type'} = $self->{'Type'};
+ foreach my $kidId (@twinIds) {
+ $set->{'KidIds'}->{$kidId}=1;
+ }
+ push @{$self->{'twin_sets'}}, $set;
+ if ($main::DEBUG) {
+ print STDERR "Started a new twin set number ",
+ scalar(@{$self->{'twin_sets'}})-1, "\n";
+ }
+ }
+ }
+
+ return $self;
+
+}
+
+
+####################################################################
+# MotherId #
+####################################################################
+
+=pod
+
+=item B<MotherId>();
+
+Return Mother Id.
+
+=cut
+
+sub MotherId {
+ my $self=shift;
+ return $self->{'Mother'};
+}
+
+####################################################################
+# FatherId #
+####################################################################
+
+=pod
+
+=item B<FatherId>();
+
+Return Father Id.
+
+=cut
+
+sub FatherId {
+ my $self=shift;
+ return $self->{'Father'};
+}
+
+
+####################################################################
+# isProband #
+####################################################################
+
+=pod
+
+=item B<isProband>();
+
+Return 1 if the pesron is a Proband and zero otherwise
+
+=cut
+
+sub isProband {
+ my $self=shift;
+ if ($self->{Proband} == 1) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+####################################################################
+# Sex #
+####################################################################
+
+=pod
+
+=item B<Sex>();
+
+Get the sex of the node
+
+=cut
+
+sub Sex {
+ my $self = shift;
+ return $self->{'Sex'};
+}
+
+####################################################################
+# DoB #
+####################################################################
+
+=pod
+
+=item B<DoB>();
+
+Get the DoB of the node
+
+=cut
+
+sub DoB {
+ my $self = shift;
+ return $self->{'DoB'};
+}
+
+####################################################################
+# DoB #
+####################################################################
+
+=pod
+
+=item B<DoD>();
+
+Get the DoB of the node
+
+=cut
+
+sub DoD {
+ my $self = shift;
+ return $self->{'DoD'};
+}
+
+####################################################################
+# Condition #
+####################################################################
+
+=pod
+
+=item B<Condition>();
+
+Returns node conditon.
+
+=cut
+
+sub Condition {
+ my $self=shift;
+ return $self->{'Condition'};
+}
+
+
+####################################################################
+# GetGenName #
+####################################################################
+
+=pod
+
+=item B<GetGenName>();
+
+Find the generation name for the node
+
+=cut
+
+sub GetGenName {
+ my $self = shift;
+ return $self->{'GenName'};
+}
+
+
+####################################################################
+# SetGenName #
+####################################################################
+
+=pod
+
+=item B<SetGenName>(I<$name>);
+
+Set the generation name of the node
+
+=cut
+
+sub SetGenName {
+ my ($self, $name) = @_;
+ $self->{'GenName'} = $name;
+ return 0;
+}
+
+
+####################################################################
+# DrawNode #
+####################################################################
+
+=pod
+
+=item B<DrawNode>(I<$xdist>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+Output the command to draw this node. The parameters are
+distances between the nodes (in cm) and fields for abovetext.
+
+=cut
+
+sub DrawNode {
+ my $self=shift;
+ my ($xdist, $ydist, $belowtextfont, $abovetextfont, @fieldsfornode) = @_;
+ my $result = '\rput('.($xdist*$self->GetAbsX()).", ".
+ ($ydist*$self->GetAbsY()).'){\pstPerson[';
+ my @opts=($self->Sex(), $self->Condition(),
+ 'belowtext={'."$belowtextfont ".$self->GetGenName().'}');
+ if (length($self->DoD())>0) {
+ push @opts, 'deceased';
+ }
+ if ($self->isProband()) {
+ push @opts, 'proband';
+ }
+ if (scalar @fieldsfornode) {
+ my @abovetext;
+ foreach my $field (@fieldsfornode) {
+ push @abovetext, $self->{$field};
+ }
+ push @opts,'abovetext={'."$abovetextfont ".join('; ',@abovetext).'}';
+ }
+ $result .= join(', ',@opts);
+ $result .= ']{'.$self->Id()."}}\n";
+ return $result;
+}
+
+####################################################################
+# PrintLegend #
+####################################################################
+
+=pod
+
+=item B<PrintLegend>(I<$lang>, I<@fields>);
+
+Print the legend for the given node, including I<@fields> in the given
+language I<$lang>.
+
+=cut
+
+sub PrintLegend {
+ my ($self, $lang, @fields) = @_;
+ my $result = '\item['.$self->GetGenName().'] ';
+ my @desc;
+ foreach my $field (@fields) {
+ if (exists $self->{$field}) {
+ my $res = $lang->PrintField($field, $self->{$field});
+ if (length($res)>0) {
+ push @desc, $res;
+ }
+ }
+ }
+ $result .= join ("; ",@desc);
+ $result .= ".\n";
+ #
+ # We print only the nodes, for which there is an information
+ #
+ if (scalar @desc) {
+ return $result;
+ }
+ return;
+}
+
+
+
+####################################################################
+# THE END #
+####################################################################
+
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+
+=head1 SEE ALSO
+
+pedigree(1), Pedigree(3)
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2006, 2007
+
+
+
+=cut
+
+1;
diff --git a/Master/texmf-dist/scripts/pedigree-perl/Pedigree/TwinsNode.pm b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/TwinsNode.pm
new file mode 100644
index 00000000000..c8557230bd7
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/Pedigree/TwinsNode.pm
@@ -0,0 +1,172 @@
+=pod
+
+=head1 NAME
+
+Pedigree::TwinsNode - an auxillary twins node in a pedigree
+
+=head1 SYNOPSIS
+
+use Pedigree::TwinsNode;
+
+$node = new Pedigree::TwinsNode(I<%params>);
+
+
+$node->DrawNode(I<$xidst>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+$node->DrawConnections();
+
+
+=head1 DESCRIPTION
+
+This package contains data about a twins node. Twins node is
+a special node between the parent and the twins.
+
+=over 4
+
+=cut
+
+
+
+####################################################################
+# Define the package #
+####################################################################
+
+package Pedigree::TwinsNode;
+use Pedigree;
+use strict;
+our @ISA=('Pedigree::Node');
+
+
+####################################################################
+# new #
+####################################################################
+
+=pod
+
+=item B<new>(I<%params>);
+
+Construct a new node from the given parameters.
+
+=cut
+
+sub new {
+ my ($class,%params)=@_;
+ my $self=$class->SUPER::new(%params);
+ if (!ref($self)) { # Bad node
+ return 0;
+ }
+
+ bless ($self,$class);
+
+ # After we constructed the node, we want to move the kids
+ # from the parent node to the twins node
+
+ my $selfId = $self->{'Id'};
+ my $parentId = $self->{'ParentId'};
+ foreach my $kidId (keys %{$self->{'KidIds'}}) {
+ if ($main::DEBUG) {
+ print STDERR
+ "Moving $kidId from $parentId and to $selfId\n";
+ }
+ delete $self->{'kids_by_parent_id'}->{$parentId}->{$kidId};
+ $self->{'kids_by_parent_id'}->{$selfId}->{$kidId}=1;
+ }
+
+ return $self;
+}
+
+
+
+####################################################################
+# DrawNode #
+####################################################################
+
+=pod
+
+=item B<DrawNode>(I<$xdist>, I<$ydist>, I<$belowtextfont>, I<$abovetextfont>,
+I<@fieldsfornode>);
+
+Output the command to draw this node. The parameters are
+distances between the nodes (in psunits).
+
+=cut
+
+sub DrawNode {
+ my $self=shift;
+ my ($xdist, $ydist, $belowtextfont, $abovetextfont, @fieldsfornode) = @_;
+ my $result = '\rput('.($xdist*$self->GetAbsX()).", ".
+ ($ydist*$self->GetAbsY()).'){\pnode{'.
+ $self->Id()."}}\n";
+ return $result;
+}
+
+####################################################################
+# DrawConnections #
+####################################################################
+
+=pod
+
+=item B<DrawConnections>();
+
+Draw the connections from the given node to its descendants and
+the parent
+
+=cut
+
+sub DrawConnections {
+ my $self = shift;
+ my $xdist = shift;
+ my $ydist = shift;
+ my $Id=$self->Id();
+ my $parentId = $self->{'ParentId'};
+ my @kids = @{$self->Kids()};
+ my $leftKid=shift @kids;
+ my $leftKidId=$leftKid->Id();
+ my $rightKid= pop @kids;
+ my $rightKidId=$rightKid->Id();
+ my @opts;
+ if ($self->Type()) {
+ push @opts, $self->Type();
+ }
+ foreach my $kid (@kids) {
+ push @opts, "addtwin=".$kid->Id();
+ }
+ my $result = '\pstTwins[';
+ if (scalar @opts) {
+ $result .= join (", ",@opts);
+ }
+ $result .= ']{'.$parentId.'}{'.
+ $Id.'}{'.$leftKidId.'}{'.$rightKidId.'}'."\n";
+ return $result;
+}
+
+
+
+
+####################################################################
+# THE END #
+####################################################################
+
+=pod
+
+=back
+
+=head1 ENVIRONMENT
+
+The calling program should define B<$main::DEBUG> and set it to 0
+or 1.
+
+=head1 SEE ALSO
+
+pedigree(1), Pedigree(3)
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2007
+
+
+
+=cut
+
+1;
diff --git a/Master/texmf-dist/scripts/pedigree-perl/pedigree.pl b/Master/texmf-dist/scripts/pedigree-perl/pedigree.pl
new file mode 100755
index 00000000000..d8ace2ce125
--- /dev/null
+++ b/Master/texmf-dist/scripts/pedigree-perl/pedigree.pl
@@ -0,0 +1,544 @@
+#!/usr/bin/env perl
+#
+# Copyright (C) 2006 Boris Veytsman & Leila Akhmadeeva
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+#
+=pod
+
+=head1 NAME
+
+pedigree - create a TeX file for pedigree from a csv file
+
+=head1 SYNOPSIS
+
+B<pedigree> [-c I<configuration_file>] [-d] [-o I<output_file>] [-s I<start_id>] I<input_file>
+
+B<pedigree> -v
+
+=head1 DESCRIPTION
+
+The program converts a comma separated I<input_file> into a TeX file
+with pst-pdgr macros.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-c> I<configuration_file>
+
+The configuration file to read along with the system-wide and user's
+configuration files
+
+=item B<-d>
+
+Debug mode on
+
+=item B<-o> -I<output_file>
+
+The ouput file instead of I<input_file.tex>
+
+=item B<-s> -I<start_id>
+
+If this option is selected, the pedigree is constructed starting from
+the node with the Id i<start_id>. Otherwise it is started from the
+proband node.
+
+This option allows to create pedigrees with multiple probands or absent
+probands, or show people who are not proband's relatives.
+
+=item B<-v>
+
+Print version information
+
+=back
+
+=head1 FILES
+
+=over 4
+
+=item B</etc/pedigree.cfg>
+
+Global configuration file
+
+=item B<$HOME/.pedigreerc>
+
+User configuration file
+
+=back
+
+=head1 SEE ALSO
+
+The manual distributed with this program describes the format of the
+configuration file and the input file.
+
+The library functions are described in Pedigree::Language(3),
+Pedigree::Parser(3), Pedigree::Node(3), Pedigree::PersonNode(3),
+Pedigree::MarriageNode(3), Pedigree::Area(3).
+
+=head1 AUTHOR
+
+Boris Veytsman, Leila Akhmadeeva, 2006, 2007
+
+
+=cut
+
+
+#########################################################
+# Packages and Options #
+#########################################################
+
+use strict;
+use vars qw($opt_c $opt_d $opt_o $opt_s $opt_v);
+
+##############################
+# TeXLive compatibility stuff
+##############################
+my $TLMaster; # Where TeXlive is
+my $TLCONF; # TL config file
+my $TLCONFLOCAL; # TL local config file
+chomp($TLMaster = `kpsewhich -var-value=SELFAUTOPARENT`);
+if (length($TLMaster)) {
+ unshift @INC, "$TLMaster/texmf-dist/scripts/pedigree-perl";
+ $TLCONF = "$TLMaster/texmf-config/pedigree/pedigree.cfg";
+ chomp($TLCONFLOCAL = `kpsewhich -var-value=TEXMFLOCAL`);
+ $TLCONFLOCAL .= "/pedigree/pedigree.cfg";
+}
+
+use Getopt::Std;
+use FileHandle;
+use Pedigree;
+
+#########################################################
+# Options Reading and Global Variables #
+#########################################################
+
+my $USAGE="Usage: $0 [-c configuration_file] [-d] [-o output_file] [-s start_id] input_file\n";
+my $COPYRIGHT=<<END;
+$0 Version 0.4, July 2012
+
+Copyright (C) 2006, 2007, 2012 Boris Veytsman & Leila Akhmadeeva
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330,
+END
+
+my $GLOBALCONF="/etc/pedigree.cfg";
+
+my $USERCONF="$ENV{HOME}/.pedigreerc";
+
+
+our $IN = new FileHandle;
+our $OUT = new FileHandle;
+
+getopts('c:do:s:v') or die $USAGE;
+
+if ($opt_v) {
+ die $COPYRIGHT;
+}
+
+our $DEBUG = $opt_d ||0;
+
+if (scalar @ARGV != 1) {
+ die $USAGE;
+}
+
+our $start_id = $opt_s;
+
+#########################################################
+# Opening Files #
+#########################################################
+
+
+if ($ARGV[0] eq '-') {
+ $IN->fdopen(fileno(STDIN),"r");
+} else {
+ $IN->open($ARGV[0], "r") or die "Cannot read from $ARGV[0]\n";
+}
+
+my $outfile=$ARGV[0];
+if ($opt_o) {
+ $outfile = $opt_o;
+} else {
+ $outfile =~ s/\.[^\.]*$/.tex/;
+}
+if ($outfile eq '-') {
+ $OUT->fdopen(fileno(STDOUT),"w");
+} else {
+ $OUT->open($outfile, "w") or die "Cannot write to $outfile\n";
+}
+
+#########################################################
+# Configuration #
+#########################################################
+
+#
+# First, the defaults. Even if we do not find any
+# configuration file, these will work.
+#
+
+
+#
+# Do we want to have a full LaTeX file or just a fragment?
+#
+our $fulldoc=1;
+
+#
+# What kind of document do we want
+#
+# our $documentheader='\documentclass[landscape]{article}';
+our $documentheader='\documentclass{article}';
+
+#
+# Define additional packages here
+#
+# our $addtopreamble=<<END;
+# \\usepackage{graphics}
+# END
+our $addtopreamble=<<END;
+\\psset{descarmA=1}
+END
+
+
+
+#
+# Do we want to print a legend?
+#
+our $printlegend=1;
+
+#
+# Fields to include in the legend. Delete Name for privacy
+# protection.
+#
+our @fieldsforlegend = qw(Name DoB AgeAtDeath Comment);
+
+#
+# Fields to put at the node. Delete Name for privacy
+# protection.
+#
+our @fieldsforchart = qw(Name);
+
+#
+# Language
+#
+# our $language="russian";
+our $language="english";
+
+#
+# Override the encoding
+#
+# our $encoding="koi8-r";
+
+our $encoding;
+
+#
+# descarmA
+#
+our $descarmA = 0.8;
+
+#
+# Fonts for nodes
+#
+our $belowtextfont='\small';
+our $abovetextfont='\scriptsize';
+
+#
+# Distances between nodes (in cm)
+#
+our $xdist=2;
+our $ydist=2;
+
+#
+# Maximal width and height of the pedigree in cm.
+# Set this to 0 to switch off scaling
+#
+our $maxW = 15;
+our $maxH = 19;
+
+#
+# Whether to rotate the page. The values are 'yes', 'no' and 'maybe'
+# If 'maybe' is chosen, the pedigree is rotated if it allows better
+# scaling
+#
+our $rotate = 'maybe';
+
+#
+# Read the global configuration file(s)
+#
+foreach my $conffile ($GLOBALCONF, $TLCONF, $TLCONFLOCAL) {
+ if (-r $conffile) {
+ if ($DEBUG) {
+ print STDERR "Reading global configuration file $conffile\n";
+ }
+ require "$conffile";
+ } else {
+ if ($DEBUG) {
+ print STDERR "Cannot find global configuration file $conffile; going without it\n";
+ }
+ }
+}
+
+#
+# Read the user configuration file
+#
+if (-r $USERCONF) {
+ if ($DEBUG) {
+ print STDERR "Reading user configuration file $USERCONF\n";
+ }
+ require "$USERCONF";
+} else {
+ if ($DEBUG) {
+ print STDERR "Cannot find user configuration file $USERCONF; going without it\n";
+ }
+}
+
+#
+# Read the option configuration file
+#
+if ($opt_c) {
+ if (-r $opt_c) {
+ if ($DEBUG) {
+ print STDERR "Reading optional configuration file $opt_c\n";
+ }
+ require "$opt_c";
+ } else {
+ die "Cannot find $opt_c\n";
+ }
+}
+
+#########################################################
+# Setting up #
+#########################################################
+
+my $lang = new Pedigree::Language($language, $encoding);
+$_=<$IN>;
+my $parser = new Pedigree::Parser($_,$lang);
+my $start;
+
+#########################################################
+# Reading input #
+#########################################################
+
+while (<$IN>) {
+ my $node = Pedigree->MakeNode($parser->Parse($_));
+ if (ref($node)) {
+ if ($start_id) {
+ if ($start_id eq $node->Id()) {
+ $start = $node;
+ if ($DEBUG) {
+ print STDERR "Found start: ", $start->Id(), "\n";
+ }
+ }
+ } else {
+ if ($node->isProband()) {
+ if (ref($start)) {
+ print STDERR "Two probands? I got ", $start->Id(),
+ " and ", $node->Id(), "\n";
+ }
+ $start=$node;
+ if ($DEBUG) {
+ print STDERR "Found proband: ", $start->Id(), "\n";
+ }
+ }
+ }
+ }
+}
+
+if (!ref($start)) {
+ die "Cannot find the start!\n";
+}
+
+#########################################################
+# Process Pedigree #
+#########################################################
+
+#
+# Check all parents
+#
+$start->CheckAllParents();
+
+
+#
+# The root is the root of the tree to which the proband
+# belongs
+#
+
+my ($root, undef)=@{$start->FindRoot(0)};
+if ($DEBUG) {
+ print STDERR "Root: ", $root->Id(), "\n";
+}
+
+#
+# Calculate relative coordinates
+#
+$root->SetRelX(0);
+$root->SetRelY(0);
+$root->SetArea();
+
+#
+# Calculate the absolute coordinates
+#
+$root->CalcAbsCoor(0,0);
+
+#
+# Check for consanguinic marriages
+#
+$root->AddConsanguinicMarriages();
+
+#
+# And twins
+#
+$root->AddTwins($ydist);
+
+#
+# Get the frame
+#
+my ($xmin, $ymin, $xmax, $ymax) = @{$root->SetFrame($xdist, $ydist)};
+
+
+
+#########################################################
+# Printing headers #
+#########################################################
+
+if ($fulldoc) {
+ printheader($OUT,$lang,$addtopreamble);
+}
+
+#########################################################
+# Calculate scale and check whether to rotate #
+#########################################################
+
+my $scale=1;
+my $scaleRotated = 1;
+
+if ($maxH && $maxW) {
+ if ($maxH/($ymax-$ymin) < $scale) {
+ $scale = $maxH/($ymax-$ymin);
+ }
+ if ($maxW/($xmax-$xmin) < $scale) {
+ $scale = $maxW/($xmax-$xmin);
+ }
+ if ($maxW/($ymax-$ymin) < $scaleRotated) {
+ $scaleRotated = $maxW/($ymax-$ymin);
+ }
+ if ($maxH/($xmax-$xmin) < $scaleRotated) {
+ $scaleRotated = $maxH/($xmax-$xmin);
+ }
+}
+
+my $doRotate = ($rotate =~ /yes/i) || (($rotate =~ /maybe/i) &&
+ ($scaleRotated > $scale));
+
+#########################################################
+# Printing pspicture #
+#########################################################
+
+my $pre;
+my $post ='}'."\n";
+
+if ($doRotate) {
+ $descarmA *= $scaleRotated;
+ $pre="\\rotatebox{90}{%\n\\psset{descarmA=$descarmA}%\n";
+ if ($scaleRotated<1) {
+ $pre .= '\psset{unit='.$scaleRotated.'}%'."\n";
+ }
+} else {
+ $descarmA *= $scale;
+ $pre="{%\n\\psset{descarmA=$descarmA}%\n";
+ if ($scale<1) {
+ $pre .= '{\psset{unit='.$scale.'}%'."\n";
+ }
+}
+
+print $OUT $pre;
+
+print $OUT '\begin{pspicture}',"($xmin,$ymin)($xmax,$ymax)\n";
+
+print $OUT $root->DrawAll($xdist, $ydist, $belowtextfont,
+ $abovetextfont, @fieldsforchart);
+
+print $OUT '\end{pspicture}%',"\n";
+
+print $OUT $post;
+
+#########################################################
+# Printing legend #
+#########################################################
+
+
+if ($printlegend) {
+ print $OUT $root->PrintAllLegends($lang, @fieldsforlegend);
+}
+
+#########################################################
+# Printing end #
+#########################################################
+
+
+if ($fulldoc) {
+ printend($OUT);
+}
+
+#########################################################
+# Exiting #
+#########################################################
+
+exit 0;
+
+#########################################################
+# Subroutines #
+#########################################################
+
+#
+# Printing headers & footers
+#
+
+sub printheader {
+ my ($OUT,$lang,$addtopreamble)=@_;
+ print $OUT <<END;
+$documentheader
+\\usepackage{pst-pdgr}
+END
+
+ print $OUT $lang->Header;
+ print $OUT <<END;
+$addtopreamble
+\\begin{document}
+END
+ return 0;
+}
+
+
+sub printend {
+ my $OUT=shift;
+ print $OUT "\\end{document}\n";
+ return 0;
+}
+
+