use warnings;
use strict;
use feature 'unicode_strings';
use open IO => ':encoding(UTF-8)', ':std';

use Getopt::Long qw/:config bundling auto_version auto_help/;

our $VERSION = 0.1;

my $java = undef;
my $debug = undef;
my $lax_parity = undef;
GetOptions("java|j+" => \$java,
           "lax_parity|p" => \$lax_parity,
           "debug|g" => \$debug) or die "Cannot parse options";

# multidimensional hash; first key is growing side identifier;
# second key is shrinking side identifier
my %program = ();

my $id = qr/(?!x)\pL\w*/o;
my $string = qr/$id(?:\s+$id)*|/o;
my $dirstring = qr/<\s*$string|$string\s*>/o;

sub parse_dirstring {
    my $ds = shift;
    if ($ds =~ s/^<//) {
        return [split " " , $ds];
    } elsif ($ds =~ s/>$//) {
        return [reverse(split(" ", $ds))];
    } else {
        die "unreachable";
    }
}

my $input_lhs = undef;
my $input_rhs = undef;
my $growside = undef;

sub input_growside {
    $growside eq '<' ? $input_lhs : $input_rhs;
}
sub input_shrinkside {
    $growside eq '>' ? $input_lhs : $input_rhs;
}

for my $line (<>) {
    chomp $line;
    $line =~ s/#.*$//;
    $line =~ s/^\s*//;
    $line =~ s/\s*$//;
    next if $line eq '';
    
    if ($line =~ /=/) {
        if ($line =~ /^($id)\s*([<>])\s*($id)\s*=\s*($dirstring)$/) {
            if ($2 eq '<') {
                $program{$1}{$3} = parse_dirstring($4);
                $lax_parity or scalar @{$program{$1}{$3}} % 2 and die
                    "replacement string $4 must have even length";
            } else {
                $program{$3}{$1} = parse_dirstring($4);
                $lax_parity or scalar @{$program{$3}{$1}} % 2 and die
                    "replacement string $4 must have even length";
            }
        } else {
            die "Malformed line '$line'";
        }
    } elsif ($line =~ /^($string)\s*([<>])\s*($string)$/) {
        defined $growside and die "two initial inputs given";
        $growside = $2;
        $input_lhs = $1;
        $input_rhs = $3;
        $input_lhs = parse_dirstring "$input_lhs>";
        $input_rhs = parse_dirstring "<$input_rhs";
    } else {
        die "Malformed line '$line'";
    }
}

unless ($lax_parity) {
    scalar @{input_shrinkside()} % 2 and die
        "the side that cannot grow on the first step must have even length";
    scalar @{input_growside()} % 2 or die
        "the side that can grow on the first step must have odd length";
}

my %all_shrinkside_keys;
%all_shrinkside_keys = (%all_shrinkside_keys, %$_)
    for values %program;

for my $growside_key (keys %program) {
    exists $all_shrinkside_keys{$growside_key}
    and die "symbol '$growside_key' has rules on both sides of an arrow";
}

if ($java) {
    # compile to Java, rather than running the program

    $lax_parity and die "the Java construction does not work with lax parity";
    
    # when -j is given twice, mangle into a 15-character character set
    sub jjescape {
        my $s = shift;
        $java == 1 and return $s;
        my @s = split '', $s;
        @s = map { sprintf "%o", ord $_ } @s;
        @s = map y/01234567/abcdeitu/r, @s;
        scalar join "0", @s;
    }
    sub mprint {
        my $s = join "", @_;
        if ($java == 1) {
            print $s;
        } else {
            $s =~ s/x/a7/g;
            $s =~ s/([^02367?\\abcdeitu])/sprintf "\\u%04x", ord $1/eg;
            $s =~ /([^02367?\\abcdeitu])/ and
                die "Bad character '$1' in escaped string '$s'";
            print $s;
        }
    }
    
    my %seen;
    mprint "interface xx {}\n";
    mprint "interface ", jjescape($_), "<x> {}\n"
        for sort keys %all_shrinkside_keys;
    for my $gk (keys %program) {
        $seen{$gk} = 1;
        my $gkj = jjescape $gk;
        mprint "class $gkj<x> implements";
        for my $sk (keys %{$program{$gk}}) {
            my $skj = jjescape $sk;
            $seen{$sk} = 1;
            $seen{$_} ||= 0 for @{$program{$gk}{$sk}};
            my $len = scalar @{$program{$gk}{$sk}};
            my $sk2 = $len ? "$skj<" : $skj;
            mprint "\n  $sk2", join("<? super ",
                                    map jjescape($_),
                                    @{$program{$gk}{$sk}}),
                "<x>", ">" x $len, ",";
        }
        mprint " xx {}\n";
    }
    for my $k (keys %seen) {
        unless ($seen{$k}) {
            # We saw a value but it doesn't have any rules.
            # Create a dummy class for it.
            my $kj = jjescape $k;
            mprint "class $kj<x> implements xx {}\n";
        }
    }
    mprint "class x {\n";
    mprint "  ", join "<? super ", map jjescape($_), @{input_growside()};
    mprint "<xx", ">" x scalar @{input_growside()}, " xc;\n";
    mprint "  ", join "<? super ", map jjescape($_), @{input_shrinkside()};
    mprint "<xx", ">" x scalar @{input_shrinkside()}, " xd = xc;\n";
    mprint "}\n";
    exit 0;
}

for (;;) {
    my @reversed_lhs = reverse @$input_lhs;
    $debug and print "@reversed_lhs$growside@$input_rhs\n";

    # An empty growside can only happen when using lax parity. This
    # terminates in failure unless the shrinkside is empty too.
    scalar @{input_growside()} or
        exit !!scalar @{input_shrinkside()};
    
    # When the shrinkside empties, we terminate successfully
    # unless we're looking at a value on the growside which has a
    # shrinkside rule.
    scalar @{input_shrinkside()} or exit
        !!exists $all_shrinkside_keys{${input_growside()}[0]};

    # A missing rule is another form of unsuccessful termination.    
    my $shrinktoken = shift @{input_shrinkside()};
    my $growtoken = shift @{input_growside()};
    my $rule = $program{$growtoken}{$shrinktoken};
    $growtoken eq $shrinktoken and $rule = [];
    defined $rule or exit 1;

    unshift @{input_growside()}, @$rule;
    $growside ^= "<" ^ ">";
}