view release on metacpan or  search on metacpan

lib/Acme/Cow/Interpreter.pm  view on Meta::CPAN

=over 4

=item new()

Return a new Cow interpreter.

=cut

sub new {
    my $proto    = shift;
    my $protoref = ref $proto;
    my $class    = $protoref || $proto;
    my $name     = 'new';

    # Check how the method is called.

    croak "$name() is a class method, not an instance/object method"
      if $protoref;

    # The new self.

    my $self = {};

    # Bless the reference into an object.

    bless $self, $class;

    # Initialize it.  The return value of init() is the object itself.

    $self -> init();
}

=pod

=item init()

Initialize an object instance. Clears the memory and register and sets the
memory pointer to zero. Also, the internally stored program source is
cleared.

=cut

sub init {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
    my $name    = 'init';

    # Check how the method is called.

    croak "$name() is an instance/object method, not a class method"
      unless $selfref;

    # Check number of arguments.

    #croak "$name(): Not enough input arguments" if @_ < 0;
    croak "$name(): Too many input arguments"   if @_ > 0;

    $self -> {prog}     = [];            # program; array of codes
    $self -> {mem}      = [0];           # memory
    $self -> {reg}      = undef;         # register
    $self -> {prog_pos} = 0;             # index of current program code
    $self -> {mem_pos}  = 0;             # index of current memory block

    return $self;
}

=pod

=item copy()

Copy (clone) an Acme::Cow::Interpreter object.

=cut

sub copy {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
    my $name    = 'copy';

    # Check how the method is called.

    croak "$name() is an instance/object method, not a class method"
      unless $selfref;

    # Check number of arguments.

    #croak "$name(): Not enough input arguments" if @_ < 0;
    croak "$name(): Too many input arguments"   if @_ > 0;

    my $copy = {};
    for my $key (keys %$self) {
        my $ref = ref $self -> {$key};
        if ($ref eq 'ARRAY') {
            @{ $copy -> {$key} } = @{ $self -> {$key} };
        } else {
            $copy -> {$key} = $self -> {$key};
        }
    }

    # Bless the copy into an object.

    bless $copy, $class;
}

=pod

=item parse_string( STRING )

Parses the given string and stores the resulting list of codes in the
object.  The return value is the object itself.

=cut

sub parse_string {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
    my $name    = 'parse_string';

    # Check how the method is called.

    croak "$name() is an instance/object method, not a class method"
      unless $selfref;

    # Check number of arguments.

    croak "$name(): Not enough input arguments" if @_ < 1;
    croak "$name(): Too many input arguments"   if @_ > 1;

    # There is no way the parser can fail. The worst thing that could happen
    # is that there are no commands in the string.

    my $string = shift; croak "$name(): Input argument is undefined"
      unless defined $string;

    # Reset, i.e., initialize, the invocand object.

    $self -> init();

    # Find the string commands, and convert them to numerical codes.

    $self -> {prog} = [
                        map { $cmd2code -> {$_} }
                          $string =~ /($cmd_regex)/go
                      ];

    return $self;
}

=pod

=item parse_file( FILENAME )

Parses the contents of the given file and stores the resulting list of codes
in the object. The return value is the object itself.

=cut

sub parse_file {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
    my $name    = 'parse_file';

    # Check how the method is called.

    croak "$name() is an instance/object method, not a class method"
      unless $selfref;

    # Check number of arguments.

    croak "$name(): Not enough input arguments" if @_ < 1;
    croak "$name(): Too many input arguments"   if @_ > 1;

    # Reset, i.e., initialize, the invocand object.

    $self -> init();

    # Get the file name argument.

    my $file = shift;

    open FILE, $file or croak "$file: can't open file for reading: $!";

    # Iterate over each line, find the string commands, and convert them to
    # numerical codes.

    while (<FILE>) {
        push @{ $self -> {prog} },
          map { $cmd2code -> {$_} }
            /($cmd_regex)/go;
    }

    close FILE or croak "$file: can't close file after reading: $!";

    return $self;
}

=pod

=item dump_mem()

Returns a nicely formatted string showing the current memory state.

=cut

sub dump_mem {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
    my $name    = 'dump_mem';

    # Check how the method is called.

    croak "$name() is an instance/object method, not a class method"
      unless $selfref;

    # Check number of arguments.

    #croak "$name(): Not enough input arguments" if @_ < 0;
    croak "$name(): Too many input arguments"   if @_ > 0;

    my $mem     = $self -> {mem};
    my $mem_pos = $self -> {mem_pos};
    my $reg     = $self -> {reg};

    my $str = '';

    # Print the contents of the memory, showing the block which the memory
    # points at.

    for (my $i = $#$mem ; $i >= 0 ; -- $i) {
        $str .= sprintf "Memory block %6u: %12d", $i, $mem->[$i];
        if ($i == $mem_pos) {
            $str .= " <<<";
        }
        $str .= "\n";
    }

    # Print the contents of the register.

    $str .= "\n";
    $str .= sprintf "Register block: %17s", defined $reg ? $reg : '<undef>';
    $str .= "\n";

    return $str;
}

=pod

=item dump_obj()

Returns a text version of object structure.

=cut

sub dump_obj {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
    my $name    = 'dump';

    # Check how the method is called.

    croak "$name() is an instance/object method, not a class method"
      unless $selfref;

    # Check number of arguments.

    #croak "$name(): Not enough input arguments" if @_ < 0;
    croak "$name(): Too many input arguments"   if @_ > 0;

    my $prog     = $self -> {prog};
    my $mem      = $self -> {mem};
    my $reg      = $self -> {reg};
    my $prog_pos = $self -> {prog_pos};
    my $mem_pos  = $self -> {mem_pos};

    my $str;

    $str .= '$obj -> {prog}     = [';
    $str .= join(', ', @$prog);
    $str .= "];\n";

    $str .= '$obj -> {prog_pos} = ';
    $str .= $prog_pos;
    $str .= ";\n";

    $str .= '$obj -> {mem}      = [';
    $str .= join(', ', @$mem);
    $str .= "];\n";

    $str .= '$obj -> {mem_pos}  = ';
    $str .= $mem_pos;
    $str .= ";\n";
    $str .= '$obj -> {reg}      = ';
    $str .= defined $reg ? $reg : '<undef>';
    $str .= ";\n";

    return $str;
}

=pod

=item execute()

Executes the source code. The return value is the object itself.

=cut

sub execute {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
    my $name    = 'execute';

    # Check how the method is called.

    croak "$name() is an instance/object method, not a class method"
      unless $selfref;

    # Check number of arguments.

    #croak "$name(): Not enough input arguments" if @_ < 0;
    croak "$name(): Too many input arguments"   if @_ > 0;

    # These variables are merely for convenience. They make the code below a
    # bit cleaner.

    my $prog     =  $self -> {prog};
    my $mem      =  $self -> {mem};
    my $prog_pos = \$self -> {prog_pos};
    my $mem_pos  = \$self -> {mem_pos};
    my $reg      = \$self -> {reg};

    # Quick exit if there are no commands (program is void).

    return 1 unless @$prog;

    # The code to be executed.

    my $code = $prog -> [$$prog_pos];

    # Main loop. Each round executes one instruction.

    {

        #print "-" x 72, "\n";
        #print "prog ...:";
        #printf " %3s", $code2cmd -> [$_] for @$prog;
        #print "\n";
        #print "ppos ...:", "    " x $$prog_pos, " ^^^\n";
        ##print "ppos ...: $$prog_pos\n";
        #print "code ...: $code ($code2cmd -> [$code])\n";
        #print "\n";
        #print "mem ....:";
        #printf " %4d", $_ for @$mem;

lib/Acme/Cow/Interpreter.pm  view on Meta::CPAN

                while ($level > 0) {

                    if ($$prog_pos == $#$prog) {
                        croak "No following 'moo' command matching 'MOO'",
                          " command. Failed at instruction number $init_pos.";
                    }

                    $prev_code = $prog -> [$$prog_pos];
                    $$prog_pos ++;

                    if ($prog -> [$$prog_pos] == 7) {         # if "MOO"
                        $level ++;
                    } elsif ($prog -> [$$prog_pos] == 0) {    # if "moo"
                        $level --;
                        if ($prev_code == 7) {
                            $level --;
                        }
                    }
                }

                # This if-test is necessary if we use 'last' rather than
                # 'croak' in the if-test inside the while-loop above.
                #
                #if ($level != 0 ) {
                #    croak "No following 'moo' command matching 'MOO'",
                #      " command. Failed at instruction number $init_pos.";
                #}

                last if $$prog_pos == $#$prog;
                $$prog_pos ++;
                $code = $prog -> [$$prog_pos];

            } else {

                last if $$prog_pos == $#$prog;
                $$prog_pos ++;
                $code = $prog -> [$$prog_pos];

            }

        }

        # Code: OOO

        elsif ($code == 8) {

            $mem -> [$$mem_pos] = 0;

            last if $$prog_pos == $#$prog;
            $$prog_pos ++;
            $code = $prog -> [$$prog_pos];

        }

        # Code: MMM

        elsif ($code == 9) {

            if (defined $$reg) {
                $mem -> [$$mem_pos] = $$reg;
                $$reg = undef;
            } else {
                $$reg = $mem -> [$$mem_pos];
            }

            last if $$prog_pos == $#$prog;
            $$prog_pos ++;
            $code = $prog -> [$$prog_pos];

        }

        # Code: OOM

        elsif ($code == 10) {

            printf "%d\n", $mem -> [$$mem_pos];

            last if $$prog_pos == $#$prog;
            $$prog_pos ++;
            $code = $prog -> [$$prog_pos];

        }

        # Code: oom

        elsif ($code == 11) {

            my $input = <STDIN>;
            croak "Input was undefined\n"
              unless defined $input;
            $input =~ s/^\s+//;
            $input =~ s/\s+$//;
            croak "Input was not an integer -- $input\n"
              unless $input =~ /^[+-]?\d+/;

            $mem -> [$$mem_pos] = $input;

            last if $$prog_pos == $#$prog;
            $$prog_pos ++;
            $code = $prog -> [$$prog_pos];

        }

        # An invalid instruction exits the running program.

        else {
            return 1;
        }

        redo;
    }

    return $self;
}

=pod

=back

=head1 NOTES

=head2 The Cow Language

The Cow language has 12 instruction. The commands and their corresponding
code numbers are:

=over 4

=item moo (0)

This command is connected to the B<MOO> command. When encountered during
normal execution, it searches the program code in reverse looking for a
matching B<MOO> command and begins executing again starting from the found
B<MOO> command. When searching, it skips the command that is immediately
before it (see B<MOO>).

=item mOo (1)

Moves current memory position back one block.

=item moO (2)

Moves current memory position forward one block.

=item mOO (3)

Execute value in current memory block as if it were an instruction. The
command executed is based on the instruction code value (for example, if the
current memory block contains a 2, then the B<moO> command is executed). An