File Coverage

blib/lib/Language/Befunge/Storage.pm

Criterion	Covered	Total	%
statement	149	149	100.0
branch	42	42	100.0
condition	3	3	100.0
subroutine	16	16	100.0
pod	9	9	100.0
total	219	219	100.0

#
# This file is part of Language::Befunge.
# Copyright (c) 2008 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#

package Language::Befunge::Storage;

use strict;
use warnings;

use Carp;
use Language::Befunge::Vector;
use Language::Befunge::IP;
use aliased 'Language::Befunge::Vector' => 'LBV';


# -- PUBLIC METHODS


#
# store( code, [vector] )
#
# Store the given code at the specified vector.  If the coordinates
# are omitted, then the code is stored at the origin (0, 0).
#
# Return the size of the code inserted, as a vector.
#
# The code is a string, representing a block of Funge code.  Rows are
# separated by newlines.  Planes are separated by form feeds.  A complete list of
# separators follows:
#
#     Axis    Delimiter
#     X       (none)
#     Y       \n
#     Z       \f
#     4       \0
#
# The new-line and form-feed delimiters are in the Funge98 spec.  However, there
# is no standardized separator for dimensions above Z.  Currently, dimensions 4
# and above use \0, \0\0, \0\0\0, etc.  These are dangerously ambiguous, but are
# the only way I can think of to retain reverse compatibility.  Suggestions for
# better delimiters are welcome.  (Using XML would be really ugly, I'd prefer not
# to.)
#
sub store {
    my ($self, $code, $base) = @_;
    my $nd = $$self{nd};
    $base = Language::Befunge::Vector->new_zeroes($$self{nd}) unless defined $base;

    # support for any eol convention
    $code =~ s/\r\n/\n/g;
    $code =~ s/\r/\n/g;

    # The torus is a tree of arrays of numbers.
    # The tree is N levels deep, where N is the number of dimensions.
    # Each number is the ordinal value of the character held in this cell.

    my @separators = ("", "\n", "\f");
    push(@separators, "\0"x($_-3)) for (4..$nd); # , "\0", "\0\0", "\0\0\0"...
    my $separators = join("", @separators);
    my %separators = ( map { $separators[$_] => $_ } (1..@separators-1));
    my @sizes = map { 0 } (1..$nd);
    my @newvalues;
    my $this = $base->copy;
    while(length($code)) {
        my $value = substr($code, 0, 1, '');
        if(index($separators, $value) > -1) {
            last unless length $code;
            my $d = $separators{$value};
            my $new = $this->get_component($d) + 1;
            $this->set_component($d, $new);
            $sizes[$d] = $new if $new > $sizes[$d];
            foreach my $i (0..$d-1) {
                my $last = $this->get_component($i);
                $this->set_component($i, $base->get_component($i));
                $sizes[$i] = $last if $last > $sizes[$i];
            }
        } else {
            my $last = $this->get_component(0);
            unless($value eq ' ') {
                push(@newvalues, [$this->copy, ord($value)]);
                $sizes[0] = $last if $last > $sizes[0];
            }
            $this->set_component(0, $last + 1);
        }
    }

    return unless scalar @newvalues;

    # Figure out the rectangle size and the end-coordinate (max).
    my $size = Language::Befunge::Vector->new(map { $_ + 1 } @sizes);
    my $max  = Language::Befunge::Vector->new(@sizes);
    $size -= $base;

    # Enlarge torus to make sure our new values will fit.
    $self->expand( $base );
    $self->expand( $max );

    # Store code.
    foreach my $pair (@newvalues) {
        $self->set_value(@$pair);
    }

    return $size;
}


#
# store_binary( code, [vector] )
#
# Store the given code at the specified coordinates. If the coordinates
# are omitted, then the code is stored at the Origin(0, 0) coordinates.
#
# Return the size of the code inserted, as a vector.
#
# This is binary insertion, that is, EOL and FF sequences are stored in
# Funge-space instead of causing the dimension counters to be reset and
# incremented.  The data is stored all in one row.
#
sub store_binary {
    my ($self, $code, $base) = @_;
    my $nd = $$self{nd};
    $base = Language::Befunge::Vector->new_zeroes($$self{nd})
        unless defined $base;

    # The torus is a tree of arrays of numbers.
    # The tree is N levels deep, where N is the number of dimensions.
    # Each number is the ordinal value of the character held in this cell.

    my @sizes = length($code);
    push(@sizes,1) for(2..$nd);

    # Figure out the min, max, and size
    my $size = Language::Befunge::Vector->new(@sizes);
    my $max  = Language::Befunge::Vector->new(map { $_ - 1 } (@sizes));
    $max += $base;

    # Enlarge torus to make sure our new values will fit.
    $self->expand( $base );
    $self->expand( $max );

    # Store code.
    for(my $v = $base->copy; defined($v); $v = $v->rasterize($base, $max)) {
        my $char = substr($code, 0, 1, "");
        next if $char eq " ";
        $self->set_value($v, ord($char));
    }
    return $size;
}


#
# get_char( vector )
#
# Return the character stored in the torus at the specified location. If
# the value is not between 0 and 255 (inclusive), get_char will return a
# string that looks like "".
#
# B As in Funge, code and data share the same playfield, the
# character returned can be either an instruction B raw data.  No
# guarantee is made that the return value is printable.
#
sub get_char {
    my $self = shift;
    my $v = shift;
    my $ord = $self->get_value($v);
    # reject invalid ascii
    return sprintf("",$ord) if ($ord < 0 || $ord > 255);
    return chr($ord);
}


#
# my $str = rectangle( start, size )
#
# Return a string containing the data/code in the specified rectangle.
#
sub rectangle {
    my ($self, $v1, $v2) = @_;
    my $nd = $$self{nd};

    # Fetch the data.
    my $data = "";
    my $min = $v1;
    foreach my $d (0..$nd-1) {
        # each dimension must >= 1, otherwise the rectangle will be empty.
        return "" unless $v2->get_component($d);
        # ... but we need to offset by -1, to calculate $max
        $v2->set_component($d, $v2->get_component($d) - 1);
    }
    my $max = $v1 + $v2;
    # No separator is used for the first dimension, for obvious reasons.
    # Funge98 specifies lf/cr/crlf for a second-dimension separator.
    # Funge98 specifies a form feed for a third-dimension separator.
    # Funge98 doesn't specify what dimensions 4 and above should use.
    # We use increasingly long strings of null bytes.
    # (4d uses 1 null byte, 5d uses 2, 6d uses 3, etc)
    my @separators = "";
    push(@separators,"\n") if $nd > 1;
    push(@separators,"\f") if $nd > 2;
    push(@separators,"\0"x($_-3)) for (4..$nd); # , "\0", "\0\0", "\0\0\0"...
    my $prev = $min->copy;
    for(my $v = $min->copy; defined($v); $v = $v->rasterize($min, $max)) {
        foreach my $d (0..$$self{nd}-1) {
            $data .= $separators[$d]
                if $prev->get_component($d) != $v->get_component($d);
        }
        $prev = $v;
        $data .= $self->get_char($v);
    }
    return $data;
}


# expand( vector )

# Expand the storage range to include the specified point, if necessary.
# This version of expand() is meant for Sparse modules; it only adjusts the min
# and max vectors with no other effect.  Non-sparse modules should supercede
# this method to do something more meaningful.

sub expand {
    my ($self, $v) = @_;
    my $min = $$self{min};
    my $max = $$self{max};
    foreach my $d (0..$$self{nd}-1) {
        $min->set_component($d, $v->get_component($d))
            if $v->get_component($d) < $min->get_component($d);
        $max->set_component($d, $v->get_component($d))
            if $v->get_component($d) > $max->get_component($d);
    }
}


#- misc methods

#
# my %labels = labels_lookup(  )
#
# Parse the Lahey space to find sequences such as C<;:(\w[^\s;])[^;]*;>
# and return a hash reference whose keys are the labels and the values
# an anonymous array with two vectors: a vector describing the absolute
# position of the character B the trailing C<;>, and a
# vector describing the velocity that lead to this label.
#
# This method will only look in the cardinal directions; west, east,
# north, south, up, down and so forth.
#
# This allow to define some labels in the source code, to be used by
# C (and maybe some extensions).
#
sub labels_lookup {
    my $self = shift;
    my $labels = {};

    my ($min, $max) = ($$self{min}, $$self{max});
    my $nd = $$self{nd};
    my @directions = ();
    foreach my $dimension (0..$nd-1) {
        # build the array of (non-diagonal) vectors
        my $v1 = Language::Befunge::Vector->new_zeroes($nd);
        my $v2 = $v1->copy;
        $v1->set_component($dimension,-1);
        push(@directions,$v1);
        $v2->set_component($dimension, 1);
        push(@directions,$v2);
    }

    R: for(my $this = $min->copy; defined($this); $this = $this->rasterize($min, $max)) {
        V: for my $v (@directions) {
            next R unless $self->get_char($this) eq ";";
            my ($label, $loc) = $self->_labels_try( $this, $v );
            next V unless defined($label);

            # How exciting, we found a label!
            croak "Help! I found two labels '$label' in the funge space"
                if exists $labels->{$label};
            $$labels{$label} = [$loc, $v];
        }
    }

    return $labels;
}


#
# my $dims = get_dims()
#
# Returns the number of dimensions this storage object operates in.
#
sub get_dims {
    my $self = shift;
    return $$self{nd};
}


#
# my $vector = min()
#
# Returns a Vector object, pointing at the beginning of the torus.
# If nothing has been stored to a negative offset, this Vector will
# point at the origin (0,0).
#
sub min {
    my $self = shift;
    return $$self{min}->copy;
}


#
# my $vector = max()
#
# Returns a Vector object, pointing at the end of the torus.
# This is usually the largest position which has been written to.
#
sub max {
    my $self = shift;
    return $$self{max}->copy;
}


# -- PRIVATE METHODS

#
# $storage->_labels_try( $x, $y, $dx, $dy )
#
# Try in the specified direction if the funge space matches a label
# definition. Return undef if it wasn't a label definition, or the name
# of the label if it was a valid label.
#
sub _labels_try {
    my ($self, $start, $delta) = @_;
    my $comment = "";
    my $wrapping = $$self{wrapping};
    my $ip = Language::Befunge::IP->new($$self{nd});
    my $min = $self->min;
    my $max = $self->max;
    $ip->set_position($start->copy);
    $ip->set_delta($delta);

    # Fetch the whole comment stuff.
    do {
        # Calculate the next cell coordinates.
        my $v = $ip->get_position;
        my $d = $ip->get_delta;

        # now, let's move the ip.
        $v += $d;

        if ( $v->bounds_check($min, $max) ) {
            $ip->set_position( $v );
        } else {
            $wrapping->wrap( $self, $ip );
        }

        $comment .= $self->get_char($ip->get_position());
    } while ( $comment !~ /;.$/ );

    # Check if the comment matches the pattern.
    $comment =~ /^:(\w[^\s;]*)[^;]*;.$/;
    return ($1, $ip->get_position());
}


1;
__END__