Re: Perl Quiz of the Week #24 (Turing Machine simulation)

On Wed, Sep 15, 2004 at 10:01:18AM -0400, Zed Lopez wrote:

>IMPORTANT: Please do not post solutions, hints, or other spoilers
>        until at least 60 hours after the date of this message.
>        Thanks.

Oh well. I'm following the moderator's example...

>For the Regular Quiz of the Week 24, we'll implement a Turing Machine.

#! /usr/bin/perl -w

=pod
This includes Colin Rafferty's suggestion of an optional third
parameter to set initial tape position.

The tape is stored in a hash; this probably isn't as fast as keeping it
in an array, but allows me to use the absence of a value as an
empty-cell marker (which makes the determination of the final size of
the tape much easier). This is the reason for the exists() checks.

The state vectors are stored in a separate hash for convenience of
lookup.

The only limits on the length of tape, length of state name, or total
size of state vector set are the available memory of the machine and
the maximum size of perl's variables.

There is some error-checking on loading the state vectors and initial
tape.
=cut

use strict;
use integer;

# initialise state vectors and set initial state
my %sv;
my $state='';
my $file=shift @ARGV || die "specify a state-vector filename\n";
open F,"<$file";
while (<F>) {
  chomp;
  s/#.*//;
  s/\s+$//;
  if ($_) {
    my @s=split ' ',$_;
    if (scalar @s != 5) {
      die "wrong number of parameters at line $. : $_\n";
    }
    if ($s[0] =~ /\W/ || $s[2] =~ /\W/) {
      die "invalid state name at line $. : $_\n";
    }
    if ($s[1] !~ /^\w$/ || $s[3] !~ /^\w$/) {
      die "invalid tape content at line $. : $_\n";
    }
    if ($s[4] !~ /^[LR]$/) {
      die "invalid movement direction at line $. : $_\n";
    }
    unless ($state) {
      $state=$s[0];
    }
    $sv{$s[0]}{$s[1]}=[@s[2..4]];
  }
}
close F;

# initialise tape
my %tape;
if (my $t=shift @ARGV) {
  if ($t =~ /\W/) {
    die "invalid character in initial tape\n";
  }
  my $n=0;
  foreach my $c (split '',$t) {
    if ($c ne '_') {
      $tape{$n}=$c;
    }
    $n++;
  }
}

# set initial position on tape
my $position=0;
if (my $p=shift @ARGV) {
  $position=0+$p;
}

# main loop
while (1) {
  my $char='_';
  if (exists $tape{$position}) {
    $char=$tape{$position};
  }
  if (exists $sv{$state}{$char}) {
    ($state,$tape{$position},my $move)=@{$sv{$state}{$char}};
    if ($tape{$position} eq '_') {
      delete $tape{$position};
    }
    if ($move eq 'L') {
      $position--;
    } else {
      $position++;
    }
  } else {
    last;
  }
};

# output tape, trimming blank leader/trailer
if (%tape) {
  my @t=sort {$a <=> $b} keys %tape;
  foreach my $t ($t[0]..$t[-1]) {
    if (exists $tape{$t}) {
      print $tape{$t};
    } else {
      print '_';
    }
  }
}
print "\n";