File Coverage

blib/lib/Language/SNUSP.pm

Criterion	Covered	Total	%
statement	9	109	8.2
branch	0	58	0.0
condition	0	15	0.0
subroutine	3	11	27.2
pod	0	7	0.0
total	12	200	6.0

use strict; use warnings;
package Language::SNUSP;
our $VERSION = '0.0.13';

my $input = '';     # SNUSP input
my $code = '';      # 2D code matrix
my $width = 1;      # 2D code width
my $pos = 0;        # 2D code execution pointer
my $max = 0;        # Maximum pos value (length of code)
my $dir = 1;        # Execution direction:
                    #   1=right -1=left $width=down -$width=up
my @args = ();      # Program input list
my @data = (0);     # Data slots
my $index = 0;      # Data slot index
my @stack = ();     # Subroutine call stack
my $count = 0;      # Execution counter

# I/O handlers
my $put = sub { print shift };
my $get = sub { substr shift(@args), 0, 1 };

# SNUSP opcode handler lookup table.
my %ops = (
    '>'  => sub { $data[++$index] ||= 0 },
    '<'  => sub { --$index >= 0 or $dir = 0 },
    '+'  => sub { ++$data[$index] },
    '-'  => sub { --$data[$index] },
    ','  => sub { $data[$index] = ord $get->() },
    '.'  => sub { $put->(chr $data[$index]) },
    '/'  => sub { $dir = -$width / $dir },
    '\\' => sub { $dir = $width / $dir },
    '!'  => sub { $pos += $dir },
    '?'  => sub { $pos += $dir if $data[$index] == 0 },
    '@'  => sub { push @stack, [ $pos + $dir, $dir ] },
    '#'  => sub { @stack ? ($pos, $dir) = @{pop @stack} : $dir = 0 },
    "\n" => sub { $dir = 0 },
);

# Runtime flags
my $file;           # Input SNUSP file
my $trace = 0;      # Run with trace execution
my $debug = 0;      # Run with 2D Curses debugger

sub run {
    my ($class, @args) = @_;
    $class->get_options(@args);

    open my $fh, '<', $file or die "Can't open '$file' for input.\n";
    $input = do { local $/; <$fh> };
    close $fh;

    for ($input =~ /^.*\n/gm) {
        $code .= $_;
        $width = length if length > $width;
    }
    $code =~ s/^.*/$& . ' ' x ($width - length $&) . "\n"/gem;
    $max = length($code) - 1;
    $width += 2;
    $pos = $code =~ /\$/ * $-[0];

    $trace ? run_trace() :
    $debug ? run_debug() :
             run_normal();

    exit $data[$index];
}

sub run_normal {
    while ($dir) {
        if (my $op = $ops{substr $code, $pos, 1}) { &$op }
        $pos += $dir;
        last if $pos < 0 or $pos > $max;
    }
}

sub run_trace {
    while ($dir) {
        my $char = substr $code, $pos, 1;
        $count++;
        print trace_line() . "\n";
        if (my $op = $ops{$char}) { &$op }
        $pos += $dir;
        last if $pos < 0 or $pos > $max;
        print "\n" if $char eq '.';
    }
}

sub run_debug {
    require Curses; Curses->import;
    require Term::ReadKey; Term::ReadKey->import;

    initscr();
    ReadMode(3);

    my $y = 0;
    addstr(
        $y++, 0,
        "(+)faster (-)slower (SPACE)stop/start (n)ext (q)uit",
    );
    my $top = ++$y;
    addstr($y++, 0, $&) while $code =~ /.+/g;

    my $key = '';
    my $sleep = 0.1;
    my $pause = 0;

    my $out = '';
    $put = sub { $out .= shift };

    while(1) {
        if ($dir and (not $pause or $key eq "n")) {
            $count++;
            if (my $op = $ops{substr $code, $pos, 1}) { &$op }
            last if $pos < 0 or $pos > $max;
            $pos += $dir;
            $pause = 1 if $dir == 0;
        }

        {
            addstr($top - 1, 0, trace_line());
            addstr($y, 0, $out);
            clrtoeol();
            move(int($pos / $width) + $top, $pos % $width);
            refresh();
        }

        $key = ReadKey($pause ? 0 : $sleep);
        if ($key =~ /^[\+\=]$/) {$sleep -= 0.01 if $sleep > 0.011}
        elsif ($key eq '-') {$sleep += 0.01}
        elsif ($key eq ' ') {$pause = not $pause}
        elsif ($key eq 'n') {$pause = 1}
        elsif ($key eq 'q') {last}
    }
    ReadMode(0);
    endwin();
}

sub trace_line {
    my $n = 0;
    my $display = join '', map {
        $n++ == $index ? "[$_] " : "$_ "
    } @data;
    return "$count)  \@${\scalar @stack}  < $display>";
}

sub get_options {
    my ($class, @options) = @_;

    for my $option (@options) {
        if ($option =~ /^(-v|--version)$/) {
            no strict 'refs';
            print qq!Language::SNUSP v${"VERSION"}!;
            exit 0;
        }
        if ($option =~ /^(-\?|-h|--help)$/) {
            die usage();
            exit 0;
        }
        if ($option =~ /^(-d|--debug)$/) {
            $debug = 1;
            next;;
        }
        if ($option =~ /^(-t|--trace)$/) {
            $trace = 1;
            next;
        }
        if ($option =~ /^-/) {
            die "Unknown option: '$option'\n\n" . usage();
        }
        if ($file) {
            push @args, $option;
            next;
        }
        if (-f $option) {
            $file = $option;
        }
        else {
            die "Input file '$option' does not exist.\n";
        }
    }
    die usage() if not $file;
}

sub usage {
    <<'...';
Usage:
    snusp [options] input_file.snusp

Options:
    -d, --debug     # Run program in the visual debugger
    -t, --trace     # Run with trace on
    -v, --version   # Print version and exit
    -h, --help      # Print help and exit
...
}

1;