Optimizing Brainfuck to Perl translator

bf.pl

#!/usr/bin/env perl

use v5.14;

#chomp(my $input = <STDIN>);

# Hello World!\n
#my $input = '++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>.';

# Hello World!
#my $input = '+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.>>>++++++++[<++++>-]<.>>>++++++++++[<+++++++++>-]<---.<<<<.+++.------.--------.>>+.';

# 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89
# (Fibonacci)
my $input = '+++++++++++>+>>>>++++++++++++++++++++++++++++++++++++++++++++>++++++++++++++++++++++++++++++++<<<<<<[>[>>>>>>+>+<<<<<<<-]>>>>>>>[<<<<<<<+>>>>>>>-]<[>++++++++++[-<-[>>+>+<<<-]>>>[<<<+>>>-]+<[>[-]<[-]]>[<<[>>>+<<<-]>>[-]]<<]>>>[>>+>+<<<-]>>>[<<<+>>>-]+<[>[-]<[-]]>[<<+>>[-]]<<<<<<<]>>>>>[++++++++++++++++++++++++++++++++++++++++++++++++.[-]]++++++++++<[->-<]>++++++++++++++++++++++++++++++++++++++++++++++++.[-]<<<<<<<<<<<<[>>>+>+<<<<-]>>>>[<<<<+>>>>-]<-[>>.>.<<<[-]]<<[>>+>+<<<-]>>>[<<<+>>>-]<<[<+>-]>[<+>-]<<<-]';

my $bf = Bf->new($input);

eval {
    $bf->translate;
    $bf->execute;
    1;
}
or do {
    exit say STDERR "Error: $@->[0]: $@->[1]";
};

package Bf;

use v5.14;

use constant MEMORY_SIZE => 1000;

use constant {
    OP_DECR  => '-',
    OP_INCR  => '+',
    OP_LEFT  => '<',
    OP_RGHT  => '>',
    OP_LSTRT => '[',
    OP_LSTP  => ']',
    OP_OTPT  => '.',
    OP_INPT  => ',',
};

sub new {
    my $class = shift;

    bless {
        source     => shift,
        output     => undef,
        pos        => 0,
        open       => [],
        compressed => [],
    }, $class;
}

sub translate {
    my $self = shift;

    $self->compress;

    my $output = $self->prologue;
    $output   .= $self->translate_one while $self->has_next;
    $output   .= $self->epilogue;

    $self->{output} = $output;
}

sub execute {
    my $self = shift;

    eval $self->{output};
    $self->error($@) if $@;
}

sub compress {
    my($self) = @_;

    my @compressed;

    my $seq_op;
    my $seq_len = 0;

    for my $op (split(//, $self->{source})) {
        # don't compress flow control ops
        if(grep($op eq $_, OP_LSTRT, OP_LSTP, OP_OTPT, OP_INPT)) {
            # flush the sequence that was going before we got to the flow
            # control op, if there was one
            if($seq_op) {
                push(@compressed, [$seq_len, $seq_op]);
                $seq_op  = undef;
                $seq_len = 0;
            }

            push(@compressed, [1, $op]);

            next;
        }

        unless($seq_op) {
            $seq_op = $op;
            $seq_len++;

            next;
        }

        if($op eq $seq_op) {
            $seq_len++;

            next;
        }

        push(@compressed, [$seq_len, $seq_op]);

        $seq_op  = $op;
        $seq_len = 1;
    }

    $self->{compressed} = \@compressed;

    return;
}

sub compress_regex {
    my $self = shift;

    my $string = $self->{source};
    for my $op (OP_DECR, OP_INCR, OP_LEFT, OP_RGHT) {
        $string =~ s<(\Q$op\E+)><length($1) . $op>ge;
    }
    for my $op (OP_LSTRT, OP_LSTP, OP_OTPT, OP_INPT) {
        $string =~ s<\Q$op\E><'1' . $op>ge;
    }

    my @compressed = $string =~ /([0-9]+)([^0-9])/g;
    while(@compressed) {
        my($mult, $op) = splice @compressed, 0, 2;
        push @{ $self->{compressed} }, [$mult, $op];
    }
}

sub has_next {
    my $self = shift;

    $self->{pos} <= $#{ $self->{compressed} };
}

sub error {
    my $self = shift;

    die [$self->{pos}, shift];
}

sub translate_one {
    my $self = shift;

    my $method = $self->method_for_current_op;
    my $code   = $self->$method . "\n";

    $self->{pos}++;

    $code;
}

sub prologue {
    my $prologue = 'my @MEMORY = (0) x ' . MEMORY_SIZE . ";\n";
    $prologue   .= 'my @OUTPUT'  . ";\n";
    $prologue   .= 'my $PTR = 0' . ";\n";

    $prologue;
}

sub epilogue {
    'END { print STDOUT pack "C*", @OUTPUT }';
}

sub method_for_current_op {
    my $self = shift;

    state $TRANSOP = {
        OP_LEFT  ,=> 'move_left',
        OP_RGHT  ,=> 'move_right',
        OP_INCR  ,=> 'increment',
        OP_DECR  ,=> 'decrement',
        OP_OTPT  ,=> 'output',
        OP_INPT  ,=> 'input',
        OP_LSTRT ,=> 'loop_start',
        OP_LSTP  ,=> 'loop_stop',
    };

    my $op     = $self->current_op;
    my $method = $TRANSOP->{$op}
        or $self->error("Unknown op '$op'");

    $method;
}

sub current_op {
    my $self = shift;

    $self->{compressed}[$self->{pos}][1];
}

sub current_multiplier {
    my $self = shift;

    $self->{compressed}[$self->{pos}][0];
}

sub move_left {
    my $self = shift;

    '$PTR-=' . $self->current_multiplier . ';';
}

sub move_right {
    my $self = shift;

    '$PTR+=' . $self->current_multiplier . ';';
}

sub increment {
    my $self = shift;

    '$MEMORY[$PTR]+=' . $self->current_multiplier . ';';
}

sub decrement {
    my $self = shift;

    '$MEMORY[$PTR]-=' . $self->current_multiplier . ';';
}

sub output {
    'push @OUTPUT, $MEMORY[$PTR];';
}

sub input {
    '$MEMORY[$PTR]=ord getc();';
}

sub loop_start {
    'while($MEMORY[$PTR]) {';
}

sub loop_stop {
    '}';
}