Universal Turing machine: Difference between revisions

=={{header|Racket}}==

<lang scheme>

#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 tape in initial state

(define-m initial-tape

[(cons h t) (Tape '() h t)])

;; shift 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

;; shift 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))

;; access to the current record on the tape

(define-m get

[(Tape _ v _) v])

(define-m* put

[('() t) t]

[(v (Tape l _ r)) (Tape l v r)])

;; 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)])

;; Running 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))))

</lang>

The resulting Turing Machine is a function that maps the initial tape record to the final one, so that several machines could run one after another.

Examples:

The simple incrementer:

<lang scheme>

(define INC

(Turing-Machine #:start 'q0

[q0 1 1 right q0]

[q0 () 1 stay qf]))

</lang>

<pre>

> (INC '(1 1 1))

STATE TAPE

q0 ((1) 1 1)

q0 (1 (1) 1)

q0 (1 1 (1))

q0 (1 1 1 ())

qf (1 1 1 (1))

(1 1 1 1)

</pre>

The incrementer for binary numbers

<lang scheme>

(define ADD1

(Turing-Machine #:start 'Start

[Start 1 1 right Start]

[Start 0 0 right Start]

[Start () () left Add]

[Add 0 1 stay End]

[Add 1 0 left Add]

[Add () 1 stay End]))

</lang>

<pre>

> (ADD1 '(1 1 0))

STATE TAPE

Start ((1) 1 0)

Start (1 (1) 0)

Start (1 1 (0))

Start (1 1 0 ())

Add (1 1 (0))

End (1 1 (1))

(1 1 1)

> (ADD1 (ADD1 '(1 1 0)))

STATE TAPE

Start ((1) 1 0)

Start (1 (1) 0)

Start (1 1 (0))

Start (1 1 0 ())

Add (1 1 (0))

End (1 1 (1))

STATE TAPE

Start ((1) 1 1)

Start (1 (1) 1)

Start (1 1 (1))

Start (1 1 1 ())

Add (1 1 (1))

Add (1 (1) 0)

Add ((1) 0 0)

Add (() 0 0 0)

End ((1) 0 0 0)

(1 0 0 0)

</pre>

The busy beaver

<lang scheme>

(define BEAVER

(Turing-Machine #:start 'a

[a () 1 right b]

[a 1 1 left c]

[b () 1 left a]

[b 1 1 right b]

[c () 1 left b]

[c 1 1 stay halt]))

</lang>

<pre>

> (BEAVER '(()))

STATE TAPE

a ()

b (1 ())

a ((1) 1)

c (() 1 1)

b (() 1 1 1)

a (() 1 1 1 1)

b (1 (1) 1 1 1)

b (1 1 (1) 1 1)

b (1 1 1 (1) 1)

b (1 1 1 1 (1))

b (1 1 1 1 1 ())

a (1 1 1 1 (1) 1)

c (1 1 1 (1) 1 1)

halt (1 1 1 (1) 1 1)

(1 1 1 1 1 1)

</pre>

The sorting machine

<lang scheme>

(define SORT

(Turing-Machine #:start 'A

[A 1 1 right A]

[A 2 3 right B]

[A () () left E]

[B 1 1 right B]

[B 2 2 right B]

[B () () 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 () () right STOP]))

</lang>

<pre>

> (SORT '(2 1 2 2 2 1 1))

STATE TAPE

A ((2) 1 2 2 2 1 1)

B (3 (1) 2 2 2 1 1)

B (3 1 (2) 2 2 1 1)

B (3 1 2 (2) 2 1 1)

B (3 1 2 2 (2) 1 1)

B (3 1 2 2 2 (1) 1)

B (3 1 2 2 2 1 (1))

B (3 1 2 2 2 1 1 ())

C (3 1 2 2 2 1 (1))

D (3 1 2 2 2 (1) 2)

D (3 1 2 2 (2) 1 2)

D (3 1 2 (2) 2 1 2)

D (3 1 (2) 2 2 1 2)

D (3 (1) 2 2 2 1 2)

D ((3) 1 2 2 2 1 2)

A (1 (1) 2 2 2 1 2)

A (1 1 (2) 2 2 1 2)

B (1 1 3 (2) 2 1 2)

B (1 1 3 2 (2) 1 2)

B (1 1 3 2 2 (1) 2)

B (1 1 3 2 2 1 (2))

B (1 1 3 2 2 1 2 ())

C (1 1 3 2 2 1 (2))

C (1 1 3 2 2 (1) 2)

D (1 1 3 2 (2) 2 2)

D (1 1 3 (2) 2 2 2)

D (1 1 (3) 2 2 2 2)

A (1 1 1 (2) 2 2 2)

B (1 1 1 3 (2) 2 2)

B (1 1 1 3 2 (2) 2)

B (1 1 1 3 2 2 (2))

B (1 1 1 3 2 2 2 ())

C (1 1 1 3 2 2 (2))

C (1 1 1 3 2 (2) 2)

C (1 1 1 3 (2) 2 2)

C (1 1 1 (3) 2 2 2)

E (1 1 (1) 2 2 2 2)

E (1 (1) 1 2 2 2 2)

E ((1) 1 1 2 2 2 2)

E (() 1 1 1 2 2 2 2)

STOP ((1) 1 1 2 2 2 2)

(1 1 1 2 2 2 2)

</pre>