;; "A Turing Turtle": a Turing Machine implemented in NetLogo
;;    by Dan Dewey 1/16/2016
;;
;; This NetLogo code implements a Turing Machine, see, e.g.,
;;    http://en.wikipedia.org/wiki/Turing_machine
;; The Turing machine fits nicely into the NetLogo paradigm in which
;; there are agents (aka the turtles), that move around
;; in a world of "patches" (2D cells).
;; Here, a single agent represents the Turing machine read/write head
;; and the patches represent the Turing tape values via their colors.
;; The 2D array of patches is treated as a single long 1D tape in an
;; obvious way.

;; This program is presented as a NetLogo example on the page:
;;    http://rosettacode.org/wiki/Universal_Turing_machine
;;    This file may be larger than others on that page, note however
;;    that I include many comments in the code and I have made no
;;    effort to 'condense' the code, prefering clarity over compactness.
;; A demo and discussion of this program is on the web page:
;;    http://sites.google.com/site/dan3deweyscspaimsportfolio/extra-turing-machine
;; The Copy example machine was taken from:
;;    http://en.wikipedia.org/wiki/Turing_machine_examples
;; The "Busy Beaver" machines encoded below were taken from:
;;    http://www.logique.jussieu.fr/~michel/ha.html

;; The implementation here allows 3 symbols (blank, 0, 1) on the tape
;; and 3 head motions (left, stay, right).

;; The 2D world is nominally set to be 29x29, going from (-14,-14) to
;; (14,14) from lower left to upper right and with (0,0) at the center.
;; This gives a total Turing tape length of 29^2 = 841 cells, sufficient for the
;; "Lazy" Beaver 5,2 example.
;; Since the max-pxcor variable is used in the code below (as opposed to
;; a hard-coded number), the effective tape size can be changed by
;; changing the size of the 2D world with the Settings...  button on the interface.

;; The "Info" tab of the NetLogo interface contains some further comments.
;; - - - - - - -

;; - - - - - - - - - - - Global/Agent variables
;; These three 2D arrays (lists of lists) encode the Turing Machine rules:
;;    WhatToWrite:  -1 (Blank), 0, 1
;;    HowToMove:    -1 (left), 0(stay), 1 (right)
;;    NextState:    0 to N-1, negative value goes to a halt state.
;; The above are a function of the current state and the current tape (patch) value.
;; MachineState is used by the turtle to pass the current state of the Turing machine
;; (or the halt code) to the observer.
globals [ WhatToWrite HowToMove NextState MachineState
   ;; some other golobals of secondary importance...
   ;; set different patch colors to record the Turing tape values
    BlankColor ZeroColor OneColor
   ;; a delay constant to slow down the operation
    RealTimePerTick ]

;; We'll have one turtle which is the Turing machine read/write head
;; it will keep track of the current Turing state in its own MyState value
turtles-own [ MyState ]

;; - - - - - - - - - - -
to Setup  ;; sets up the world
  clear-all  ;; clears the world first

  ;; Try to not have (too many) ad hoc numbers in the code,
  ;; collect and set various values here especially if they might be used in multiple places:
  ;;    The colors for Blank, Zero and One :   (user can can change as desired)
  set BlankColor 2 ;; dark gray
  set OneColor green
  set ZeroColor red
  ;;    slow it down for the humans to watch
  set RealTimePerTick 0.2  ;; have simulation go at nice realtime speed

  create-turtles 1   ;; create the one Turing turtle
  [                  ;; set default parameters
    set size 2       ;; set a nominal size
    set color yellow ;; color of border
    ;; set the starting location, some Turing programs will adjust this if needed:
    setxy 0 0 ;; -1 * max-pxcor -1 * max-pxcor
    set shape "square2empty"   ;; edited version of "square 2" to have clear in middle

    ;; set the starting state - always 0
    set MyState 0
    set MachineState 0   ;; the turtle will update this global value from now on
  ]

  ;; Define the Turing machine rules with 2D lists.
  ;; Based on the selection made on interface panel, setting the string Turing_Program_Selection.
  ;; This routine has all the Turing 'programs' in it - it's at the very bottom of this file.
  LoadTuringProgram

  ;; the environment, e.g. the Turing tape
  ask patches
  [
    ;; all patches are set to the blank color
    set pcolor BlankColor
  ]

  ;; keep track of time; each tick is a Turing step
  reset-ticks
end

;; - - - - - - - - - - - - - - - -
to Go  ;; this  repeatedly does steps

  ;; The turtle does the main work
  ask turtles
  [
    DoOneStep
    wait RealTimePerTick
  ]

  tick

  ;; The Turing turtle will die if it tries to go beyond the cells,
  ;; in that case (no turtles left) we'll stop.
  ;; Also stop if the MachineState has been set to a negative number (a halt state).
  if ((count turtles = 0) or (MachineState < 0))
  [ stop ]

end

to DoOneStep
   ;; have the turtle do one Turing step
   ;; First, 'read the tape', i.e., based on the patch color here:
   let tapeValue GetTapeValue

   ;; using the tapeValue and MyState, get the desired actions here:
   ;; (the item commands extract the appropriate value from the list-of-lists)
   let myWrite item (tapeValue + 1) (item MyState WhatToWrite)
   let myMove item (tapeValue + 1) (item MyState HowToMove)
   let myNextState item (tapeValue + 1) (item MyState NextState)

   ;; Write to the tape as appropriate
   SetTapeValue myWrite

   ;; Move as appropriate
   if (myMove = 1) [MoveForward]
   if (myMove = -1) [MoveBackward]

   ;; Go to the next state; check if it is a halt state.
   ;; Update the global MachineState value
   set MachineState myNextState
   ifelse (myNextState < 0)
   [
     ;; It's a halt state.  The negative MachineState will signal the stop.
     ;; Go back to the starting state so it can be re-run if desired.
     set MyState 0]
   [
     ;; Not a halt state, so change to the desired next state
     set MyState myNextState
     ]
end

to MoveForward
  ;; move the turtle forward one cell, including line wrapping.
  set heading 90
  ifelse (xcor = max-pxcor)
    [set xcor -1 * max-pxcor
      ;; and go up a row if possible... otherwise die
      ifelse ycor = max-pxcor
      [ die ]  ;; tape too short - a somewhat crude end of things ;-)
      [set ycor ycor + 1]
    ]
    [jump 1]
end

to MoveBackward
  ;; move the turtle backward one cell, including line-wrapping.
  set heading -90
  ifelse (xcor = -1 * max-pxcor)
    [
      set xcor max-pxcor
      ;; and go down a row... or die
      ifelse ycor = -1 * max-pxcor
      [ die ]  ;; tape too short - a somewhat crude end of things ;-)
      [set ycor ycor - 1]
    ]
    [jump 1]
end

to-report GetTapeValue
  ;; report the tape color equivalent value
  if (pcolor = ZeroColor) [report 0]
  if (pcolor = OneColor) [report 1]
  report -1
end

to SetTapeValue [ value ]
  ;; write the appropriate color on the tape
  ifelse (value = 1)
  [set pcolor OneColor]
  [ ifelse (value = 0)
    [set pcolor ZeroColor][set pcolor BlankColor]]
end

;; - - - - - OK, here are the data for the various Turing programs...
;; Note that besdes settting the rules (array values) these sections can also
;; include commands to clear the tape, position the r/w head, adjust wait time, etc.
to LoadTuringProgram

  ;; A template of the rules structure: a list of lists
  ;; E.g. values are given for States 0 to 4, when looking at Blank, Zero, One:
  ;; For 2-symbol machines use Blank(-1) and One(1) and ignore the middle values (never see zero).
  ;; Normal Halt will be state -1, the -9 default shows an unexpected halt.
  ;;                       state 0       state 1       state 2       state 3       state 4
  set WhatToWrite (list (list -1 0 1) (list -1 0 1) (list -1 0 1) (list -1 0 1) (list -1 0 1) )
  set HowToMove    (list (list 0 0 0)  (list 0 0 0)  (list 0 0 0)  (list 0 0 0)  (list 0 0 0) )
  set NextState(list (list -9 -9 -9) (list -9 -9 -9) (list -9 -9 -9) (list -9 -9 -9) (list -9 -9 -9) )

  ;; Fill the rules based on the selected case
  if (Turing_Program_Selection = "Simple Incrementor")
  [
    ;; simple Incrementor - this is from the RosettaCode Universal Turing Machine page - very simple!
    set WhatToWrite (list (list 1 0 1) )
    set HowToMove   (list (list 0 0 1) )
    set NextState   (list (list -1 -9 0) )
  ]

  ;; Fill the rules based on the selected case
  if (Turing_Program_Selection = "Incrementor w/Return")
  [
    ;; modified Incrementor: it returns to the first 1 on the left.
    ;; This version allows the "Copy Ones to right" program to directly follow it.
    ;;                     move right    append one    back to beginning
    set WhatToWrite (list (list -1 0 1) (list 1 0 1)   (list -1 0 1) )
    set HowToMove   (list (list 1 0 1)  (list 0 0 1)   (list 1 0 -1) )
    set NextState   (list (list 1 -9 1) (list 2 -9 1)  (list -1 -9 2) )
  ]

  ;; Fill the rules based on the selected case
  if (Turing_Program_Selection = "Copy Ones to right")
  [
    ;; "Copy" from Wiki "Turing machine examples" page; slight mod so that it ends on first 1
    ;; of the copy allowing Copy to be re-executed to create another copy.
    ;; Has 5 states and uses Blank and 1 to make a copy of a string of ones;
    ;; this can be run after runs of the "Incrementor w/Return".
    ;;                       state 0       state 1        state 2       state 3       state 4
    set WhatToWrite (list (list -1 0 -1) (list -1 0 1)  (list 1 0 1)   (list -1 0 1)  (list 1 0 1) )
    set HowToMove   (list (list 1 0 1)   (list 1 0 1)   (list -1 0 1)   (list -1 0 -1)   (list 1 0 -1) )
    set NextState   (list (list -1 -9 1)  (list 2 -9 1)  (list 3 -9 2)  (list 4 -9 3)  (list 0 -9 4) )
  ]

  ;; Fill the rules based on the selected case
  if (Turing_Program_Selection = "Binary Counter")
  [
    ;; Count in binary - can start on a blank space.
    ;;         States:       start          carry-1          back-to-beginning
    set WhatToWrite (list (list 1 1 0)      (list 1 1 0)      (list -1 0 1)  )
    set HowToMove (list   (list 0 0 -1)     (list 0 0 -1)     (list -1 1 1)  )
    set NextState (list   (list -1 -1 1)    (list 2 2 1)      (list -1 2 2)  )
    ;; Select line above from these two:
    ;; can either count by 1 each time it is run:
    ;;    set NextState (list   (list -1 -1 1)    (list 2 2 1)      (list -1 2 2)  )
    ;; or count forever once started:
    ;;    set NextState (list   (list 0 0 1)      (list 2 2 1)      (list 0 2 2)  )
    set RealTimePerTick 0.2
  ]

  if (Turing_Program_Selection = "Busy-Beaver 3-State, 2-Sym")
  [
    ;; from the RosettaCode.org Universal Turing Machine page
    ;;      state name:           a             b             c
    set WhatToWrite (list (list 1 0 1) (list 1 0 1) (list 1 0 1) (list -1 0 1) (list -1 0 1) )
    set HowToMove (list (list 1 0 -1) (list -1 0 1) (list -1 0 0) (list 0 0 0) (list 0 0 0) )
    set NextState (list (list 1 -9 2) (list 0 -9 1) (list 1 -9 -1) (list -9 -9 -9) (list -9 -9 -9) )
    ;; Clear the tape
    ask Patches [set pcolor BlankColor]
  ]

  ;; should output 13 ones and take 107 steps to do it...
  if (Turing_Program_Selection = "Busy-Beaver 4-State, 2-Sym")
  [
    ;; from the RosettaCode.org Universal Turing Machine page
    ;;      state name:           A            B            C             D
    set WhatToWrite (list (list 1 0 1) (list 1 0 -1) (list 1 0 1) (list 1 0 -1) (list -1 0 1) )
    set HowToMove (list (list 1 0 -1) (list -1 0 -1) (list 1 0 -1) (list 1 0 1) (list 0 0 0) )
    set NextState (list (list 1 -9 1) (list 0 -9 2) (list -1 -9 3) (list 3 -9 0) (list -9 -9 -9) )
    ;; Clear the tape
    ask Patches [set pcolor BlankColor]
  ]

  ;; This takes 38 steps to write 9 ones/zeroes
  if (Turing_Program_Selection = "Busy-Beaver 2-State, 3-Sym")
  [
    ;;                            A            B
    set WhatToWrite (list (list 0 1 0) (list 1 1 0) (list -1 0 1) (list -1 0 1) (list -1 0 1) )
    set HowToMove    (list (list 1 -1 1)  (list -1 1 -1)  (list 0 0 0)  (list 0 0 0)  (list 0 0 0) )
    set NextState(list (list 1 1 -1) (list 0 1 1) (list -9 -9 -9) (list -9 -9 -9) (list -9 -9 -9) )
    ;; Clear the tape
    ask Patches [set pcolor BlankColor]
  ]

  ;; This only makes 501 ones and stops after 134,467 steps -- it does do that !!!
  if (Turing_Program_Selection = "Lazy-Beaver 5-State, 2-Sym")
  [
    ;; from the RosettaCode.org Universal Turing Machine page
    ;;      state name:           A0            B1           C2             D3           E4
    set WhatToWrite (list (list 1 0 -1) (list 1 0 1) (list 1 0 -1) (list -1 0 1) (list 1 0 1) )
    set HowToMove (list (list 1 0 -1) (list 1 0 1) (list -1 0 1) (list 1 0 1) (list -1 0 1) )
    set NextState (list (list 1 -9 2) (list 2 -9 3) (list 0 -9 1) (list 4 -9 -1) (list 2 -9 0) )
    ;; Clear the tape
    ask Patches [set pcolor BlankColor]
    ;; Looks like it goes much more forward than back on the tape
    ;; so start the head just a row from the bottom:
    ask turtles [setxy 0 -1 * max-pxcor + 1]
    ;; and go faster
    set RealTimePerTick 0.02
  ]

  ;; The rest have large outputs and run for a long time, so I haven't confirmed
  ;; that they work as advertised...

  ;; This is the 5,2 record holder: 4098 ones in 47,176,870 steps.
  ;; With max-pxcor of 14 and offset r/w head start (below), this will
  ;; run off the tape at about 150,000+steps...
  if (Turing_Program_Selection = "Busy-Beaver 5-State, 2-Sym")
  [
    ;; from the RosettaCode.org Universal Turing Machine page
    ;;      state name:           A            B            C             D             E
    set WhatToWrite (list (list 1 0 1) (list 1 0 1) (list 1 0 -1) (list 1 0 1) (list 1 0 -1) )
    set HowToMove (list (list 1 0 -1) (list 1 0 1) (list 1 0 -1) (list -1 0 -1) (list 1 0 -1) )
    set NextState (list (list 1 -9 2) (list 2 -9 1) (list 3 -9 4) (list 0 -9 3) (list -1 -9 0) )
    ;; Clear the tape
    ask Patches [set pcolor BlankColor]
    ;; Writes more backward than forward, so start a few rows from the top:
    ask turtles [setxy 0 max-pxcor - 3]
    ;; and go faster
    set RealTimePerTick 0.02
  ]

  if (Turing_Program_Selection = "Lazy-Beaver 3-State, 3-Sym")
  [
    ;; This should write 5600 ones/zeros and take 29,403,894 steps.
    ;; Ran it to 175,000+ steps and only covered 1/2 of the cells (w/max-pxcor = 14)...
    ;;      state name:           A            B            C
    set WhatToWrite (list (list 0 1 0) (list 1 -1 0) (list 0 1 0) (list -1 0 1) (list -1 0 1) )
    set HowToMove (list (list 1 1 -1) (list -1 1 1) (list 1 -1 1) (list 0 0 0) (list 0 0 0) )
    set NextState (list (list 1 0 0) (list 2 2 1) (list -1 0 1) (list -9 -9 -9) (list -9 -9 -9) )
    ;; Clear the tape
    ask Patches [set pcolor BlankColor]
    ;; It goes much more forward than back on the tape
    ;; so start the head just a row from the bottom:
    ask turtles [setxy 0 -1 * max-pxcor + 1]
    ;; and go faster
    set RealTimePerTick 0.02
  ]

  if (Turing_Program_Selection = "Busy-Beaver 3-State, 3-Sym")
  [
    ;; This should write 374,676,383 ones/zeros and take 119,112,334,170,342,540 (!!!) steps.
    ;; Rn it to ~ 175,000 steps covering about 2/3 of the max-pxcor=14 cells.
    ;;      state name:           A            B            C
    set WhatToWrite (list (list 0 1 0) (list -1 1 0) (list 0 0 0) (list -1 0 1) (list -1 0 1) )
    set HowToMove (list (list 1 -1 -1) (list -1 1 -1) (list 1 1 1) (list 0 0 0) (list 0 0 0) )
    set NextState (list (list 1 0 2) (list 0 1 1) (list -1 0 2) (list -9 -9 -9) (list -9 -9 -9) )
    ;; Clear the tape
    ask Patches [set pcolor BlankColor]
    ;; Writes more backward than forward, so start a rowish from the top:
    ask turtles [setxy 0 max-pxcor - 1]
    ;; and go faster
    set RealTimePerTick 0.02
  ]

  ;; in all cases reset the machine state to 0:
  ask turtles [set MyState 0]
  set MachineState 0
  ;; and the ticks
  reset-ticks

end


import strutils, tables

proc runUTM(state, halt, blank: string, tape: seq[string] = @[],
            rules: seq[seq[string]]) =
  var
    st = state
    pos = 0
    tape = tape
    rulesTable: Table[tuple[s0, v0: string], tuple[v1, dr, s1: string]]

  if tape.len == 0: tape = @[blank]
  if pos < 0: pos += tape.len
  assert pos in 0..tape.high

  for r in rules:
    assert r.len == 5
    rulesTable[(r[0], r[1])] = (r[2], r[3], r[4])

  while true:
    stdout.write st, '\t'
    for i, v in tape:
      stdout.write if i == pos: '[' & v & ']' else: ' ' & v & ' '
    echo()

    if st == halt: break
    if not rulesTable.hasKey((st, tape[pos])): break

    let (v1, dr, s1) = rulesTable[(st, tape[pos])]
    tape[pos] = v1
    if dr == "left":
      if pos > 0: dec pos
      else: tape.insert blank
    if dr == "right":
      inc pos
      if pos >= tape.len: tape.add blank
    st = s1

echo "incr machine\n"
runUTM(halt  = "qf",
       state = "q0",
       tape  = "1 1 1".split,
       blank = "B",
       rules = @["q0 1 1 right q0".splitWhitespace,
                 "q0 B 1 stay  qf".splitWhitespace])

echo "\nbusy beaver\n"
runUTM(halt  = "halt",
       state = "a",
       blank = "0",
       rules = @["a 0 1 right b".splitWhitespace,
                 "a 1 1 left  c".splitWhitespace,
                 "b 0 1 left  a".splitWhitespace,
                 "b 1 1 right b".splitWhitespace,
                 "c 0 1 left  b".splitWhitespace,
                 "c 1 1 stay  halt".splitWhitespace])

echo "\nsorting test\n"
runUTM(halt  = "STOP",
       state = "A",
       blank = "0",
       tape  = "2 2 2 1 2 2 1 2 1 2 1 2 1 2".split,
       rules = @["A 1 1 right A".splitWhitespace,
                 "A 2 3 right B".splitWhitespace,
                 "A 0 0 left  E".splitWhitespace,
                 "B 1 1 right B".splitWhitespace,
                 "B 2 2 right B".splitWhitespace,
                 "B 0 0 left  C".splitWhitespace,
                 "C 1 2 left  D".splitWhitespace,
                 "C 2 2 left  C".splitWhitespace,
                 "C 3 2 left  E".splitWhitespace,
                 "D 1 1 left  D".splitWhitespace,
                 "D 2 2 left  D".splitWhitespace,
                 "D 3 1 right A".splitWhitespace,
                 "E 1 1 left  E".splitWhitespace,
                 "E 0 0 right STOP".splitWhitespace])


program project1;
uses
 Classes, sysutils;

type
 TCurrent = record
   state : string;
   input : char;
 end;

 TMovesTo = record
   state : string;
   output : char;
   moves : char;
 end;

 var
   ST, ET: TDateTime;
   C:TCurrent;
   M:TMovesTo;
   Tape, Rules:TStringList;
   TP:integer; //TP = Tape position
   Blank : char;
   j:integer;
   FinalState, InitialState, R : string;
   Count:integer;

Function ApplyRule(C:TCurrent):TMovesTo;
var
  x,k:integer;
begin
  //Find the appropriate rule and pass it as the result
  For k:= 0 to Rules.Count-1 do
  begin
     If (k mod 5 = 0) and (Rules[k] = C.state) and (Rules[k+1] = C.input) then
     begin
         Result.output := Rules[k+2][1];
         Result.moves := Rules[k+3][1];
         Result.state := Rules[k+4];
     end;
  end;
end;

Procedure ChangeTape(var TapePosition:integer;N:TMovesTo);
begin
   Tape[TapePosition]:=N.output;
   Case N.moves of
   'l':begin
         TapePosition := TapePosition-1;
       end;
   'r':begin
         TapePosition := TapePosition+1;
       end;
   end;
end;

function GetInput(TapePosition:integer):char;
begin
  Result:=Tape[TapePosition][1];
end;

procedure ShowResult;
var
  k:integer;
begin
  writeln('Current State  :',C.state);
  writeln('Input          :',C.input);
  write(' Tape ');
  For k:= 0 to Tape.count-1 do
  begin
     write(Tape[k]);
  end;
  writeln;
  writeln('New    State  :',M.state);
  writeln('Tape position :',TP);
  writeln('-----------------------');
end;

begin
  writeln('Universal Turing Machine');
  writeln('------------------------');
  Count:=0;
  ST:=Time;

  //Set up the rules
  Rules := TStringList.create;
  R := 'q0,1,1,right,q0,q0,B,1,stay,qf';
  Rules.CommaText := R;
  InitialState := 'q0';
  FinalState := 'qf';

  //Set up the tape
  Tape:=TStringList.create;
  Tape.add('1');
  Tape.add('1');
  Tape.add('1');
  Blank := 'B';
  For j:= 1 to 10 do
  begin
     Tape.add(Blank);
  end;

  //Set up the initial state
  writeln('Initial state');
  C.state:=InitialState;
  C.input:=' ';
  M.state:='';
  M.output:=' ';
  M.moves:=' ';
  TP:=0;

  //Run the machine
  While (TP >= 0) and (M.State <> FinalState) do
  begin
    C.Input := GetInput(TP);
    If M.state <> '' then
    begin
      C.State := M.State;
    end;
    M:=ApplyRule(C);
    ChangeTape(TP,M);
    Count:=Count+1;
    ShowResult;
  end;

  //State the outcome.
  If TP < 0 then
  begin
     writeln('Error! Tape has slipped off at left!');
  end;
  If M.state = FinalState then
  begin
     writeln('Program has finished');
     ET:=Time;
     writeln('Time taken ');
     writeln(FormatDateTime('sss:zzz',ET-ST));
     writeln(Count, ' steps taken');
  end;

  Tape.free;
  Rules.free;
  readln;
end.


use strict;
use warnings;

sub run_utm {
	my %o = @_;
	my $st = $o{state}	// die "init head state undefined";
	my $blank = $o{blank}	// die "blank symbol undefined";
	my @rules = @{$o{rules}} or die "rules undefined";
	my @tape = $o{tape} ? @{$o{tape}} : ($blank);
	my $halt = $o{halt};

	my $pos = $o{pos} // 0;
	$pos += @tape if $pos < 0;
	die "bad init position" if $pos >= @tape || $pos < 0;

step:	while (1) {
		print "$st\t";
		for (0 .. $#tape) {
			my $v = $tape[$_];
			print $_ == $pos ? "[$v]" : " $v ";
		}
		print "\n";

		last if $st eq $halt;
		for (@rules) {
			my ($s0, $v0, $v1, $dir, $s1) = @$_;
			next unless $s0 eq $st and $tape[$pos] eq $v0;

			$tape[$pos] = $v1;

			if ($dir eq 'left') {
				if ($pos == 0) { unshift @tape, $blank}
				else { $pos-- }
			} elsif ($dir eq 'right') {
				push @tape, $blank if ++$pos >= @tape
			}

			$st = $s1;
			next step;
		}

		die "no matching rules";
	}
}

print "incr machine\n";
run_utm	halt=>'qf',
	state=>'q0',
	tape=>[1,1,1],
	blank=>'B',
	rules=>[[qw/q0 1 1 right q0/],
		[qw/q0 B 1 stay  qf/]];

print "\nbusy beaver\n";
run_utm halt=>'halt',
	state=>'a',
	blank=>'0',
	rules=>[[qw/a 0 1 right b/],
		[qw/a 1 1 left  c/],
		[qw/b 0 1 left  a/],
		[qw/b 1 1 right b/],
		[qw/c 0 1 left  b/],
		[qw/c 1 1 stay  halt/]];

print "\nsorting test\n";
run_utm halt=>'STOP',
	state=>'A',
	blank=>'0',
	tape=>[qw/2 2 2 1 2 2 1 2 1 2 1 2 1 2/],
	rules=>[[qw/A 1 1 right A/],
		[qw/A 2 3 right B/],
		[qw/A 0 0 left  E/],
		[qw/B 1 1 right B/],
		[qw/B 2 2 right B/],
		[qw/B 0 0 left  C/],
		[qw/C 1 2 left  D/],
		[qw/C 2 2 left  C/],
		[qw/C 3 2 left  E/],
		[qw/D 1 1 left  D/],
		[qw/D 2 2 left  D/],
		[qw/D 3 1 right A/],
		[qw/E 1 1 left  E/],
		[qw/E 0 0 right STOP/]];


with javascript_semantics
enum name, initState, endState, blank, rules

-- Machine definitions
constant incrementer = {
    /*name =*/ "Simple incrementer",
    /*initState =*/ "q0",
    /*endState =*/ "qf",
    /*blank =*/ "B",
    /*rules =*/ {
        {"q0", "1", "1", "right", "q0"},
        {"q0", "B", "1", "stay", "qf"}
    }
}

constant threeStateBB = {
    /*name =*/ "Three-state busy beaver",
    /*initState =*/ "a",
    /*endState =*/ "halt",
    /*blank =*/ "0",
    /*rules =*/ {
        {"a", "0", "1", "right", "b"},
        {"a", "1", "1", "left", "c"},
        {"b", "0", "1", "left", "a"},
        {"b", "1", "1", "right", "b"},
        {"c", "0", "1", "left", "b"},
        {"c", "1", "1", "stay", "halt"}
    }
}

constant fiveStateBB = {
    /*name =*/ "Five-state busy beaver",
    /*initState =*/ "A",
    /*endState =*/ "H",
    /*blank =*/ "0",
    /*rules =*/ {
        {"A", "0", "1", "right", "B"},
        {"A", "1", "1", "left", "C"},
        {"B", "0", "1", "right", "C"},
        {"B", "1", "1", "right", "B"},
        {"C", "0", "1", "right", "D"},
        {"C", "1", "0", "left", "E"},
        {"D", "0", "1", "left", "A"},
        {"D", "1", "1", "left", "D"},
        {"E", "0", "1", "stay", "H"},
        {"E", "1", "0", "left", "A"}
    }
}

procedure show(string state, integer headpos, sequence tape)
    printf(1," %-6s | ",{state})
    for p=1 to length(tape) do
        printf(1,iff(p=headpos?"[%s]":" %s "),{tape[p]})
    end for
    printf(1,"\n")
end procedure

-- a universal turing machine
procedure UTM(sequence machine, sequence tape, integer countOnly=0)
    string state = machine[initState]
    integer headpos = 1, counter = 0
    printf(1,"\n\n%s\n%s\n",{machine[name],repeat('=',length(machine[name]))})
    if not countOnly then printf(1," State  | Tape [head]\n---------------------\n") end if
    while 1 do
        if headpos>length(tape) then
            tape = append(tape,machine[blank])
        elsif headpos<1 then
            tape = prepend(tape,machine[blank])
            headpos = 1
        end if
        if not countOnly then show(state, headpos, tape) end if
        for i=1 to length(machine[rules]) do
            sequence rule = machine[rules][i]
            if rule[1]=state and rule[2]=tape[headpos] then
                tape[headpos] = rule[3]
                if rule[4] == "left" then headpos -= 1 end if
                if rule[4] == "right" then headpos += 1 end if
                state = rule[5]
                exit
            end if
        end for
        counter += 1
        if state=machine[endState] then exit end if
    end while
    if countOnly then
        printf(1,"Steps taken: %d\n",{counter})
    else
        show(state, headpos, tape)
    end if
end procedure

atom t0 = time()
UTM(incrementer, {"1", "1", "1"})
UTM(threeStateBB, {})
if platform()!=JS then -- 1min 7s
    UTM(fiveStateBB, {}, countOnly:=1)
end if
?elapsed(time()-t0)


module turing;

extern printf;

struct @Command {
	field @Integer tape {get:tape,set:stape};
	field @Integer move {get:move,set:smove};
	field @Integer next {get:next,set:snext};

	@Command init(@Integer tape, @Integer move, @Integer next) [
		this.stape(tape);
		this.smove(move);
		this.snext(next);
		return this;
	]
};

doc 2 dimansional array structure;

struct @Rules {

	field @Integer maxstates { get: maxstates, set: smaxstates };
	field @Integer maxvalue  { get: maxvalue, set: smaxvalue };

	field @Array<@Array<@Command> > table {get: t, set: st};

	@Rules init(@Integer states, @Integer values)
	[
		this.smaxstates(states);
		this.smaxvalue(values);
		this.st(new @Array<@Array<@Command> >.init(states));
		return this;
	]

	@Void setRule(@Integer state, @Integer tape, @Command command)
	[
		if (null == this::t.get(state)) {
			this::t.set(state, new @Array<@Command>.init(this::maxvalue));
		}
		this::t.get(state).set(tape, command);
	]

	@Command getRule(@Integer state, @Integer tape)
	[
		return this::t.get(state).get(tape);
	]

};

@Void emulateTuring(@Rules rules, @Integer start, @Integer stop, @Array<@Integer> tape, @Integer blank) [
	var tapepointer = 0;
	var state = start;

	doc output;
	printf("Tape\tState\n");

	while (state != stop) {
		doc add more cells to the tape;
		if (tapepointer == tape::size) tape.add(blank);
		if (tapepointer == 0-1) { tape = (new @Array<@Integer>..blank).addAll(tape); tapepointer = 0; }

		doc output;
		for (var i = 0; i < tape::size; i=i+1) {
			printf("%i", tape.get(i));
		}
		printf("\t%i\n", state);
		for (var i = 0; i < tapepointer; i=i+1) {
			printf(" ");
		}
		printf("^\n");

		doc the value of the current cell;
		var tapeval = tape.get(tapepointer);

		doc the current state;
		var command = rules.getRule(state, tapeval);

		tape.set(tapepointer, command::tape);
		tapepointer = tapepointer + command::move;
		state = command::next;
	}

	doc output;
	for (var i = 0; i < tape::size; i=i+1) {
		printf("%i", tape.get(i));
	}
	printf("\t%i\n", state);
	for (var i = 0; i < tapepointer; i=i+1) {
		printf(" ");
	}
	printf("^\n");
]

@Integer main [

	doc incrementer;

	doc 2 states, 2 symbols;

	var rules = new @Rules.init(2, 2);

	doc q0, 1 -> 1, right, q0;
	doc q0, B -> 1, stay, qf;

	rules.setRule(0, 1, new @Command.init(1, 1, 0));
	rules.setRule(0, 0, new @Command.init(1, 0, 1));

	doc tape = [1, 1, 1];

	var tape = new @Array<@Integer>..1..1..1;

	doc start turing machine;

	emulateTuring(rules, 0, 1, tape, 0);

	doc ---------------------------------------------------;

	doc three state busy beaver;

	doc 4 states, 2 symbols;

	rules = new @Rules.init(4, 2);

	doc	a, 0 -> 1, right, b
		a, 1 -> 1, left, c
		b, 0 -> 1, left, a
		b, 1 -> 1, right, b
		c, 0 -> 1, left, b
		c, 1 -> 1, stay, halt
	;

	doc	a = 0,
		b = 1,
		c = 2,
		halt = 3;

	rules.setRule(0, 0, new @Command.init(1, 1, 1));
	rules.setRule(0, 1, new @Command.init(1, 0-1, 2));
	rules.setRule(1, 0, new @Command.init(1, 0-1, 0));
	rules.setRule(1, 1, new @Command.init(1, 1, 1));
	rules.setRule(2, 0, new @Command.init(1, 0-1, 1));
	rules.setRule(2, 1, new @Command.init(1, 0, 3));

	doc tape = [];

	tape = new @Array<@Integer>;

	doc start turing machine;

	emulateTuring(rules, 0, 3, tape, 0);
	return 0;
]


# Finite state machine
(de turing (Tape Init Halt Blank Rules Verbose)
   (let
      (Head 1
         State Init
         Rule NIL
         S 'start
         C (length Tape))
      (catch NIL
         (loop
            (state 'S
               (start 'print
                  (when (=0 C)
                     (setq Tape (insert Head Tape Blank))
                     (inc 'C) ) )
               (print 'lookup
                  (when Verbose
                     (for (N . I) Tape
                        (if (= N Head)
                           (print (list I))
                           (prin I) ) )
                     (prinl) )
                  (when (= State Halt) (throw NIL) ) )
               (lookup 'do
                  (setq Rule
                     (find
                        '((X)
                           (and
                              (= (car X) State)
                              (= (cadr X) (car (nth Tape Head))) ) )
                        Rules ) ) )
               (do 'step
                  (setq Tape (place Head Tape (caddr Rule))) )
               (step 'print
                  (cond
                     ((= (cadddr Rule) 'R) (inc 'Head))
                     ((= (cadddr Rule) 'L) (dec 'Head)) )
                  (cond
                     ((< Head 1)
                        (setq Tape (insert Head Tape Blank))
                        (inc 'C)
                        (one Head) )
                     ((> Head C)
                        (setq Tape (insert Head Tape Blank))
                        (inc 'C) ) )
                  (setq State (last Rule)) ) ) ) ) )
   Tape )

(println "Simple incrementer")
(turing '(1 1 1) 'A 'H 'B '((A 1 1 R A) (A B 1 S H)) T)

(println "Three-state busy beaver")
(turing '() 'A 'H 0
   '((A 0 1 R B)
     (A 1 1 L C)
     (B 0 1 L A)
     (B 1 1 R B)
     (C 0 1 L B)
     (C 1 1 S H)) T )

(println "Five-state busy beaver")
(let Tape (turing '() 'A 'H 0
   '((A 0 1 R B)
     (A 1 1 L C)
     (B 0 1 R C)
     (B 1 1 R B)
     (C 0 1 R D)
     (C 1 0 L E)
     (D 0 1 L A)
     (D 1 1 L D)
     (E 0 1 S H)
     (E 1 0 L A)) NIL)
   (println '0s: (cnt '((X) (= 0 X)) Tape))
   (println '1s: (cnt '((X) (= 1 X)) Tape)) )

(bye)


turing(Config, Rules, TapeIn, TapeOut) :-
    call(Config, IS, _, _, _, _),
    perform(Config, Rules, IS, {[], TapeIn}, {Ls, Rs}),
    reverse(Ls, Ls1),
    append(Ls1, Rs, TapeOut).

perform(Config, Rules, State, TapeIn, TapeOut) :-
    call(Config, _, FS, RS, B, Symbols),
    ( memberchk(State, FS) ->
        TapeOut = TapeIn
    ; memberchk(State, RS) ->
        {LeftIn, RightIn} = TapeIn,
        symbol(RightIn, Symbol, RightRem, B),
        memberchk(Symbol, Symbols),
        once(call(Rules, State, Symbol, NewSymbol, Action, NewState)),
        memberchk(NewSymbol, Symbols),
        action(Action, {LeftIn, [NewSymbol|RightRem]}, {LeftOut, RightOut}, B),
        perform(Config, Rules, NewState, {LeftOut, RightOut}, TapeOut) ).

symbol([],       B,   [], B).
symbol([Sym|Rs], Sym, Rs, _).

action(left,  {Lin, Rin},  {Lout, Rout}, B) :- left(Lin, Rin, Lout, Rout, B).
action(stay,  Tape,        Tape,         _).
action(right, {Lin, Rin},  {Lout, Rout}, B) :- right(Lin, Rin, Lout, Rout, B).

left([],     Rs, [], [B|Rs], B).
left([L|Ls], Rs, Ls, [L|Rs], _).

right(L, [],     [B|L], [], B).
right(L, [S|Rs], [S|L], Rs, _).


from __future__ import print_function

def run_utm(
        state = None,
        blank = None,
        rules = [],
        tape = [],
        halt = None,
        pos = 0):
    st = state
    if not tape: tape = [blank]
    if pos < 0: pos += len(tape)
    if pos >= len(tape) or pos < 0: raise Error( "bad init position")
    rules = dict(((s0, v0), (v1, dr, s1)) for (s0, v0, v1, dr, s1) in rules)

    while True:
        print(st, '\t', end=" ")
        for i, v in enumerate(tape):
            if i == pos: print("[%s]" % (v,), end=" ")
            else: print(v, end=" ")
        print()

        if st == halt: break
        if (st, tape[pos]) not in rules: break

        (v1, dr, s1) = rules[(st, tape[pos])]
        tape[pos] = v1
        if dr == 'left':
            if pos > 0: pos -= 1
            else: tape.insert(0, blank)
        if dr == 'right':
            pos += 1
            if pos >= len(tape): tape.append(blank)
        st = s1

# EXAMPLES

print("incr machine\n")
run_utm(
    halt = 'qf',
	state = 'q0',
	tape = list("111"),
	blank = 'B',
	rules = map(tuple,
               ["q0 1 1 right q0".split(),
		        "q0 B 1 stay  qf".split()]
        )
    )

print("\nbusy beaver\n")
run_utm(
    halt = 'halt',
	state = 'a',
	blank = '0',
	rules = map(tuple,
        ["a 0 1 right b".split(),
         "a 1 1 left  c".split(),
         "b 0 1 left  a".split(),
         "b 1 1 right b".split(),
         "c 0 1 left  b".split(),
         "c 1 1 stay  halt".split()]
        )
    )

print("\nsorting test\n")
run_utm(halt = 'STOP',
	state = 'A',
	blank = '0',
	tape = "2 2 2 1 2 2 1 2 1 2 1 2 1 2".split(),
	rules = map(tuple,
       ["A 1 1 right A".split(),
		"A 2 3 right B".split(),
		"A 0 0 left  E".split(),
		"B 1 1 right B".split(),
		"B 2 2 right B".split(),
		"B 0 0 left  C".split(),
		"C 1 2 left  D".split(),
		"C 2 2 left  C".split(),
		"C 3 2 left  E".split(),
		"D 1 1 left  D".split(),
		"D 2 2 left  D".split(),
		"D 3 1 right A".split(),
		"E 1 1 left  E".split(),
		"E 0 0 right STOP".split()]
        )
    )


#lang racket
;;;=============================================================
;;; Due to heavy use of pattern matching we define few macros
;;;=============================================================

(define-syntax-rule (define-m f m ...)
  (define f (match-lambda m ... (x x))))

(define-syntax-rule (define-m* f m ...)
  (define f (match-lambda** m ...)))

;;;=============================================================
;;; The definition of a functional type Tape,
;;; representing infinite tape with O(1) operations:
;;; put, get, shift-right and shift-left.
;;;=============================================================
(struct Tape (the-left-part      ; i-1 i-2 i-3 ...
              the-current-record ; i
              the-right-part))   ; i+1 i+2 i+3 ...

;; the initial record on the tape
(define-m initial-tape
  [(cons h t) (Tape '() h t)])

;; shifts caret to the right
(define (snoc a b) (cons b a))
(define-m shift-right
  [(Tape '() '() (cons h t)) (Tape '() h t)]      ; left end
  [(Tape  l x '()) (Tape (snoc l x) '() '())]     ; right end
  [(Tape  l x (cons h t)) (Tape (snoc l x) h t)]) ; general case

;; shifts caret to the left
(define-m flip-tape [(Tape l x r) (Tape r x l)])

(define shift-left
  (compose flip-tape shift-right flip-tape))

;; returns the current record on the tape
(define-m get [(Tape _ v _) v])

;; writes to the current position on the tape
(define-m* put
  [('() t) t]
  [(v (Tape l _ r)) (Tape l v r)])

;; Shows the list representation of the tape (≤ O(n)).
;; A tape is shown as (... a b c (d) e f g ...)
;; where (d) marks the current position of the caret.

(define (revappend a b) (foldl cons b a))

(define-m show-tape
  [(Tape '() '() '()) '()]
  [(Tape l '() r) (revappend l (cons '() r))]
  [(Tape l v r) (revappend l (cons (list v) r))])

;;;-------------------------------------------------------------------
;;; The Turing Machine interpreter
;;;

;; interpretation of output triple for a given tape
(define-m* interprete
  [((list v 'right S) tape) (list S (shift-right (put v tape)))]
  [((list v 'left S) tape) (list S (shift-left (put v tape)))]
  [((list v 'stay S) tape) (list S (put v tape))]
  [((list S _) tape) (list S tape)])

;; Runs the program.
;; The initial state is set to start.
;; The initial tape is given as a list of records.
;; The initial position is the leftmost symbol of initial record.
(define (run-turing prog t0 start)
  ((fixed-point
    (match-lambda
      [`(,S ,T) (begin
                  (printf "~a\t~a\n" S (show-tape T))
                  (interprete (prog `(,S ,(get T))) T))]))
   (list start (initial-tape t0))))

;; a general fixed point operator
(define ((fixed-point f) x)
  (let F ([x x] [fx (f x)])
    (if (equal? x fx)
        fx
        (F fx (f fx)))))

;; A macro for definition of a Turing-Machines.
;; Transforms to a function which accepts a list of initial
;; tape records as input and returns the tape after stopping.
(define-syntax-rule (Turing-Machine #:start start (a b c d e) ...)
  (λ (l)
    (displayln "STATE\tTAPE")
    ((match-lambda [(list _ t) (flatten (show-tape t))])
     (run-turing
      (match-lambda ['(a b) '(c d e)] ... [x x])
      l start))))


sub run_utm(:$state! is copy, :$blank!, :@rules!, :@tape = [$blank], :$halt, :$pos is copy = 0) {
    $pos += @tape if $pos < 0;
    die "Bad initial position" unless $pos ~~ ^@tape;

STEP: loop {
        print "$state\t";
        for ^@tape {
            my $v = @tape[$_];
            print $_ == $pos ?? "[$v]" !! " $v ";
        }
        print "\n";

        last if $state eq $halt;

        for @rules -> @rule {
            my ($s0, $v0, $v1, $dir, $s1) = @rule;
            next unless $s0 eq $state and @tape[$pos] eq $v0;

            @tape[$pos] = $v1;

            given $dir {
                when 'left' {
                    if $pos == 0 { unshift @tape, $blank }
                    else { $pos-- }
                }
                when 'right' {
                    push @tape, $blank if ++$pos >= @tape;
                }
            }

            $state = $s1;
            next STEP;

        }
        die 'No matching rules';
    }

}

say "incr machine";
run_utm	:halt<qf>,
    :state<q0>,
    :tape[1,1,1],
    :blank<B>,
    :rules[
        [< q0 1 1 right q0 >],
        [< q0 B 1 stay  qf >]
    ];

say "\nbusy beaver";
run_utm :halt<halt>,
    :state<a>,
    :blank<0>,
    :rules[
        [< a 0 1 right b >],
        [< a 1 1 left  c >],
        [< b 0 1 left  a >],
        [< b 1 1 right b >],
        [< c 0 1 left  b >],
        [< c 1 1 stay  halt >]
    ];

say "\nsorting test";
run_utm :halt<STOP>,
    :state<A>,
    :blank<0>,
    :tape[< 2 2 2 1 2 2 1 2 1 2 1 2 1 2 >],
    :rules[
        [< A 1 1 right A >],
        [< A 2 3 right B >],
        [< A 0 0 left  E >],
        [< B 1 1 right B >],
        [< B 2 2 right B >],
        [< B 0 0 left  C >],
        [< C 1 2 left  D >],
        [< C 2 2 left  C >],
        [< C 3 2 left  E >],
        [< D 1 1 left  D >],
        [< D 2 2 left  D >],
        [< D 3 1 right A >],
        [< E 1 1 left  E >],
        [< E 0 0 right STOP >]
    ];


/*REXX program executes a  Turing machine  based on   initial state,  tape, and rules.  */
state = 'q0'                                     /*the initial Turing machine state.    */
term  = 'qf'                                     /*a state that is used for a  halt.    */
blank = 'B'                                      /*this character is a  "true"  blank.  */
call Turing_rule  'q0 1 1 right q0'              /*define a rule for the Turing machine.*/
call Turing_rule  'q0 B 1 stay  qf'              /*   "   "   "   "   "     "      "    */
call Turing_init   1 1 1                         /*initialize the tape to some string(s)*/
call TM                                          /*go and invoke the  Turning  machine. */
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
TM:  !=1;   bot=1;   top=1;   @er= '***error***' /*start at  the tape location   1.     */
     say                                         /*might as well display a blank line.  */
          do cycle=1  until  state==term         /*process Turing machine  instructions.*/
             do k=1  for rules                   /*   "       "       "        rules.   */
             parse var rule.k rState rTape rWrite rMove rNext .          /*pick pieces. */
             if state\==rState | @.!\==rTape  then iterate               /*wrong rule ? */
             @.!=rWrite                          /*right rule;  write it ───► the tape. */
             if rMove== 'left'  then !=!-1       /*Are we moving left?   Then subtract 1*/
             if rMove=='right'  then !=!+1       /* "   "    "   right?    "    add    1*/
             bot=min(bot, !);   top=max(top, !)  /*find the  tape  bottom and top.      */
             state=rNext;       iterate cycle    /*use this for the next  state;  and   */
             end   /*k*/
          say @er 'unknown state:' state;  leave /*oops, we have an unknown state error.*/
          end   /*cycle*/
     $=                                          /*start with empty string  (the tape). */
          do t=bot  to top;        [email protected].t
          if _==blank  then _=' '                /*do we need to translate a true blank?*/
          $=$ || pad || _                        /*construct char by char, maybe pad it.*/
          end   /*t*/                            /* [↑]  construct  the  tape's contents*/
     L=length($)                                 /*obtain length of  "     "       "    */
     if L==0     then $= "[tape is blank.]"      /*make an  empty tape  visible to user.*/
     if L>1000   then $=left($, 1000) ...        /*truncate tape to 1k bytes, append ···*/
     say "tape's contents:"  $                   /*show the tape's contents (or 1st 1k).*/
     say "tape's   length: " L                   /*  "   "     "   length.              */
     say 'Turning machine used '    rules    " rules in "    cycle    ' cycles.'
     return
/*──────────────────────────────────────────────────────────────────────────────────────*/
Turing_init:  @.=blank;  parse arg x;    do j=1  for words(x);  @.j=word(x,j);  end  /*j*/
              return
/*──────────────────────────────────────────────────────────────────────────────────────*/
Turing_rule:  if symbol('RULES')=="LIT"  then rules=0;       rules=rules+1
              pad=left('', length( word( arg(1),2 ) ) \==1 )          /*padding for rule*/
              rule.rules=arg(1);         say right('rule' rules, 20)   "═══►"   rule.rules
              return


class Turing
    class Tape
        def initialize(symbols, blank, starting_tape)
            @symbols = symbols
            @blank = blank
            @tape = starting_tape
            @index = 0
        end
        def read
            retval = @tape[@index]
            unless retval
                retval = @tape[@index] = @blank
            end
            raise "invalid symbol '#{retval}' on tape" unless @tape.member?(retval)
            return retval
        end
        def write(symbol)
            @tape[@index] = symbol
        end
        def right
            @index += 1
        end
        def left
            if @index == 0
              @tape.unshift @blank
            else
              @index -= 1
            end
        end
        def stay
            # nop
        end
        def get_tape
            return @tape
        end
    end

    def initialize(symbols, blank,
                   initial_state, halt_states, running_states,
                   rules, starting_tape = [])
        @tape = Tape.new(symbols, blank, starting_tape)
        @initial_state = initial_state
        @halt_states = halt_states
        @running_states = running_states
        @rules = rules
        @halted = false
    end
    def run
        raise "machine already halted" if @halted
        state = @initial_state
        while (true)
            break if @halt_states.member? state
            raise "unknown state '#{state}'" unless @running_states.member? state
            symbol = @tape.read
            outsym, action, state = @rules[state][symbol]
            @tape.write outsym
            @tape.send action
        end
        @halted = true
        return @tape.get_tape
    end
end


use std::collections::VecDeque;
use std::fmt::{Display, Formatter, Result};

fn main() {
    println!("Simple incrementer");
    let rules_si = vec!(
        Rule::new("q0", '1', '1', Direction::Right, "q0"),
        Rule::new("q0", 'B', '1', Direction::Stay, "qf")
    );
    let states_si = vec!("q0", "qf");
    let terminating_states_si = vec!("qf");
    let permissible_symbols_si = vec!('B', '1');
    let mut tm_si = TM::new(states_si, "q0", terminating_states_si, permissible_symbols_si, 'B', rules_si, "111");
    while !tm_si.is_done() {
        println!("{}", tm_si);
        tm_si.step();
    }

    println!("___________________");
    println!("Three-state busy beaver");
    let rules_bb3 = vec!(
        Rule::new("a", '0', '1', Direction::Right, "b"),
        Rule::new("a", '1', '1', Direction::Left, "c"),
        Rule::new("b", '0', '1', Direction::Left, "a"),
        Rule::new("b", '1', '1', Direction::Right, "b"),
        Rule::new("c", '0', '1', Direction::Left, "b"),
        Rule::new("c", '1', '1', Direction::Stay, "halt"),
    );
    let states_bb3 = vec!("a", "b", "c", "halt");
    let terminating_states_bb3 = vec!("halt");
    let permissible_symbols_bb3 = vec!('0', '1');
    let mut tm_bb3 = TM::new(states_bb3 ,"a", terminating_states_bb3, permissible_symbols_bb3, '0', rules_bb3, "0");
    while !tm_bb3.is_done() {
        println!("{}", tm_bb3);
        tm_bb3.step();
    }
    println!("{}", tm_bb3);

    println!("___________________");
    println!("Five-state busy beaver");
    let rules_bb5 = vec!(
        Rule::new("A", '0', '1', Direction::Right, "B"),
        Rule::new("A", '1', '1', Direction::Left, "C"),
        Rule::new("B", '0', '1', Direction::Right, "C"),
        Rule::new("B", '1', '1', Direction::Right, "B"),
        Rule::new("C", '0', '1', Direction::Right, "D"),
        Rule::new("C", '1', '0', Direction::Left, "E"),
        Rule::new("D", '0', '1', Direction::Left, "A"),
        Rule::new("D", '1', '1', Direction::Left, "D"),
        Rule::new("E", '0', '1', Direction::Stay, "H"),
        Rule::new("E", '1', '0', Direction::Left, "A"),
    );
    let states_bb5 = vec!("A", "B", "C", "D", "E", "H");
    let terminating_states_bb5 = vec!("H");
    let permissible_symbols_bb5 = vec!('0', '1');
    let mut tm_bb5 = TM::new(states_bb5 ,"A", terminating_states_bb5, permissible_symbols_bb5, '0', rules_bb5, "0");
    let mut steps = 0;
    while !tm_bb5.is_done() {
        tm_bb5.step();
        steps += 1;
    }
    println!("Steps: {}", steps);
    println!("Band lenght: {}", tm_bb5.band.len());
}

struct TM<'a> {
    state: &'a str,
    terminating_states: Vec<&'a str>,
    rules: Vec<Rule<'a>>,
    band: VecDeque<char>,
    head: usize,
    blank: char,
}

struct Rule<'a> {
    state: &'a str,
    read: char,
    write: char,
    dir: Direction,
    new_state: &'a str,
}

enum Direction{
    Left,
    Right,
    Stay,
}

impl<'a> TM<'a> {

    fn new(_states: Vec<&'a str>, initial_state: &'a str, terminating_states: Vec<&'a str>, _permissible_symbols: Vec<char>, blank: char, rules: Vec<Rule<'a>>, input: &str) -> Self {
        Self { state: initial_state, terminating_states, rules, band: input.chars().collect::<VecDeque<_>>(), head: 0, blank }
    }

    fn is_done(&self) -> bool {
        self.terminating_states.contains(&self.state)
    }

    fn step(&mut self) {
        let field = self.band.get(self.head).unwrap();
        let rule = self.rules.iter().find(|rule| rule.state == self.state && &rule.read == field).unwrap();
        let field = self.band.get_mut(self.head).unwrap();
        *field = rule.write;
        self.state = rule.new_state;
        match rule.dir {
            Direction::Left => {
                if self.head == 0 {
                    self.band.push_front(self.blank)
                } else {
                    self.head -= 1;
                }
            },
            Direction::Right => {
                if self.head == self.band.len() - 1 {
                    self.band.push_back(self.blank)
                }
                self.head += 1;
            },
            Direction::Stay => {},
        }
    }
}

impl<'a> Display for TM<'a> {
    fn fmt(&self, f: &mut Formatter<'_>) -> Result {
        let band = self.band.iter().enumerate().map(|(i, c)| {
            if i == self.head {
                format!("[{}]", c)
            } else {
                format!(" {} ", c)
            }
        }).fold(String::new(), |acc, val| acc + &val);
        write!(f, "{}\t{}", self.state, band)
    }
}

impl<'a> Rule<'a> {
    fn new(state: &'a str, read: char, write: char, dir: Direction, new_state: &'a str) -> Self {
        Self { state, read, write, dir, new_state }
    }
}


package utm.scala

import scala.annotation.tailrec
import scala.language.implicitConversions

/**
  * Implementation of Universal Turing Machine in Scala that can simulate an arbitrary
  * Turing machine on arbitrary input
  *
  * @author Abdulla Abdurakhmanov (https://github.com/abdolence/utms)
  */
class UniversalTuringMachine[S](
    val rules: List[UTMRule[S]],
    val initialState: S,
    val finalStates: Set[S],
    val blankSymbol: String,
    val inputTapeVals: Iterable[String],
    printEveryIter: Int = 1
) {

  private val initialTape = UTMTape( inputTapeVals.toVector, 0, blankSymbol )

  @tailrec
  private def iterate( state: S, curIteration: Int, tape: UTMTape ): UTMTape = {
    if (curIteration % printEveryIter == 0) {
      print( s"${curIteration}: ${state}: " )
      tape.printTape()
    }

    if (finalStates.contains( state )) {
      println( s"Finished in the final state: ${state}" )
      tape.printTape()
      tape
    } else {
      rules.find(rule => rule.state == state && rule.fromSymbol == tape.current() ) match {
        case Some( rule ) => {
          val updatedTape = tape.updated( rule.toSymbol, rule.action )

          iterate( rule.toState, curIteration + 1, updatedTape )
        }
        case _ => {
          println(
            s"Finished: no suitable rules found for ${state}/${tape.current()}"
          )
          tape.printTape()
          tape
        }
      }
    }
  }

  def run(): UTMTape =
    iterate( state = initialState, curIteration = 0, tape = initialTape )

}

/**
 * Universal Turing Machine actions
 */
sealed trait UTMAction

object UTMAction {
  case object left extends UTMAction
  case object right extends UTMAction
  case object stay extends UTMAction
}

/**
 * Universal Turing Machine rule definition
 */
case class UTMRule[S]( state: S, fromSymbol: String, toSymbol: String, action: UTMAction, toState: S )

object UTMRule {

  implicit def tupleToUTMLRule[S](
      tuple: ( S, String, String, UTMAction, S )
  ): UTMRule[S] =
    UTMRule[S]( tuple._1, tuple._2, tuple._3, tuple._4, tuple._5 )
}

/**
 * Universal Turing Machine Tape
 */
case class UTMTape( content: Vector[String], position: Int, blankSymbol: String ) {

  private def updateContentAtPos( symbol: String ) = {
    if (position >= content.length) {
      content :+ symbol
    } else if (position < 0) {
      symbol +: content
    } else if (content( position ) != symbol)
      content.updated( position, symbol )
    else
      content
  }

  private[scala] def updated( symbol: String, action: UTMAction ): UTMTape = {
    val updatedTape =
      this.copy( content = updateContentAtPos( symbol ), position = action match {
        case UTMAction.left  => position - 1
        case UTMAction.right => position + 1
        case UTMAction.stay  => position
      } )

    if (updatedTape.position < 0) {
      updatedTape.copy(
        content = blankSymbol +: updatedTape.content,
        position = 0
      )
    } else if (updatedTape.position >= updatedTape.content.length) {
      updatedTape.copy( content = updatedTape.content :+ blankSymbol )
    } else
      updatedTape
  }

  private[scala] def current(): String = {
    if (content.isDefinedAt( position ))
      content( position )
    else
      blankSymbol
  }

  def printTape(): Unit = {
    print( "[" )
    if (position < 0)
      print( "˅" )
    content.zipWithIndex.foreach {
      case ( symbol, index ) =>
        if (position == index)
          print( "˅" )
        else
          print( " " )
        print( s"$symbol" )
    }
    if (position >= content.length)
      print( "˅" )
    println( "]" )
  }

}

object UniversalTuringMachine extends App {

  main()

  def main(): Unit = {
    import UTMAction._

    def createIncrementMachine() = {

      sealed trait IncrementStates
      case object q0 extends IncrementStates
      case object qf extends IncrementStates

      new UniversalTuringMachine[IncrementStates](
        rules = List( ( q0, "1", "1", right, q0 ), ( q0, "B", "1", stay, qf ) ),
        initialState = q0,
        finalStates = Set( qf ),
        blankSymbol = "B",
        inputTapeVals = Seq( "1", "1", "1" )
      ).run()

    }

    def createThreeStateBusyBeaver() = {

      sealed trait ThreeStateBusyStates
      case object a extends ThreeStateBusyStates
      case object b extends ThreeStateBusyStates
      case object c extends ThreeStateBusyStates
      case object halt extends ThreeStateBusyStates

      new UniversalTuringMachine[ThreeStateBusyStates](
        rules = List(
          ( a, "0", "1", right, b ),
          ( a, "1", "1", left, c ),
          ( b, "0", "1", left, a ),
          ( b, "1", "1", right, b ),
          ( c, "0", "1", left, b ),
          ( c, "1", "1", stay, halt )
        ),
        initialState = a,
        finalStates = Set( halt ),
        blankSymbol = "0",
        inputTapeVals = Seq()
      ).run()

    }

    def createFiveState2SymBusyBeaverMachine() = {
      sealed trait FiveBeaverStates
      case object FA extends FiveBeaverStates
      case object FB extends FiveBeaverStates
      case object FC extends FiveBeaverStates
      case object FD extends FiveBeaverStates
      case object FE extends FiveBeaverStates
      case object FH extends FiveBeaverStates

      new UniversalTuringMachine[FiveBeaverStates](
        rules = List(
          ( FA, "0", "1", right, FB ),
          ( FA, "1", "1", left, FC ),
          ( FB, "0", "1", right, FC ),
          ( FB, "1", "1", right, FB ),
          ( FC, "0", "1", right, FD ),
          ( FC, "1", "0", left, FE ),
          ( FD, "0", "1", left, FA ),
          ( FD, "1", "1", left, FD ),
          ( FE, "0", "1", stay, FH ),
          ( FE, "1", "0", left, FA )
        ),
        initialState = FA,
        finalStates = Set( FH ),
        blankSymbol = "0",
        inputTapeVals = Seq(),
        printEveryIter = 100000
      ).run()
    }

    createIncrementMachine()
    createThreeStateBusyBeaver()
    // careful here, 47 mln iterations
    createFiveState2SymBusyBeaverMachine()
  }
}


;----------------------------------------------------------------------------------------------

; The tape is a doubly-linked list of "cells".  Each cell is a pair in which the cdr points
; to the cell on its right, and the car is a vector containing: 0: the value of the cell;
; 1: pointer to the cell on this cell's left; 2: #t if the cell has never been written.

; Make a new cell with the given contents, but linked to no other cell(s).
; (This is the only place that a cell can be marked as un-written.)
(define make-cell
  (lambda (val . opt-unwrit)
    (list (vector val '() (if (pair? opt-unwrit) (car opt-unwrit) #f)))))

; Return the un-written flag of the cell.
(define cell-unwrit?
  (lambda (cell)
    (vector-ref (car cell) 2)))

; Return the value of the cell.
(define cell-get
  (lambda (cell)
    (vector-ref (car cell) 0)))

; Store the value of the cell.
; Clears the un-written flag of the cell.
(define cell-set!
  (lambda (cell val)
    (vector-set! (car cell) 0 val)
    (vector-set! (car cell) 2 #f)))

; Return the cell to the right of the given cell on the tape.
; Returns () if there is no cell to the right.
(define cell-right
  (lambda (cell)
    (cdr cell)))

; Return the cell to the left of the given cell on the tape.
; Returns () if there is no cell to the left.
(define cell-left
  (lambda (cell)
    (vector-ref (car cell) 1)))

; Return the cell to the right of the given cell on the tape.
; Extends the tape with the give blank symbol if there is no cell to the right.
; Optionally, passes the given un-written flag to make-cell (if needed).
(define cell-extend-right
  (lambda (cell blank . opt-unwrit)
    (if (null? (cdr cell))
      (let ((new (if (pair? opt-unwrit) (make-cell blank (car opt-unwrit)) (make-cell blank))))
        (vector-set! (car new) 1 cell)
        (set-cdr! cell new)
        new)
      (cell-right cell))))

; Return the cell to the left of the given cell on the tape.
; Extends the tape with the give blank symbol if there is no cell to the left.
; Optionally, passes the given un-written flag to make-cell (if needed).
(define cell-extend-left
  (lambda (cell blank . opt-unwrit)
    (if (null? (vector-ref (car cell) 1))
      (let ((new (if (pair? opt-unwrit) (make-cell blank (car opt-unwrit)) (make-cell blank))))
        (set-cdr! new cell)
        (vector-set! (car cell) 1 new)
        new)
      (cell-left cell))))

; Make a new tape whose cells contain the values in the given list.
; Optionally, pad the tape per the given blank symbol, left-padding and right-padding amounts.
(define make-tape
  (lambda (values . opt-pads)
    (unless (pair? values) (error 'make-tape "values argument is not a list" pads))
    (let* ((tape (make-cell (car values)))
           (last (do ((values (cdr values) (cdr values))
                      (cell tape (cell-extend-right cell (car values))))
                     ((null? values) cell))))
      (when (pair? opt-pads)
        (let ((blank (list-ref opt-pads 0))
              (left (list-ref opt-pads 1))
              (right (list-ref opt-pads 2)))
          (unless (and (integer? left) (integer? right))
            (error 'make-tape "padding arguments must be integers" opt-pads))
          (do ((count 0 (1+ count))
               (cell last (cell-extend-right cell blank #t)))
              ((>= count right)))
          (do ((count 0 (1+ count))
               (cell tape (cell-extend-left cell blank #t)))
              ((>= count left)))))
      tape)))

; Make a deep copy of the given tape.
; Note:  Only copies from the given cell forward.
(define tape-copy
  (lambda (tape)
    (let ((copy (make-cell (cell-get tape))))
      (do ((tape (cdr tape) (cdr tape))
           (cell copy (cell-extend-right cell (cell-get tape))))
          ((null? tape)))
      copy)))

; Return the first cell on a tape.
; Optionally, leading blank symbols are not included (will return last cell of blank tape).
(define tape-fst
  (lambda (cell . opt-blank)
    (let ((fst (do ((fst cell (cell-left fst))) ((null? (cell-left fst)) fst))))
      (if (null? opt-blank)
        fst
        (do ((fst fst (cell-right fst)))
            ((or (null? (cell-right fst)) (not (eq? (car opt-blank) (cell-get fst)))) fst))))))

; Return the last cell on a tape.
; Optionally, trailing blank symbols are not included (will return first cell of blank tape).
(define tape-lst
  (lambda (cell . opt-blank)
    (let ((lst (do ((lst cell (cell-right lst))) ((null? (cell-right lst)) lst))))
      (if (null? opt-blank)
        lst
        (do ((lst lst (cell-left lst)))
            ((or (null? (cell-left lst)) (not (eq? (car opt-blank) (cell-get lst)))) lst))))))

; Return true if the given tape is empty.  (I.e. contains nothing but blank symbols.)
(define tape-empty?
  (lambda (cell blank)
    (let ((fst (tape-fst cell blank)))
      (and (null? (cell-right fst)) (eq? blank (cell-get fst))))))

; Convert the contents of a tape to a string.
; Place a mark around the indicated cell (if any match).
; Prints the entire contents regardless of which cell is given.
; Optionally, leading and trailing instances of the given blank symbol are suppressed.
; The values of un-written cells are not shown, though space for them is included.
(define tape->string
  (lambda (cell mark . opt-blank)
    (let ((strlst (list #\[))
          (marked-prev #f)
          (fst (if (null? opt-blank) (tape-fst cell) (tape-fst cell (car opt-blank))))
          (lst (if (null? opt-blank) (tape-lst cell) (tape-lst cell (car opt-blank)))))
      (do ((cell fst (cell-right cell)))
          ((eq? cell (cell-right lst)))
        (let* ((mark-now (eq? cell mark))
               (fmtstr (cond (mark-now " {~a}") (marked-prev " ~a") (else "  ~a")))
               (value (if (and (not mark-now) (cell-unwrit? cell)) " " (cell-get cell))))
          (set! strlst (append strlst (string->list (format fmtstr value))))
          (set! marked-prev mark-now)))
      (list->string (append strlst (string->list (if marked-prev " ]" "  ]")))))))

;----------------------------------------------------------------------------------------------

; A Turing Machine contains the 7-tuple that formally defines it, stored in an array to
; make access relatively fast.  The transitions are stored in an association list keyed by
; the pair (q_i . s_j) for ease of lookup.

; Make a new Turing Machine from the given arguments:
; Symbols list, blank symbol, input symbols list, states list, initial state, final (accepting)
; states list, and list of transitions.  A transition is a 5-element list of: state (q_i),
; symbol read (s_i), symbol to write (s_ij), direction to move (d_ij), and next state (q_ij).
(define make-turing
  (lambda (symbols blank inputs states initial finals . transitions)
    ; Raise error if any element in list lst is not in list set.
    (define all-list-in-set
      (lambda (set lst msg)
        (for-each (lambda (val) (unless (memq val set) (error 'make-turing msg val))) lst)))
    ; Raise error if the given transition is not correctly formed.
    (define transition-validate
      (lambda (tran)
        (when (or (not (list? tran)) (not (= 5 (length tran))))
              (error 'make-turing "transition not a length-5 list" tran))
        (let ((q_i (list-ref tran 0))
              (s_j (list-ref tran 1))
              (s_ij (list-ref tran 2))
              (d_ij (list-ref tran 3))
              (q_ij (list-ref tran 4)))
          (unless (memq q_i states) (error 'make-turing "q_i not in states" q_i))
          (unless (memq s_j symbols) (error 'make-turing "s_j not in symbols" s_j))
          (unless (memq s_ij symbols) (error 'make-turing "s_ij not in symbols" s_ij))
          (unless (memq d_ij '(L R N)) (error 'make-turing "d_ij not in {L R N}" d_ij))
          (unless (memq q_ij states) (error 'make-turing "q_ij not in states" q_ij)))))
    ; Convert the given transitions list into an alist of transitions keyed by (q_i . s_j).
    (define transitions-alist
      (lambda (trns)
        (cond ((null? trns) '())
              (else (cons (cons (cons (caar trns) (cadar trns)) (list (cddar trns)))
                          (transitions-alist (cdr trns)))))))
    ; Validate all the arguments.
    (unless (list? symbols) (error 'make-turing "symbols not a list" symbols))
    (unless (memq blank symbols) (error 'make-turing "blank not in symbols" blank))
    (all-list-in-set symbols inputs "inputs not all in symbols")
    (unless (list? states) (error 'make-turing "states not a list" states))
    (unless (memq initial states) (error 'make-turing "initial not in states" initial))
    (all-list-in-set states finals "finals not all in states")
    (for-each (lambda (tran) (transition-validate tran)) transitions)
    ; Construct and return the Turing Machine tuple vector.
    (let ((tuple (make-vector 7)))
      (vector-set! tuple 0 symbols)
      (vector-set! tuple 1 blank)
      (vector-set! tuple 2 inputs)
      (vector-set! tuple 3 states)
      (vector-set! tuple 4 initial)
      (vector-set! tuple 5 finals)
      (vector-set! tuple 6 (transitions-alist transitions))
      tuple)))

; Return the symbols of a Turing Machine.
(define-syntax turing-symbols (syntax-rules () ((_ tm) (vector-ref tm 0))))

; Return the blank symbol of a Turing Machine.
(define-syntax turing-blank (syntax-rules () ((_ tm) (vector-ref tm 1))))

; Return the input symbols of a Turing Machine.
(define-syntax turing-inputs (syntax-rules () ((_ tm) (vector-ref tm 2))))

; Return the states of a Turing Machine.
(define-syntax turing-states (syntax-rules () ((_ tm) (vector-ref tm 3))))

; Return the initial state of a Turing Machine.
(define-syntax turing-initial (syntax-rules () ((_ tm) (vector-ref tm 4))))

; Return the final states of a Turing Machine.
(define-syntax turing-finals (syntax-rules () ((_ tm) (vector-ref tm 5))))

; Return the transitions of a Turing Machine.
(define-syntax turing-transitions (syntax-rules () ((_ tm) (vector-ref tm 6))))

; Return the q_i (current state) of alist element transition.
(define-syntax tran-q_i (syntax-rules () ((_ atran) (car (car atran)))))

; Return the s_j (symbol read from the tape) of alist element transition.
(define-syntax tran-s_j (syntax-rules () ((_ atran) (cdr (car atran)))))

; Return the s_ij (symbol written) of alist element transition.
(define-syntax tran-s_ij (syntax-rules () ((_ atran) (car (cadr atran)))))

; Return the d_ij (direction of move) of alist element transition.
(define-syntax tran-d_ij (syntax-rules () ((_ atran) (cadr (cadr atran)))))

; Return the q_ij (state transition) of alist element transition.
(define-syntax tran-q_ij (syntax-rules () ((_ atran) (caddr (cadr atran)))))

; Lookup the transition matching the given state and symbol in the given Turing Machine.
(define atrns-lookup
  (lambda (state symbol tm)
    (assoc (cons state symbol) (turing-transitions tm))))

; Convert the given Turing Machine transition to a string.
(define tran->string
  (lambda (atran)
    (format "(~a ~a ~a ~a ~a)"
      (tran-q_i atran) (tran-s_j atran) (tran-s_ij atran) (tran-d_ij atran) (tran-q_ij atran))))

; Convert the given Turing Machine definition to a string.
; Options (zero or more) are, in order: component prefix string (default "");
; component suffix string (default ""); component separator string (default newline).
(define turing->string
  (lambda (tm . opts)
    (let ((prestr (if (> (length opts) 0) (list-ref opts 0) ""))
          (sufstr (if (> (length opts) 1) (list-ref opts 1) ""))
          (sepstr (if (> (length opts) 2) (list-ref opts 2) (make-string 1 #\newline)))
          (strlst '()))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-symbols tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-blank tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-inputs tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-states tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-initial tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-finals tm) sufstr
          (if (> (length (turing-transitions tm)) 0) sepstr "")))))
      (do ((index 0 (1+ index)))
          ((>= index (length (turing-transitions tm))))
        (set! strlst (append strlst (string->list
          (format "~a~a~a~a" prestr (tran->string (list-ref (turing-transitions tm) index)) sufstr
            (if (< index (1- (length (turing-transitions tm)))) sepstr ""))))))
      (list->string strlst))))

;----------------------------------------------------------------------------------------------

; Run the given Turing Machine on the given input tape.
; If specified, display log of progress.  Optionally, abort after given number of iterations.
; Returns the count of iterations, the accepting state (if one; else void), and the output
; tape as multiple values.
(define turing-run
  (lambda (tm cell show-log? . opt-abort)
    ; Validate contents of input tape.  (Leading/trailing blanks allowed; internals are not.)
    (unless (tape-empty? cell (turing-blank tm))
      (let ((fst (tape-fst cell (turing-blank tm)))
            (lst (tape-lst cell (turing-blank tm))))
        (if (eq? fst lst)
          (unless (memq (cell-get fst) (turing-symbols tm))
            (error 'turing-run "input tape has disallowed content" (cell-get fst)))
          (do ((cell fst (cell-right cell)))
              ((eq? cell (cell-right lst)))
            (unless (memq (cell-get cell) (turing-inputs tm))
                  (error 'turing-run "input tape has disallowed content" (cell-get cell)))))))
    ; Initialize state and head.
    (let ((state (turing-initial tm)) (head cell) (atran #f)
          (abort (and (pair? opt-abort) (integer? (car opt-abort))
                      (> (car opt-abort) 0) (car opt-abort))))
      ; Loop until no transition matches state/symbol or reached a final state.
      (do ((count 0 (1+ count))
           (atran (atrns-lookup state (cell-get head) tm)
                  (atrns-lookup state (cell-get head) tm)))
          ((or (not atran) (memq state (turing-finals tm)) (and abort (>= count abort)))
           ; Display final progress (optional).
           (when show-log?
             (let* ((string (format "~a" state))
                    (strlen (string-length string))
                    (padlen (max 1 (- 25 strlen)))
                    (strpad (make-string padlen #\ )))
               (printf "~a~a~a~%" string strpad (tape->string cell head))))
           ; Return resultant count, accepting state (or void), and tape.
           (values count (if (memq state (turing-finals tm)) state (void)) head))
        ; Display progress (optional).
        (when show-log?
          (let* ((string (format "~a ~a  ->  ~a ~a ~a" state (cell-get head)
                                 (tran-s_ij atran) (tran-d_ij atran) (tran-q_ij atran)))
                 (strlen (string-length string))
                 (padlen (max 1 (- 25 strlen)))
                 (strpad (make-string padlen #\ )))
            (printf "~a~a~a~%" string strpad (tape->string cell head))))
        ; Iterate.
        (cell-set! head (tran-s_ij atran))
        (set! state (tran-q_ij atran))
        (set! head (case (tran-d_ij atran)
                         ((L) (cell-extend-left head (turing-blank tm)))
                         ((R) (cell-extend-right head (turing-blank tm)))
                         ((N) head)))))))

;----------------------------------------------------------------------------------------------


//region Imports

import <Utilities/Conversion.sl>;
import <Utilities/Sequence.sl>;

//endregion

//region Types

MCONFIG ::= (Label: char(1), Symbols: char(2), Operations: char(2), FinalConfig: char(1));
STATE ::= (CurrentConfig: char(1), CurrentPosition: int(0), Tape: char(1));
INPUT_DATA ::= (Iterations: int(0), InitialTape: char(1), StartingPosition: int(0), InitialConfig: char(1), MConfigs: MCONFIG(1));

//endregion

//region Constants

SPACE_CHAR := '_';
DELIMITTER := '|';

NULL_CONFIG := (Label: "", Symbols: [], Operations: [], FinalConfig: "");

TRACE_HEADER := ["Config:\t| Place:\t| Tape:"];

//endregion

//region Helpers

StateToString(state(0)) :=
    state.CurrentConfig ++
    "  \t\t| " ++ intToString(state.CurrentPosition) ++
    "  \t| " ++ state.Tape;

StateToArrowString(state(0)) :=
    state.Tape ++ "\n" ++
    duplicate(' ', state.CurrentPosition - 1) ++ "|\n" ++
    duplicate(' ', state.CurrentPosition - 1) ++ state.CurrentConfig ++ "\n";

HeadOfEach(strings(2))[i] :=
    head(strings[i]);

RemoveCharacter(character(0), string(1))[i] :=
    string[i] when not(string[i] = character);

GetFSquares(Tape(1))[i] :=
    Tape[i] when (i mod 2) = 1;

//endregion

//region Parsing

ParseConfig(Line(1)) :=
    let
        entries := split(Line, DELIMITTER);
        label := entries[1];
        symbols := split(entries[2], ',');
        operations := split(entries[3], ',');
        finalConfig := entries[4];
    in
        ((Label: label, Symbols: symbols, Operations: operations, FinalConfig: finalConfig) when not((Line[1] = '/') and (Line[2] = '/')))
            when size(Line) > 0;

ParseTextFile(Text(1)) :=
    let
        noSpaces := RemoveCharacter('\t', RemoveCharacter('\r', RemoveCharacter(' ', Text)));
        lines := split(noSpaces, '\n');
        iterations := stringToInt(lines[1]);
        initialTape := lines[2];
        initialPosition := stringToInt(lines[3]);
        initialConfig := lines[4];
        mConfigs := ParseConfig(lines[5 ... size(lines)]);
    in
        (Iterations: iterations, InitialTape: initialTape, StartingPosition: initialPosition, InitialConfig: initialConfig, MConfigs: mConfigs);

//endregion

//region Config Finding

Matches: char(0) * char(2) -> bool;
Matches(currentSymbol(0), symbols(2)) :=
        true when size(symbols) = 0 //some(equalListNT("", symbols))
    else
        true when currentSymbol = SPACE_CHAR and some(equalListNT("none", symbols))
    else
        true when not(currentSymbol = SPACE_CHAR) and some(equalListNT("any", symbols))
    else
        true when some(currentSymbol = HeadOfEach(symbols))
    else
        false;

GetCurrentSymbol(State(0)) :=
        State.Tape[State.CurrentPosition] when size(State.Tape) >= State.CurrentPosition and State.CurrentPosition > 0
    else
        SPACE_CHAR;

GetConfigHelper(label(1), symbol(0), mConfigs(1))[i] :=
    mConfigs[i] when equalList(mConfigs[i].Label, label) and Matches(symbol, mConfigs[i].Symbols);

GetConfig(label(1), symbol(0), mConfigs(1)) :=
    let
        searchResults := GetConfigHelper(label, symbol, mConfigs);
    in
            NULL_CONFIG when size(searchResults) = 0
        else
            searchResults[1];

//endregion

//region Operations

TrimTapeEnd(tape(1), position(0)) :=
        tape when position = size(tape)
    else
        tape when not(last(tape) = SPACE_CHAR)
    else
        TrimTapeEnd(allButLast(tape), position);

ApplyOperations(State(0), Operations(2)) :=
    let
        newState := ApplyOperation(State, head(Operations));
    in
            State when size(Operations) = 0
        else
            ApplyOperations(newState, tail(Operations));

ApplyOperation(State(0), Operation(1)) :=
    let
        newTape :=
                PrintOperation(head(tail(Operation)), State.CurrentPosition, State.Tape) when head(Operation) = 'P'
            else
                EraseOperation(State.CurrentPosition, State.Tape) when head(Operation) = 'E'
            else
                [SPACE_CHAR] ++ State.Tape when head(Operation) = 'L' and State.CurrentPosition = 1
            else
                State.Tape ++ [SPACE_CHAR] when head(Operation) = 'R' and State.CurrentPosition = size(State.Tape)
            else
                State.Tape;

        newPosition :=
                1 when head(Operation) = 'L' and State.CurrentPosition = 1
            else
                State.CurrentPosition + 1 when head(Operation) = 'R'
            else
                State.CurrentPosition - 1 when head(Operation) = 'L'
            else
                State.CurrentPosition;

        trimmedTape := TrimTapeEnd(newTape, newPosition);
    in
            State when size(Operation) = 0
        else
            (CurrentPosition: newPosition, Tape: trimmedTape);

PrintOperation(Symbol(0), Position(0), Tape(1)) :=
    let
        diff := Position - size(Tape) when Position > size(Tape) else 0;
        expandedTape := Tape ++ duplicate(SPACE_CHAR, diff);
        finalTape := setElementAt(expandedTape, Position, Symbol);
    in
        finalTape;

EraseOperation(Position(0), Tape(1)) :=
    PrintOperation(SPACE_CHAR, Position, Tape);

//endregion

//region Execution

RunMachine(Text(1), Flag(1)) :=
    let
        input := ParseTextFile(Text);
        initialState := (CurrentConfig: input.InitialConfig, CurrentPosition: input.StartingPosition, Tape: input.InitialTape);

        processed := Process(initialState, input.MConfigs, input.Iterations);
        processedWithTrace := ProcessWithTrace(initialState, input.MConfigs, input.Iterations);
    in
            "\n" ++ delimit(TRACE_HEADER ++ StateToString(processedWithTrace), '\n') when equalList(Flag, "trace")
        else
            "\n" ++ delimit(StateToArrowString(processedWithTrace), '\n') when equalList(Flag, "arrow-trace")
        else
            processed.Tape when equalList(Flag, "tape")
        else
            TrimTapeEnd(GetFSquares(processed.Tape), 1) when equalList(Flag, "f-squares")
        else
            boolToString(DoesMachineHalt(initialState, input.MConfigs, input.Iterations)) when equalList(Flag, "halts")
        else
            StateToString(processed);

DoesMachineHalt(InitialState(0), mConfigs(1), Iterations(0)) :=
    let
        resultState := Process(InitialState, mConfigs, Iterations);
    in
        equalList(resultState.CurrentConfig, "halt");

ProcessWithTrace(InitialState(0), mConfigs(1), Iterations(0)) :=
        [InitialState] when Iterations <= 0 or size(InitialState.CurrentConfig) = 0 or equalList(InitialState.CurrentConfig, "halt")
    else
        [InitialState] ++ ProcessWithTrace(Iterate(InitialState, mConfigs), mConfigs, Iterations - 1);

Process(InitialState(0), mConfigs(1), Iterations(0)) :=
        InitialState when Iterations = 0 or size(InitialState.CurrentConfig) = 0 or equalList(InitialState.CurrentConfig, "halt")
    else
        Process(Iterate(InitialState, mConfigs), mConfigs, Iterations - 1);

Iterate(State(0), mConfigs(1)) :=
    let
        currentConfig := GetConfig(State.CurrentConfig, GetCurrentSymbol(State), mConfigs);
        newState := Execute(State, currentConfig);
    in
        newState;

Execute(State(0), mConfig(0)) :=
    let
        newState := ApplyOperations(State, mConfig.Operations);
    in
        (CurrentConfig: mConfig.FinalConfig, CurrentPosition: newState.CurrentPosition, Tape: newState.Tape);

//endregion


func run_utm(state="", blank="", rules=[], tape=[blank], halt="", pos=0) {

    if (pos < 0) {
        pos += tape.len;
    }

    if (pos !~ tape.range) {
        die "Bad initial position";
    }

    loop {
        print "#{state}\t";
        tape.range.each { |i|
            var v = tape[i];
            print (i == pos ? "[#{v}]" : " #{v} ");
        };
        print "\n";

        if (state == halt) {
            break;
        }

        rules.each { |rule|
            var (s0, v0, v1, dir, s1) = rule...;
            if ((s0 != state) || (tape[pos] != v0)) {
                next;
            }

            tape[pos] = v1;

            given(dir) {
                when ('left') {
                     if (pos == 0) { tape.unshift(blank) }
                     else          { --pos };
                }
                when ('right') {
                    if (++pos >= tape.len) {
                        tape.append(blank)
                    }
                }
            }

            state = s1;
            goto :NEXT;
        }

        die 'No matching rules';
        @:NEXT;
    }
}

print "incr machine\n";
run_utm(
    halt:  'qf',
    state: 'q0',
    tape:  %w(1 1 1),
    blank: 'B',
    rules: [
        %w(q0 1 1 right q0),
        %w(q0 B 1 stay  qf),
    ]);

say "\nbusy beaver";
run_utm(
    halt:  'halt',
    state: 'a',
    blank: '0',
    rules: [
        %w(a 0 1 right b),
        %w(a 1 1 left  c),
        %w(b 0 1 left  a),
        %w(b 1 1 right b),
        %w(c 0 1 left  b),
        %w(c 1 1 stay  halt),
    ]);

say "\nsorting test";
run_utm(
    halt:  'STOP',
    state: 'A',
    blank: '0',
    tape:  %w(2 2 2 1 2 2 1 2 1 2 1 2 1 2),
    rules: [
        %w(A 1 1 right A),
        %w(A 2 3 right B),
        %w(A 0 0 left  E),
        %w(B 1 1 right B),
        %w(B 2 2 right B),
        %w(B 0 0 left  C),
        %w(C 1 2 left  D),
        %w(C 2 2 left  C),
        %w(C 3 2 left  E),
        %w(D 1 1 left  D),
        %w(D 2 2 left  D),
        %w(D 3 1 right A),
        %w(E 1 1 left  E),
        %w(E 0 0 right STOP),
    ]);


(*** Signatures ***)

signature TAPE = sig
	datatype move = Left | Right | Stay

	type ''a tape
	val empty : ''a tape
	val moveLeft  : ''a tape -> ''a tape
	val moveRight : ''a tape -> ''a tape
	val move      : ''a tape -> move -> ''a tape
	val getSymbol : ''a tape -> ''a option
	val write     : ''a option -> ''a tape -> ''a tape
	val leftOf    : ''a tape -> ''a option list	(* Symbols left of the head in reverse order *)
	val rightOf   : ''a tape -> ''a option list	(* Symbols right of of the head *)
end

signature MACHINE = sig
	structure Tape : TAPE

	type state = int

	(* ''a is band alphabet type *)
	type ''a transitions = (state * ''a option Vector.vector) ->
	                       (state * (Tape.move * ''a option) Vector.vector)

	type ''a configuration = { state : state, tapes : ''a Tape.tape Vector.vector }

	type ''a machine = {
			alphabet : ''a Vector.vector,		(* (not used) *)
			states : state Vector.vector,		(* (not used) *)
			start  : state,				(* element of stats *)
			final  : state,				(* element of stats *)
			transitions : ''a transitions,		(* transitions *)
			tapes  : ''a Tape.tape Vector.vector	(* vector of the initial tapes *)
		}
end

signature UNIVERSALMACHINE = sig
	structure Machine : MACHINE

	val start : ''a Machine.machine -> ''a Machine.configuration

	(* Find a holding configuration (limited by n steps)
	 * Execute the handler for each step *)
	val simulate : (''a Machine.configuration -> unit) -> ''a Machine.machine -> int option -> ''a Machine.configuration option
end

(*** Implementation ***)

structure Tape :> TAPE = struct

	(*
	 * NONE   => blank field
	 * SOME a => written field
	 *)
	type ''a symbol = ''a option

	datatype move = Left | Right | Stay

	(*
	 * Four cases:
	 * 1   The tape is complete empty.
	 * 2   The head is in the written area.
	 *     On the right and on the left handside are symbols,
	 *     On the head is a symbol.
	 * 3/4 The head is (n-1) fields over the right/left edge of the written area.
	 *     There is at least one entry and a rest list of entries.
	 *)
	datatype ''a tape =
	  Empty
	| Middle  of ''a symbol list * ''a symbol * ''a symbol list
	| LeftOf  of ''a symbol * ''a symbol list * int
	| RightOf of ''a symbol * ''a symbol list * int

	val empty = Empty

	fun rep a 0 = nil
	  | rep a n = a :: rep a (n-1)

	fun leftOf  (Empty)              = nil
	  | leftOf  (Middle (ls, _, _))  = ls
	  | leftOf  (RightOf (r, rs, i)) = rep NONE i @ r :: rs
	  | leftOf  (LeftOf _)           = nil

	fun rightOf (Empty)              = nil
	  | rightOf (Middle (_, _, rs))  = rs
	  | rightOf (RightOf _)          = nil
	  | rightOf (LeftOf (l, ls, i))  = rep NONE i @ l :: ls

	fun write (NONE) t = t (* Cannot write a blank field! *)
	  | write a      t = Middle (leftOf t, a, rightOf t)

	fun getSymbol (Middle (_, m, _)) = m
	  | getSymbol _ = NONE (* blank *)

	fun moveRight (Empty) = Empty
	  | moveRight (Middle (ls, m,   nil)) = RightOf (m, ls, 0)
	  | moveRight (Middle (ls, m, r::rs)) = Middle (m::ls, r, rs)
	  | moveRight (RightOf (l, ls, n))    = RightOf (l, ls, n+1)
	  | moveRight (LeftOf (r, rs, 0))     = Middle (nil, r, rs)
	  | moveRight (LeftOf (r, rs,  n))    = LeftOf (r, rs, n-1)

	fun moveLeft (Empty) = Empty
	  | moveLeft (Middle (nil, m,   rs)) = LeftOf (m, rs, 0)
	  | moveLeft (Middle (l::ls, m, rs)) = Middle (ls, l, m::rs)
	  | moveLeft (RightOf (l, ls, 0))    = Middle (ls, l, nil)
	  | moveLeft (RightOf (l, ls, n))    = RightOf (l, ls, n-1)
	  | moveLeft (LeftOf (r, rs,  n))    = LeftOf (r, rs, n+1)

	fun move tape Stay  = tape
	  | move tape Right = moveRight tape
	  | move tape Left  = moveLeft  tape

	(* Test *)
	local
		val tape : int tape = empty		(* [] *)
		val tape = moveRight tape		(* [] *)
		val NONE = getSymbol tape
		val tape = write (SOME 42) tape		(* [42] *)
		val (SOME 42) = getSymbol tape
		val tape = moveRight tape		(* 42, [] *)
		val tape = moveRight tape		(* 42, , [] *)
		val NONE = getSymbol tape
		val tape = moveLeft tape		(* 42, [] *)
		val NONE = getSymbol tape
		val tape = moveLeft tape		(* [42] *)
		val (SOME 42) = getSymbol tape
		val tape = write NONE tape		(* [42] *) (* !!! *)
		val (SOME 42) = getSymbol tape
		val tape = moveLeft tape		(* [], 42 *)
		val tape = moveLeft tape		(* [], , 42 *)
		val tape = write (SOME 47) tape		(* [47], , 42 *)
		val (SOME 47) = getSymbol tape
		val tape = moveRight tape		(* 47, [], 42 *)
		val NONE = getSymbol tape
		val tape = moveRight tape		(* 47, , [42] *)
		val (SOME 42) = getSymbol tape
	in end
end

structure Machine :> MACHINE = struct
	structure Tape = Tape

	type state = int

	(* ''a is band alphabet type *)
	type ''a transitions = (state * ''a option Vector.vector) ->
	                       (state * (Tape.move * ''a option) Vector.vector)

	type ''a configuration = { state : state, tapes : ''a Tape.tape Vector.vector }

	type ''a machine = {
			alphabet : ''a Vector.vector,
			states : state Vector.vector,
			start  : state,
			final  : state,
			transitions : ''a transitions,
			tapes  : ''a Tape.tape Vector.vector
		}
end

structure UniversalMachine :> UNIVERSALMACHINE = struct

	structure Machine = Machine

	fun start ({ start, tapes, ... } : ''a Machine.machine) : ''a Machine.configuration = {
			state = start,
			tapes = tapes
		}

	fun doTransition ({ state, tapes } : ''a Machine.configuration)
	    ((state', actions) : (Machine.state * (Machine.Tape.move * ''a option) Vector.vector))
		: ''a Machine.configuration = {
			state = state',
			tapes = Vector.mapi (fn (i, tape) =>
					let val (move, write) = Vector.sub (actions, i)
					    val tape'  = Machine.Tape.write write tape
					    val tape'' = Machine.Tape.move tape' move
					in tape'' end) tapes
		}

	fun getSymbols ({ tapes, ... } : ''a Machine.configuration) : ''a option Vector.vector =
		Vector.map (Machine.Tape.getSymbol) tapes

	fun step ({ transitions, ... } : ''a Machine.machine) (conf : ''a Machine.configuration) : ''a Machine.configuration =
		doTransition conf (transitions (#state conf, getSymbols conf))

	fun isFinal ({final, ...} : ''a Machine.machine) ({state, ...} : ''a Machine.configuration) : bool =
		final = state

	fun iter term (SOME 0) f s = NONE
	  | iter term (SOME n) f s = if term s then SOME s else iter term (SOME (n-1)) f (f s)
	  | iter term NONE     f s = if term s then SOME s else iter term NONE f (f s)

	fun simulate handler (machine : ''a Machine.machine) optcount =
		let val endconf = iter (isFinal machine) optcount (fn conf => (handler conf; step machine conf)) (start machine)
		in case endconf of NONE => NONE | SOME conf => (handler conf; endconf) end

end

structure ExampleMachines = struct

	structure Machine = UniversalMachine.Machine

	(* Tranform the 5-Tuple notation into the vector function *)
	fun makeTransitions nil : ''a Machine.transitions = (fn (t, vec) => (print (Int.toString t); raise Subscript))
	  | makeTransitions ((s : Machine.state,
	  		      read : ''a option,
	                      write : ''a option,
			      move : Machine.Tape.move,
			      s' : Machine.state) :: ts) =
	  	fn (t, vec) =>
	  		if s=t andalso vec=(Vector.fromList [read])
		        then (s', Vector.fromList [(move, write)])
			else makeTransitions ts (t, vec)

	(* `createTape xs` creates an tape initialized by xs, where the head stands on the first element of xs *)
	fun createTape' nil     = Machine.Tape.empty
	  | createTape' (x::xs) = Machine.Tape.moveLeft (Machine.Tape.write x (createTape' xs))

	fun createTape xs = Machine.Tape.moveRight (createTape' (rev xs))

	(* Convert a tape into a string to print it. It needs a function that converts each symbol to string *)
	fun tapeToStr (symStr : ''a -> string) (tape : ''a Machine.Tape.tape) : string =
		let val left     : ''a option list = rev (Machine.Tape.leftOf tape)
		    val right    : ''a option list = Machine.Tape.rightOf tape
		    val current  : ''a option      = Machine.Tape.getSymbol tape
		    val symToStr : ''a option -> string = (fn (NONE) => "#" | (SOME a) => symStr a)
		in
		    String.concatWith " " ((map symToStr left) @ [ "|" ^ symToStr current ^ "|" ] @ (map symToStr right))
		end

	(* Convert a vector to a list *)
	fun vectToList vect = List.tabulate (Vector.length vect, fn i => Vector.sub (vect, i))

	(* Do this before every step and after the last step. *)
	fun handler (symToStr : ''a -> string) ({state, tapes} : ''a Machine.configuration) : unit =
		let
			val str = "State " ^ Int.toString state ^ "\n" ^
			String.concat (vectToList (Vector.mapi (fn (i, tape) => "Tape #" ^ Int.toString i ^ ": " ^
			tapeToStr symToStr tape ^ "\n") tapes))
		in
			print str
		end

	(* Simulate and make result into string *)
	fun simulate (symToStr : ''a -> string) (machine : ''a Machine.machine)
	    (optcount : int option) : string =
		case (UniversalMachine.simulate (handler symToStr) machine optcount) of
		  NONE => "Did not terminate."
		| SOME ({state, tapes} : ''a Machine.configuration) => "Terminated."

	(* Now finaly the machines! *)

	val incrementer : unit Machine.machine = {
		alphabet = Vector.fromList [()],
		states   = Vector.fromList [0, 1],
		start    = 0,
		final    = 1,
		tapes    = Vector.fromList [createTape (map SOME [(), (), (), ()])],
		transitions = makeTransitions [
			(0, SOME (), SOME (), Machine.Tape.Right, 0),
			(0, NONE,    SOME (), Machine.Tape.Stay,  1)]
	}

	val busybeaver : unit Machine.machine = {
		alphabet = Vector.fromList [()],
		states   = Vector.fromList [0, 1, 2, 3],
		start    = 0,
		final    = 3,
		tapes    = Vector.fromList [Machine.Tape.empty],
		transitions = makeTransitions [
			(0, NONE,    SOME (), Machine.Tape.Right, 1),
			(0, SOME (), SOME (), Machine.Tape.Left,  2),
			(1, NONE,    SOME (), Machine.Tape.Left,  0),
			(1, SOME (), SOME (), Machine.Tape.Right, 1),
			(2, NONE,    SOME (), Machine.Tape.Left,  1),
			(2, SOME (), SOME (), Machine.Tape.Stay,  3)]
	}

	val sorting : int Machine.machine = {
		alphabet = Vector.fromList [1,2,3],
		states   = Vector.fromList [0,1,2,3,4,5],
		start    = 1,
		final    = 0,
		tapes    = Vector.fromList [createTape (map SOME [2, 1, 2, 2, 1, 1])],
		transitions = makeTransitions [
			(1, SOME 1, SOME 1, Machine.Tape.Right, 1),
			(1, SOME 2, SOME 3, Machine.Tape.Right, 2),
			(1, NONE,   NONE,   Machine.Tape.Left,  5),
			(2, SOME 1, SOME 1, Machine.Tape.Right, 2),
			(2, SOME 2, SOME 2, Machine.Tape.Right, 2),
			(2, NONE,   NONE,   Machine.Tape.Left,  3),
			(3, SOME 1, SOME 2, Machine.Tape.Left,  3),
			(3, SOME 2, SOME 2, Machine.Tape.Left,  3),
			(3, SOME 3, SOME 2, Machine.Tape.Left,  5),
			(4, SOME 1, SOME 1, Machine.Tape.Left,  4),
			(4, SOME 2, SOME 2, Machine.Tape.Left,  4),
			(4, SOME 3, SOME 1, Machine.Tape.Right, 1),
			(5, SOME 1, SOME 1, Machine.Tape.Left,  5),
			(5, NONE,   NONE,   Machine.Tape.Right, 0)]
		}
end

(** Invoke Simulations **)
local
	open ExampleMachines
	val unitToString = (fn () => "()")
	fun simulate_unit machine optcount = print (simulate unitToString machine optcount ^ "\n")
	fun simulate_int  machine optcount = print (simulate Int.toString machine optcount ^ "\n")
in
	val () = print "Simulate incrementer...\n\n"
	val () = simulate_unit incrementer NONE
	val () = print "\nSimulate Busy Beaver...\n\n"
	val () = simulate_unit busybeaver NONE
	val () = print "\nSimulate Sorting...\n\n"
	val () = simulate_int sorting NONE
end


proc turing {states initial terminating symbols blank tape rules {doTrace 1}} {
    set state $initial
    set idx 0
    set tape [split $tape ""]
    if {[llength $tape] == 0} {
	set tape [list $blank]
    }
    foreach rule $rules {
	lassign $rule state0 sym0 sym1 move state1
	set R($state0,$sym0) [list $sym1 $move $state1]
    }
    while {$state ni $terminating} {
	set sym [lindex $tape $idx]
	lassign $R($state,$sym) sym1 move state1
	if {$doTrace} {
	    ### Print the state, great for debugging
	    puts "[join $tape ""]\t$state->$state1"
	    puts "[string repeat { } $idx]^"
	}
	lset tape $idx $sym1
	switch $move {
	    left {
		if {[incr idx -1] < 0} {
		    set idx 0
		    set tape [concat [list $blank] $tape]
		}
	    }
	    right {
		if {[incr idx] == [llength $tape]} {
		    lappend tape $blank
		}
	    }
	}
	set state $state1
    }
    return [join $tape ""]
}


#!/usr/bin/env bash
main() {
  printf 'Simple Incrementer\n'
  printf '1 1 1' | run_utm q0 qf B q0,1,1,R,q0 q0,B,1,S,qf

  printf '\nThree-state busy beaver\n'
  run_utm a halt 0 \
    a,0,1,R,b a,1,1,L,c b,0,1,L,a b,1,1,R,b c,0,1,L,b c,1,1,S,halt \
    </dev/null
}

run_utm() {
  local initial=$1 final=$2 blank=$3
  shift 3
  local rules=("[email protected]") tape
  mapfile -t -d' ' tape
  if (( ! ${#tape[@]} )); then
    tape=( "$blank" )
  fi
  local state=$initial
  local head=0
  while [[ $state != $final ]]; do
    print_state "$state" "$head" "${tape[@]}"
    local symbol=${tape[head]}
    local found=0 rule from input output move to
    for rule in "${rules[@]}"; do
      IFS=, read from input output move to <<<"$rule"
      if [[ $state == $from && $symbol == $input ]]; then
        found=1
        break
      fi
    done
    if (( ! found )); then
        printf >&2 "Configuration error: no match for state=$state input=$sym\n"
        return 1
    fi
    tape[head]=$output
    state=$to
    case "$move" in
     L) if (( ! head-- )); then
          head=0
          tape=("$blank" "${tape[@]}")
        fi
        ;;
     R) if (( ++head >= ${#tape[@]} )); then
          tape+=("$blank")
        fi
        ;;
    esac
  done
  print_state "$state" "$head" "${tape[@]}"
}

print_state() {
  local state=$1 head=$2
  shift 2
  local tape=("[email protected]")
  printf '%s' "$state"
  printf '  %s' "${tape[@]}"
  printf '\r'
  (( t = ${#state} + 1 + 3 * head ))
  printf '\e['"$t"'C<\e[C>\n'
}

main "[email protected]"


Option Base 1
Public Enum sett
    name_ = 1
    initState
    endState
    blank
    rules
End Enum
Public incrementer As Variant, threeStateBB As Variant, fiveStateBB As Variant
'-- Machine definitions
Private Sub init()
    incrementer = Array("Simple incrementer", _
        "q0", _
        "qf", _
        "B", _
         Array( _
         Array("q0", "1", "1", "right", "q0"), _
         Array("q0", "B", "1", "stay", "qf")))
    threeStateBB = Array("Three-state busy beaver", _
       "a", _
       "halt", _
       "0", _
        Array( _
        Array("a", "0", "1", "right", "b"), _
        Array("a", "1", "1", "left", "c"), _
        Array("b", "0", "1", "left", "a"), _
        Array("b", "1", "1", "right", "b"), _
        Array("c", "0", "1", "left", "b"), _
        Array("c", "1", "1", "stay", "halt")))
    fiveStateBB = Array("Five-state busy beaver", _
        "A", _
        "H", _
        "0", _
         Array( _
         Array("A", "0", "1", "right", "B"), _
         Array("A", "1", "1", "left", "C"), _
         Array("B", "0", "1", "right", "C"), _
         Array("B", "1", "1", "right", "B"), _
         Array("C", "0", "1", "right", "D"), _
         Array("C", "1", "0", "left", "E"), _
         Array("D", "0", "1", "left", "A"), _
         Array("D", "1", "1", "left", "D"), _
         Array("E", "0", "1", "stay", "H"), _
         Array("E", "1", "0", "left", "A")))
End Sub

Private Sub show(state As String, headpos As Long, tape As Collection)
    Debug.Print " "; state; String$(7 - Len(state), " "); "| ";
    For p = 1 To tape.Count
        Debug.Print IIf(p = headpos, "[" & tape(p) & "]", " " & tape(p) & " ");
    Next p
    Debug.Print
End Sub

'-- a universal turing machine
Private Sub UTM(machine As Variant, tape As Collection, Optional countOnly As Long = 0)
    Dim state As String: state = machine(initState)
    Dim headpos As Long: headpos = 1
    Dim counter As Long, rule As Variant
    Debug.Print machine(name_); vbCrLf; String$(Len(machine(name_)), "=")
    If Not countOnly Then Debug.Print " State  | Tape [head]" & vbCrLf & "---------------------"
    Do While True
        If headpos > tape.Count Then
            tape.Add machine(blank)
        Else
            If headpos < 1 Then
                tape.Add machine(blank), Before:=1
                headpos = 1
            End If
        End If
        If Not countOnly Then show state, headpos, tape
        For i = LBound(machine(rules)) To UBound(machine(rules))
            rule = machine(rules)(i)
            If rule(1) = state And rule(2) = tape(headpos) Then
                tape.Remove headpos
                If headpos > tape.Count Then
                    tape.Add rule(3)
                Else
                    tape.Add rule(3), Before:=headpos
                End If
                If rule(4) = "left" Then headpos = headpos - 1
                If rule(4) = "right" Then headpos = headpos + 1
                state = rule(5)
                Exit For
            End If
        Next i
        counter = counter + 1
        If counter Mod 100000 = 0 Then
            Debug.Print counter
            DoEvents
            DoEvents
        End If
        If state = machine(endState) Then Exit Do
    Loop
    DoEvents
    If countOnly Then
        Debug.Print "Steps taken: ", counter
    Else
        show state, headpos, tape
        Debug.Print
    End If
End Sub

Public Sub main()
    init
    Dim tap As New Collection
    tap.Add "1": tap.Add "1": tap.Add "1"
    UTM incrementer, tap
    Set tap = New Collection
    UTM threeStateBB, tap
    Set tap = New Collection
    UTM fiveStateBB, tap, countOnly:=-1
End Sub