The code posted works as I expected, and I am pleased with it generally The following scripts are for generating SVGs with SVG.
What I am working towards is looping lines 47 through 154 in the first script to put between lines 80 and 82 in the second script, which is a lot of lines in a loop. I know that long loop blocks may be fine, but I am just wondering if there is anything in the code that I could make more concise to make the loop shorter (on the page). So, is there anything that I made too long that can be made shorter?
Also, if you have any "How come?" or "Why?" questions about how I wrote the code in general, please ask.
Script 1 called tree-paths.pl currently
Usage:
tree-paths.pl 'family=Noyb; rel=marriage; mother=Susie Q; father=Gerald McBoing-Boing; children=Foo Q-Boing, Bar Q-Boing, Baz Q-Boing, Qux Q-Boing; gen=3;'
#!/usr/bin/perl
use strict;
use warnings;
use Fancy::Join qw(join_defined); # this can be replaced with join('',
+ defined()); for the $couple variable
use Util::Convert qw(idify); # this can be removed from the make_
+ids sub
use SVG ();
# Note
## It appears the SVG module is not complete.
## When you see '->tag ', that means that tag was not exported by SVG.
sub make_ids {
my $in = shift;
( my $no_space = $in) =~ s/\s//g;
my $id = idify($no_space);
return $id;
}
sub family_y {
my ($gen, $num_parents) = @_;
my $multiplier = $gen - 1;
my $modifier = $num_parents == 2 ? 0 : $num_parents == 1 ? 18 : 38
+;
my $family_y = (-18 + (-76 * $multiplier)) + $modifier;
return $family_y;
}
my $input = shift;
my $points = [ split(/; /, $input) ];
my $data;
for my $point (@$points) {
my ($key, $value) = split(/\=/, $point);
$data->{$key} = $value;
}
# Start the top of the svg
my $width = 300;
my $height = 300;
my $svg = SVG->new( viewBox => "0 0 $width $height", width => $width,
+height => $height);
# Start the family groups
my $family = $data->{family};
my $gen = $data->{gen};
my $mother = $data->{mother};
my $father = $data->{father};
my $children = $data->{children};
if ( $gen == 1 && $children ) {
die "Generation 1 families do not have children, you might want gene
+ration 2. tree-paths.pl died$!";
}
my $Yyy = $mother ? substr $mother, 0, 3 : undef;
my $Xxx = $father ? substr $father, 0, 3 : undef;
my $moth_id = $mother ? make_ids($mother) : undef;
my $fath_id = $father ? make_ids($father) : undef;
my $couple = join_defined(' and ', ($mother, $father));
my $num_parents = ($mother && $father) ? 2 :
($mother || $father) ? 1 :
0;
my $rel_id = $num_parents == 2 ? "$Yyy$Xxx" :
$mother ? $moth_id :
$father ? $fath_id :
$family ? $family :
undef;
my $rel = $data->{rel} // undef;
my $abb_rel = $rel ? substr $rel, 0, 1 : undef;
my $couple_id = "$abb_rel$rel_id";
my $child_list = $children ? [ split(/, /, $children) ] : undef;
my $child_ids = $children ? [ map { make_ids($_) } @$child_list ] :
+undef;
my $child_count = $children ? @$child_list : 0;
my $family_y = family_y($gen, $num_parents);
my $family_group;
my $child_group;
# Start the paths of relationship if both parents are known
if ( $num_parents == 2 ) {
$family_group = $svg->group( id => '', class => $rel, transform =>
+ "translate(79, $family_y)" );
$family_group->tag('title')->cdata(ucfirst "$rel of $couple");
$family_group->tag('path', d => 'm 0,0 h -19', id => "$couple_id-$mo
+th_id");
$family_group->tag('path', d => 'm 0,0 h 19', id => "$couple_id-$fa
+th_id");
}
# End the paths of relationship if both parents are known
# Start the group for the children
if ( $child_count > 0 ) {
my $id_prefix = $num_parents > 0 ? "c$rel_id" : "sib$rel_id";
# Start section determining if children group stands alone.
if ( $num_parents == 2 ) {
$child_group = $family_group->group( id => "$family-children", cla
+ss => 'child' );
}
else {
$child_group = $svg->group( id => "$family-siblings", class => 'ch
+ild', transform => "translate(30, $family_y)" );
}
# End section determining if children group stands alone.
# Start paths for children
# Start path for one child
if ( $child_count == 1 ) {
$child_group->tag('title')->cdata("$child_list->[0], child of $cou
+ple");
$child_group->tag('path', d => 'm 0,0 v 58', id => "$couple_id-$c
+hild_ids->[0]");
}
# End path for one child
# Start group for multiple children
else {
my $child_title = $num_parents > 0 ? "Children of $couple" : "$fam
+ily siblings";
my $base_h = -40;
my $start_h = $base_h + (( $#$child_ids - 1 ) * -40);
$child_group->tag('title')->cdata($child_title);
$child_group->tag('path', d => 'm 0,0 v 38', id => "$couple_id-$
+id_prefix") if $num_parents > 0;
for my $num (0..$#$child_ids) {
$child_group->tag('path', d => "m 0,38 h $start_h v 20", id => "
+$id_prefix-$child_ids->[$num]");
$start_h += 80;
}
$child_group->tag('circle', cx => '0', cy => '38', r => "1.5", id
+=> "$id_prefix");
# End group for multiple children
}
}
# End the group for the children
# Start the circle of relationship of parents if both are known
## This circle had to come last.
## It covers the converging ends of the paths between the parents and
+children.
if ( $num_parents == 2 ) {
$family_group->tag('circle', cx => '0', cy => '0', r => "1.5", id =>
+ "$abb_rel$rel_id");
}
# End the circle of relationship of parents if both are known
# End the family groups
my $text = $num_parents == 2 ? $family_group->xmlify : $child_group->x
+mlify;
print "$text\n";
Script 2 called family-tree.pl currently. It hasn't been written to accept data yet.
#!/usr/bin/perl
use strict;
use warnings;
use feature qw(say);
use Data::Dumper;
use Fancy::Join qw(join_defined);
use SVG ();
sub gen_y {
my $gen = shift;
my $multiplier = $gen - 1;
my $gen_y = 36 + ( 76 * $multiplier);
return $gen_y;
}
sub family_y {
my ($gen, $two_parents, $one_parent) = @_;
my $multiplier = $gen - 1;
my $modifier = $two_parents ? 0 : $one_parent ? 18 : 38;
my $family_y = (-18 + (-76 * $multiplier)) + $modifier;
return $family_y;
}
my $width = 620;
my $height = 220;
my $chart_trans_y = $height - 5;
my $chart_title_y = ($chart_trans_y - 12) * -1;
my $family = 'Noyb';
my $source = 'me';
my $svg = SVG->new(
'xmlns' => "http://www.w3.org/2000/svg",
'xmlns:xlink' => "http://www.w3.org/1999/xlink",
'xmlns:rdf' => "http://www.w3.org/1999/02/22-rdf-syntax-ns#",
'xmlns:dc' => "http://purl.org/dc/elements/1.1/",
'xmlns:cc' => "http://creativecommons.org/ns#",
viewBox => "0 0 $width $height",
width => $width,
height => $height
);
$svg->tag('title', id => "svg_title" )->cdata(ucfirst "The $family
+family from $source");
my $metadata = $svg->tag('metadata', id => "Family_metadata");
my $md_rdf = $metadata->tag('rdf:RDF');
my $rdf_cc = $md_rdf->tag('cc:work', 'rdf:about' => '');
$rdf_cc->tag('dc:format')->cdata('image/svg+xml');
$rdf_cc->tag('dc:type', 'rdf:resource' => 'http://purl.org/dc
+/dcmitype/StillImage');
$rdf_cc->tag('dc:title')->cdata("The $family family from $sou
+rce");
my $cc_creator = $rdf_cc->tag('dc:creator');
my $dc_creator = $cc_creator->tag('cc:agent');
$dc_creator->tag('dc:title')->cdata('me');
$rdf_cc->tag('dc:language')->cdata('en-US');
$rdf_cc->tag('dc:date')->cdata('2020-03');
$svg->tag('style', id => "Family_styles", type => "text/css")->cdat
+a(q(
@import url(../../../css/family_tree.css);
g.deceased.male rect { fill: url(#m_dead); }
g.deceased.female rect { fill: url(#f_dead); }
));
my $defs = $svg->tag('defs', id => "Family_defs");
my $m_dead_grad = $defs->gradient( -type => "radial", id => "m_dead"
+);
$m_dead_grad->stop( id => 'mds1', offset => '75%', style => 'stop
+-color:#ccccff;stop-opacity:0.85;');
$m_dead_grad->stop( id => 'mds2', offset => '25%', style => 'stop
+-color:#eeeeff;stop-opacity:0.85;');
my $f_dead_grad = $defs->gradient( -type => "radial", id => "f_dead"
+);
$f_dead_grad->stop( id => 'fds1', offset => '75%', style => 'stop
+-color:#ffcccc;stop-opacity:0.85;');
$f_dead_grad->stop( id => 'fds2', offset => '25%', style => 'stop
+-color:#ffeeee;stop-opacity:0.85;');
my $tree = $svg->group( id => $source, class => 'graph', transform =
+> "translate(5, $chart_trans_y)" );
$tree->tag('title')->cdata('');
$tree->text( x => $width / 2, y => $chart_title_y, class => 'char
+t_title')->cdata("The $family family from $source");
my $text = $svg->xmlify;
print "$text\n";
After I get the code from script 1 all nice and loopy and into script 2, I will begin working on the rectangles for the people in the family tree. Then I will make that loopy.