#!/usr/bin/env perl

# A basic, non-optimizing Re:direction interpreter.
# Copyright (C) 2018 Alex Smith
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use utf8;
use warnings;
use strict;
use feature 'unicode_strings';
use open IN => ":bytes", OUT => ":utf8", ":std";

use Text::Tabs;
use Encode qw/decode/;
use Getopt::Std;
$Getopt::Std::STANDARD_HELP_VERSION = 1;
our $VERSION = 0.1;

sub HELP_MESSAGE {
    print "-d\tPrint debug output";
    print "-f\tPretty-print the packed and unpacked program to STDERR\n";
    print "-p\tInterpret input as a packed program\n";
    print "-A\tInput and output as character codes, not integers\n";
}

our ($opt_f, $opt_p, $opt_d, $opt_A);
getopts('fdpA');

undef $/;
$| = 1;
my $program = <>; <>;
my $input = <> // '';

# Unpack the program.
if ($opt_p) {
    # We're using the packed representation.
    my @charset = (" ", "♦", "◄", "▲", "►", "▼", "\n");
    my $unpacked = '';
    my $spaceweight = 3;
    for my $char (split //, $program) {
        my $code = ord $char;
        if ($code == 0 || $code >= 252) {
            # We use a special representation for long strings of
            # spaces. Code 0 is "   " for consistency with the other
            # codes in the 0..251 range. However, codes 252 to 255
            # represent strings of twice, three times, etc. as much.
            # To avoid redundancy when multiple whitespace is used in
            # a row, we use (little-endian) bijective base 5, i.e.
            # each successive whitespace character has 5 times the
            # width.
            my $value = ($code == 0 ? 1 : $code - 250);
            $unpacked .= ' ' x ($value * $spaceweight);
            $spaceweight *= 5;
        } else {
            # Three packed characters, which aren't all spaces.
            # Only the third can be a newline.
            use integer;
            $unpacked .= $charset[$code % 6];
            $unpacked .= $charset[($code / 6) % 6];
            $unpacked .= $charset[$code / 36];
            $spaceweight = 3;
        }
        $program = $unpacked;
    }
} else {
    $program = decode('UTF-8', $program, Encode::FB_CROAK);
    $program = expand($program);
    $program =~ y/\x04\x11\x1E\x10\x1F+<^>v/♦◄▲►▼♦◄▲►▼/;    
}

# Now pack the program.
my $unpacked = $program;
my $packed = '';
my %charset = (" " => 0, "♦" => 1, "◄" => 2,
               "▲" => 3, "►" => 4, "▼" => 5, "\n" => 6);
my @spaceset = (undef, chr 0, chr 252, chr 253, chr 254, chr 255);
while (length $program && $program =~ s/^(\ {3,}|...|.?.?\n|.?.?\z)//) {
    my $section = $1;
    $section =~ s/(\n?)\z/ $1/ while length $section < 3;
    while ((length $section) % 3) {
        # It must be a whitespace section. Trim it down to a
        # multiple of 3.
        $program = " $program";
        $section =~ s/\ \z// or die;
    }
    if ($section =~ /^ +\z/) {
        my $l = length($section) / 3;
        while ($l > 0) {
            my $c = $l % 5;
            $c or $c = 5;
            $packed .= $spaceset[$c];
            $l -= $c;
            $l /= 5;
        }
    } else {
        $section =~ /^(.)(.)(.)$/s or die;
        my $char1 = $charset{$1} || 0;
        my $char2 = $charset{$2} || 0;
        my $char3 = $charset{$3} || 0;
        my $code = $char3 * 36 + $char2 * 6 + $char1;
        $packed .= chr $code;
    }
}
$program = $unpacked;
$program =~ s/ +\n/\n/g;
$program =~ s/[ \n]+\z//;
my $ulength = length $program;
my $plength = length $packed;

if ($opt_f) {
    print STDERR "Program ($ulength characters):\n<pre>\n$program\n</pre>\n\n";
    print STDERR "Hexdump of packed representation ($plength bytes):\n<pre>\n",
        unpack("H*", $packed), "\n</pre>\n\n";
}

my %dx = ("◄" => -1, "►" => 1);
my %dy = ("▲" => -1, "▼" => 1);

my $dir = "►";
my $x = -1;
my $y = 0;
my $lx = -1;
my $ly = -1;
my @queue = ();
my @plines = split "\n", $program;
my $width = 0;
my $height = @plines;
length > $width and $width = length for @plines;
my @pmatrix = map [split //, $_], @plines;
$width and $height or
    (print STDERR "Error: program has zero width or height\n"), exit 1;

my @inlist = ();
if ($opt_A) {
    @inlist = map ord, split //, $input;
} else {
    push @inlist, $1 while $input =~ s/(\d+)//;
}
for my $inelem (@inlist) {
    push @queue, "►" for 1..$inelem;
    push @queue, "▼";
}

while (1) {
    $x += $dx{$dir} || 0;
    $y += $dy{$dir} || 0;
    $x += $width; $x %= $width;
    $y += $height; $y %= $height;
    if ($opt_d) {
        local $" = "";
        printf STDERR "(%6d,%6d) %s\n", $x, $y, "@queue";
    }
    my $curcell = $pmatrix[$y][$x] || ' ';
    if ($dx{$curcell} || $dy{$curcell}) {
        if ($lx == $x && $ly == $y) {
            my $queuestr;
            { local $" = ""; $queuestr = "@queue"; }
            my @outlist = ();
            $queuestr =~ s/[^▼►]//g;
            push @outlist, length $1 while $queuestr =~ s/^(►*)▼//;
            print "@outlist\n" unless $opt_A;
            print map chr, @outlist if $opt_A;
            exit 0;
        }
        $lx = $x;
        $ly = $y;
        push @queue, $curcell;
        $dir = $curcell;
    } elsif ($curcell eq '♦') {
        @queue or (print STDERR "Error: Queue underflow!\n"), exit 1;
        $dir = shift @queue;
        $lx = -1;
    }
}