#!/usr/bin/env perl
# Roundtrip triangle tests. Run from repo root.
# Usage: ./tests/roundtrip [suite...]   (default: all machines + repig)
# Optional: ROUNDTRIP_JOBS=N  (default: 8 × number of suites)
#
# Each tests/<machine>/ directory is one suite. Extension selects the
# compare rules; the triangle shape is the same for every machine:
#   Leg 1: source → UTF-8 → UTF-8   (canonicalization)
#   Leg 2: UTF-8 → p47
#   Base via UTF-8: p47 → source
#   Direct: source → p47 → p47      (apex verifier)
#   Direct: p47 → source            (when source is not already p47)
#
# Forty/thirty directories hold layer deltas: a file must pass its
# machine and fail its predecessor (see pred in @SUITES).

use strict;
use warnings;

use FindBin;
use File::Temp qw(tempdir tempfile);
use File::Copy;
use File::Spec;
use File::Find;
use Cwd qw(abs_path);
use IPC::Open3 ();
use Symbol qw(gensym);
use Parallel::ForkManager;

my $REJIG = File::Spec->catfile($FindBin::Bin, '..', 'rejig');
$REJIG = './rejig' if $FindBin::Bin =~ m{/tests\z};
my $APEX = 'p47';

my $color_ok    = (-t STDOUT) ? "\e[32m" : '';
my $color_fail  = (-t STDOUT) ? "\e[31m" : '';
my $color_reset = (-t STDOUT) ? "\e[0m" : '';

# One row per suite directory under tests/ (repig is not a machine).
# pred: higher layer must fail this predecessor (IR-raised listing check).
# exts: input extensions gathered (goldens like .p47u / .txt skipped).
my @SUITES = (
    { name => 'r47',     exts => [qw(p47)] },
    { name => 'repig',   exts => [qw(repig)] },
    { name => 'plus42',  exts => [qw(raw p42 plus42)], pred => 'free42' },
    { name => 'free42',  exts => [qw(raw f42 free42)], pred => 'hp42s' },
    { name => 'hp42s',   exts => [qw(raw hp42s)],      pred => 'hp41c' },
    { name => 'dm41x',   exts => [qw(raw dm41x)],      pred => 'hp41c' },
    { name => 'hp41c',   exts => [qw(raw hp41c)] },
    { name => 'hp35s',   exts => [qw(35s hp35s)],      pred => 'dm32' },
    { name => 'dm32',    exts => [qw(d32)],            pred => 'hp32sii' },
    { name => 'hp32sii', exts => [qw(hp32sii 32sii)] },
    { name => 'hp16c',   exts => [qw(16c hp16c)] },
    { name => 'hp15c',   exts => [qw(15c hp15c)] },
    { name => 'hp12c',   exts => [qw(12c hp12c)] },
    { name => 'hp11c',   exts => [qw(11c hp11c)] },
);
my %SUITE = map { $_->{name} => $_ } @SUITES;
my @SUITE_NAMES = map { $_->{name} } @SUITES;

# State frames are that machine's container; skip predecessor check.
my %SKIP_PRED_EXT = map { $_ => 1 } qw(f42 p42);

########################################################################
# Process helpers
########################################################################

sub colorize_line {
    my ($line) = @_;
    return $line unless length $color_ok;
    return $line if $line =~ s/^OK /${color_ok}OK$color_reset /;
    return $line if $line =~ s/^FAIL /${color_fail}FAIL$color_reset /;
    return $line;
}

sub run_cmd {
    my ($err_ref, $cmd, @args) = @_;
    my $err = '';
    open my $err_fh, '>', \$err;
    my $pid = IPC::Open3::open3(gensym, '>&STDOUT', $err_fh, $cmd, @args);
    waitpid $pid, 0;
    close $err_fh;
    $$err_ref = $err;
    return $? == 0 ? 1 : 0;
}

sub run_rejig {
    my ($err_ref, @args) = @_;
    run_cmd($err_ref, $REJIG, @args);
}

sub short_name {
    my ($f) = @_;
    my (undef, $dir, $base) = File::Spec->splitpath($f);
    return $base unless length $dir;
    my @parts = grep { length } File::Spec->splitdir($dir);
    my $parent = $parts[-1] // '';
    return $parent ? "$parent/$base" : $base;
}

sub source_ext {
    my ($f) = @_;
    return lc($1) if $f =~ /\.([^.]+)\z/;
    return 'bin';
}

sub basename_of {
    my ($f) = @_;
    my (undef, undef, $base) = File::Spec->splitpath($f);
    return $base;
}

########################################################################
# Diff + normalizers
########################################################################

# Undef on equal; otherwise unified diff of two strings.
sub diff_text {
    my ($left, $right) = @_;
    return undef if $left eq $right;
    my (undef, $a) = tempfile('dffaXXXXXX', TMPDIR => 1, UNLINK => 1);
    my (undef, $b) = tempfile('dffbXXXXXX', TMPDIR => 1, UNLINK => 1);
    open my $afh, '>', $a or return "temp: $!";
    open my $bfh, '>', $b or return "temp: $!";
    print $afh $left;
    print $bfh $right;
    close $afh;
    close $bfh;
    my $diff = `diff -u "$a" "$b" 2>&1`;
    return $? == 0 ? undef : $diff;
}

sub read_raw {
    my ($path) = @_;
    open my $fh, '<:raw', $path or return undef;
    local $/;
    my $t = <$fh>;
    close $fh;
    return defined $t ? $t : '';
}

sub read_text {
    my ($path) = @_;
    open my $fh, '<', $path or return undef;
    local $/;
    my $t = <$fh>;
    close $fh;
    return defined $t ? $t : '';
}

# Apply named normalizer rules, then diff.
sub diff_normalized {
    my ($a_path, $b_path, @rules) = @_;
    my $a = read_raw($a_path);
    my $b = read_raw($b_path);
    return "read failed\n" unless defined $a && defined $b;
    for my $rule (@rules) {
        $a = $rule->($a, $a_path);
        $b = $rule->($b, $b_path);
        return "normalize failed\n" unless defined $a && defined $b;
    }
    return diff_text($a, $b);
}

sub n_strip_at_comments {
    my ($t) = @_;
    return $t if $t =~ /\0/;
    my @out;
    for my $line (split /\n/, $t, -1) {
        next if $line =~ /^\s*\@(\s|$)/;
        $line =~ s/\s+\@.*$//;
        push @out, $line;
    }
    $t = join "\n", @out;
    # Section blanks exist only to separate @ blocks; after those
    # comments are gone they are not semantic.
    $t =~ s/^\s*\n//mg;
    return $t;
}

sub n_strip_trailing_comments {
    my ($t) = @_;
    return $t if $t =~ /\0/;
    my @out;
    for my $line (split /\n/, $t, -1) {
        next if $line =~ /^\s*#/;
        $line =~ s/\s+(?:;|#).*$//;
        $line =~ s/\s+$//;
        push @out, $line;
    }
    return join "\n", @out;
}

sub n_drop_trailing_end {
    my ($t) = @_;
    $t =~ s/\n\s*\.END\.\s*\z/\n/s;
    return $t;
}

sub n_dm32_body {
    my ($t) = @_;
    my @lines = split /\n/, $t, -1;
    shift @lines if @lines && $lines[0] =~ /^#\s*DM32 program generated/;
    my @out;
    for my $line (@lines) {
        next if $line =~ /^\s*#/;
        $line =~ s/\s+#.*$//;
        $line =~ s/\s+$//;
        push @out, $line;
    }
    return join "\n", @out;
}

# Voyager simulator listings: compare key sequences only (mnemonic
# spelling and brace padding vary across JRPN / Manz / rejig emitters).
sub n_voyager_keys {
    my ($t) = @_;
    my @keys;
    for my $line (split /\n/, $t) {
        next unless $line =~ /^\s*(\d{3})\s*\{\s*([^}]*)\}/;
        my ($n, $keys) = ($1, $2);
        $keys =~ s/^\s+|\s+$//g;
        $keys = join ' ', grep { length } split /\s+/, $keys;
        push @keys, sprintf("%03d|%s", $n, $keys);
    }
    return join("\n", @keys) . (@keys ? "\n" : "");
}

# NutEm IR listings: dotted locals may be quoted (ASCII or curly);
# scientific E/e and a trailing dot on integers are equivalent; END
# markers and blank lines are stripped on import.
sub n_nutem_listing {
    my ($t) = @_;
    $t = n_strip_trailing_comments($t);
    $t = n_nutem_strip_solve_bridge($t);
    # Dotted locals may be curly-quoted in textbook UTF-8. Match raw
    # UTF-8 bytes (read_raw); no "use utf8" in this script.
    my $lq = "\xE2\x80\x98"; # ‘
    my $rq = "\xE2\x80\x99"; # ’
    $t =~ s/\b(LBL|GTO|XEQ)\s+(?:$lq|\x27)(\.[0-9])(?:$rq|\x27)/$1 $2/g;
    # Digit key runs vs one literal: 4\n  3\n  2\n  1  ≡  4321
    while ($t =~ s/^([ \t]*)(-?[0-9]+)\n\1([0-9]+)/$1$2$3/mg) { }
    $t =~ s/\b([0-9]+)E([+-]?[0-9]+)\b/$1e$2/g;
    $t =~ s/\b(-?[0-9]+)\.(?=\s|$)/$1/g;
    $t =~ s/\n\s*END\s*\n\.END\.\s*\z/\n/s;
    $t =~ s/\n\s*\.END\.\s*\z/\n/s;
    $t =~ s/\n\s*END\s*\z/\n/s;
    $t =~ s/^\s*\n//mg;
    return $t;
}

# Binary .f42 / .p42: ignore platform string at byte 8 through NUL.
sub n_state_drop_platform {
    my ($t) = @_;
    return $t if length($t) < 9;
    my $head = substr($t, 0, 8);
    my $rest = substr($t, 8);
    $rest =~ s/^[^\0]*\0//;
    return $head . $rest;
}

sub n_nutem_strip_solve_bridge {
    my ($t) = @_;
    $t =~ s/^[ \t]*MVAR[ \t]+\S*rejigX\S*[ \t]*\n//mg;
    $t =~ s/^[ \t]*RCL[ \t]+\S*rejigX\S*[ \t]*\n//mg;
    return $t;
}

sub compare_paths {
    my ($a, $b, @rules) = @_;
    return diff_normalized($a, $b, @rules) if @rules;
    my $diff = `diff "$a" "$b" 2>&1`;
    return $? == 0 ? undef : $diff;
}

# Encode-back compares: strip @ comments unless the file is a binary image.
sub compare_native {
    my ($a, $b, $machine, $ext, @rules) = @_;
    if ($ext =~ /^(?:raw|p47|f42|p42)\z/) {
        return compare_paths($a, $b, @rules);
    }
    # .16c and Voyager textbook listings: R47 UTF-8 semantic parity.
    if ($ext =~ /^(?:16c|hp11c|hp12c|hp15c|hp16c)\z/) {
        return semantic_utf8_compare($a, $b, $machine);
    }
    return diff_normalized(
        $a, $b,
        sub { n_strip_at_comments($_[0]) },
        @rules,
    );
}

########################################################################
# Dialect flags from machine + output kind
########################################################################

# --validate is the directory machine (except r47). --syntax is that
# machine only for UTF-8 listing output; raw/state UTF-8 legs use r47.
sub flags_for {
    my ($machine, $kind) = @_;
    return () if $machine eq 'r47';
    my @v = ('--validate', $machine);
    if ($kind eq 'listing') {
        return (@v, '--syntax', $machine);
    }
    if ($kind eq 'utf8_canonical') {
        return (@v, '--syntax', 'r47');
    }
    # apex / native binary: validate only
    return @v;
}

sub is_forty {
    my ($m) = @_;
    return $m =~ /^(?:hp41c|dm41x|hp42s|free42|plus42)\z/;
}

sub is_voyager {
    my ($m) = @_;
    return $m =~ /^(?:hp11c|hp12c|hp15c|hp16c)\z/;
}

# UTF-8 container extension for the listing legs. Prefer the machine
# name so -o infers the right dialect even when a moved fixture still
# carries another suffix (e.g. loclbl.plus42 under free42).
sub utf8_ext_for {
    my ($machine, $ext) = @_;
    return 'utf8' if $ext =~ /^(?:raw|f42|p42|p47)\z/;
    return 'hp15c' if $ext eq '15c';
    return 'hp16c' if $ext eq '16c';
    return 'hp11c' if $ext eq '11c';
    return 'hp12c' if $ext eq '12c';
    return 'dm32'  if $ext eq 'd32';
    return $machine if $machine ne 'r47';
    return 'utf8';
}

sub listing_rules {
    my ($machine, $ext) = @_;
    my @r = (sub { n_strip_trailing_comments($_[0]) });
    push @r, sub { n_drop_trailing_end($_[0]) } if is_forty($machine);
    return @r;
}

sub native_rules {
    my ($machine, $ext) = @_;
    return (sub { n_dm32_body($_[0]) }) if $ext eq 'd32';
    return (sub { n_voyager_keys($_[0]) }) if $ext eq '15c';
    # .16c keys are not stable through P47 (SHOW base, digit literals).
    # Semantic compare is used instead (see compare_native_voyager).
    return (sub { n_state_drop_platform($_[0]) }) if $ext =~ /^(?:f42|p42)\z/;
    return listing_rules($machine, $ext) if $ext !~ /^(?:raw|p47|11c|12c|16c|hp11c|hp12c|hp15c|hp16c)\z/;
    return ();
}

# Decode both sides to R47 UTF-8 and compare (Voyager textbook / .16c).
sub semantic_utf8_compare {
    my ($a, $b, $machine) = @_;
    my $e = '';
    my (undef, $ua) = tempfile('semaXXXXXX', SUFFIX => '.utf8', TMPDIR => 1, UNLINK => 1);
    my (undef, $ub) = tempfile('sembXXXXXX', SUFFIX => '.utf8', TMPDIR => 1, UNLINK => 1);
    return "rejig→utf8($a)\n$e"
        unless run_rejig(\$e, flags_for($machine, 'utf8_canonical'), qw(-o), $ua, $a);
    $e = '';
    return "rejig→utf8($b)\n$e"
        unless run_rejig(\$e, flags_for($machine, 'utf8_canonical'), qw(-o), $ub, $b);
    return diff_normalized(
        $ua, $ub,
        sub { n_strip_trailing_comments($_[0]) },
        sub { n_strip_at_comments($_[0]) },
    );
}

########################################################################
# Raw semantic compare (decode both to listings)
########################################################################

sub raw_semantic_compare {
    my ($a, $b, $machine) = @_;
    my $e = '';
    my (undef, $ua) = tempfile('rawaXXXXXX', SUFFIX => '.utf8', TMPDIR => 1, UNLINK => 1);
    my (undef, $ub) = tempfile('rawbXXXXXX', SUFFIX => '.utf8', TMPDIR => 1, UNLINK => 1);
    return "rejig→utf8($a)\n$e"
        unless run_rejig(\$e, flags_for($machine, 'utf8_canonical'), qw(-o), $ua, $a);
    $e = '';
    return "rejig→utf8($b)\n$e"
        unless run_rejig(\$e, flags_for($machine, 'utf8_canonical'), qw(-o), $ub, $b);
    return diff_normalized(
        $ua, $ub,
        sub { n_strip_trailing_comments($_[0]) },
        sub { n_drop_trailing_end($_[0]) },
    );
}

########################################################################
# Predecessor (layer delta) check
########################################################################

sub check_predecessor {
    my ($f, $machine, $ext, $err_ref) = @_;
    my $pred = $SUITE{$machine}{pred} or return (1, undef);
    return (1, undef) if $SKIP_PRED_EXT{$ext};

    my (undef, $ir) = tempfile('predirXXXXXX', SUFFIX => '.utf8', TMPDIR => 1, UNLINK => 1);
    # Raise to IR under the current machine, then require predecessor reject.
    if ($ext eq 'd32') {
        return (0, "predecessor: expected reject by $pred for $f\n")
            if run_rejig($err_ref, '--validate', $pred, qw(-o), '/dev/null', $f);
        return (1, undef);
    }
    return (0, "predecessor IR $f\n$$err_ref")
        unless run_rejig($err_ref, flags_for($machine, 'utf8_canonical'), qw(-o), $ir, $f);
    $$err_ref = '';
    return (0, "predecessor: expected reject by $pred for $f\n")
        if run_rejig($err_ref, '--validate', $pred, qw(-o), '/dev/null', $ir);
    return (1, undef);
}

########################################################################
# Extras
########################################################################

sub extra_r47_p47u {
    my ($f, $rt_tmp, $err_ref, $short) = @_;
    return (1, $short) unless -r "${f}u";
    my $d  = File::Spec->catfile($rt_tmp, 'd.utf8');
    my $bu = File::Spec->catfile($rt_tmp, 'bu.utf8');
    return (0, "p47u→utf8 $short\n$$err_ref")
        unless run_rejig($err_ref, qw(-o), $d, "${f}u");
    my $diff = compare_native($d, $bu, 'r47', 'utf8',
        sub { n_strip_trailing_comments($_[0]) });
    return (0, "p47u→bu $short\n$diff") if defined $diff;
    return (1, $short);
}

sub listing_matches_golden {
    my ($got, $want, $label) = @_;
    my $diff = diff_normalized(
        $got, $want,
        sub { n_strip_trailing_comments($_[0]) },
        sub { n_strip_at_comments($_[0]) },
        sub { n_drop_trailing_end($_[0]) },
    );
    return (0, "$label\n$diff") if defined $diff;
    return (1, undef);
}

sub extra_notascii {
    my ($f, $rt_tmp, $err_ref, $short) = @_;
    my (undef, $dir) = File::Spec->splitpath($f);
    my $golden = File::Spec->catfile($dir, 'NotASCII.p47u');
    return (0, "NotASCII golden missing $golden\n") unless -f $golden;
    my (undef, $got) = tempfile('notaXXXXXX', SUFFIX => '.p47u', TMPDIR => 1, UNLINK => 1);
    return (0, "NotASCII r47 golden $short\n$$err_ref")
        unless run_rejig($err_ref, qw(--validate hp42s --syntax r47 -o), $got, $f);
    my ($ok, $msg) = listing_matches_golden($got, $golden, "NotASCII r47 golden $short");
    return ($ok, $ok ? $short : $msg);
}

sub extra_flags {
    my ($f, $rt_tmp, $err_ref, $short) = @_;
    my (undef, $dir) = File::Spec->splitpath($f);
    my $golden_p47u = File::Spec->catfile($dir, 'FLAGS.p47u');
    my $golden_txt  = File::Spec->catfile($dir, 'FLAGS.txt');
    return (0, "FLAGS golden missing $golden_p47u\n") unless -f $golden_p47u;
    return (0, "FLAGS golden missing $golden_txt\n")  unless -f $golden_txt;

    my (undef, $got_r47) = tempfile('flgrXXXXXX', SUFFIX => '.p47u', TMPDIR => 1, UNLINK => 1);
    return (0, "FLAGS r47 golden $short\n$$err_ref")
        unless run_rejig($err_ref, qw(--validate hp42s --syntax r47 -o), $got_r47, $f);
    my ($ok, $msg) = listing_matches_golden($got_r47, $golden_p47u, "FLAGS r47 golden $short");
    return (0, $msg) unless $ok;

    my (undef, $got_raw) = tempfile('flgaXXXXXX', SUFFIX => '.hp42s', TMPDIR => 1, UNLINK => 1);
    my (undef, $got_txt) = tempfile('flgbXXXXXX', SUFFIX => '.hp42s', TMPDIR => 1, UNLINK => 1);
    return (0, "FLAGS hp42s raw listing $short\n$$err_ref")
        unless run_rejig($err_ref, qw(--syntax hp42s -o), $got_raw, $f);
    return (0, "FLAGS hp42s txt listing $short\n$$err_ref")
        unless run_rejig($err_ref, qw(--syntax hp42s -o), $got_txt, $golden_txt);
    ($ok, $msg) = listing_matches_golden($got_raw, $got_txt, "FLAGS hp42s syntax parity $short");
    return ($ok, $ok ? $short : $msg);
}

sub extra_free42_native {
    my ($f, $rt_tmp, $err_ref, $short) = @_;
    my $u  = File::Spec->catfile($rt_tmp, 'u.utf8');
    my $cf = File::Spec->catfile($rt_tmp, 'c.f42');
    my $du = File::Spec->catfile($rt_tmp, 'd.utf8');
    return (0, "free42→free42 $short\n$$err_ref")
        unless run_rejig($err_ref, qw(-o), $cf, $f);
    return (0, "free42→utf8 $short\n$$err_ref")
        unless run_rejig($err_ref, flags_for('free42', 'utf8_canonical'), qw(-o), $du, $cf);
    my $diff = compare_paths($u, $du);
    return (0, "free42 native utf8 $short\n$diff") if defined $diff;
    return (1, $short);
}

sub nutem_ir_roundtrip {
    my ($f, $rt_tmp, $err_ref, $short, $syntax) = @_;
    my $direct = File::Spec->catfile($rt_tmp, 'nutem_direct.utf8');
    my $nutem  = File::Spec->catfile($rt_tmp, 'nutem.utf8');
    my $via    = File::Spec->catfile($rt_tmp, 'nutem_via.utf8');
    return (0, "nutem direct utf8 $short\n$$err_ref")
        unless run_rejig($err_ref, qw(-o), $direct, $f);
    return (0, "nutem emit $short\n$$err_ref")
        unless run_rejig($err_ref, '--syntax', $syntax, qw(--flavor nutem -o), $nutem, $f);
    return (0, "nutem parse $short\n$$err_ref")
        unless run_rejig($err_ref, qw(--from utf8 -o), $via, $nutem);
    my $diff = diff_normalized(
        $direct, $via,
        sub { n_nutem_listing($_[0]) },
    );
    return (0, "nutem IR $short\n$diff") if defined $diff;
    return (1, $short);
}

########################################################################
# HP-12C native formats only (no p47 apex)
# Unmapped finance keys and absolute GTO lines have no faithful p47 form.
########################################################################

# Nonzero absolute GTO (textbook GTO nn, or RLM 43|33|nnn with nnn != 000).
sub hp12c_has_absolute_gto {
    my ($f) = @_;
    my $t = read_text($f);
    return 0 unless defined $t;
    if (source_ext($f) eq '12c') {
        while ($t =~ /"43\|33\|(\d{3})"/g) {
            return 1 if $1 ne '000';
        }
        return 0;
    }
    # Optional Voyager step prefix (01- / 001-) before GTO.
    while ($t =~ /^\s*(?:\d{2,3}-\s+)?GTO\s+(\d+)\s*$/img) {
        return 1 if int($1) != 0;
    }
    return 0;
}

sub run_hp12c_native_only {
    my ($f, $rt_tmp, $err_ref, $machine) = @_;
    my $short = short_name($f);
    my $ext   = source_ext($f);
    my $ut    = 'hp12c';
    my @dia_utf8 = flags_for($machine, 'listing');
    my @dia_apex = flags_for($machine, 'apex');
    # RLM/mem drop @ section comments; strip them for semantic UTF-8 compare.
    my @utf8_rules = (
        listing_rules($machine, $ut),
        sub { n_strip_at_comments($_[0]) },
    );

    my $a_in = File::Spec->catfile($rt_tmp, "a.$ext");
    File::Copy::copy($f, $a_in) or return (0, "copy $short: $!");

    # Raise to textbook UTF-8 and check idempotence under --syntax hp12c.
    my $u  = File::Spec->catfile($rt_tmp, "u.$ut");
    my $bu = File::Spec->catfile($rt_tmp, "bu.$ut");
    return (0, "$ext→utf8 $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_utf8, qw(-o), $u, $a_in);
    return (0, "utf8→utf8 $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_utf8, qw(-o), $bu, $u);
    my $diff = compare_paths($u, $bu, @utf8_rules);
    return (0, "utf8 verify $short\n$diff") if defined $diff;

    # Textbook ↔ RLM JSON ↔ textbook (semantic via hp12c UTF-8).
    my $j12 = File::Spec->catfile($rt_tmp, 'cross.12c');
    my $u2  = File::Spec->catfile($rt_tmp, "u2.$ut");
    return (0, "utf8→12c $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_apex, qw(-o), $j12, $u);
    return (0, "12c→utf8 $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_utf8, qw(-o), $u2, $j12);
    $diff = compare_paths($u, $u2, @utf8_rules);
    return (0, "12c cross $short\n$diff") if defined $diff;

    # Textbook ↔ VoyagerSave *.12cmem ↔ textbook (semantic only).
    my ($mok, $mmsg) = voyager_mem_roundtrip($u, $rt_tmp, $err_ref, $short, $machine);
    return (0, $mmsg) unless $mok;

    return (1, $short);
}

########################################################################
# VoyagerSave Continuous Memory (*.12cmem / *.15cmem / *.16cmem)
########################################################################

sub voyager_mem_ext {
    my ($machine) = @_;
    return '12cmem' if $machine eq 'hp12c';
    return '15cmem' if $machine eq 'hp15c';
    return '16cmem' if $machine eq 'hp16c';
    return;
}

sub voyager_mem_roundtrip {
    my ($utf8_path, $rt_tmp, $err_ref, $short, $machine) = @_;
    my $mext = voyager_mem_ext($machine);
    return (1, $short) unless defined $mext;
    my $ut = ($machine eq 'hp12c') ? 'hp12c'
           : ($machine eq 'hp15c') ? 'hp15c'
           :                         'hp16c';
    my @dia_utf8 = flags_for($machine, 'listing');
    my @utf8_rules = listing_rules($machine, $ut);
    push @utf8_rules, sub { n_strip_at_comments($_[0]) } if $machine eq 'hp12c';

    my $mem = File::Spec->catfile($rt_tmp, "cross.$mext");
    my $u2  = File::Spec->catfile($rt_tmp, "umem.$ut");
    my @dia_bin = flags_for($machine, 'apex'); # validate only; --syntax is utf8/hpraw
    my $err = '';
    unless (run_rejig(\$err, @dia_bin, qw(-o), $mem, $utf8_path)) {
        # Skip when the program uses key sequences not yet packed
        # (two-byte 15C labels, etc.). 12C native_only still requires success.
        # slog may land on the parent's stdout under open3, so also treat a
        # missing/empty dump as an unsupported-encode skip for 15C/16C.
        if ($machine ne 'hp12c' &&
            ($err =~ /voyagersave encode failed|not supported yet/ || !-s $mem)) {
            return (1, $short);
        }
        $$err_ref = $err;
        return (0, "utf8→$mext $short\n$err");
    }
    return (0, "$mext→utf8 $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_utf8, qw(-o), $u2, $mem);
    my $diff = compare_paths($utf8_path, $u2, @utf8_rules);
    return (0, "$mext cross $short\n$diff") if defined $diff;
    return (1, $short);
}

########################################################################
# Triangle
########################################################################

sub run_one_triangle {
    my ($f, $rt_tmp, $err_ref, $machine) = @_;
    my $short = short_name($f);
    my $ext   = source_ext($f);
    my $base  = basename_of($f);

    my ($ok, $msg) = check_predecessor($f, $machine, $ext, $err_ref);
    return (0, $msg) unless $ok;

    # HP-12C: unmapped finance keys and absolute GTO lines have no
    # faithful p47 wire form; round-trip only inside native formats.
    if ($machine eq 'hp12c' &&
        ($base =~ /^AllOps\./ || hp12c_has_absolute_gto($f))) {
        return run_hp12c_native_only($f, $rt_tmp, $err_ref, $machine);
    }

    my $ut = utf8_ext_for($machine, $ext);
    my $is_raw   = ($ext eq 'raw');
    my $is_state = ($ext =~ /^(?:f42|p42)\z/);
    # Raw/state UTF-8 legs use --syntax r47 (canonical IR text). Simulator
    # and textbook listings use --syntax $machine (Voyager dialect).
    my $utf8_kind = ($is_raw || $is_state) ? 'utf8_canonical' : 'listing';
    my @dia_utf8 = flags_for($machine, $utf8_kind);
    my @dia_apex = flags_for($machine, 'apex');

    my @native_rules = native_rules($machine, $ext);
    my @utf8_rules   = listing_rules($machine, $ut);

    my $skip_direct_native = $is_raw
        || $machine eq 'hp41c'
        || $machine eq 'dm41x'
        || $ext eq $APEX;

    my $a_in = File::Spec->catfile($rt_tmp, "a.$ext");
    File::Copy::copy($f, $a_in) or return (0, "copy $short: $!");

    my $u     = File::Spec->catfile($rt_tmp, "u.$ut");
    my $bu    = File::Spec->catfile($rt_tmp, "bu.$ut");
    my $via_p = File::Spec->catfile($rt_tmp, "via.$APEX");
    my $c_out = File::Spec->catfile($rt_tmp, "c.$ext");

    # Leg 1: source → UTF-8 → UTF-8
    return (0, "$ext→utf8 $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_utf8, qw(-o), $u, $a_in);
    return (0, "utf8→utf8 $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_utf8, qw(-o), $bu, $u);
    my $diff = compare_paths($u, $bu, @utf8_rules);
    return (0, "leg1 utf8 $short\n$diff") if defined $diff;

    # Leg 2: UTF-8 → p47
    return (0, "utf8→$APEX $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_apex, qw(-o), $via_p, $bu);

    # Base via UTF-8: p47 → source
    my @frame;
    push @frame, '--frame', $a_in if $is_state;
    return (0, "$APEX→$ext $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_apex, @frame, qw(-o), $c_out, $via_p);

    if ($is_raw) {
        $diff = raw_semantic_compare($a_in, $c_out, $machine);
    } else {
        $diff = compare_native($a_in, $c_out, $machine, $ext, @native_rules);
    }
    return (0, "base via $APEX $short\n$diff") if defined $diff;

    # Direct: source → p47 → p47
    my $dir_a = File::Spec->catfile($rt_tmp, "dir_a.$APEX");
    my $dir_b = File::Spec->catfile($rt_tmp, "dir_b.$APEX");
    return (0, "direct $ext→$APEX $short\n$$err_ref")
        unless run_rejig($err_ref, @dia_apex, qw(-o), $dir_a, $a_in);
    return (0, "direct $APEX→$APEX $short\n$$err_ref")
        unless run_rejig($err_ref, qw(-o), $dir_b, $dir_a);
    $diff = compare_paths($dir_a, $dir_b);
    return (0, "direct $APEX verify $short\n$diff") if defined $diff;

    if (!$skip_direct_native) {
        my $dir_c = File::Spec->catfile($rt_tmp, "dir_c.$ext");
        my @dframe;
        push @dframe, '--frame', $a_in if $is_state;
        return (0, "direct $APEX→$ext $short\n$$err_ref")
            unless run_rejig($err_ref, @dia_apex, @dframe, qw(-o), $dir_c, $dir_a);
        $diff = compare_native($a_in, $dir_c, $machine, $ext, @native_rules);
        return (0, "direct base $short\n$diff") if defined $diff;
    }

    # Filename extras
    if ($machine eq 'r47') {
        return extra_r47_p47u($f, $rt_tmp, $err_ref, $short);
    }
    if ($machine eq 'hp42s' && $base eq 'NotASCII.raw') {
        return extra_notascii($f, $rt_tmp, $err_ref, $short);
    }
    if ($machine eq 'hp42s' && $base eq 'FLAGS.raw') {
        return extra_flags($f, $rt_tmp, $err_ref, $short);
    }
    if ($machine eq 'free42' && $is_raw) {
        return extra_free42_native($f, $rt_tmp, $err_ref, $short);
    }
    if (is_voyager($machine) && $ext =~ /^(?:15c|16c|11c|12c|hp11c|hp12c|hp15c|hp16c)\z/) {
        my ($nok, $nmsg) = nutem_ir_roundtrip($f, $rt_tmp, $err_ref, $short, $machine);
        return (0, $nmsg) unless $nok;
        if (voyager_mem_ext($machine)) {
            my $u = File::Spec->catfile($rt_tmp, 'u.' . utf8_ext_for($machine, $ext));
            return voyager_mem_roundtrip($u, $rt_tmp, $err_ref, $short, $machine);
        }
        return (1, $short);
    }

    return (1, $short);
}

sub run_one_repig {
    my ($f, $rt_tmp, $err_ref) = @_;
    my $short = short_name($f);
    (my $golden = $f) =~ s/\.repig\z/.p47u/i;
    return (0, "missing RePIG golden for $short: $golden\n") unless -r $golden;
    my $out = File::Spec->catfile($rt_tmp, 'out.p47u');
    return (0, "repig→p47u for $short\n$$err_ref")
        unless run_rejig($err_ref, qw(-o), $out, $f);
    my $diff = `diff -u "$golden" "$out" 2>&1`;
    return (0, "repig golden $short\n$diff") if $? != 0;
    return (1, $short);
}

########################################################################
# File gather
########################################################################

sub gather_suite_files {
    my ($tests_root, $suite) = @_;
    my $exts = $SUITE{$suite}{exts} or return ();
    my %want = map { $_ => 1 } @$exts;
    my @out;

    my $dir = File::Spec->catfile($tests_root, $suite);
    if (-d $dir) {
        for my $f (glob(File::Spec->catfile($dir, '*'))) {
            next unless -f $f;
            next if $f =~ m{/disabled/};
            my $base = basename_of($f);
            next if $base =~ /^t\./i;
            my $ext = source_ext($f);
            next unless $want{$ext};
            push @out, $f;
        }
    }

    # Sibling unpublished trees: beside rejig (r47/<machine>) and beside r47.
    unless ($suite eq 'hp42s' || $suite eq 'repig' || $suite eq 'r47') {
        my %seen;
        for my $n_up (2, 3) {
            my $sib = File::Spec->catfile($tests_root, (('..') x $n_up), $suite);
            next unless -d $sib;
            my $skey = abs_path($sib) // $sib;
            next if $seen{$skey}++;
            File::Find::find(
                {
                    wanted => sub {
                        return unless -f $_;
                        my $ext = source_ext($_);
                        return unless $want{$ext};
                        return if $_ =~ m{/t\.[^/]+\z}i;
                        push @out, $File::Find::name;
                    },
                    no_chdir => 1,
                },
                $sib
            );
        }
    }

    if ($suite eq 'r47') {
        for my $glob (
            File::Spec->catfile($tests_root, '..', '..', '*.p47'),
            File::Spec->catfile($tests_root, '..', '*.p47'),
            File::Spec->catfile($tests_root, 'r47', '*.p47'),
        ) {
            push @out, grep {
                -f && $_ !~ /PLOT-r47\.p47\z/ && $_ !~ /NotASCII\.p47\z/ && $_ !~ /!ASCII\.p47\z/
            } glob($glob);
        }
    }

    my %seen;
    return grep { -f && !$seen{$_}++ } @out;
}

########################################################################
# Plus42 raw2txt post
########################################################################

sub plus42_raw2txt_post {
    my ($tests_root) = @_;
    my $src = File::Spec->catfile($tests_root, 'plus42', 'AllOps.raw');
    return unless -f $src;
    my $aor = '/tmp/rejig-plus42-ao.raw';
    File::Copy::copy($src, $aor) or return;
    my $aot = $aor;
    $aot =~ s/\.raw$/.txt/;
    my $raw2txt = $ENV{HOME} . '/bin/raw2txt';
    return unless -x $raw2txt;
    system("$raw2txt " . quotemeta($aor) . " 2>/tmp/trt-free42.err");
    return if $? != 0;
    die "FAIL raw2txt did not create $aot\n" unless -f $aot;
    my $aoua = '/tmp/rejig-plus42-ao-a.p47u';
    my $aoub = '/tmp/rejig-plus42-ao-b.p47u';
    my $e = '';
    if (!run_rejig(\$e, qw(--validate plus42 --syntax plus42 -o), $aoua, $aot)) {
        print "SKIP raw2txt→plus42 (parse failed):\n$e";
        return;
    }
    if (!run_rejig(\$e, qw(--syntax plus42 -o), $aoub, $aor)) {
        print "FAIL rejig $aor -o $aoub\n$e";
        exit 1;
    }
    my $diff = `diff $aoua $aoub 2>&1`;
    if ($? != 0) {
        print "FAIL raw2txt→plus42 round-trip; diffs:\n$diff";
        exit 1;
    }
    print "OK raw2txt→plus42 AllOps.raw\n";
}

########################################################################
# Main
########################################################################

my $tests_root = $FindBin::Bin;
my $repo_root  = File::Spec->catdir($tests_root, '..');
chdir $repo_root or die "chdir $repo_root: $!";
$REJIG = './rejig' unless -e $REJIG;
die "rejig not found" unless -e $REJIG;

my %alias = (
    rlm11c  => 'hp11c',
    rlm11cx => 'hp11c',
    rlm12c  => 'hp12c',
    rlm15c  => 'hp15c',
    rlm15cx => 'hp15c',
);
my @want = @ARGV ? @ARGV : @SUITE_NAMES;
@want = map { $alias{$_} // $_ } @want;

for my $name (@want) {
    next if $SUITE{$name};
    die "Unknown suite: $name (want: @SUITE_NAMES; alias rlm11c→hp11c, rlm12c→hp12c, rlm15c→hp15c)\n";
}

# Build job list: [suite, file]
my @jobs;
my %suite_files;
for my $suite (@want) {
    my @files = gather_suite_files($tests_root, $suite);
    $suite_files{$suite} = \@files;
    push @jobs, map { [ $suite, $_ ] } @files;
}

my $max_jobs = $ENV{ROUNDTRIP_JOBS} // (8 * scalar @want);
my $pm = Parallel::ForkManager->new($max_jobs);
$pm->set_waitpid_blocking_sleep(0) if $pm->can('set_waitpid_blocking_sleep');

my %results; # suite => { file => [ok, msg] }

$pm->run_on_finish(sub {
    my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $data) = @_;
    return unless $data;
    my ($suite, $f, $ok, $msg) = @$data;
    $results{$suite}{$f} = [ $ok, $msg ];
});

for my $i (0 .. $#jobs) {
    my ($suite, $f) = @{ $jobs[$i] };
    $pm->start and next;
    my $rt_tmp = tempdir(CLEANUP => 1);
    my $err = '';
    my ($ok, $msg);
    if ($suite eq 'repig') {
        ($ok, $msg) = run_one_repig($f, $rt_tmp, \$err);
    } else {
        ($ok, $msg) = run_one_triangle($f, $rt_tmp, \$err, $suite);
    }
    $pm->finish($ok ? 0 : 1, [ $suite, $f, $ok, $msg ]);
}
$pm->wait_all_children;

my $any_fail = 0;
my @summaries; # [label, status] printed after all per-file lines

# Per-file results first (suite order = @want / @SUITES; files = gather
# order), then suite summaries in the same suite order.
for my $suite (@want) {
    my $files = $suite_files{$suite} // [];
    my $tried = scalar @$files;
    my $succeeded = 0;
    my $by_file = $results{$suite} // {};

    for my $f (@$files) {
        my $row = $by_file->{$f};
        unless ($row) {
            print colorize_line("FAIL missing result for $f\n");
            $any_fail = 1;
            next;
        }
        my ($ok, $msg) = @$row;
        $succeeded++ if $ok;
        print colorize_line($ok ? "OK $msg\n" : "FAIL $msg");
        $any_fail = 1 unless $ok;
    }

    if ($suite eq 'plus42') {
        plus42_raw2txt_post($tests_root);
    }

    my $status;
    if ($tried == $succeeded) {
        $status = sprintf "%2d/%-2d %s", $tried, $succeeded, $color_ok . 'OK' . $color_reset;
    } else {
        $status = sprintf "%2d/%-2d %s %2d %s",
            $succeeded, $tried, $color_ok . 'OK' . $color_reset,
            $tried - $succeeded, $color_fail . 'FAIL' . $color_reset;
    }
    push @summaries, [ $suite, $status ];
}

for my $row (@summaries) {
    printf "%10s %s\n", @$row;
}

exit($any_fail ? 1 : 0);
