view release on metacpan or  search on metacpan

bin/VertFigure  view on Meta::CPAN

#!/usr/local/bin/perl -w

use strict;
use warnings;
use Getopt::Std;
use Data::Dumper; 
use SVG;
use SVG::VCD;

my %options;
if (!getopts('d', \%options) || @ARGV != 1) {
    print STDERR "\
Usage: $0 [options] <VCD-file>
	-d		Dump information about parsed VCD-file.
";
    exit 1;
}

if (@ARGV != 1) {
    exit 1;
}

my $vcd = new SVG::VCD($ARGV[0]);
if ($options{d}) {
    print Dumper($vcd);
    exit;
}

my $n = $vcd->ntaxa();
my $th = $vcd->config("taxon-height");
my $cw = $vcd->config("cervical-width");
my $ch = $vcd->config("cervical-height");
my $dw = $vcd->config("dorsal-width");
my $dh = $vcd->config("dorsal-height");
my $dhg = $vcd->config("dorsal-height-gradient");
my $tyo = $vcd->config("text-y-offset") || 0;
my $cdo = $vcd->config("cervico-dorsal-offset");
my $cdc = $vcd->config("cervico-dorsal-color");

my $width = $vcd->config("width");
my $height = $vcd->config("height");
my $svg = SVG->new(width => $width, height => $height);

my $background = $vcd->config("background");
if ($background) {
    $svg->rectangle(x => 0, y => 0, width => $width, height => $height,
		    style => { 'fill' => $background });
}

my $st = $svg->group(style => { 'font-family' => $vcd->config("font-family"),
				'font-size' => $vcd->config("font-size"),
				fill => 'black',
		     });

foreach my $i (1 .. $n) {
    my $taxon = $vcd->taxon($i-1);
    my $data = $taxon->field("data");
    my($cdata, $ddata) = split('\|', $data);
    $ddata = "" if !defined $ddata;
    my $nc = length($cdata);
    my $nd = length($ddata);

    my $text = $st->text(x => 10, 'y' => $th * $i + $tyo);
    my $tname = $taxon->field("taxon");
    my %args = ( style => { 'font-style' => "italic" } );
    if ($tname =~ s/^\///) {
	%args = ();
    }
    $text->tspan(%args)->cdata($tname);
    my $specimen = $taxon->field("specimen");
    # I don't know why, but some versions of InkScape (e.g. v0.48 on
    # Ubuntu 12.04.2) do not render an ordinary space in this context
    # -- hence use of a non-breaking space.
    $text->tspan()->cdata("&#160;$specimen") if defined $specimen;

    # Cervicals
    foreach (my $j = 0; $j < $nc; $j++) {
	vertebra($svg, $vcd, $i, $j-$nc, $cw, $ch, substr($cdata, $j, 1));
    }

    # Dorsals
    my $dheight = $dh;
    foreach (my $j = 0; $j < $nd; $j++) {
	vertebra($svg, $vcd, $i, $j, $dw, $dheight, substr($ddata, $j, 1));
	$dheight += $dhg if defined $dhg;
    }
}

if ($cdc) {
    my $maxh = $ch > $dh ? $ch : $dh;
    my $margin = $th - $maxh;
    $svg->line(x1 => $cdo, y1 => $margin/2,
	       x2 => $cdo, y2 => $n * $th + $margin/2,
	       style => { stroke => $cdc } );
}

print $svg->xmlify();


sub vertebra {
    my($svg, $vcd, $yoff, $xoff, $width, $height, $char) = @_;
    $char = lc($char);
    my $cdo = $vcd->config("cervico-dorsal-offset");
    my $th = $vcd->config("taxon-height");
    my $bc = $vcd->config("box-color") || "grey";

    my $x = $cdo + $xoff * $width;
    my $y = $th * $yoff - $height;
    $svg->rectangle(x => $x, 'y' => $y, width => $width, height => $height,
		    style => { stroke => $bc, fill => 'white' });

    if (my $polygon = $vcd->config("state-$char-polygon")) {
	$svg->polygon(style => { fill => $vcd->config("state-$char-color") },
		      points => compile_points($x, $y, $width, $height,
					       0.2, 0,
					       split(/[, ]/, $polygon)));
    } elsif ($char eq "-") {
	# Unknown state (e.g. vertebra missing): nothing to draw
    } else {
	die "unrecognised bifurcation state '$char'";
    }
}


# Returns a string of the form '0,0 0,1 1,1 1,0'
sub compile_points {
    my $xoff = shift();
    my $yoff = shift();
    my $xscale = shift();
    my $yscale = shift();
    my $pMargin = shift();
    my $aMargin = shift();
    my $text = "";

    while (@_) {
	my $x = shift();
	my $y = shift();