File Coverage

blib/lib/Language/Befunge/IP.pm

Criterion	Covered	Total	%
statement	210	210	100.0
branch	42	42	100.0
condition			n/a
subroutine	47	47	100.0
pod	38	38	100.0
total	337	337	100.0

#
# This file is part of Language-Befunge
#
# This software is copyright (c) 2003 by Jerome Quelin.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use 5.010;
use strict;
use warnings;

package Language::Befunge::IP;
# ABSTRACT: an Instruction Pointer for a Befunge-98 program
$Language::Befunge::IP::VERSION = '5.000';
use integer;

use Carp;
use Language::Befunge::Vector;
use Storable qw(dclone);

use Class::XSAccessor
    getters => {
        get_position    => 'position',
        get_data        => 'data',
        get_delta       => 'delta',
        get_dims        => 'dims',
        get_end         => 'end',
        get_id          => 'id',
        get_libs        => 'libs',
        get_ss          => 'ss',
        get_storage     => 'storage',
        get_string_mode => 'string_mode',
        get_toss        => 'toss',
    },
    setters => {
        set_position    => 'position',
        set_data        => 'data',
        set_delta       => 'delta',
        set_end         => 'end',
        set_id          => 'id',
        set_libs        => 'libs',
        set_ss          => 'ss',
        set_storage     => 'storage',
        set_string_mode => 'string_mode',
        set_toss        => 'toss',
    };


# -- CONSTRUCTORS

sub new {
    my ($class, $dims) = @_;
    $dims = 2 unless defined $dims;
    my $self  =
      { id           => 0,
        dims         => $dims,
        toss         => [],
        ss           => [],
        position     => Language::Befunge::Vector->new_zeroes($dims),
        delta        => Language::Befunge::Vector->new_zeroes($dims),
        storage      => Language::Befunge::Vector->new_zeroes($dims),
        string_mode  => 0,
        end          => 0,
        data         => {},
        libs         => { map { $_=>[] } 'A'..'Z' },
      };
    # go right by default
    $self->{delta}->set_component(0, 1);
    bless $self, $class;
    $self->set_id( $self->_get_new_id );
    return $self;
}

sub clone {
    my $self = shift;
    my $clone = dclone( $self );
    $clone->set_id( $self->_get_new_id );
    return $clone;
}


# -- ACCESSORS


sub soss {
    my $self = shift;
    # Remember, the Stack Stack is up->bottom.
    @_ and $self->get_ss->[0] = shift;
    return $self->get_ss->[0];
}


sub scount {
    my $self = shift;
    return scalar @{ $self->get_toss };
}

sub spush {
    my $self = shift;
    push @{ $self->get_toss }, @_;
}

sub spush_vec {
    my ($self) = shift;
    foreach my $v (@_) {
        $self->spush($v->get_all_components);
    }
}

sub spush_args {
    my $self = shift;
    foreach my $arg ( @_ ) {
        $self->spush
          ( ($arg =~ /^-?\d+$/) ?
              $arg                                    # A number.
            : reverse map {ord} split //, $arg.chr(0) # A string.
          );
    }
}

sub spop {
    my $self = shift;
    my $val = pop @{ $self->get_toss };
    defined $val or $val = 0;
    return $val;
}

sub spop_mult {
    my ($self, $count) = @_;
    my @rv = reverse map { $self->spop() } (1..$count);
    return @rv;
}

sub spop_vec {
    my $self = shift;
    return Language::Befunge::Vector->new($self->spop_mult($self->get_dims));
}

sub spop_gnirts {
    my $self = shift;
    my ($val, $str);
    do {
        $val = pop @{ $self->get_toss };
        defined $val or $val = 0;
        $str .= chr($val);
    } while( $val != 0 );
    chop $str; # Remove trailing \0.
    return $str;
}

sub sclear {
    my $self = shift;
    $self->set_toss( [] );
}

sub svalue {
    my ($self, $idx) = @_;

    $idx = - abs( $idx );
    return 0 unless exists $self->get_toss->[$idx];
    return $self->get_toss->[$idx];
}

sub ss_count {
    my $self = shift;
    return scalar( @{ $self->get_ss } );
}

sub ss_create {
    my ( $self, $n ) = @_;

    my @new_toss;

    if ( $n < 0 ) {
        # Push zeroes on *current* toss (to-be soss).
        $self->spush( (0) x abs($n) );
    } elsif ( $n > 0 ) {
        my $c = $n - $self->scount;
        if ( $c <= 0 ) {
            # Transfer elements.
            @new_toss = splice @{ $self->get_toss }, -$n;
        } else {
            # Transfer elems and fill with zeroes.
            @new_toss = ( (0) x $c, @{ $self->get_toss } );
            $self->sclear;
        }
    }
    # $n == 0: do nothing


    # Push the former TOSS on the stack stack and copy reference to
    # the new TOSS.
    # For commodity reasons, the Stack Stack is oriented up->bottom
    # (that is, a push is an unshift, and a pop is a shift).
    unshift @{ $self->get_ss }, $self->get_toss;
    $self->set_toss( \@new_toss );
}

sub ss_remove {
    my ( $self, $n ) = @_;

    # Fetch the TOSS.
    # Remember, the Stack Stack is up->bottom.
    my $new_toss = shift @{ $self->get_ss };

    if ( $n < 0 ) {
        # Remove values.
        if ( scalar(@$new_toss) >= abs($n) ) {
            splice @$new_toss, $n;
        } else {
            $new_toss = [];
        }
    } elsif ( $n > 0 ) {
        my $c = $n - $self->scount;
        if ( $c <= 0 ) {
            # Transfer elements.
            push @$new_toss, splice( @{ $self->get_toss }, -$n );
        } else {
            # Transfer elems and fill with zeroes.
            push @$new_toss, ( (0) x $c, @{ $self->get_toss } );
        }
    }
    # $n == 0: do nothing


    # Store the new TOSS.
    $self->set_toss( $new_toss );
}

sub ss_transfer {
    my ($self, $n) = @_;
    $n == 0 and return;

    if ( $n > 0 ) {
        # Transfer from SOSS to TOSS.
        my $c = $n - $self->soss_count;
        my @elems;
        if ( $c <= 0 ) {
            @elems = splice @{ $self->soss }, -$n;
        } else {
            @elems = ( (0) x $c, @{ $self->soss } );
            $self->soss_clear;
        }
        $self->spush( reverse @elems );

    } else {
        $n = -$n;
        # Transfer from TOSS to SOSS.
        my $c = $n - $self->scount;
        my @elems;
        if ( $c <= 0 ) {
            @elems = splice @{ $self->get_toss }, -$n;
        } else {
            @elems = ( (0) x $c, @{ $self->get_toss } );
            $self->sclear;
        }
        $self->soss_push( reverse @elems );

    }
}

sub ss_sizes {
    my $self = shift;

    my @sizes = ( $self->scount );

    # Store the size of each stack.
    foreach my $i ( 1..$self->ss_count ) {
        push @sizes, scalar @{ $self->get_ss->[$i-1] };
    }

    return @sizes;
}


sub soss_count {
    my $self = shift;
    return scalar( @{ $self->soss } );
}

sub soss_push {
    my $self = shift;
    push @{ $self->soss }, @_;
}


sub soss_pop_mult {
    my ($self, $count) = @_;
    my @rv = reverse map { $self->soss_pop() } (1..$count);
    return @rv;
}

sub soss_push_vec {
    my $self = shift;
    foreach my $v (@_) {
        $self->soss_push($v->get_all_components);
    }
}

sub soss_pop {
    my $self = shift;
    my $val = pop @{ $self->soss };
    defined $val or $val = 0;
    return $val;
}

sub soss_pop_vec {
    my $self = shift;
    return Language::Befunge::Vector->new($self->soss_pop_mult($self->get_dims));
}

sub soss_clear {
    my $self = shift;
    $self->soss( [] );
}



sub dir_go_east {
    my $self = shift;
    $self->get_delta->clear;
    $self->get_delta->set_component(0, 1);
}

sub dir_go_west {
    my $self = shift;
    $self->get_delta->clear;
    $self->get_delta->set_component(0, -1);
}

sub dir_go_north {
    my $self = shift;
    $self->get_delta->clear;
    $self->get_delta->set_component(1, -1);
}

sub dir_go_south {
    my $self = shift;
    $self->get_delta->clear;
    $self->get_delta->set_component(1, 1);
}

sub dir_go_high {
    my $self = shift;
    $self->get_delta->clear;
    $self->get_delta->set_component(2, 1);
}

sub dir_go_low {
    my $self = shift;
    $self->get_delta->clear;
    $self->get_delta->set_component(2, -1);
}

sub dir_go_away {
    my $self = shift;
    my $nd = $self->get_dims;
    my $dim = (0..$nd-1)[int(rand $nd)];
    $self->get_delta->clear;
    my $value = (-1, 1)[int(rand 2)];
    $self->get_delta->set_component($dim, $value);
}

sub dir_turn_left {
    my $self = shift;
    my $old_dx = $self->get_delta->get_component(0);
    my $old_dy = $self->get_delta->get_component(1);
    $self->get_delta->set_component(0, 0 + $old_dy);
    $self->get_delta->set_component(1, 0 + $old_dx * -1);
}

sub dir_turn_right {
    my $self = shift;
    my $old_dx = $self->get_delta->get_component(0);
    my $old_dy = $self->get_delta->get_component(1);
    $self->get_delta->set_component(0, 0 + $old_dy * -1);
    $self->get_delta->set_component(1, 0 + $old_dx);
}

sub dir_reverse {
    my $self = shift;
    $self->set_delta(-$self->get_delta);
}

sub load {
    my ($self, $lib) = @_;

    my $libs = $self->get_libs;
    foreach my $letter ( 'A' .. 'Z' ) {
        next unless $lib->can($letter);
        push @{ $libs->{$letter} }, $lib;
    }
}

sub unload {
    my ($self, $lib) = @_;

    my $libs = $self->get_libs;
    foreach my $letter ( 'A' .. 'Z' ) {
        next unless $lib->can($letter);
        pop @{ $libs->{$letter} };
    }
}

sub extdata {
    my $self = shift;
    my $lib  = shift;
    @_ ? $self->get_data->{$lib} = shift : $self->get_data->{$lib};
}


# -- PRIVATE METHODS

#
# my $id = _get_new_id;
#
# Forge a new IP id, that will distinct it from the other IPs of the program.
#
my $id = 0;
sub _get_new_id {
    return $id++;
}

1;

__END__