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