Data commit

Task/Universal-Turing-machine/Racket/universal-turing-machine-1.rkt

@@ -0,0 +1,96 @@
+#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))))

Task/Universal-Turing-machine/Racket/universal-turing-machine-2.rkt

@@ -0,0 +1,4 @@
+(define INC
+  (Turing-Machine #:start 'q0
+    [q0 1 1 right q0]
+    [q0 () 1 stay qf]))

Task/Universal-Turing-machine/Racket/universal-turing-machine-3.rkt

@@ -0,0 +1,8 @@
+(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]))

Task/Universal-Turing-machine/Racket/universal-turing-machine-4.rkt

@@ -0,0 +1,8 @@
+(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]))

Task/Universal-Turing-machine/Racket/universal-turing-machine-5.rkt

@@ -0,0 +1,16 @@
+(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]))