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

My Turing machine simulator is simple, and not very different from some of
the solutions posted.  I used an array for the tape, and unshift'ed a
blank (and re-calibrated the tape head) whenever the tape head fell off
the left.

Supports a --debug option, which prints a line to STDERR for each
iteration including the state, the tape, and tape head position.  Also
supports a --maxiterations option, in case a billion iterations isn't
enough (or too much).

I also started work on a macro processor, but I lost interest. :)

Great puzzle, easy and fun!  Thanks!
-- Dan

- - -

#!/usr/bin/perl -w

# turing, a simulation of a Turing Machine
# By Dan Sanderson
# For Perl Quiz of the Week # 24

use Getopt::Long;
my $debug = 0;
my $maxiterations = 1_000_000_000;
my $result = GetOptions('debug' => \$debug,
			'maxiterations:i' => \$maxiterations,
		       );

my $state;
my @tape;  # Undefined cells are considered blank.
my $headpos = 0;

# The instruction table.
# $progtable{oldstate}->{oldtape} = [newstate, newtape, headmove]
my %progtable;

if (!$result || (scalar(@ARGV) != 1 && scalar(@ARGV) != 2)) {
    die "Usage: $0 [--debug] [--maxiterations=#] programfile [tapestring]\n";
}

# Initialize tape string.
if (defined($ARGV[1])) {
    die "Invalid initial tapestring\n" if $ARGV[1] !~ /^[a-zA-Z0-9_]+$/;
    @tape = split(//, $ARGV[1]);
}

# Read instruction table from file.
open my $fh, $ARGV[0] or die "Could not open $ARGV[0] for reading: $!\n";
while (defined(my $line = <$fh>)) {
    # Strip comments and whitespace, skip lines without commands.
    $line =~ s/\#.*$//;
    $line =~ s/\s+$//;
    $line =~ s/^\s+//;
    next if !$line;

    my ($oldstate, $oldtape, $newstate, $newtape, $headmove) = split(/\s+/, $line);
    if (!defined($oldstate)
	|| !defined($oldtape)
	|| !defined($newstate)
	|| !defined($newtape)
	|| !defined($headmove)
       ) {
	die "Syntax error in program on line $.: too few elements\n";
    }
    if ($oldtape !~ /^[a-zA-Z0-9_]$/
	|| $newtape !~ /^[a-zA-Z0-9_]$/
	|| $oldtape !~ /^\w+$/
	|| $newtape !~ /^\w+$/
	|| ($headmove ne 'L' && $headmove ne 'R')
       ) {
	die "Syntax error in program on line $.: invalid elements\n";
    }

    # Initialize state from first instruction.
    $state = $oldstate if (!defined($state));

    # Detect instruction overwrites.
    die "Attempt to overwrite an instruction on line $.\n"
	if (exists($progtable{$oldstate})
	    && exists($progtable{$oldstate}->{$oldtape}));

    # Store instruction in table.
    $progtable{$oldstate}->{$oldtape} = [$newstate, $newtape, $headmove];
}
close $fh;

# A subroutine that prints the state and tape, with head position indicated.
sub display_state {
    printf STDERR "%-20s", $state;
    for (my $i = 0; $i <= $#tape; $i++) {
	if ($i == $headpos) {
	    print STDERR "[".(defined($tape[$i]) ? $tape[$i] : '_')."]";
	} else {
	    print STDERR defined($tape[$i]) ? $tape[$i] : '_';
	}
    }
    if ($headpos > $#tape) {
	print STDERR '_' x ($headpos - $#tape - 1), '[_]';
    }
    print STDERR "\n";
}

my $iterations = 0;
my $action;
while (exists($progtable{$state})
       && exists($progtable{$state}->{(defined($tape[$headpos]) ? $tape[$headpos] : '_')})
       && ($action = $progtable{$state}->{(defined($tape[$headpos]) ? $tape[$headpos] : '_')})
      ) {
    &display_state if $debug;

    my ($newstate, $newtape, $headmove) = (@{$action});
    $state = $newstate;

    if ($newtape eq '_') {
	# Continue to use undef (not '_') for blanks in tape array.
	undef($tape[$headpos]);
    } else {
	$tape[$headpos] = $newtape;
    }

    if ($headmove eq 'L') {
	--$headpos;
    } elsif ($headmove eq 'R') {
	++$headpos;
    }

    # Shift tape if head falls off the left.
    if ($headpos < 0) {
	unshift @tape, undef;
	$headpos = 0;
    }

    die "Maximum iterations reached ($iterations), aborting\n"
	if (++$iterations > $maxiterations);
}
&display_state if $debug;

# Print the final tape, starting from first non-blank to last non-blank,
# outputting interior blanks as '_'.
shift @tape while (!defined($tape[0]));
pop @tape while (!defined($tape[$#tape]));
@tape = map { !defined($_) ? '_' : $_ } @tape;
print @tape, "\n";

exit(0);

__END__