File Coverage

blib/lib/Language/Nouse.pm

Criterion	Covered	Total	%
statement	170	200	85.0
branch	50	72	69.4
condition			n/a
subroutine	20	25	80.0
pod	10	13	76.9
total	250	310	80.6

package Language::Nouse;

use strict;
use warnings;

our $VERSION = '0.04';

sub new {
        my $class = shift;
        my $self = bless {}, $class;

        my $options = shift;
        $self->clear();

	$self->{sub_get} = \&NOUSE_DEFAULT_get;
	$self->{sub_put} = \&NOUSE_DEFAULT_put;

        return $self;
}

sub clear {
	my ($self) = @_;
	$self->{ring} = [];
	$self->{stack} = [];
	$self->{ring_pointer} = 0;
}

sub set_get {
	my ($self, $new) = @_;
	$self->{sub_get} = $new;
}

sub set_put {
	my ($self, $new) = @_;
	$self->{sub_put} = $new;
}

sub NOUSE_DEFAULT_get {
	return getc;
}

sub NOUSE_DEFAULT_put {
	print $_[0];
}

sub load_linenoise {
	my ($self, $input) = @_;

	$self->_reset_ring();

	my $op = qr/[#:<>+?^]/;
	my $mul = qr/[0-9a-z_]/;

	my $not_op = qr/[^#:<>+?^]/;
	my $not_mul = qr/[^0-9a-z_]/;

	while ($input =~ m/$not_op*($op)$not_mul*($mul)/g){

		my $this_op = $1;
		my $this_mul = $2;

		$this_op =~ y/#:<>+?^/0123456/;

		$this_mul = 10 + (ord($this_mul) - ord('a')) if ($this_mul =~ m/[a-z]/);
		$this_mul = 36 if ($this_mul eq '_');

		my $op_code = ($this_mul * 7) + $this_op;

		push @{$self->{ring}}, $op_code;
	}

}

sub load_assembly {
	my ($self, $input) = @_;

	$self->_reset_ring();

	$input =~ s/#(.*?)(\r|\n|$)/$2/g;

	my @tokens = split /[,\n\r]/, $input;

	for my $token(@tokens){
		$token =~ s/\s*(.*?)\s*/$1/;

			if ($token =~ m/(cut|paste|read|write|add|test|swap) (\d+)/i){

				my $op = $1;
				my $mul = $2;

				if ($op eq 'cut'){$op = 0;}
				elsif ($op eq 'paste'){$op = 1;}
				elsif ($op eq 'read'){$op = 2;}
				elsif ($op eq 'write'){$op = 3;}
				elsif ($op eq 'add'){$op = 4;}
				elsif ($op eq 'test'){$op = 5;}
				elsif ($op eq 'swap'){$op = 6;}

				push @{$self->{ring}}, ($mul * 7) + $op;

			}elsif ($token =~ m/(\d+)/){

				push @{$self->{ring}}, $1+0;

			}
	}
}

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

	$self->_reset_ring();

	my $buffer = '';
	for my $raw(@{$self->{ring}}){
		my $op = $raw % 7;
		my $mul = int($raw / 7);

		$op =~ y/0123456/#:<>+?^/;

		if ($mul == 36){
			$mul = '_';
		}elsif ($mul > 9){
			$mul = chr(ord('a') + ($mul - 10));
		}

		$buffer .= $op.$mul;
	}
	return $buffer;
}

sub get_assembly {
	my ($self, $per_line) = @_;

	$self->_reset_ring();

	$per_line = 4 unless defined $per_line;

	my @ops;

	for my $raw(@{$self->{ring}}){
		my $op = $raw % 7;
		my $mul = int($raw / 7);

		if ($op == 0){
			$op = 'cut';
		}elsif ($op == 1){
			$op = 'paste';
		}elsif ($op == 2){
			$op = 'read';
		}elsif ($op == 3){
			$op = 'write';
		}elsif ($op == 4){
			$op = 'add';
		}elsif ($op == 5){
			$op = 'test';
		}elsif ($op == 6){
			$op = 'swap';
		}

		push @ops, "$op $mul";
	}

	my $buffer = '';
	while (@ops){
		$buffer .= join(', ', splice @ops, 0, $per_line)."\n";
	}

	return $buffer;
}

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

	while(scalar(@{$self->{ring}})){
		$self->step();
	}
}

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

	my ($op, $mul, $raw) = $self->_get_op();

	my $skip = scalar(@{$self->{stack}}) * $mul;
	$skip++;

	if ($op == 0){
		# cut
		$self->_skip($skip);
		$self->_push($self->_get_oprand());
		$self->_remove_op();
		$skip--;
	}

	if ($op == 1){
		# paste
		$self->_skip($skip);
		if (scalar(@{$self->{stack}})){
			$self->_insert_op($self->_pop());
		}else{
			$self->_insert_op($self->_get_oprand());
		}
	}

	if ($op == 2){
		# read
		my $in = &{$self->{sub_get}}();
		if (defined $in){
			$self->_push(ord($in) % 256);
		}
	}

	if ($op == 3){
		# write
		if (scalar(@{$self->{stack}})){
			&{$self->{sub_put}}(chr($self->_peek()));
		}
	}

	if ($op == 4){
		# add
		if (scalar(@{$self->{stack}})){
			$self->_skip($skip);
			my $oprand = $self->_get_oprand();
		$oprand += $self->_pop();
			$self->_push($oprand % 256);
		}
	}

	if ($op == 5){
		# test
		if (scalar(@{$self->{stack}})){
			$self->_skip($skip);
			my $oprand = $self->_get_oprand();
			if ($oprand == $self->_peek()){
				$self->_pop();
			}
		}
	}

	if ($op == 6){
		# swap
		$self->_swap();
	}

	$self->_skip($skip);
}

sub _skip {
	my ($self, $by) = @_;
	# skip the ring pointer along by $by places
	$self->{ring_pointer} += $by;

	my $s = scalar(@{$self->{ring}});
	if ($s == 0){
		$self->{ring_pointer} = 0;
		return;
	}

	$self->{ring_pointer} = $self->{ring_pointer} % $s;
}

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

	my $raw = $self->_get_oprand();
	my $op = $raw % 7;
	my $mul = int($raw / 7);

	return ($op, $mul, $raw);
}

sub _get_oprand {
	my ($self) = @_;
	die "ARGH: The ring is empty and you're asking for an oprand!" if !scalar(@{$self->{ring}});
	return $self->{ring}->[$self->{ring_pointer}];
}

sub _push {
	my ($self, $value) = @_;
	push @{$self->{stack}}, $value;
}

sub _pop {
	my ($self) = @_;
	return pop @{$self->{stack}};
}

sub _peek {
	my ($self) = @_;
	my $data = $self->_pop();
	$self->_push($data);
	return $data;
}

sub _remove_op {
	my ($self) = @_;
	splice @{$self->{ring}}, $self->{ring_pointer}, 1;
}

sub _insert_op {
	my ($self, $value) = @_;
	splice @{$self->{ring}}, $self->{ring_pointer}, 0, ($value);
}

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

	my $p = $self->{ring_pointer};
	my $l = scalar(@{$self->{ring}});

	my @new_ring = splice(@{$self->{ring}}, $p, $l-$p);
	push @new_ring, splice(@{$self->{ring}}, 0, $p);

	$self->{ring} = \@new_ring;
	$self->{ring_pointer} = 0;
}

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

	my @new_ring = @{$self->{stack}};

	my $p = $self->{ring_pointer};
	my $l = scalar(@{$self->{ring}});

	my @new_stack = splice(@{$self->{ring}}, $p, $l-$p);
	push @new_stack, splice(@{$self->{ring}}, 0, $p);

	$self->{stack} = \@new_stack;
	$self->{ring} = \@new_ring;
	$self->{ring_pointer} = 0;
}


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

	print "RING: ".join(',',@{$self->{ring}})."  STACK:".join(',',@{$self->{stack}})."\n";
}

1;

__END__