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

>     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.

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 used an array to represent the tape.  Getting an infinite tape is
not as difficult as some people seemed to think it would be.  There
are at least three techniques that occurred to me.  One would be to
have

        TAPE(n) is stored in $tape[1 - 2*$n] when n <  0
                          in $tape[    2*$n] when n >= 0        

and an alternative would use this as a backend to a tied array which
would interpret the negative subscripts transparently.

A third way is the way I did it in this program, which I think is
simple and elegant.

The program supports a tape head motion of 'N' = 'none'; to suppress
this feature, delete that entry from the %motion hash.


#!/usr/bin/perl

my ($prog, $tape) = @ARGV;
@TAPE = defined($tape) ? split(//, $tape) : ('_');
$HEAD = 0;

open P, "<", $prog
  or die "Couldn't open '$prog': $!; aborting";

{
  my %motion = (L => -1, R => 1, N => 0);
  while (<P>) {
    s/\#.*$//;
    next unless /\S/;
    my ($instate, $intape, $outstate, $outtape, $motion) = split;
    $STATE = $instate unless defined $STATE;
    die "Unknown tape head motion '$motion'" unless exists $motion{$motion};
    /^\w$/ or die "Unknown tape symbol '$_'" for $intape, $outtape;
    $transition{$instate}{$intape} = [$outstate, $outtape, $motion{$motion}];
  }
  close P;
}

while (my $ttab = $transition{$STATE}) {

  if ($ENV{DEBUG}) {
    print sprintf("%5s: ", $STATE);
#    print @TAPE[0..$HEAD-1], ".$TAPE[$HEAD].",
    @TAPE[$HEAD+1..$#TAPE], "\n";
    print join("", map $_ == $HEAD   ? "<$TAPE[$_]" :
                       $_ == $HEAD+1 ? ">$TAPE[$_]" : " $TAPE[$_]",
                           0 .. $#TAPE),
          "\n";
  }

  my $inc;
  ($STATE, $TAPE[$HEAD], $inc) = @{$ttab->{$TAPE[$HEAD]}};
  $HEAD += $inc;

  # Extend the tape
  while ($HEAD < 0) {
    $HEAD++;
    unshift @TAPE, '_';
  }
  $TAPE[$HEAD] = '_' if $HEAD >= @TAPE;
}

shift @TAPE while @TAPE && $TAPE[0]  eq '_';
  pop @TAPE while @TAPE && $TAPE[-1] eq '_';

print @TAPE, "\n";