#!/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);

