#!/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";
