File Coverage

blib/lib/Graph/Undirected/Hamiltonicity/Output.pm
Criterion Covered Total %
statement 12 125 9.6
branch 1 26 3.8
condition 2 20 10.0
subroutine 4 7 57.1
pod 1 4 25.0
total 20 182 10.9


line stmt bran cond sub pod time code
1             package Graph::Undirected::Hamiltonicity::Output;
2              
3 15     15   100 use Modern::Perl;
  15         29  
  15         94  
4 15     15   1764 use Carp;
  15         31  
  15         788  
5 15     15   73 use Exporter qw(import);
  15         27  
  15         20156  
6              
7             our @EXPORT_OK = qw(
8             &output
9             &output_graph_svg
10             &output_image_svg
11             &output_adjacency_matrix_svg
12             );
13              
14             our %EXPORT_TAGS = ( all => \@EXPORT_OK, );
15              
16             ##############################################################################
17              
18             sub output {
19 11674     11674 1 20090 my ($input) = @_;
20              
21 11674   100     30393 my $format = $ENV{HC_OUTPUT_FORMAT} || 'none';
22              
23 11674 50       30411 return if $format eq 'none';
24              
25 0 0         if ( $format eq 'html' ) {
    0          
26 0 0         if ( ref $input ) {
27 0           output_image_svg(@_);
28             } else {
29 0           say $input;
30             }
31              
32             } elsif ( $format eq 'text' ) {
33 0 0         if ( ref $input ) {
34             ### Print the graph's edge-list as a string.
35 0           say "$input";
36             } else {
37             ### Strip out HTML
38 0           $input =~ s@
  • @* @gi;
  • 39 0           $input =~ s@
    @@gi;
    40 0           $input =~ s@@@gi;
    41 0           $input =~ s@]*?>@=================@gi;
    42 0           say $input;
    43             }
    44             } else {
    45 0           croak "Environment variable HC_OUTPUT_FORMAT should be "
    46             . "one of: 'html', 'text', or 'none'\n";
    47             }
    48              
    49             }
    50              
    51             ##########################################################################
    52              
    53             sub output_image_svg {
    54 0     0 0   my ( $g, $hash_ref ) = @_;
    55              
    56 0   0       my %params = %{ $hash_ref // {} };
      0            
    57 0   0       my $image_size = $params{size} || 600;
    58              
    59 0           say qq{
    };
    60              
    61             ### Output image
    62 0           say qq{
    63            
    64             "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
    65              
    66            
    67             xmlns="http://www.w3.org/2000/svg">
    68             };
    69              
    70 0           output_graph_svg( $g, { %params, image_size => $image_size } );
    71 0 0         if ( $g->vertices() <= 12 ) {
    72 0           output_adjacency_matrix_svg( $g,
    73             { %params, image_size => $image_size } );
    74             }
    75 0           say qq{};
    76 0           say qq{\n};
    77             }
    78              
    79             ##########################################################################
    80              
    81             sub output_graph_svg {
    82 0     0 0   my ( $g, $hash_ref ) = @_;
    83              
    84 0   0       my %params = %{ $hash_ref // {} };
      0            
    85              
    86 0           my $Pi = 4 * atan2 1, 1;
    87 0           my $v = scalar( $g->vertices() );
    88              
    89             ### Compute angle between vertices
    90 0           my $angle_between_vertices = 2 * $Pi / $v;
    91              
    92 0   0       my $image_size = $params{size} || 600;
    93              
    94             ### Compute Center of image
    95 0           my $x_center = $image_size / 2;
    96 0           my $y_center = $x_center;
    97 0           my $border = int( $image_size / 25 ); ### cellpadding in the image
    98              
    99             ### Compute vertex coordinates
    100 0           my $radius = ( $image_size / 2 ) - $border;
    101 0           my $angle = $Pi * ( 0.5 - ( 1 / $v ) );
    102 0           my @vertices = $g->vertices();
    103              
    104 0           @vertices = sort { $a <=> $b } @vertices;
      0            
    105 0           my $text_xml = '';
    106 0           my $vertices_xml = '';
    107 0           my @vertex_coordinates;
    108             ### Draw vertices ( and include text labels )
    109 0           for my $vertex (@vertices) {
    110              
    111 0           my $x = ( $radius * cos($angle) ) + $x_center;
    112 0           my $y = ( $radius * sin($angle) ) + $y_center;
    113              
    114 0           $vertices_xml .= qq{\n};
    115 0           $text_xml .= q{ 116 0 0         $text_xml .= $x - ( length("$vertex") == 1 ? 4 : 8 );
    117 0           $text_xml .= q{" y="};
    118 0           $text_xml .= $y + 5;
    119 0           $text_xml .= qq{">$vertex\n};
    120              
    121 0           $vertex_coordinates[$vertex] = [ $x, $y ];
    122 0           $angle += $angle_between_vertices;
    123             }
    124              
    125 0           my $edges_xml = '';
    126             ### Draw edges
    127 0           foreach my $edge_ref ( $g->edges() ) {
    128 0           my ( $orig, $dest ) = @$edge_ref;
    129              
    130 0 0         if ( $orig > $dest ) {
    131 0           my $temp = $orig;
    132 0           $orig = $dest;
    133 0           $dest = $temp;
    134             }
    135              
    136             my $required = $params{required}
    137 0   0       || $g->get_edge_attribute( $orig, $dest, 'required' );
    138              
    139 0           my $override_attrs = "";
    140 0 0         if ( $required ) {
    141 0           $override_attrs = qq{ stroke-width="3" stroke="#FF0000" };
    142             }
    143              
    144 0           $edges_xml .= qq{ 145 0           $edges_xml .= q{" x1="};
    146 0           $edges_xml .= $vertex_coordinates[$orig]->[0];
    147 0           $edges_xml .= q{" y1="};
    148 0           $edges_xml .= $vertex_coordinates[$orig]->[1];
    149 0           $edges_xml .= q{" x2="};
    150 0           $edges_xml .= $vertex_coordinates[$dest]->[0];
    151 0           $edges_xml .= q{" y2="};
    152 0           $edges_xml .= $vertex_coordinates[$dest]->[1];
    153 0           $edges_xml .= qq{"$override_attrs />};
    154 0           $edges_xml .= "\n";
    155             }
    156              
    157             ### Output image
    158 0           say qq{
    159            
    160             "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
    161              
    162            
    163             xmlns="http://www.w3.org/2000/svg">
    164              
    165            
    166             $edges_xml
    167              
    168            
    169             style="opacity: 1; fill: blue; fill-opacity: 1; stroke: black; stroke-opacity: 1">
    170             $vertices_xml
    171              
    172            
    173             style="opacity: 1; fill: lightgreen; fill-opacity: 1; stroke: lightgreen; stroke-opacity: 1">
    174              
    175             $text_xml
    176              
    177             };
    178              
    179             }
    180              
    181             ##########################################################################
    182              
    183             sub output_adjacency_matrix_svg {
    184              
    185 0     0 0   my ( $g, $hash_ref ) = @_;
    186              
    187 0   0       my %params = %{ $hash_ref // {} };
      0            
    188              
    189 0           say qq{};
    190 0           say qq{};
    191              
    192 0           my $square_size = 30;
    193 0           my @vertices = sort { $a <=> $b } $g->vertices();
      0            
    194              
    195 0   0       my $image_size = $params{image_size} || 600;
    196              
    197 0           my $x_init = $image_size + 60;
    198 0           my $y_init = $image_size - $square_size * scalar(@vertices);
    199              
    200 0           my $x = $x_init;
    201 0           my $y = $y_init;
    202 0           my $counter = 0;
    203              
    204 0           foreach my $i (@vertices) {
    205 0 0         if ($counter) {
    206 0           print q{ 207 0           print $x - 25;
    208 0           print q{" y="};
    209 0           print $y + $square_size - 10;
    210 0           print qq{">$i\n}; ### vertex label
    211             }
    212              
    213 0           print q{ 214 0           print $x + 10 + ( $square_size * $counter++ );
    215 0           print q{" y="};
    216 0           print $y + 20;
    217 0           print qq{">$i\n}; ### vertex label
    218              
    219 0           foreach my $j (@vertices) {
    220              
    221 0 0         last if $i == $j;
    222              
    223 0           my $fill_color;
    224 0 0         if ( $g->has_edge( $i, $j ) ) {
    225             $fill_color =
    226             $params{required}
    227 0 0 0       || $g->get_edge_attribute( $i, $j, 'required' )
    228             ? '#FF0000'
    229             : '#000000';
    230             } else {
    231 0           $fill_color = '#FFFFFF';
    232             }
    233 0           print qq{
    234 0           print qq{height="$square_size" fill="$fill_color" />\n};
    235              
    236 0           $x += $square_size;
    237             }
    238 0           $y += $square_size;
    239 0           $x = $x_init;
    240             }
    241              
    242 0           say qq{\n};
    243              
    244             }
    245              
    246             ##########################################################################
    247              
    248             1; # End of Graph::Undirected::Hamiltonicity::Output