Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Get code ready for a loop (and a little RFC)

by Lady_Aleena (Curate)
on Mar 13, 2020 at 06:03 UTC ( #11114203=perlquestion: print w/replies, xml ) Need Help??

Lady_Aleena has asked for the wisdom of the Perl Monks concerning the following question:

Hello everyone!

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.

I've missed you guys! So thank you to everyone who stops by and read this.

Update: (18 March 2020) The code above was put into a subroutne from the suggestions below and is now all nice and loopy. The code's output is what was expected.

No matter how hysterical I get, my problems are not time sensitive. So, relax, have a cookie, and a very nice day!
Lady Aleena

Replies are listed 'Best First'.
Re: Get code ready for a loop (and a little RFC)
by GrandFather (Sage) on Mar 13, 2020 at 07:57 UTC

    Why not just put the code in a sub and call the sub inside the loop?

    Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond

      That would be a big sub, but it has crossed my mind. 8)

      No matter how hysterical I get, my problems are not time sensitive. So, relax, have a cookie, and a very nice day!
      Lady Aleena

        Better a big sub than a sea of code inside a loop. One advantage of using a sub is you get to name it so at the point where it is called the intent is clear. The point about big blobs of code is that you can't keep everything in your head while you try to understand what is going on. Breaking it up into named chunks (subs) makes the code easier to write correctly and easier to maintain.

        Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
Re: Get code ready for a loop (and a little RFC)
by tobyink (Canon) on Mar 14, 2020 at 12:39 UTC

    "cc:work" should be "cc:Work" and "cc:agent" should probably be "dc:Agent", except that you're using the Dublin Core 1.1 namespace which doesn't have dc:Agent. Try using "http://purl.org/dc/terms/" as the namespace for Dublin Core; it's the newer version and doesn't contain a version number because it's designed to evolve.

Re: Get code ready for a loop (and a little RFC)
by Veltro (Hermit) on Mar 14, 2020 at 10:43 UTC

    Hello Lady Aleena

    Maybe you want to use the sub that you eventually create to be used by several programs...

    There is a technique that I sometimes use to be able to use common functionality that is needed by several programs. And I don't want to repeat myself over and over so I put those in libraries that are commonly accessible. E.g. I have a simple "CommonFunctions.pm" file containing functions like "trim", "trimleft", "trimright". I will share this example how to achieve this because I think it might be usefull to you. I have added use examples below under __END__.

    MySVG.pm

    package MySVG ; use strict ; use warnings ; use Exporter ; use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS ) ; @ISA = qw( Exporter ); @EXPORT = ( ) ; @EXPORT_OK = qw( gen_y family_y ) ; %EXPORT_TAGS = ( SVGFunc => [qw( &gen_y &family_y )] ) ; 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; } 1; __END__ use examples (which should always work in case MySVG is in the same lo +cation as your program): - use MySVG qw( :SVGFunc ) ; - use MySVG qw( gen_y ) ; Ways to make perl find the lib in case it is somewhere else: - Add location of MySVG to PATH environment variable - use the perl -Idirectory switch - In case only your current project uses it and the pm file is in say +"lib\MySVG\" and you are working on a file in lib\somewhere-else\: use File::Basename qw( dirname ) ; use lib dirname( dirname __FILE__ ) . '/MySVG' ;

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://11114203]
Approved by GrandFather
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (3)
As of 2020-11-25 03:03 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?