summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/scripts/pedigree-perl/pedigree.pl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/texmf-dist/scripts/pedigree-perl/pedigree.pl')
-rwxr-xr-xMaster/texmf-dist/scripts/pedigree-perl/pedigree.pl544
1 files changed, 544 insertions, 0 deletions
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;
+}
+
+