#!/usr/bin/env perl

=encoding latin1

=head1 NAME

apeartree - A Pear Tree interpreter

=head1 SYNOPSIS

 apeartree program.apt

=head1 DESCRIPTION

This program interprets the esoteric programming language A Pear Tree.
The language is a variant of Perl designed mainly to work better for
polyglot competitions, although it can also occasionally lead to
terser code.

C<apeartree> takes no arguments but the file containing the program to
run.

=head1 THE A PEAR TREE LANGUAGE

A Pear Tree initially starts by trying to find the start of the
program, which is not necessarily at the start of the file.  The
process works like this: each substring of the program has its CRC-32
checked; then the substring with the CRC-32 of zero is chosen.  (If
more than one such substring exists, the longest is chosen, with ties
given to the string that comes first in a version of "alphabetical
order" generalized to all octets.  If no such substring exists, the
interpreter prints C<a partridge> and exits.)  Then the first
occurrence of that substring within the program is identified.
Everything that appears before the substring in question is moved to
the end of the program (i.e. the program is rotated to move the
substring to the start).  The resulting program will eventually be
interpreted as a Perl program; however, various transformations are
made first.

After rotating the program, the program is scanned for sequences of
alphanumeric characters and underscores (bordered by whitespace,
punctuation, or the boundaries of the file) that appear more than once
in contexts where they aren't immediately preceded by C<$>, C<@>, or
C<%>, and that start with a letter.  For each such sequence found,
that isn't a Perl keyword or built-in function, the program will be
prepended with code that defines an lvalue subroutine that returns the
scalar with the matching name.  (For example, if C<w> is found this
way, the text

 sub w : lvalue {ref $_[0] eq 'ARRAY' ? $w->[$_[0][0]] : $w}

will be prepended to the program.)  This is basically just a crude way
to change Perl's variable syntax to match those of other languages.
(Note that you have to be careful here; C<x> and C<y> are both
keywords in Perl, for example.)

The last transformation on the program is to prepend a definition of a
subroutine C<repr> that produces an escaped version of its argument
(via the use of L<Data::Dumper>), and to prepend code to set C<$\> to
a newline and C<$,> to a space.  This is to make it easier to write
quines, and to make C<print> act the same way as in Python.

Finally, the program is run.  If there's any text on standard input,
C<-ap> will be provided as an argument to the inner Perl interpreter
(or C<-p0777> if the program does not contain an uppercase C<F>
anywhere).

=head1 SEE ALSO

L<perl(1)>

=cut

#r3TQJ
    
use Digest::CRC 'crc32';
use Pod::Functions '%Type';
use File::Temp 'tempfile';
use warnings;
use strict;
use 5.010;
undef $/;
my $program = <>;
my $best_substring = undef;
my $minlen = 1;
my $startpos = undef;

for my $start (0 .. (length $program) - $minlen) {
    for my $end ($start + $minlen .. length $program) {
        my $substr = substr $program, $start, ($end - $start);
        crc32($substr) and next;
        if (defined $best_substring) {
            length $substr == $minlen &&
                $best_substring le $substr and next;
        }
        $minlen = length $substr;
        $best_substring = $substr;
        $startpos = $start;
    }
}
unless (defined $best_substring) {
    print "a partridge\n";
    exit;
}

my $movedportion = substr $program, 0, $startpos, "";
$program .= $movedportion;

my %identifiers;

$identifiers{$_}++ for $program =~ /(?<![\%\$\@])\b([a-z]+)\b/g;

# the keys of %Type are Perl's keywords and builtins
/^(\w+)/ and delete $identifiers{$1} for keys %Type;
$identifiers{$_} == 1 and delete $identifiers{$_}
    for keys %identifiers;
delete $identifiers{'repr'};

/^[a-z]/ and $program = <<EOF
sub $_ : lvalue {(ref \$_[0] || 0) eq 'ARRAY' ? \$$_\->[\$_[0][0]] : \$$_}
$program
EOF
    for keys %identifiers;

$program = <<EOF;
use Data::Dumper ();
sub repr {
    Data::Dumper->new([shift])->Terse(1)->Indent(0)->Useqq(1)->Dump
}
\$\\="\\n";
\$,=" ";
$program
EOF

my ($program_fh, $program_filename) =
    tempfile("aptXXXX", UNLINK => 1);
print $program_fh $program;

<>; # absorb EOF
my $input = <>;
my @clopt = $program_filename;

length $input and
    unshift @clopt, ($program =~ /F/ ? "-ap" : "-p0777");
open my $fh, "|-", $^X, @clopt;
length $input and print $fh $input;
close $fh;