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

On Fri, 17 Sep 2004 03:43:05 +0700, Bill Tucker <[email protected]> wrote:
> I was a little surprised at how easy this was. I'd studied Turing
> machines in school, but had never actually implemented one.
> 

Same here !! :)

This is my first QOTW attempt, and Im happy that I could do it
"relatively" easily. (Apart from getting the Hash to work ;)

Here's my entry, and suggestions on the approach/ critiques welcome ..

Thanks
Abhinav
--------------------------------------------------------------------------------

#!/local/perl5.8/bin/perl
use strict;
use warnings;
#use Data::Dumper;

die "No File as input!" if (!$ARGV[0] or !-f $ARGV[0]);
die "Incorrect input string" if ($ARGV[1] and $ARGV[1] !~ /^\s*\w+\s*$/ );

my %table;
my %states;
my $sr;     # The State Register
my $tape="_________";   # The Tape
my $head;   # The Head;
my $curVal;
my $newVal;
my $dir;

$tape = $ARGV[1] if ($ARGV[1]);

initTable();
$tape = '_'. $tape;
$head=1;

while(1)
{
 $curVal=substr($tape,$head,1);
 #print $curVal . "\n";

 (
 $sr = $table{$sr}{$curVal}[0] and
 $newVal = $table{$sr}{csurVal}[1] and
 $dir = $table{$sr}{$curVal}[3]
 )||
 ( $tape =~ s/^_*(.*)$/$1/ and $tape =~ s/^(\w*?)_*$/$1/ and print
$tape."\n" and exit);
 substr($tape,$head,1,$newVal);
 $head += 1 if ($dir eq 'R');
 appendRight() if (! substr($tape,$head,1));
 $head -= 1 if ($dir eq 'L');
 appendLeft() if ($head <= 0);
}

sub initTable
{

 open(FH, "<$ARGV[0]") or die "Could not open tm file $ARGV[0] : $!";
 my @lines = <FH>;
 close (FH) or die "Could not close tm file $ARGV[0] : $!";
 my $stateCnt = 1;

 for (@lines)
 {
   chomp $_;
   (print "skipped $_ \n" && next) if (/^\s*$/ || /^\s*#.*/ );
   die "Incorrect file format: line $_"
         if (! /^\s*(\w+)\s+(\w)\s+(\w+)\s+(\w)\s+([LR])\s*.*$/i);
   $states{$1} = $stateCnt++ if (!$states{$1});
   $sr=$states{$1}  unless($sr);
   $states{$3} = $stateCnt++ if (!$states{$3});
   $table{$states{$1}}{$2} = [$states{$3},$4,uc($5)] if (!
$table{$states{$1}}{$2}) or
           die "More than 1 rule for same state/input" ;
 }
 #print Dumper(\%table);
}

sub appendLeft
{
$tape="_" x 10 . $tape;
$head += 10;
}

sub appendRight
{
$tape .= "_" x 10;
}

-----------------------------------------------------------------------------
> I catch one thing I think is an input error that didn't (unless I
> missed it) get mentioned in the problem statement - more than one
> line in the program for a given state/tape symbol.
> 
> Thanks, that was fun.
> 
> Bill
> 
> ---------------------------------------------------------------
> 
> #!/usr/bin/perl
> 
> use strict;
> 
> my (@tape, $tapePos, $state, %transitions, $filename, $new, $out, $move);
> 
> @tape = ();
> $tapePos = 0;
> %transitions = ();
> 
> sub parse_pgm
>      {
>      my $filename = shift;
>      my ($fh);
> 
>      open ($fh,"<$filename") or die "Couldn't open $filename";
> 
>      while (<$fh>)
>          {
>          /^\s*(#.*)?$/ and next; # Skip blank and comment lines
>          /^\s*(\w+)\s+(\w+)\s+(\w+)\s+(\w+)\s+([LR])\s*(#.*)?$/i or
> die "Illegal line at line number $.: $_";
>          (defined($state)) or $state = $1;  # This inits the state to
> the first one in the pgm
>          (defined($transitions{$1}{$2})) and die "Stop confusing me!
> There are two program lines for state $1, tape value $2";
>          $transitions{$1}{$2} = { 'STATE'=>$3, 'VALUE'=>$4, 'MOVE'=>$5 };
>          }
>      close ($fh);
>      }
> 
> sub move
>      {
>      my $direction = shift;
> 
>      if (uc($direction) eq "L")
>          {
>          ($tapePos == 0) ? (unshift (@tape, '_')) : ($tapePos--);
>          }
>      else    # We made sure the direction was "L" or "R" when we parsed the pgm
>          {
>          (defined($tape[++$tapePos]))  or push (@tape, '_');
>          }
>      }
> 
> # Start of main
> 
> ($filename = shift) or die "You didn't give me a program file!";
> (@ARGV) ? (@tape = split('',shift)) : ($tape[$tapePos] = '_');
> 
> &parse_pgm($filename);
> 
> while (defined($transitions{$state}{$tape[$tapePos]}))
>      {
>      $new = $transitions{$state}{$tape[$tapePos]};
>      $state          = $new->{STATE};
>      $tape[$tapePos] = $new->{VALUE};
>      &move($new->{MOVE});
>      }
> 
> $out = join('',@tape);
> $out =~ s/^\_*(.*?)\_*$/$1/;
> print $out."\n";
> exit;
> 
> 



-- 
-------------
http://www.abhinavmodi.tk