The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl
use strict;
use warnings;
use 5.010_000;
use feature ':5.10';
use Getopt::Long qw( GetOptions );
use Runops::Movie::Util qw( printf_pretty_size );
use File::Spec::Functions qw( catfile );
use Carp::Always;
use Alien::Judy;
use Judy::1;
use Judy::L;
use Inline
    C => 'DATA',
    ( # Config:
	OPTIMIZE => '-g',
	CLEAN_AFTER_BUILD => 1,
	INC => join( ' ',
		     map { "-I$_" }
		     Alien::Judy::inc_dirs()
	),
	LIBS => join( ' ',
		      (
		          map { "-L$_" }
		          Alien::Judy::lib_dirs()
		      ),
		      '-lJudy'
	)
    );

GetOptions(
    help         => sub { die 'pod2usage( -verbose => 2 )' },
    'dir=s'      => \my($dir),
    'rulledge=s' => \my($in_rulledge),
    'vertex=s'   => \my($in_vertex),
    'arity=s'    => \my($in_arity),
    'edge=s'     => \my($out_edge),
)
  or die 'pod2usage( -verbose => 2 )';

# --dir automagic
#
if ( $dir ) {
    $in_vertex   //= catfile( $dir, 'frame.vertex'   );
    $in_rulledge //= catfile( $dir, 'frame.rulledge' );
    $in_arity    //= catfile( $dir, 'frame.arity'    );
    $out_edge    //= catfile( $dir, 'frame.edge'     );
}

my $rulledge;
{
    printf_pretty_size(
        "Read $in_rulledge (%s)\n",
        -s $in_rulledge
    );
    open my($fh), '<', $in_rulledge
        or die "Can't open $in_rulledge: $!";
    $rulledge = read_rulledge($fh);
}

my $arity;
{
    printf_pretty_size(
        "Read $in_arity (%s)\n",
        -s $in_arity
    );
    open my($fh), '<', $in_arity
        or die "Can't open $in_arity: $!";
    $arity = read_arity($fh);
}


open my($ifh), '<', $in_vertex
    or die "Can't open $in_vertex: $!";
open my($ofh), '>', $out_edge
    or die "Can't open $out_edge: $!";

deparent( $ifh, $ofh, $rulledge, $arity );
printf_pretty_size(
    "Wrote $out_edge (%s)\n",
    -s $out_edge
);

# Free judy
{
    Judy::L::Free($arity);
    my ( undef, $yedge, $x ) = Judy::L::First( $rulledge, 0 );
    while ( defined $x ) {
        Judy::1::Free( $yedge );
        ( undef, $yedge, $x ) = Judy::L::Next( $rulledge, $x );
    }
    Judy::L::Free($rulledge);
}

__DATA__
__C__
#include <Judy.h>

void*
read_rulledge(PerlIO *fh) {
    SV *line_sv;
    char *line;
    Pvoid_t rulledge = 0;
    Pvoid_t *pxedge;
    STRLEN line_len;
    int Rc_int, x, y;

    line_sv = newSVpv("",0);
    while (sv_gets(line_sv,fh,0)) {
        line = SvPV(line_sv,line_len);
        if ( 2 != sscanf(line,"rdge(%x,%x).",&y,&x) ) {
            croak(line);
        }

        /* Upsert rulledge[y] //= yedge */
        JLI(pxedge,rulledge,y);

        /* rulledge[y][x] = 1 */
        J1S(Rc_int,*pxedge,x);
    }
    SvREFCNT_dec(line_sv);

    return rulledge;
}

void*
read_arity(PerlIO *fh) {
    SV *line_sv;
    char *line;
    Pvoid_t arity = 0;
    STRLEN line_len;
    int x;
    PWord_t pxarity;
    Word_t xarity;

    line_sv = newSVpv("",0);
    while (sv_gets(line_sv,fh,0)) {
        line = SvPV(line_sv,line_len);
        if ( 2 != sscanf(line,"arity(%x,%d).",&x,&xarity) ) {
            croak(line);
        }

        JLI(pxarity,arity,x);
        *pxarity = xarity;
    }
    SvREFCNT_dec(line_sv);

    return arity;
}

void
deparent( PerlIO *ifh, PerlIO *ofh, void *rulledge, void *arity ) {
    SV *line_sv;
    char *line;
    Pvoid_t *pxedge;
    PWord_t pxarity;
    Word_t x,y,best_x,best_x_arity;
    STRLEN line_len;
    int found_x;

    /* for each line */
    line_sv = newSVpv("",0);
    while (sv_gets(line_sv,ifh,0)) {
        line = SvPV(line_sv,line_len);
        if ( 1 != sscanf(line,"vertex(%x).",&y) ) {
            croak(line);
        }

        /* Fetch parents */
        JLG(pxedge,rulledge,y);
        if ( pxedge ) {

            /* For each parent, find the best */
            best_x_arity = -1;
            best_x = -1;
            x = 0;
            J1F(found_x,*pxedge,x);
            while ( found_x ) {

                /* Fetch parent's arity */
                JLG(pxarity,arity,x);
                if ( pxarity ) {
                    /* Choose best parent */
                    if ( -1 == best_x
                         || best_x_arity < *pxarity
                         || ( best_x_arity == *pxarity && x < best_x ) ) {
                        best_x = x;
                        best_x_arity = *pxarity;
                    }
                }

                J1N(found_x,*pxedge,x);
            }

            /* Write best parent */
            PerlIO_printf(ofh,"edge(%x,%x).\n",best_x,y);
        }
        else {
            PerlIO_printf(ofh,"edge(0,%x).\n",y);
        }

    }
    SvREFCNT_dec(line_sv);
}