#!/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<jericson-a09SyBuiYrA@public.gmane.org>

=cut

