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.




 
(require 'struct)
 
(struct TM (read-only: name states symbs final rules mem  state-values: tape pos state))
 
(define-syntax-rule (rule-idx state symb numstates)
    (+ state (* symb numstates)))
 
(define-syntax-rule (make-TM name states symbs rules) 
    (_make-TM  name 'states 'symbs 'rules))
 
;; a rule is (state symbol --> write move new-state)
;; index for rule = state-num + (number of states)  * symbol-num
;; convert states/symbol into vector indices
(define (compile-rule T rule  into: rules)
    (define numstates (vector-length (TM-states T)))
    (define state (vector-index [rule 0](TM-states T) )) ; index 
    (define symb (vector-index [rule 1](TM-symbs T) ))
    (define write-symb (vector-index [rule 2] (TM-symbs T)  ))
    (define move (1- (vector-index  [rule 3] #(left stay right) )))
    (define new-state (vector-index  [rule 4](TM-states T)))
    (define rulenum (rule-idx state symb numstates))
    (vector-set! rules rulenum (vector write-symb move new-state))
    ; (writeln 'rule  rulenum [rules rulenum])
    )
 
(define (_make-TM name states symbs rules)
    (define T (TM  name (list->vector states) (list->vector symbs) null null))
    (set-TM-final! T (1-  (length states))) ;; assume one final state
    (set-TM-rules! T (make-vector (* (length states) (length symbs))))
    (for ((rule rules)) (compile-rule T (list->vector rule) into: (TM-rules T)))
    T ) ; returns a TM
 
;;------------------
;; TM-trace 
;;-------------------
(string-delimiter "")
 
(define (TM-print T symb-index: symb (hilite #f))
	(cond 
	((= 0 symb) (if hilite "🔲"  "◽️" ))
	((= 1 symb) (if hilite  "🔳 " "◾️" ))
	(else "X")))
 
(define (TM-trace T tape pos state step)
	(if (= (TM-final T) state)
		(write "🔴")
		(write "🔵"))
 
    (for [(p (in-range  (- (TM-mem T) 7) (+ (TM-mem T) 8)))]
        (write (TM-print T [tape p] (= p pos))))
    (write step)
    (writeln))
 
;;---------------
;; TM-init : alloc and init tape
;;---------------
(define (TM-init T input-symbs (mem 20))
    ;; init state variables
    (set-TM-tape! T (make-vector (* 2 mem)))
    (set-TM-pos!  T  mem)
    (set-TM-state! T 0)
    (set-TM-mem! T mem)
 
    (for [(symb input-symbs) (i (in-naturals))]
        (vector-set! (TM-tape T) [+ i (TM-pos T)] (vector-index symb (TM-symbs T))))
    (TM-trace T  (TM-tape T) mem 0 0)
    mem )
 
;;---------------
;; TM-run : run at most maxsteps
;;---------------
(define (TM-run T  (verbose #f)  (maxsteps 1_000_000))
(define count 0)
    (define final (TM-final T))
    (define rules (TM-rules T))
    (define rule 0)
    (define numstates (vector-length (TM-states T)))
    ;; set current state vars
    (define pos (TM-pos T))
    (define state (TM-state T))
    (define tape (TM-tape T))
 
    (when (and (zero? state) (= pos (TM-mem T)))
    	 (writeln 'Starting (TM-name T))
    	 (TM-trace T tape pos 0 count))
 
    (while (and (!= state final) (< count maxsteps))
    (++ count)
;; The machine
        (set! rule [rules (rule-idx state [tape pos] numstates)])
        (when (= rule 0) (error "missing rule" (list state [tape pos])))
        (vector-set! tape pos [rule 0])
        (set! state [rule 2])
        (+= pos [rule 1])
;; end machine
        (when verbose (TM-trace  T tape pos state count )))
;; save TM state
    (set-TM-pos! T pos)
    (set-TM-state! T state)
    (when (= final state)  (writeln 'Stopping (TM-name T) 'at-pos (- pos (TM-mem T))))
    count)  
 