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

Good clean fun, as previous respondents indicated. I'm not all
that pleased with my result - this can all be expressed more
concisely and elegantly. As I'm sure someone will demonstrate
in a minute :)

I am somewhat befuddled by the behaviour of $. in my 'die'
clause at line 46 - this reports the last line number of the
program file, rather than the current line, as I would expect
it to. Anyone care to clue me in?

(I'm considering writing this in another language. It can be
done, but can _I_ pull it off?)



#!/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__

--
Jurgen Pletinckx
AlgoNomics NV