One of the foundational mathematical constructs behind computer science
is the universal Turing Machine.



(Alan Turing introduced the idea of such a machine in 1936–1937.)

Indeed one way to definitively prove that a language
is turing-complete
is to implement a universal Turing machine in it.



Task

Simulate such a machine capable
of taking the definition of any other Turing machine and executing it.

Of course, you will not have an infinite tape,
but you should emulate this as much as is possible.

The three permissible actions on the tape are "left", "right" and "stay".

To test your universal Turing machine (and prove your programming language
is Turing complete!), you should execute the following two Turing machines
based on the following definitions.


Simple incrementer

 States: q0, qf
 Initial state: q0
 Terminating states: qf
 Permissible symbols: B, 1
 Blank symbol: B
 Rules:
 (q0, 1, 1, right, q0)
 (q0, B, 1, stay, qf)


The input for this machine should be a tape of 1 1 1


Three-state busy beaver

 States: a, b, c, halt
 Initial state: a
 Terminating states: halt
 Permissible symbols: 0, 1
 Blank symbol: 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)


The input for this machine should be an empty tape.


Bonus:

5-state, 2-symbol probable Busy Beaver machine from Wikipedia

 States: A, B, C, D, E, H
 Initial state: A
 Terminating states: H
 Permissible symbols: 0, 1
 Blank symbol: 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)


The input for this machine should be an empty tape.

This machine runs for more than 47 millions steps.




//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