summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/scripts/pedigree-perl/Pedigree/Node.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/texmf-dist/scripts/pedigree-perl/Pedigree/Node.pm')
-rw-r--r--Master/texmf-dist/scripts/pedigree-perl/Pedigree/Node.pm1240
1 files changed, 1240 insertions, 0 deletions
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;