#!perl
use strict;
use warnings;
use 5.010_000;
use feature ':5.10';
use File::Basename qw( dirname );
use lib dirname(__FILE__);
use TM qw( size );
use Getopt::Long qw( GetOptions );
GetOptions(
help => sub { die 'pod2usage( -verbose => 2 )' },
my $in_edge = "$ARGV[0].fulledge";
my $out_edge = "$ARGV[0].edge";
say "Read $in_edge (@{[ size( -s $in_edge ) ]})";
my $edge = retrieve( $in_edge );
# Find the shortest paths to each node except the ones that go directly from 'root'. I want at least a /little/ indirection.
my %paths;
our %WALK;
walk( 'root' );
undef %WALK;
# Compute all the parent -> @children paths
my %edges;
for my $child ( keys %paths ) {
my $path = delete $paths{$child};
my $parent = $path->[1]; # $path->[0] eq $child
next if ! defined $parent;
push @{ $edges{$parent} }, $child;
}
store( \ %edges, $out_edge );
say "Wrote $out_edge (@{[ size( -s $out_edge ) ]})";
sub walk {
my $node = $_[-0];
# Do not recurse infinitely.
return if $WALK{$node};
local $WALK{$node} = 1;
# Process this path.
my $prev = $paths{$node};
if ( ! $prev ) {
$paths{$node} = [ @_ ];
}
elsif ( @$prev <= 1 ) {
# say "Preferring [@_] to [@$prev] because \@\$prev <= 1";
$paths{$node} = [ @_ ];
}
elsif ( @_ > 2 && @$prev > @_ ) {
# say "Preferring [@_] to [@$prev] because \@_ > 2 && \@\$prev > \@_";
$paths{$node} = [ @_ ];
}
# Find children to recurse into.
my $children = $edge->{$node};
return if ! $children;
# Recurse into children.
walk( $_, @_ ) for keys %$children;
}