~ubuntu-branches/ubuntu/utopic/texlive-bin/utopic

« back to all changes in this revision

Viewing changes to texk/texlive/linked_scripts/pedigree-perl/pedigree.pl

  • Committer: Package Import Robot
  • Author(s): Norbert Preining
  • Date: 2012-05-07 10:47:49 UTC
  • mfrom: (1.2.4)
  • Revision ID: package-import@ubuntu.com-20120507104749-p00ot5sajjbkp1hp
Tags: 2011.20120507-1
* new upstream checkout: uptex 1.10
* drop patches for config file inclusion in (x)dvipdfmx, included upstream
* add man page for etex
* include pmpost patches and build it
* adapt/unfuzzify patches for current sources
* disable mtx building, we have prepmx package in Debian

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
#!/usr/bin/env perl
 
2
#
 
3
# Copyright (C) 2006-2012 Boris Veytsman & Leila Akhmadeeva
 
4
#
 
5
# This program is free software; you can redistribute it and/or modify
 
6
# it under the terms of the GNU General Public License as published by
 
7
# the Free Software Foundation; either version 2 of the License, or
 
8
# (at your option) any later version.
 
9
#
 
10
# This program is distributed in the hope that it will be useful,
 
11
# but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
# GNU General Public License for more details.
 
14
#
 
15
# You should have received a copy of the GNU General Public License
 
16
# along with this program; if not, write to the Free Software
 
17
# Foundation, Inc., 59 Temple Place - Suite 330,
 
18
# Boston, MA 02111-1307, USA.
 
19
#
 
20
#
 
21
=pod
 
22
 
 
23
=head1 NAME
 
24
 
 
25
pedigree - create a TeX file for pedigree from a csv file
 
26
 
 
27
=head1 SYNOPSIS
 
28
 
 
29
B<pedigree> [-c I<configuration_file>] [-d] [-o I<output_file>] [-s I<start_id>] I<input_file>
 
30
 
 
31
B<pedigree> -v
 
32
 
 
33
=head1 DESCRIPTION
 
34
 
 
35
The program converts a comma separated I<input_file> into a TeX file
 
36
with pst-pdgr macros.  
 
37
 
 
38
=head1 OPTIONS
 
39
 
 
40
=over 4
 
41
 
 
42
=item B<-c> I<configuration_file>
 
43
 
 
44
The configuration file to read along with the system-wide and user's
 
45
configuration files
 
46
 
 
47
=item B<-d>
 
48
 
 
49
Debug mode on
 
50
 
 
51
=item B<-o> -I<output_file> 
 
52
 
 
53
The ouput file instead of I<input_file.tex>
 
54
 
 
55
=item B<-s> -I<start_id> 
 
56
 
 
57
If this option is selected, the pedigree is constructed starting from
 
58
the node with the Id i<start_id>. Otherwise it is started from the 
 
59
proband node.
 
60
 
 
61
This option allows to create pedigrees with multiple probands or absent
 
62
probands, or show people who are not proband's relatives.
 
63
 
 
64
=item B<-v>
 
65
 
 
66
Print version information
 
67
 
 
68
=back
 
69
 
 
70
=head1 FILES
 
71
 
 
72
=over 4
 
73
 
 
74
=item B</etc/pedigree.cfg>
 
75
 
 
76
Global configuration file
 
77
 
 
78
=item B<$HOME/.pedigreerc>
 
79
 
 
80
User configuration file
 
81
 
 
82
=back 
 
83
 
 
84
=head1 SEE ALSO
 
85
 
 
86
The manual distributed with this program describes the format of the
 
87
configuration file and the input file.
 
88
 
 
89
The library functions are described in Pedigree::Language(3),
 
90
Pedigree::Parser(3), Pedigree::Node(3), Pedigree::PersonNode(3),
 
91
Pedigree::MarriageNode(3), Pedigree::Area(3).
 
92
 
 
93
=head1  AUTHOR
 
94
 
 
95
Boris Veytsman, Leila Akhmadeeva, 2006-2012
 
96
 
 
97
 
 
98
=cut
 
99
 
 
100
 
 
101
#########################################################
 
102
#   Packages and Options                                #
 
103
#########################################################
 
104
 
 
105
use strict;
 
106
use vars qw($opt_c $opt_d $opt_o $opt_s $opt_v);
 
107
 
 
108
our $TLCONF;        # TL config file
 
109
our $TLCONFLOCAL;   # TL local config file
 
110
 
 
111
BEGIN {
 
112
    # find files relative to our installed location within TeX Live
 
113
    chomp(my $TLMaster = `kpsewhich -var-value=SELFAUTOPARENT`); # TL root
 
114
    if (length($TLMaster)) {
 
115
        unshift @INC, "$TLMaster/texmf-dist/scripts/pedigree-perl";
 
116
        $TLCONF = "$TLMaster/texmf-config/pedigree/pedigree.cfg";
 
117
        chomp($TLCONFLOCAL = `kpsewhich -var-value=TEXMFLOCAL`);
 
118
        $TLCONFLOCAL .= "/pedigree/pedigree.cfg";
 
119
    }
 
120
}
 
121
 
 
122
use Getopt::Std;
 
123
use FileHandle;
 
124
use Pedigree;
 
125
 
 
126
#########################################################
 
127
#   Options Reading and Global Variables                #
 
128
#########################################################
 
129
 
 
130
my $USAGE="Usage: $0 [-c configuration_file] [-d] [-o output_file] [-s start_id] input_file\n";
 
131
my $COPYRIGHT=<<END;
 
132
$0 Version 1.0, April 2012
 
133
 
 
134
Copyright (C) 2006-2012 Boris Veytsman & Leila Akhmadeeva
 
135
 
 
136
This program is free software; you can redistribute it and/or modify
 
137
it under the terms of the GNU General Public License as published by
 
138
the Free Software Foundation; either version 2 of the License, or
 
139
(at your option) any later version.
 
140
 
 
141
This program is distributed in the hope that it will be useful,
 
142
but WITHOUT ANY WARRANTY; without even the implied warranty of
 
143
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
144
GNU General Public License for more details.
 
145
 
 
146
You should have received a copy of the GNU General Public License
 
147
along with this program; if not, write to the Free Software
 
148
Foundation, Inc., 59 Temple Place - Suite 330,
 
149
END
 
150
 
 
151
my $GLOBALCONF="/etc/pedigree.cfg";
 
152
 
 
153
my $USERCONF="$ENV{HOME}/.pedigreerc";
 
154
 
 
155
 
 
156
our $IN = new FileHandle;
 
157
our $OUT = new FileHandle;
 
158
 
 
159
getopts('c:do:s:v') or die $USAGE;
 
160
    
 
161
if ($opt_v) {
 
162
    die $COPYRIGHT;
 
163
}
 
164
 
 
165
our $DEBUG = $opt_d ||0;
 
166
 
 
167
if (scalar @ARGV != 1) {
 
168
    die $USAGE;
 
169
}
 
170
 
 
171
our $start_id = $opt_s;
 
172
 
 
173
#########################################################
 
174
#   Opening Files                                       #
 
175
#########################################################
 
176
 
 
177
 
 
178
if ($ARGV[0] eq '-') {
 
179
    $IN->fdopen(fileno(STDIN),"r");
 
180
} else {
 
181
    $IN->open($ARGV[0], "r") or die "Cannot read from $ARGV[0]\n";
 
182
}
 
183
 
 
184
my $outfile=$ARGV[0];
 
185
if ($opt_o) {
 
186
    $outfile = $opt_o;
 
187
} else {
 
188
    $outfile =~ s/\.[^\.]*$/.tex/;
 
189
}
 
190
if ($outfile eq '-') {
 
191
    $OUT->fdopen(fileno(STDOUT),"w");
 
192
} else {
 
193
    $OUT->open($outfile, "w") or die "Cannot write to $outfile\n";
 
194
}
 
195
 
 
196
#########################################################
 
197
#   Configuration                                       #
 
198
#########################################################
 
199
 
 
200
#
 
201
# First, the defaults.  Even if we do not find any
 
202
# configuration file, these will work.
 
203
#    
 
204
 
 
205
 
 
206
#
 
207
# Do we want to have a full LaTeX file or just a fragment?
 
208
#
 
209
our $fulldoc=1;
 
210
 
 
211
#
 
212
# What kind of document do we want
 
213
#
 
214
# our $documentheader='\documentclass[landscape]{article}';
 
215
our $documentheader='\documentclass{article}';
 
216
 
 
217
#
 
218
# Define additional packages here
 
219
#
 
220
# our $addtopreamble=<<END;
 
221
# \\usepackage{graphics}
 
222
# END
 
223
our $addtopreamble=<<END;
 
224
\\psset{descarmA=1}
 
225
END
 
226
 
 
227
 
 
228
 
 
229
#
 
230
# Do we want to print a legend?
 
231
#
 
232
our $printlegend=1;
 
233
 
 
234
#
 
235
# Fields to include in the legend.  Delete Name for privacy 
 
236
# protection. 
 
237
#
 
238
our @fieldsforlegend = qw(Name DoB AgeAtDeath Comment);
 
239
 
 
240
#
 
241
# Fields to put at the node.  Delete Name for privacy 
 
242
# protection. 
 
243
#
 
244
our @fieldsforchart = qw(Name);
 
245
 
 
246
#
 
247
# Language
 
248
#
 
249
# our $language="russian";
 
250
our $language="english";
 
251
 
 
252
#
 
253
# Override the encoding
 
254
#
 
255
# our $encoding="koi8-r";
 
256
 
 
257
our $encoding;
 
258
 
 
259
#
 
260
#  descarmA
 
261
#
 
262
our $descarmA = 0.8;
 
263
 
 
264
#
 
265
# Fonts for nodes
 
266
#
 
267
our $belowtextfont='\small';
 
268
our $abovetextfont='\scriptsize';
 
269
 
 
270
#
 
271
# Distances between nodes (in cm)
 
272
#
 
273
our $xdist=2;
 
274
our $ydist=2;
 
275
 
 
276
#
 
277
# Maximal width and height of the pedigree in cm.
 
278
# Set this to 0 to switch off scaling
 
279
#
 
280
our $maxW = 15;
 
281
our $maxH = 19;
 
282
 
 
283
#
 
284
# Whether to rotate the page.  The values are 'yes', 'no' and 'maybe'
 
285
# If 'maybe' is chosen, the pedigree is rotated if it allows better
 
286
# scaling
 
287
#
 
288
our $rotate = 'maybe';
 
289
 
 
290
#
 
291
# Read the global configuration file(s)
 
292
#
 
293
foreach my $conffile ($GLOBALCONF, $TLCONF, $TLCONFLOCAL) {
 
294
    if (-r $conffile) {
 
295
        if ($DEBUG) {
 
296
            print STDERR "Reading global configuration file $conffile\n";
 
297
        }
 
298
        require "$conffile";
 
299
    } else {
 
300
        if ($DEBUG) {
 
301
            print STDERR "Cannot find global configuration file $conffile; going without it\n";
 
302
        }
 
303
    }
 
304
}
 
305
 
 
306
#
 
307
# Read the user configuration file
 
308
#
 
309
if (-r $USERCONF) {
 
310
    if ($DEBUG) {
 
311
        print STDERR "Reading user configuration file $USERCONF\n";
 
312
    }
 
313
    require "$USERCONF";
 
314
} else {
 
315
    if ($DEBUG) {
 
316
        print STDERR "Cannot find user configuration file $USERCONF; going without it\n";
 
317
    }
 
318
}
 
319
 
 
320
#
 
321
# Read the option configuration file
 
322
#
 
323
if ($opt_c) {
 
324
    if (-r $opt_c) {
 
325
        if ($DEBUG) {
 
326
            print STDERR "Reading optional configuration file $opt_c\n";
 
327
        }
 
328
        require "$opt_c";
 
329
    } else {
 
330
        die "Cannot find $opt_c\n";
 
331
    }
 
332
}
 
333
 
 
334
#########################################################
 
335
#   Setting up                                          #
 
336
#########################################################
 
337
 
 
338
my $lang = new Pedigree::Language($language, $encoding);
 
339
$_=<$IN>;
 
340
my $parser = new Pedigree::Parser($_,$lang);
 
341
my $start;
 
342
 
 
343
#########################################################
 
344
#   Reading input                                       #
 
345
#########################################################
 
346
 
 
347
while (<$IN>) {
 
348
    my $node = Pedigree->MakeNode($parser->Parse($_));
 
349
    if (ref($node)) {
 
350
        if ($start_id) {
 
351
            if ($start_id eq $node->Id()) {
 
352
                $start = $node;
 
353
                if ($DEBUG) {
 
354
                    print STDERR "Found start: ", $start->Id(), "\n";
 
355
                }
 
356
            }
 
357
        } else {
 
358
            if ($node->isProband()) {
 
359
                if (ref($start)) {
 
360
                    print STDERR "Two probands?  I got ", $start->Id(), 
 
361
                    " and ", $node->Id(), "\n";
 
362
                }
 
363
                $start=$node;
 
364
                if ($DEBUG) {
 
365
                    print STDERR "Found proband: ", $start->Id(), "\n";
 
366
                }
 
367
            }
 
368
        }
 
369
    }
 
370
}
 
371
 
 
372
if (!ref($start)) {
 
373
    die "Cannot find the start!\n";
 
374
}
 
375
 
 
376
#########################################################
 
377
#   Process Pedigree                                    #
 
378
#########################################################
 
379
 
 
380
#
 
381
# Check all parents
 
382
#
 
383
$start->CheckAllParents();
 
384
 
 
385
 
 
386
#
 
387
# The root is the root of the tree to which the proband
 
388
# belongs
 
389
#
 
390
 
 
391
my ($root, undef)=@{$start->FindRoot(0)};
 
392
if ($DEBUG) {
 
393
    print STDERR "Root: ", $root->Id(), "\n";
 
394
}
 
395
 
 
396
#
 
397
# Calculate relative coordinates
 
398
#
 
399
$root->SetRelX(0);
 
400
$root->SetRelY(0);
 
401
$root->SetArea();
 
402
 
 
403
#
 
404
# Calculate the absolute coordinates
 
405
#
 
406
$root->CalcAbsCoor(0,0);
 
407
 
 
408
#
 
409
# Check for consanguinic marriages
 
410
#
 
411
$root->AddConsanguinicMarriages();
 
412
 
 
413
#
 
414
# And twins
 
415
#
 
416
$root->AddTwins($ydist);
 
417
 
 
418
#
 
419
#  Get the frame
 
420
#
 
421
my ($xmin, $ymin, $xmax, $ymax) = @{$root->SetFrame($xdist, $ydist)};
 
422
 
 
423
 
 
424
 
 
425
#########################################################
 
426
#   Printing headers                                    #
 
427
#########################################################
 
428
 
 
429
if ($fulldoc) {
 
430
    printheader($OUT,$lang,$addtopreamble);
 
431
}
 
432
 
 
433
#########################################################
 
434
#   Calculate scale and check whether to rotate         #
 
435
#########################################################
 
436
 
 
437
my $scale=1;
 
438
my $scaleRotated = 1;
 
439
 
 
440
if ($maxH && $maxW) {
 
441
    if ($maxH/($ymax-$ymin) < $scale) {
 
442
        $scale = $maxH/($ymax-$ymin);
 
443
    }
 
444
    if ($maxW/($xmax-$xmin) < $scale) {
 
445
        $scale = $maxW/($xmax-$xmin);
 
446
    }
 
447
    if ($maxW/($ymax-$ymin) < $scaleRotated) {
 
448
        $scaleRotated = $maxW/($ymax-$ymin);
 
449
    }
 
450
    if ($maxH/($xmax-$xmin) < $scaleRotated) {
 
451
        $scaleRotated = $maxH/($xmax-$xmin);
 
452
    }
 
453
}
 
454
 
 
455
my $doRotate = ($rotate =~ /yes/i) || (($rotate =~ /maybe/i) &&
 
456
                                       ($scaleRotated > $scale));
 
457
 
 
458
#########################################################
 
459
#   Printing pspicture                                  #
 
460
#########################################################
 
461
 
 
462
my $pre;
 
463
my $post ='}'."\n"; 
 
464
 
 
465
if ($doRotate) {
 
466
    $descarmA *=  $scaleRotated;
 
467
    $pre="\\rotatebox{90}{%\n\\psset{descarmA=$descarmA}%\n";
 
468
    if ($scaleRotated<1) {
 
469
        $pre .= '\psset{unit='.$scaleRotated.'}%'."\n";
 
470
    }
 
471
} else {
 
472
    $descarmA *= $scale;
 
473
    $pre="{%\n\\psset{descarmA=$descarmA}%\n";
 
474
    if ($scale<1) {
 
475
        $pre .= '{\psset{unit='.$scale.'}%'."\n";
 
476
    }
 
477
}
 
478
 
 
479
print $OUT $pre;
 
480
 
 
481
print $OUT '\begin{pspicture}',"($xmin,$ymin)($xmax,$ymax)\n";
 
482
 
 
483
print $OUT $root->DrawAll($xdist, $ydist, $belowtextfont, 
 
484
                          $abovetextfont, @fieldsforchart);
 
485
 
 
486
print $OUT '\end{pspicture}%',"\n";
 
487
 
 
488
print $OUT $post;
 
489
 
 
490
#########################################################
 
491
#   Printing legend                                     #
 
492
#########################################################
 
493
 
 
494
 
 
495
if ($printlegend) {
 
496
    print $OUT $root->PrintAllLegends($lang, @fieldsforlegend);
 
497
}
 
498
 
 
499
#########################################################
 
500
#   Printing end                                        #
 
501
#########################################################
 
502
 
 
503
 
 
504
if ($fulldoc) {
 
505
    printend($OUT);
 
506
}
 
507
 
 
508
#########################################################
 
509
#   Exiting                                             #
 
510
#########################################################
 
511
 
 
512
exit 0;
 
513
 
 
514
#########################################################
 
515
#   Subroutines                                         #
 
516
#########################################################
 
517
 
 
518
#
 
519
# Printing headers & footers
 
520
#
 
521
 
 
522
sub printheader {
 
523
    my ($OUT,$lang,$addtopreamble)=@_;
 
524
    print $OUT <<END;
 
525
$documentheader
 
526
\\usepackage{pst-pdgr}
 
527
END
 
528
 
 
529
    print $OUT $lang->Header;
 
530
    print $OUT <<END;
 
531
$addtopreamble
 
532
\\begin{document}
 
533
END
 
534
    return 0;
 
535
}
 
536
 
 
537
 
 
538
sub printend {
 
539
    my $OUT=shift;
 
540
    print $OUT "\\end{document}\n";
 
541
    return 0;
 
542
}
 
543
 
 
544