diff options
author | Karl Berry <karl@freefriends.org> | 2012-04-13 23:09:10 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2012-04-13 23:09:10 +0000 |
commit | 2d9b64e84ae06eba8f2f5d0e958f4f2f335de076 (patch) | |
tree | e49120eb2857c9aa1a11ca26cda4d3ba5db6b8b6 /Master/texmf-dist/scripts/pedigree-perl | |
parent | 1c08c44c738be3e43fc4411812e7484d2471de7e (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')
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; +} + + |