Re: [SPOILER] Perl Quiz of the Week #24 (Turing Machine simulation)

Mark Jason Dominus <[email protected]> writes:

>>     if (/^(\w+)\s+(\w)\s+(\w+)\s+(\w)\s+([LR])\s*$/)
>
> I'm surprised that all four of the sample solutions posted so far use
> a complicated-looking regex like this instead of going for 'split',
> seemed to me to be the obvious and straightforward technique.

I thought about the regex solution, but I wanted better error
messages.

> Here's mine.  I probably spent as much time fussing with the format of
> the debugging output as I did with the rest of the program combined.
> Not counting the debugging output section, the program is only 26
> lines long, and I don't think it is obfuscated.

I wrote mine by writing test cases first -- stating with
helloworld.tm.  Getting the three examples working was
straightforward.  Coming up with all of the thing that can go wrong,
took a bit more time.  Thanks, Andrew Dalke for providing some really
good tests. :-)

CPAN has a Turing module
(http://search.cpan.org/~grommel/Acme-Turing-0.01/), which I looked at
after I had a solution.  Unfortunately, it didn't yield many test
cases.  Here's a (significantly modified) example:

  start 0 maybe _ R
  start 1 erase 1 R

  maybe 1 erase 1 R
  maybe 0 maybe _ R
  maybe _ stop 0 R

  erase 1 erase _ R
  erase 0 erase _ R
  erase _ stop _ R


I idly considered implementing a Turing Machine
in Conway's Game of Life (see
http://rendell.server.org.uk/gol/tm.htm), but that seemed like
work. :-)

I was wishing for a macro feature so that I could implement optional
tracing, without hurting performance when tracing was turned off.
I've been reading On Lisp (http://www.paulgraham.com/onlisp.html), and
that seems like a pretty big advantage lisp has over perl at the
moment.

The other thing I miss is the binary // operator from
<http://dev.perl.org/perl6/apocalypse/A03.html>, so I could say:

  $tape //= '_';

rather than:

  $tape = '_' unless defined $tape;


I implemented the optional third argument specifying a tape position,
but otherwise it's fairly similar to the other solutions that use an
array for the tape.  There's something very gratifying about a machine
with only four parts: a tape (array), a state table (hash), a state
register (scalar) and the tape head (scalar).


#!/usr/bin/perl -w
use strict;

# Perl Quiz of the Week #24 (Turing Machine simulation)

use Pod::Usage;
pod2usage("$0: not enough arguments") unless @ARGV > 0;
pod2usage("$0: too many arguments") if @ARGV > 3;

# The third argument is the initial position of the tape head.
my $head = pop if @ARGV == 3;
$head = 0 unless defined $head;

# The second argument is the initial state of the tape.
my $tape = pop if @ARGV == 2;
$tape = '_' unless defined $tape;
die "tape may not contain '$1'" if $tape =~ /([^\w])/;

my @tape = split(//, $tape);

while ($head > $#tape) {
    push @tape, '_';
}

while ($head < 0) {
    unshift @tape, '_';
    $head++;
}

my %prog;
my $state;

my $file = pop;
{
    no strict 'refs';
    open($file, $file) or die "can't open $file: $!";
};

while (<$file>) {
    chomp;
    s/#.*//;
    my ($old, $read, $new, $write, $move) = split;
    next unless defined $old;

    # Most of these error checks aren't really needed.  I included
    # them to comply with the spec.

    if ($old =~ /([^\w])/){
        warn "instruction skipped since state may not contain '$1': '$_'";
        next;
    };

    die "state may not contain '$1'" if $new =~ /([^\w])/;

    die "this machine can only write one of A-z0-9_ to tape"
      unless $write =~ /^\w$/;

    unless ($read =~ /^\w$/){
        warn "instruction will never be executed: '$_'";
        next;
    };

    # I'll forgive lowercase
    $move = uc($move);
    die "movement must be either 'L' or 'R'"
      unless ($move eq 'L' or $move eq 'R');

    $state = $old unless defined $state;
    warn "new instruction '$_' replacing previous '$prog{$old}{$read}[3]'"
      if exists $prog{$old}{$read};
    $prog{$old}{$read} = [$new, $write, $move, $_];
}

close $file or warn "close of $file failed: $!";

die "no valid instructions found" unless defined $state;

while (exists($prog{$state}{$tape[$head]})){
   my @inst = @{$prog{$state}{$tape[$head]}};

    $tape[$head] = $inst[1];

    if ($inst[2] eq 'R') {
        $head++;
        $tape[$head] = '_' unless defined $tape[$head];
    } else {
        $head--;
        if ($head < 0) {
            unshift @tape, '_';
            $head = 0;
        }
    }

    $state = $inst[0];
}

print format_tape(@tape), "\n";

exit (0);

sub format_tape{
    for (join('', @_)) {
        s/^_*//;
        s/_*$//;
        return $_;
    }
};

__END__

=head1 NAME

tm.pl - B<T>uring B<M>achine simulator

=head1 SYNOPSIS

B<tm.pl> I<program_file> [I<tape> [I<head_position>]]

=head1 SEE ALSO

I<http://article.gmane.org/gmane.comp.lang.perl.qotw.quiz-of-the-week/113>
for a complete description.

I<http://perl.plover.com/~alias/list.cgi?1:mss:2202:200409:pkjnoemnogpnbdkajdih>
for details about the optional third argument.

=head1 AUTHOR

Jon Ericson I<[email protected]>

=cut

Thanks for a satisfying quiz,
Jon