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.




 
#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))))
 