97 lines
3.1 KiB
Racket
97 lines
3.1 KiB
Racket
#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))))
|