: # *-*-perl-*-*
  eval 'exec perl -S  $0 ${1+"$@"}' 
    if 0;  # if running under some shell
#!/usr/bin/perl
#
#    Copyright (c) 1997-2024 Robert Munafo
#    License: Creative Commons Attribution-NonCommercial 4.0 International
#    Source: http://mrob.com/pub/perl/turing.txt

$g_maxrun = 50000000;

$bapropos = q`
turing(1r) - Simple interactive Turing machine simulator
`;

<< 'HEADER_END';

NAME

   turing  -- Simple interactive Turing machine simulator

   For more perl goodness, go to mrob.com/pub/perl

REVISION HISTORY
 20000128 Create, use to test sample Turing machines on my web page.
 20000128 Using regexps for all tape operations and store tape as a
string, instead of storing cells in a hash. Way faster!
 20000130 Slight speed optimizations
 20000131 Move command processing into getcommand(); add command to
edit the tape; add display(); $sincecr becomes $runfor.
 20000131 Add first-order (simple) optimization (simple period-1 loops
only). It can now easily perform runs of 1e8 steps; I did a long run
that went to 3.7e9 steps and 1.25e5 symbols with no problems.
 20000201 Add period-3 and period-4 cases to tape compression in
display().
 20001127 Update examples to include new BB(6) candidate
 20001128 Add 'g' command and options to 'r' to facilitate experiments
to analyze BB candidates.
 20001129 Add 'p', 'n' and '0' commands.
 20031104 Improve the help a bit.
 20070901 Add another sample machine; make it easier to cut and paste
the samples
 20231021 Accept 5-tuple format e.g. "2,_:3,1,>   2,1:4,1,>" when entering
machine definition.
 20240724 Accept '[' and ']' in patterns (equivalent to ':') and
explain pattern syntax in help; add 'mr' command
 20240726 Independent control of colour and 'compression' display; fix
some bugs in the 'restart' commands.
 20240730 Accept any of the 'r' restart commands after a halt.

 the next steps are:
  - dynamic compression and on-demand expansion (tape is stored in compressed format)
  - make sure it handles (1^3)1(1^4) -> (1^8)
  - try to make it easy to do searches -- e.g. "1*" gets translated
into \(1\^\d+\). Don't need to solve the whole problem now.
  - 1-cycle optimization adapt to recognize new exponent tape format
  - test it: it should now run the BB(6) further and faster

  - implement kgenerator. It needs to test for infinite loops (stepcount > 2^K * N)
  - implement kmachine. Should be able to retain on-demand exponent stuff
  - iterate 3 versions of kmachines in parallel, leanest machine survives

HEADER_END

# This is for implementing Marxen-Buntrock K-macro-machines, but not used
# yet
%kcode6 = (
  "0" => "000000", "1" => "000001", "2" => "000010", "3" => "000011",
  "4" => "000100", "5" => "000101", "6" => "000110", "7" => "000111",
  "8" => "001000", "9" => "001001", "A" => "001010", "B" => "001011",
  "C" => "001100", "D" => "001101", "E" => "001110", "F" => "001111",
  "G" => "010000", "H" => "010001", "I" => "010010", "J" => "010011",
  "K" => "010100", "L" => "010101", "M" => "010110", "N" => "010111",
  "O" => "011000", "P" => "011001", "Q" => "011010", "R" => "011011",
  "S" => "011100", "T" => "011101", "U" => "011110", "V" => "011111",
  "W" => "100000", "X" => "100001", "Y" => "100010", "Z" => "100011",
  "a" => "100100", "b" => "100101", "c" => "100110", "d" => "100111",
  "e" => "101000", "f" => "101001", "g" => "101010", "h" => "101011",
  "i" => "101100", "j" => "101101", "k" => "101110", "l" => "101111",
  "m" => "110000", "n" => "110001", "o" => "110010", "p" => "110011",
  "q" => "110100", "r" => "110101", "s" => "110110", "t" => "110111",
  "u" => "111000", "v" => "111001", "w" => "111010", "x" => "111011",
  "y" => "111100", "z" => "111101", "_" => "111110", "-" => "111111"
 );

sub initcode
{
  my($k, $v);

  foreach $k (keys %kcode6) {
    $v = $kcode6{$k};
    $kdecode6{$v} = $k;
  }
}

# display the tape
sub display
{
  my($t, $n, $head, $hdr, $stl);

  if ($runfor <= 25) {
    $t = $tape;
    $t =~ s/_//g;
    $t =~ s/://;
    $pop = length($t);
    $stl = $d_state_alpha ? chr(64+$stt) : $stt;

    $hdr = sprintf("%4d (%4d)  ", $steps, $pop);

    $t = $tape;

    if ($d_expanded) {
      $t =~ s/:(.)/[\1]/;
      $t =~ tr/_/0/ if ($d_usezeros);
      print $hdr if ($d_numbers);
      if ($d_color) {
        $t =~ s/(\[.\])/$color[$stt] . $1 . $normal/e;
      } else {
        $t = "$stl: $t";
      }
      print "$t\n";
      return;
    }

    if (length($t) > ($d_numbers ? 66 : 79)) {
      # try to compress the tape display

      # first, preserve whatever's around the head
      if ($t =~ s/(..:...)/H/) {
        $head = $1;
      } elsif ($t =~ s/(..:)/H/) {
        $head = $1;
      } elsif ($t =~ s/(:...)/H/) {
        $head = $1;
      }

      # Simple digit runs are the easiest
      while ($t =~ s/(111111+)/X/) {
        $n = length($1);
        $n = ' 1^' . $n . ' ';
        $t =~ s/X/$n/;
      }

      while ($t =~ s/(______+)/X/) {
        $n = length($1);
        $n = ' _^' . $n . ' ';
        $t =~ s/X/$n/;
      }

      # Next handle the 2-cycles (only one)
      if ($t =~ m/_1_1_1_1/) {
        $t =~ s/_1/m/g;
        while ($t =~ s/m(mm+)m/mXm/) {
          $n = length($1);
          $n = ' (_1)^' . $n . ' ';
          $t =~ s/X/$n/;
        }
        $t =~ s/m/_1/g;
      }

      # 3-cycles
      if ($t =~ m/_1__1__1__1_/) {
        $t =~ s/_1_/m/g;
        while ($t =~ s/m(mm+)m/mXm/) {
          $n = length($1);
          $n = ' (_1_)^' . $n . ' ';
          $t =~ s/X/$n/;
        }
        $t =~ s/m/_1_/g;
      }
      if ($t =~ m/1_11_11_11_1/) {
        $t =~ s/1_1/m/g;
        while ($t =~ s/m(mm+)m/mXm/) {
          $n = length($1);
          $n = ' (1_1)^' . $n . ' ';
          $t =~ s/X/$n/;
        }
        $t =~ s/m/1_1/g;
      }

      # 4-cycles
      if ($t =~ m/_1___1___1___1__/) {
        $t =~ s/_1__/m/g;
        while ($t =~ s/m(mm+)m/mXm/) {
          $n = length($1);
          $n = ' (_1__)^' . $n . ' ';
          $t =~ s/X/$n/;
        }
        $t =~ s/m/_1__/g;
      }
      if ($t =~ m/1_111_111_111_11/) {
        $t =~ s/1_11/m/g;
        while ($t =~ s/m(mm+)m/mXm/) {
          $n = length($1);
          $n = ' (1_11)^' . $n . ' ';
          $t =~ s/X/$n/;
        }
        $t =~ s/m/1_11/g;
      }
      if ($t =~ m/1__11__11__11__1/) {
        $t =~ s/1__1/m/g;
        while ($t =~ s/m(mm+)m/mXm/) {
          $n = length($1);
          $n = ' (1__1)^' . $n . ' ';
          $t =~ s/X/$n/;
        }
        $t =~ s/m/1__1/g;
      }

      # restore head area
      $t =~ s/H/$head/;
    }

    print $hdr if ($d_numbers);
    if ($d_color) {
      $t =~ s/:(.)/$color[$stt] . $1 . $normal/e;
    } else {
      $t =~ s/:(.)/[\1]/;
      $t = "$stl: $t";
    }
    $t =~ tr/_/0/ if ($d_usezeros);
    print $t;
    print "\n";
  }
} # End of dis.play

sub setup_restart
{
  my($l) = @_;
  $l =~ s/^ +//;
  $l =~ s/ +$//;
  if ($l =~ m/^r +([1-7a-gA-G]) +([^ ]+)$/) {
    # restart with state and tape
    $initstate = uc($1);
    $inittape = $2;
    $initstate =~ tr/A-G/1-7/;
    $inittape =~ tr/0/_/;
    if ($inittape =~ m/:$/) {
      $inittape .= "_";
      $initsym = "_";
    } elsif ($inittape =~ m/:(.)/) {
      # ok
      $initsym = $1;
    } elsif ($inittape =~ m/^(.)/) {
      $inittape = ":" . $inittape;
      $initsym = $1;
    }
    $running = 0;
    $restart = 1;
    $runfor = 1; # to get out of command loop
    $pattern = "";
  } elsif ($l =~ m/^r +([^ ][^ ]+)$/) {
    # restart with default and tape
    $initstate = 1;
    $inittape = $1;
    $inittape =~ tr/0/_/;
    if ($inittape =~ m/:$/) {
      $inittape .= "_";
      $initsym = "_";
    } elsif ($inittape =~ m/:(.)/) {
      # ok
      $initsym = $1;
    } elsif ($inittape =~ m/^(.)/) {
      $inittape = ":" . $inittape;
      $initsym = $1;
    }
    $running = 0;
    $restart = 1;
    $runfor = 1; # to get out of command loop
    $pattern = "";
  } elsif ($l =~ m/^r +([1-7A-G])/) {
    # restart with state
    $initstate = uc($1);
    $initstate =~ tr/A-G/1-7/;
    $inittape = ":_";
    $initsym = "_";
    $running = 0;
    $restart = 1;
    $runfor = 1; # to get out of command loop
    $pattern = "";
  } else {
    # Just do a default restart
    $initstate = 1;
    $inittape = ":_";
    $initsym = "_";
    $running = 0;
    $restart = 1;
    $runfor = 1; # to get out of command loop
    $pattern = "";
  }
} # End of setup.restart

sub getcommand
{
  my($l, $t1, $t2);

command_loop: ;
  print "More, # to skip N steps, R to restart, ? for help: ";
  $l = <>; chop $l; $l =~ tr/A-Z/a-z/;
  if ($l eq "?") {
    print
"
States are not displayed if they contain the same tape pattern as the
previously displayed state.

 /pat         - run the machine until the given pattern appears on the tape
 170          - skip 170 steps and stop pattern-searching
 /            - return to pattern-searching, using same pattern as before
 <return>     - run another 25 steps, or continue current pattern search
 f0           - Display 0 cells as '_' or '0'
 fc           - Use colour to show the head position
 fe           - Choose expanded or 'exponential' (compressed) display
 fn           - Show/hide step count and population (1's count)
 mr 9999999   - Set max steps to run while pattern searching
 r            - restart from blank tape, state 1
 r C 110:1100 - restart from state C and given tape pattern
 s/from/to/   - edit tape
 ^C           - exit

Pattern examples:
 /00[1]00    - the head on a '1' with '00' on both sides, anywhre in tape
 /^1[11*$    - all 1's with head on the second '1' (note ']' is optional)
 /00[10$     - pattern ends with 0010 with head on the 1
 /00:10$     - ':' is equivalent to '['
";

  } elsif ($l =~ m/^g +([1-7])/) {
    $l = $1;
    print "Change head state to $l\n";
    $stt = $l;

  } elsif ($l =~ m/^mr +([0-9]+)/) {
    $g_maxrun = $1 + 0;
    print "Max run amount is now $g_maxrun\n";

  } elsif ($l eq "f0") {
    # Display 0's as '_' or '0'
    $d_usezeros = ($d_usezeros == 0);

  } elsif ($l eq "fc") {
    # Use colour to show the head position
    $d_color = ($d_color == 0);

  } elsif ($l eq "fe") {
    # Switch between expanded and 'exponential' (compressed) display
    $d_expanded = ($d_expanded == 0);

  } elsif ($l eq "fn") {
    # Show step count and 1's count
    $d_numbers = ($d_numbers == 0);

  } elsif ($l eq "fs") {
    # Show state as letter or a number
    $d_state_alpha = ($d_state_alpha == 0);

  } elsif ($l =~ m/^r +[1-7a-gA-G] +[^ ]+$/) {
    &setup_restart($l);
  } elsif ($l =~ m/^r +[^ ][^ ]+$/) {
    &setup_restart($l);
  } elsif ($l =~ m/^r +[1-7A-G]$/) {
    &setup_restart($l);
  } elsif ($l eq "r") {
    &setup_restart($l);

  } elsif ("$l//" =~ m,^s/([^/]+)/([^/]*)/([gi]*)/,) {
    # edit the tape
    $from = $1; $to = $2; $opt = $3;
    $from =~ tr/0/_/; $to =~ tr/0/_/;
    $e = '$t1 =~ s/' . $from . "/" . $to . "/" . $opt . ";";
    $t1 = $tape;
    eval($e);
    if ($t1 ne $tape) {
      # success: head was not in the way of the pattern
      $tape = $t1;
      if ($tape =~ m/:/) {
        # head was not inside pattern
      } else {
        # restore head
        $tape = ":" . $tape;
      }
    } else {
      # let's try to take the head out and then do the translate
      $e = '$t1 =~ s/' . $from . "/:" . $to . "/" . $opt . ";";
      $t1 =~ s/://;
      $t2 = $t1;
      eval($e);
      if ($t1 ne $t2) {
        # yup, that worked.
        $tape = ":" . $t1;
      } else {
        print "Pattern /$from/ was not found.\n";
      }
    }
  } elsif ($l =~ m,^/(.+)$,) {
    $pattern = $1;
    $pattern =~ s|/$||;
    if ($pattern =~ m/\[[_01]\]/) {
      # okay
    } elsif ($pattern =~ m/\[/) {
      # illegal, e.g. [] or [11]
      print "[ and ] must have only 1 symbol between, ignoring.\n";
      $pattern =~ s|\[||;
    }
    $pattern =~ s|\]||;
    $pattern =~ tr/[/:/;
    $pattern =~ tr/0/_/;
    $lastpat = $pattern;
    print "Searching at most $g_maxrun steps for /$pattern/...\n";
    $runfor = $g_maxrun;
  } elsif ($l eq "/") {
    $pattern = $lastpat;
    print "Searching at most $g_maxrun steps for /$pattern/...\n";
    $runfor = $g_maxrun;
  } elsif ($l eq "") {
    $runfor = 25;
    # or search some more...
    if ($pattern ne "") {
      print "Continuing search for /$pattern/ another $g_maxrun steps...\n";
      $runfor = $g_maxrun;
    }
  } else {
    # interpret as a number: run this many more
    $pattern = "";
    $runfor = $l;
  }

  if ($runfor <= 0) {
    &display();
    goto command_loop;
  }
}

$| = 1;

# Note: These environment variables are nonstandard. I really need to find
# a standard way to test which stty erase needs to be set. It depends
# on your operating system and what type of terminal connection you're
# running in (xterm, telnet, ssh, etc.) Suggestions are welcome!
$erase_bs = $ENV{"ERASE_BS"};
$erase_del = $ENV{"ERASE_DEL"};
if ($erase_del) {
  system("stty erase '^?'");
} elsif ($erase_bs) {
  system("stty erase '^H'");
} else {
  system("stty erase '^?'");
}

initcode();

$esc = "\033";
$color[1] = $esc . "[0;1;31m";
$color[2] = $esc . "[0;1;33m";
$green = $esc . "[0;1;32m"; $color[3] = $green;
$color[4] = $esc . "[0;1;36m";
$color[5] = $esc . "[0;1;34m";
$color[6] = $esc . "[0;1;35m";
$normal = $esc . "[0m";

print "
Examples:

   The 2-state busy beaver:
       2,1,>   2,1,<
       1,1,<   h,1,<

   A binary counter:
       B,1,r  A,1,l
       A,_,l  B,_,r
       A,_,l  H,1,r

   The 4-state champion:
     2,1,r 2,1,l
     1,1,l 3,0,l
     h,1,r 4,1,l
     4,1,r 1,0,r

   A 6-state machine that runs for 8e15 steps:
     A0:B,1,>   A1:A,1,>
     B0:C,1,<   B1:B,1,<
     C0:F,_,>   C1:D,1,<
     D0:A,1,>   D1:E,0,<
     E0:h,1,<   E1:F,1,<
     F0:A,_,<   F1:C,_,< 

   The current 6-state busy beaver candidate:
       b1r c0r
       a0l d0r
       d1r h1r
       e1l d0l
       f1r b1l
       a1r e1r

All of the above are valid input: letters A-F = states 1-6;
'0' = '_'; 'l' = '<' and 'r' = '>', commas are optional.
";


$ns = 0;
$l = " ";
while($l ne "") {
  print "State rules for state ";
  print ($ns+1);
  print ": ";
  $l = <>; chop $l;

  # Allow some flexibility in turing machine rules format.
  # All of the following input lines are acceptable (standard
  # "easy to type format" on right):
  #   2/1/> B1<        21r 21l
  #   3,1,< 5_R        31l 50r
  #   40L  A_R         40l 10r
  #   11r   4,0l       11r 40l
  #   H,1/R 3,_/>      h1r 30r

  $l =~ tr/A-Z/a-z/;
  $l =~ tr/z/h/;
  $l =~ tr/abcdefg/1234567/;
  $l =~ s|[:/]|,|g;
  $l =~ tr|<>|lr|;
  $l =~ tr|0o|__|;

  $l =~ s|^ +||;
  $l =~ s| +$||;

  if ($l =~ m/^([h0-9]),?([01_]),?([lr]) +([h0-9]),?([01_]),?([lr])$/) {
    $ns++;
    $s0 = $1; $w0 = $2; $m0 = $3;
    $s1 = $4; $w1 = $5; $m1 = $6;
    $machine{"$ns _"} = "$s0 $w0 $m0";
    # print "machine{'$ns _'} = '$s0 $w0 $m0'\n";
    $machine{"$ns 1"} = "$s1 $w1 $m1";
    # print "machine{'$ns 1'} = '$s1 $w1 $m1'\n";
  } elsif ($l =~ m/^([1-9]),?_,?([h0-9]),?([01_]),?([lr]) +([1-9]),?1,?([h0-9]),?([01_]),?([lr])$/) {
    $v1 = $1; $s0 = $2; $w0 = $3; $m0 = $4;
    $v2 = $5; $s1 = $6; $w1 = $7; $m1 = $8;
    $sp2 = $ns+1;
    if (($v1 == $sp2) && ($v2 == $sp2)) {
      $ns++;
      $machine{"$ns _"} = "$s0 $w0 $m0";
      # print "machine{'$ns _'} = '$s0 $w0 $m0'\n";
      $machine{"$ns 1"} = "$s1 $w1 $m1";
      # print "machine{'$ns 1'} = '$s1 $w1 $m1'\n";
    } else {
      print "Illegal input -- conditions should both be for the state $sp2\n";
    }
  } elsif ($l ne "") {
    print "Illegal input -- skipped.\n";
  }
}

$d_color = 0;
$d_numbers = 1;
$d_expanded = 0;
$d_usezeros = 1;
$d_state_alpha = 1;

full_restart: ;
$initstate = 1;
$inittape = ":_";
$initsym = "_";

restart_here: ;
$tape = $inittape;
$stt = $initstate;
$laststate = 0; # Prevent 1-cycle optimisation
$running = 1;
$steps = 0;

$restart = 0;
$runfor = 25;

$sym = $initsym;
&display(); # print ("   0: " . $color[$stt] . "$sym$normal\n");
while($running) {
  # read symbol
  #   symbol was read immediately after previous move

  # get instructions to execute
  $do = $machine{"$stt $sym"};
  # print "run: m{'$stt $sym'} == $do\n";

  # if we're in a numbered state and if the symbol was legal, the
  # instructions will match this pattern.
  if ($do =~ m/^([h0-9]) ([1_]) ([lr])$/) {
    $stt = $1;
    $write = $2;
    $move = $3;

    # noopt will indicate we didn't do optimization
    $noopt = 1;

    if (($stt == $laststate)
#          && ($runfor - length($tape) > 25)
    ) {
      # state,sym mapped onto same state.
      # we can optimize if more of the same sym's exist beyond the current
      # head position
      if ($move eq "l") {
        # change 'sssss:s' to ':swwwww'
        # this is 5 consecutive moves and writes. 
        # we use /(s+):s/:X/ followed by /X/swwwww/
        if ($tape =~ s/($sym+):$sym/:X/) {
          $pat = $1;
          $numopt = length($pat);
          $pat = $sym . ($write x $numopt);
          $tape =~ s/X/$pat/;
          $noopt = 0;
          $steps += $numopt;
          $runfor -= $numopt;
        }
      } else {
        # change ':ssssss' to 'wwwww:s'
        # this is 5 consecutive moves and writes. 
        # we use /:(s+)s/X:s/ followed by /X/wwwww/
        if ($tape =~ s/:($sym+)$sym/X:$sym/) {
          $pat = $1;
          $numopt = length($pat);
          $pat = ($write x $numopt);
          $tape =~ s/X/$pat/;
          $noopt = 0;
          $steps += $numopt;
          $runfor -= $numopt;
        }
      }
    }

    if ($noopt) {
      # do the write
      $tape =~ s/:./:$write/;
  
      # Perform head movement, and read new tape symbol (used next time
      # through the loop).
      $lastsym = $sym; # for testing next time
      $laststate = $stt;
      if ($move eq "r") {
        if ($tape =~ s/:(.)(.)/\1:\2/) {
          $sym = $2;
        } else {
          $tape =~ s/:(.)/\1:/;
          $sym = "_";
          $tape .= $sym;
        }
      } else {
        $tape =~ s/^:/_:/;
        $tape =~ s/(.):/:\1/;
        $sym = $1;
      }
  
      $steps++;
      $runfor--;
    }

    # detect search pattern
    if ($pattern =~ m/:/) {
      # Pattern speficies head position
      $t2 = $tape;
      if ($t2 =~ m/$pattern/) {
        $l1 = length($t2);
        print ($green . "Matched pattern, tape is $l1 symbols long.$normal\n");
        $runfor = 0 if ($runfor > 0);
      }
    } elsif ($pattern ne "") {
      # Pattern ignores head position
      $t2 = $tape;
      $t2 =~ s/://;
      if ($t2 =~ m/$pattern/) {
        $l1 = length($t2);
        print ($green . "Matched pattern, tape is $l1 symbols long.$normal\n");
        $runfor = 0 if ($runfor > 0);
      }
    }

    # Show machine state
    &display();

    # Get a command if it's time
    if ($runfor <= 0) {
      &getcommand();
    }
  } elsif ($stt eq "h") {
    print "Machine halted normally after ";
    print ($steps);
    print " steps, leaving $pop filled cells.\n";
    $running = 0;
  } elsif ($stt > $ns) {
    print "State transition to unknown state $stt.\n";
    $running = 0;
  } else {
    print "Can't parse transition '$do'.\n";
    $running = 0;
  }
}

if ($restart) {
  goto restart_here;
} else {
  print "Enter a restart command, empty to restart normally, or ^C to quit: ";
  $l = <>;
  chomp $l;
  if ($l ne '') {
    if (!($l =~ m/^r /)) {
      $l = "r " . $l;
    }
    &setup_restart($l);
    if ($restart) {
      goto restart_here;
    }
  }
  goto full_restart;
}