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.




include "cowgol.coh";
include "strings.coh";
include "malloc.coh";
 
###############################################################################
########################## Turing machine definition ##########################
###############################################################################
typedef Symbol is uint8; # 256 symbols ought to be enough for everyone
 
const LEFT := 1;
const RIGHT := 2;
const STAY := 3;
typedef Action is int(LEFT, STAY);
 
# Linked list
record Linked is
    next: [Linked];
end record;
 
record DoublyLinked: Linked is
    prev: [DoublyLinked];
end record;
 
sub FreeLinked(r: [Linked]) is
    while r != 0 as [Linked] loop
        var v := r.next;
        Free(r as [uint8]);
        r := v;
    end loop;
end sub;
 
sub FreeDoublyLinked(r: [DoublyLinked]) is
    FreeLinked(r.next);
    while r != 0 as [DoublyLinked] loop
        var v := r.prev;
        Free(r as [uint8]);
        r := v;
    end loop;
end sub;
 
# Turing machine
typedef Turing is [TuringR];
record StateR: Linked is
    tm: Turing;     # turing machine this state belongs to
    term: uint8;    # whether state is terminating
end record;
typedef State is [StateR];
 
record Cell: DoublyLinked is  
    sym: Symbol;
end record;
 
record RuleR: Linked is
    instate: State;
    insym: Symbol;
    outsym: Symbol;
    action: Action;
    outstate: State;
end record;
typedef Rule is [RuleR];
 
record TuringR is
    states: State;
    rules: Rule;
    initial: State;
    current: State;
    blank: Symbol;
    head: [Cell];
end record;
 
sub MakeCell(): (c: [Cell]) is
    c := Alloc(@bytesof Cell) as [Cell];
    MemZero(c as [uint8], @bytesof Cell);
end sub;
 
# Define a Turing machine
sub MakeTuring(blank: Symbol, init: [Symbol]): (t: Turing) is
    t := Alloc(@bytesof TuringR) as Turing;
    MemZero(t as [uint8], @bytesof TuringR);
    t.blank := blank;
    t.head := MakeCell();
    t.head.sym := blank;
 
    var c := t.head;
    var d: [Cell];
    while [init] != 0 loop
        c.sym := [init];
        init := @next init;
        if [init] == 0 then break; end if;
        d := Alloc(@bytesof Cell) as [Cell];
        d.prev := c as [DoublyLinked];
        d.next := 0 as [Linked];
        c.next := d as [Linked];
        c := d;
    end loop;
end sub;
 
# Add a state to a Turing machine
const T_NONE := 0;
const T_INIT := 1;
const T_HALT := 2;
sub MakeState(t: Turing, type: uint8): (s: State) is    
    s := Alloc(@bytesof StateR) as State;
    s.tm := t;
    s.next := t.states as [Linked];
    t.states := s;
 
    if type & T_INIT != 0 then
        t.initial := s;
        t.current := s;
    end if;
    s.term := 0;
    if type & T_HALT != 0 then
        s.term := 1;
    end if;
end sub;
 
# Add a rule to a Turing machine
sub MakeRule(t: Turing,
             instate: State, 
             insym: Symbol,
             outsym: Symbol,
             action: Action,
             outstate: State): (r: Rule) is
    r := Alloc(@bytesof RuleR) as Rule;
    r.instate := instate;
    r.insym := insym;
    r.outsym := outsym;
    r.action := action;
    r.outstate := outstate;
    r.next := t.rules as [Linked];
    t.rules := r;
end sub;
 
# Free a Turing machine
sub FreeTuring(t: Turing) is    
    FreeDoublyLinked(t.head as [DoublyLinked]);
    FreeLinked(t.states as [Linked]);
    FreeLinked(t.rules as [Linked]);
    Free(t as [uint8]);
end sub;
 
# Move the head
sub MoveHead(t: Turing, a: Action) is   
    var c: [Cell];
    case a is
        when STAY: return;
        when LEFT:
            if t.head.prev == 0 as [DoublyLinked] then
                c := Alloc(@bytesof Cell) as [Cell];
                c.prev := 0 as [DoublyLinked];
                c.next := t.head as [Linked];
                c.sym := t.blank;
                t.head.prev := c as [DoublyLinked];
            end if;
            t.head := t.head.prev as [Cell];
            return;
        when RIGHT:
            if t.head.next == 0 as [Linked] then
                c := Alloc(@bytesof Cell) as [Cell];
                c.next := 0 as [Linked];
                c.prev := t.head as [DoublyLinked];
                c.sym := t.blank;
                t.head.next := c as [Linked];
            end if;
            t.head := t.head.next as [Cell];
            return;
        when else:
            print("Invalid action\n");
            ExitWithError();
    end case;
end sub;
 
# Step a Turing machine 
sub Step(t: Turing): (halt: uint8) is
    # If we're in a halt state, do nothing
    if t.current.term != 0 then
        halt := 1;
        return;
    end if;
 
    var r := t.rules;
    while r != 0 as Rule loop
        # Check each rule to see if it matches the current configuration
        if  t.current  == r.instate
        and t.head.sym == r.insym then
            # Found a match
            t.head.sym := r.outsym;
            MoveHead(t, r.action);
            t.current := r.outstate;
            halt := t.current.term;
            return;
        end if;    
        r := r.next as Rule;
    end loop;
    print("No valid rule!\n");
    ExitWithError();
end sub;
 
# Run a Turing machine until it halts
sub Run(t: Turing) is
    while Step(t) == 0 loop
    end loop;
end sub;
 
# Print the touched part of the tape of a Turing machine
sub PrintTape(t: Turing, max: uint32) is
    var c := t.head;
    var len: uint32 := 0;
    while c.prev != 0 as [DoublyLinked] loop
        c := c.prev as [Cell];
    end loop;
    while c != 0 as [Cell] loop
        if len < max then
            print_char(c.sym as uint8);
        end if;
        c := c.next as [Cell];
        len := len + 1;
    end loop;
    if len >= max then
        print("... (total length: ");
        print_i32(len);
        print(")");
    end if;
end sub;
 
###############################################################################
######################## Turing machines from the task ########################
###############################################################################
 
interface TuringFactory(): (t: Turing);
 
sub SimpleIncrementer implements TuringFactory is
    var r: Rule;
    t := MakeTuring('B', "111");
    var q0 := MakeState(t, T_INIT);
    var qf := MakeState(t, T_HALT);
    r := MakeRule(t, q0, '1', '1', RIGHT, q0);
    r := MakeRule(t, q0, 'B', '1', STAY, qf);
end sub;
 
sub ThreeStateBeaver implements TuringFactory is  
    var r: Rule;
    t := MakeTuring('0', "");
    var a := MakeState(t, T_INIT);
    var b := MakeState(t, T_NONE);
    var c := MakeState(t, T_NONE);
    var halt := MakeState(t, T_HALT);
    r := MakeRule(t, a, '0', '1', RIGHT, b);
    r := MakeRule(t, a, '1', '1', LEFT, c);
    r := MakeRule(t, b, '0', '1', LEFT, a);
    r := MakeRule(t, b, '1', '1', RIGHT, b);
    r := MakeRule(t, c, '0', '1', LEFT, b);
    r := MakeRule(t, c, '1', '1', STAY, halt);
end sub;
 
sub FiveStateBeaver implements TuringFactory is
    var r: Rule;
    t := MakeTuring('0', "");
    var A := MakeState(t, T_INIT);
    var B := MakeState(t, T_NONE);
    var C := MakeState(t, T_NONE);
    var D := MakeState(t, T_NONE);
    var E := MakeState(t, T_NONE);
    var H := MakeState(t, T_HALT);
    r := MakeRule(t, A, '0', '1', RIGHT, B);
    r := MakeRule(t, A, '1', '1', LEFT,  C);
    r := MakeRule(t, B, '0', '1', RIGHT, C);
    r := MakeRule(t, B, '1', '1', RIGHT, B);
    r := MakeRule(t, C, '0', '1', RIGHT, D);
    r := MakeRule(t, C, '1', '0', LEFT,  E);
    r := MakeRule(t, D, '0', '1', LEFT,  A);
    r := MakeRule(t, D, '1', '1', LEFT,  D);
    r := MakeRule(t, E, '0', '1', STAY,  H);
    r := MakeRule(t, E, '1', '0', LEFT,  A);
end sub;
 
record TF is
    name: [uint8];
    tf: TuringFactory;
end record;
 
var machines: TF[] := {
    {"Simple incrementer", SimpleIncrementer},
    {"Three state beaver", ThreeStateBeaver},
    {"Five state beaver", FiveStateBeaver}
};
 
var i: @indexof machines;
i := 0;
while i < @sizeof machines loop
    print(machines[i].name);
    print(": ");
    var t := (machines[i].tf) ();
    Run(t);
    PrintTape(t, 32);
    FreeTuring(t);
    print_nl();
    i := i + 1;
end loop;