/r/dailyprogrammer chal #164 befunge interpreter

gistfile1.pl

use strict;

$| = 1;

my $STACKMAX = 1000;
my $VERBOSE = $ARGV[0] ne '' ? $ARGV[0] : 0;

my %directions = ('^' => [-1,0],
                  'v' => [1, 0],
                  '<' => [0,-1],
                  '>' => [0, 1]);

my @dimensions = (0, 0);

my @prog; # [r][c]
my @input;
my @stack;
my $result;

my ($A, $B, $C);

my @ptr = (0, 0);
my @direction = (0, 1);

###########################################################################

sub getinput {
    my ($flag, $l) = (0, 0);
    chomp($_ = <STDIN>);
    @input = split '';
    for (<STDIN>) {
        next if /^$/;
        $flag = 1 unless /^\s*$/;
        next if /^\s*$/ and !$flag;
        chomp;
        $l = length($_) if length($_) > $l;
        push @prog, [split ''];
    }
    @dimensions = (scalar @prog, $l);
    if ($VERBOSE > 1) {
        print "DIMENSIONS: $dimensions[0], $dimensions[1]\n";
        print "PROGRAM: \n";
        print join '', @{$prog[$_]}, "\n" for 0..$#prog;
        print "#" x 79, "\n";
    }
    die "No program\n" unless $dimensions[0] > 0 and $dimensions[1] > 0;
}

sub moveptr {
    $ptr[0] += $direction[0];
    $ptr[1] += $direction[1];
    $ptr[0] = 0 if $ptr[0] >= $dimensions[0];
    $ptr[1] = 0 if $ptr[1] >= $dimensions[1];
    $ptr[0] = $dimensions[0] - 1 if $ptr[0] < 0;
    $ptr[1] = $dimensions[1] - 1 if $ptr[1] < 0;
}

sub getptr { return $prog[$ptr[0]][$ptr[1]]; }

sub warnifverb {
    my ($str) = @_;
    warn "$str\n" if $VERBOSE;
}

sub getstack {
    my ($ct) = @_;
    $A = pop @stack;
    unless (defined $A) {
        ($A, $B, $C) = (0, 0, 0);
        warnifverb("stack empty during operation $prog[$ptr[0]][$ptr[1]] " .
             "at ptr position [$ptr[0], $ptr[1]]; treating \$A as 0\n");
        return 1;
    }
    return 0 unless $ct == 2;
    $B = pop @stack;
    unless (defined $B) {
        ($B, $C) = (0, 0);
        warnifverb("stack empty during operation $prog[$ptr[0]][$ptr[1]] " .
             "at ptr position [$ptr[0], $ptr[1]]; treating \$B as 0\n");
        return 2;
    }
    return 0 unless $ct == 3;
    $C = pop @stack;
    unless (defined $C) {
        $C = 0;
        warnifverb("stack empty during operation $prog[$ptr[0]][$ptr[1]] " .
             "at ptr position [$ptr[0], $ptr[1]]; treating \$C as 0\n");
        return 3;
    }
    return 0;
}

sub asciimode {
    my $timer = 0;
    moveptr;
    print "Characters added during ASCII mode: '" if $VERBOSE >= 2;
    until (($_ = getptr) eq '"') {
        print if $VERBOSE >= 2;
        push @stack, ord $_;
        die "stack overflow\n" if @stack > $STACKMAX;
        moveptr;
    }
        print "'\n" if $VERBOSE >= 2;
}

sub progloop {
    while(1) {
        $_ = getptr;
        print "\nOP at pos $ptr[0], $ptr[1]: $_\n" if $VERBOSE > 1;
        die "stack overflow\n" if @stack > $STACKMAX;
        if (/[0-9]/) { push @stack, ord($_) - 48; }

        if (/[+\-*\/\%]/) {
            getstack(2);
            eval "\$result = int($B $_ $A)";
            if ($@) {
                $@ =~ s/at \(eval \d+\) line \d+\.$//;
                warnifverb("\U$@ at ptr position [$ptr[0], $ptr[1]]\n");
            } else {
                push @stack, $result;
            }
        }

        if (/"/) { asciimode; }
        if (/[v<>^]/) {
            $direction[0] = ${$directions{$_}}[0];
            $direction[1] = ${$directions{$_}}[1];
        }
        if (/\?/) {
            my $r = int rand keys %directions;
            ($direction[0], $direction[1]) =
                (${$directions{(sort keys %directions)[$r]}}[0],
                ${$directions{(sort keys %directions)[$r]}}[1]);
        }
        if (/`/) {
            getstack(2);
            push @stack, ($B > $A ? 1 : 0);
        }
        if (/!/) {
            getstack(1);
            push @stack, ($A ? 0 : 1);
        }
        if (/_/) {
            getstack(1);
            @direction = $A ? (0, -1) : (0, 1);
        }
        if (/\|/) {
            getstack(1);
            @direction = $A ? (-1, 0) : (1, 0);
        }
        if (/:/) {
            if (@stack) { push @stack, $stack[-1]; }
            else {
                warnifverb("stack empty; could not duplicate end of stack " .
                "at ptr position [$ptr[0], $ptr[1]]\n");
            }
        }
        if (/\\/) {
            if (@stack >= 2) { ($stack[-1], $stack[-2]) = ($stack[-2], $stack[-1]) }
            else {
                my $n = scalar @stack;
                warnifverb("stack contains $n values; " .
                "could not swap end at ptr position [$ptr[0], $ptr[1]]\n");
            }
        }
        if (/\$/) {
            if (@stack) { pop @stack; }
            else {
                warnifverb("stack empty; could not discard value " .
                "at ptr position [$ptr[0], $ptr[1]]\n");
            }
        }
        if (/\./) {
            getstack(1);
            print "$A ";
        }
        if (/,/) {
            getstack(1);
            print chr $A;
        }
        if (/#/) { moveptr; }
        if (/p/) {
            if (@stack >= 3) {
                ($A, $B, $C) = (pop @stack, pop @stack, pop @stack);
              print "$prog[$A][$B] ->" if $VERBOSE > 2;
                $prog[$A][$B] = chr $C;
            print "$prog[$A][$B] PROGRAM: \n" if $VERBOSE > 2;
            if ($VERBOSE > 2) {
            print join '', @{$prog[$_]}, "\n" for 0..$#prog;
            }
            } else {
                my $n = scalar @stack;
                warnifverb("stack contains $n values; " .
                "could not change prog value at ptr position [$ptr[0], $ptr[1]]\n");
            }
        }
        if (/g/) {
            if (@stack >= 2) {
                ($A, $B) = (pop @stack, pop @stack);
                push @stack, ord($prog[$A][$B]);
            } else {
                warnifverb("stack contains ", scalar @stack, " values; " .
                "could not get prog value at ptr position [$ptr[0], $ptr[1]]\n");
            }
        }
        if (/&/) {
            if (@input) {
                my $val;
                my $n = 0;
                if ($input[0] =~ /[0-9]/) {
                    while ($input[0] =~ /[0-9]/) {
                        $val = shift @input;
                        $n = $n * 10 + ord($val) - 48;
                    }
                    push @stack, $n;
                } else { warnifverb("input is not number at ptr position [$ptr[0], $ptr[1]]\n"); }
            } else { warnifverb("no input during operation $_ at ptr position [$ptr[0], $ptr[1]]\n"); }
        }
        if (/~/) {
            my $val = shift @input;
            if (defined $val) {
                push @stack, ord $val;
            } else {
                warnifverb("no input during operation $_ at ptr position [$ptr[0], $ptr[1]]\n");
            }
        }
        if (/@/) {
        if ($VERBOSE > 2) {
            print "PROGRAM: \n";
            print join '', @{$prog[$_]}, "\n" for 0..$#prog;
        }
        exit;
        }
        print "\nStack at pos $ptr[0], $ptr[1]: @stack\n" if $VERBOSE > 2;
        moveptr;
    }
}

getinput;
progloop;