Turing machine

Here is my Turing machine implementation. The code is very messy, but I 
have already spent too much time on it to clean it up, sorry...

I have provided a few options:

--start allows you to start at any position in the tape (normally you 
start at position 0, where the first character of the tape is; positive 
values move to the right of the tape, negative values move backward).

--init allows you to specify the initial state. (This is useful when 
using the extended syntax, for instance. See below)

--debug shows the machine working.

--notrim outputs the portion of the tape that was worked on. By 
default, whitespace is trimmed from the output.

--help displays an help message and quits.

--extend turns on the extended syntax. This is just syntactic sugar and 
adds no special abilities to the machine. In the extended syntax, you 
can use patterns such as /a-z0-9/ to specify character ranges in the 
first state/symbol pairs. You can also use ¥1, ¥2, ... ¥9. In the next 
three fields (next state, symbol to write and direction to go) you can 
use $1, ... $9 to use the values that were matched in the lefthand part 
and `...` to include perl code to be evaluated. This is *very* brittle 
and doesn't work for everything. (In a nutshell: everything is put into 
a string then passed to eval. A `code` section is transformed into 
"@{[do{code}]}" in order to be evaluated inside a string. This is a 
really ugly hack.)

Here is a short program that turns a word into uppercase, using the 
extended syntax.

   s0  /A-Z0-9/  s0  $1        R
   s0  /a-z/     s0  `uc($1)`  R

It is equivalent to:

   s0  A  s0  A  R
   s0  B  s0  B  R
   ...
   s0  9  s0  9  R
   s0  a  s0  A  R
   ...
   s0  z  s0  Z  R

I also rewrote the decimal addition (excellent program!) to show some 
features of the extended syntax:

   SeekR1          _       SeekR2       _       R
   SeekR/12/       /0-9/   SeekR$1      $2      R
   SeekR2          _       Dec          _       L
   Dec             /1-9/   NoMoveSeekL  `$1-1`  R
   Dec             0       Dec          9       L
   Dec             _       CleanUp      _       R
   CleanUp         9       CleanUp      _       R
   CleanUp         _       End          _       R
   SeekL1          /0-9/   SeekL1       $1      L
   SeekL1          _       Inc          _       L
   Inc             _       NoMoveSeekR  1       L
   Inc             /0-8/   NoMoveSeekR  `$1+1`  L
   Inc             9       Inc          0       L
   NoMoveSeek/LR/  /0-9_/  Seek`$1`1    $2      $1

Here is the code. Again I apologize for the mess :)


--
Julien
:wq

#!/usr/bin/perl

use strict;
use warnings;
use Getopt::Long;

# Command line options
my $DEBUG = 0;
my $HELP = 0;
my $START = 0;
my $TRIM = 1;
my $INIT = "";
my $EXT = 0;
GetOptions("debug!" => \$DEBUG, "extended!" => \$EXT, help => \$HELP,
   "initial=s" => \$INIT, "start=s" => \$START, "trim!" => \$TRIM);

# Regex for an atomic unit pattern (normally just \w, but more complex 
with the
# extended syntax)
my $PAT1 = $EXT ? '(?:\w|\/[\w-]+\/|\\\\\d)' : "\\w";
my $PAT2 = $EXT ? '(?:\w|\$\d|`[^`]+`)' : "\\w";
my $PATLR = $EXT ? '(?:\w|\$\d|`[^`]+`)' : "[LR]";

# Display the help message then quit
if ($HELP) {
   print <<HELP;

Usage: $0 [options] program_file [tape]

Options are:
   --debug, --nodebug: turns debugging on or off.
   --extended, --noextended: use extended syntax or not.
   --help: shows this message and exits.
   --initial q: intial state is q.
   --start p: starts at position p in the tape (first position is 0).
   --trim, --notrim: trim _ characters at beginning and end of output.

HELP
   exit;
}

# Get the arguments (program file and optional initial tape)
my ($program, $tape) = @ARGV;
die "No program given.\n" if !defined $program;
warn "Extra arguments ignored: @ARGV[2 .. $#ARGV]\n" if @ARGV > 2;

# Read in the program
my %states = ();
my $q = $INIT;
open PROGRAM, $program or die "Cannot open program file $program: $!\n";
while (<PROGRAM>) {
   my $line = $_;
   # Normalize space and remove comments, skip empty lines
   s/\s+/ /g;
   s/^ //;
   s/#.*$//;
   s/ $//;
   next if !$_;
   # Syntax checking
   if (!m!($PAT1+) ($PAT1) ($PAT2+) ($PAT2) ($PATLR)!) {
     my $msg = "Sytnax error, line $.:\n  $line";
     $msg .= "(perhaps you forgot the --extend flag?)\n" if !$EXT;
     die $msg;
   }
   # Get value for initial state
   $q = $1 if $q eq "";
   my $rx = "$1 $2";
   my $rest = [map { s/`([^`]+)`/\@{[do{$1}]}/g; $_ } my @rest = ($3, 
$4, $5)];
   $rx =~ s!/([\w-]+)/!([$1])!g if $EXT;
   die "Redefinition of state $1 / symbol $2 at line $..\n"
     if exists $states{$rx};
   $states{$rx} = $rest;
   print STDERR "$rx => @$rest\n" if $DEBUG;
}
close PROGRAM;

# Initialize the tape and check the start state
die "Cannot use $q as initial state.\n" if $q =~ /\W/;
my $pos = $START;
$tape = "_" if !defined $tape;
die "Illegal symbols on tape.\n" if $tape =~ /\W/;
my @tape = split //, $tape;
# Add symbols to the tape if the start position is outside of the range
# specified by the initial values
if ($pos < 0) {
   unshift @tape, ("_") x -$pos;
   $pos = 0;
} else {
   push @tape, ("_") x ($pos - $#tape);
}
my $start = 0;
my $end = $#tape;

# Run the program
while (my @states = grep { "$q $tape[$pos]" =~ /^$_$/ } keys %states) {
   die "Too many possible matches for $q/$tape[$pos] (",
     join(", ", map { s! !/!; $_ } @states), ").\n" if @states > 1;
   "$q $tape[$pos]" =~ /$states[0]/;
   my ($next, $new, $move) = map { eval "\"$_\"" } 
@{$states{$states[0]}};
   die "Next state cannot be $next.\n" if $next !~ /^\w+$/;
   die "Cannot write symbol \"$new\" on tape.\n" if $new !~ /^\w$/;
   die "Cannot move in direction \"$move\".\n" if $move !~ /^[LR]$/;
   print STDERR "... @tape ...\n", " " x (2 * $pos + 4),
     "^ $q -> $next, $new, $move\n" if $DEBUG;
   # Update the state
   $q = $next;
   $tape[$pos] = $new;
   $end = $pos if $end < $pos;
   # The tape is infinite but stored in an array, so if we go past one 
end we
   # have to add symbols.
   if ($move eq "L") {
     --$pos;
     --$start if $pos < $start;
     if ($pos < 0) {
       $pos = 0;
       $start = 1;
       ++$end;
       unshift @tape, "_";
     }
   } else {
     ++$pos;
     if ($pos == @tape) {
       push @tape, "_";
     }
   }
}
# Show the state one last time (once the program has finished running)
print STDERR "... @tape ...\n", " " x (2 * $pos + 4), "^ $q\n" if 
$DEBUG;

# Output the result
my $result = join "", @tape[$start .. $end];
if ($TRIM) {
   print STDERR "Trimming result $result\n" if $DEBUG;
   $result =~ s/^_+//;
   $result =~ s/_+$//;
}
print "$result\n";