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

my $progfile = shift;
my $tape = shift||'_';

my @tape = split '', $tape;
my $pos = 0;
my ($progref, $state) = get_program($progfile);

my $end;
my $taperef = \@tape;

while (!$end)
{
 ($state, $pos, $taperef, $end) = do_step($progref, $state, $pos, $taperef);
}

print_tape($taperef);

sub get_program
{
 my $progfile = shift;
 open PROG, $progfile or die "Couldn't open programfile |$progfile| for
reading: $!";

 my (%program,$register);

 for (<PROG>)
 {
   chomp;
   s/#.*//;
   next if /^\s*$/; #liberal def of 'blank line'

   if (/^(\w+)\s+(\w)\s+(\w+)\s+(\w)\s+([LR])\s*$/)
   {
     my ($state, $readcell, $newstate, $writecell) = ($1,$2,$3,$4);
     my $shift = ($5 eq 'L' ? -1 : 1);
     $program{$state}{$readcell} = {newstate => $newstate,
                               writecell => $writecell,
                               shift => $shift};
     $register = $state unless defined $register;
   }
   else
   {
     die "Fatal error - Illegal instruction |$_| at line $. of program
|$progfile|\n";
   }
 }

 return \%program, $register;
}

sub do_step
{
 my ($progref, $state, $pos, $taperef) = @_;
 my @tape = @{$taperef};

 my $read = $tape[$pos];

 return (undef,undef,$taperef,1) unless exists $progref->{$state} and exists
$progref->{$state}{$read};

 my $instruction = $progref->{$state}{$read};

 $state = $instruction->{newstate};
 $tape[$pos] = $instruction->{writecell};
 $pos += $instruction->{shift};

 if ($pos == -1)
 {
   $pos = 0;
   unshift @tape, '_';
 }
 elsif ($pos == @tape)
 {
   push @tape, '_';
 }

 return $state, $pos, \@tape, 0;
}

sub print_tape
{
 my $taperef = shift;
 my @tape = @{$taperef};
 shift @tape while @tape and $tape[0] eq '_';
 pop @tape while @tape and $tape[-1] eq '_';

 print @tape, "\n";
}

__END__
