Gaucheでチューリングマシン
wikipedia:ビジービーバーを見てGaucheでチューリングマシンを実装してみた。
仕様はWikipediaの項目通り。
(run 命令 -1)で動く。
チューリングマシンは(マシンの現状態,現在位置のテープの記号)→(テープ上に書き込むべき記号,テープ上を移動する方向,次に遷移する状態)の対応関係の組で定まるわけなので、それを順番に並べて
| 現状態 | 現記号 | → | 次に書く記号 | 移動方向 | 次状態 |
|---|---|---|---|---|---|
| 1 | 0 | 1 | r | 2 | |
| 1 | 1 | 0 | l | 2 | |
| 2 | 0 | 0 | l | 1 | |
| 2 | 1 | 0 | r | 0 |
右三列のリストを命令として渡してやればいい。0は停止状態。
(run '((1 r 2) (1 l 2) (1 l 1) (1 r 0)) -1)
返り値は停止した時テープ上にある1の数。
(run 命令 50)とかすると50回を上限に遷移を繰り返し、停止しなければ返り値は#f。
実行すると
steps: 70 | position: 4 | num of 1: 8 | state: 1
0
11110110011
^
みたいなのが出る。11110110011がテープで、上に0があるのがテープの原点というか開始位置。下の^はテープヘッダの現在位置。テープヘッダがうねうね左右に動くのを眺めるのはちょっと楽しい。
以下コード。効率とか全然考えていないのでn=5だと全然終わらない*1。
(use srfi-1) ;; (define (make-instructions lst) (map (lambda (lst) (list (if (equal? (car lst) 0) #f #t) (if (or (equal? (cadr lst) 0) (equal? (cadr lst) 'l)) #f #t) (caddr lst))) lst)) ;; (define (list-has? lst element) (lset<= equal? (list element) lst)) (define (nth lst n) (car (drop lst (- n 1)))) ;; (define-class <turing-machine> () ((instructions :init-value () :init-keyword :instructions :accessor instructions))) (define-class <turing-machine-running> (<turing-machine>) ((tape :init-value () :accessor tape) (state :init-value 1 :accessor state) (position :init-value 0 :accessor position))) (define-method run ((instructions <pair>) (iteration <integer>)) (let ((tm (make <turing-machine-running> :instructions (make-instructions instructions)))) (do ((halted? #f) (result #f) (x 0 (inc! x))) ((or (= x iteration) halted?) result) (tm-transition! tm) (format #t "steps: ~8@a | position: ~8@a | num of 1: ~8@a | state: ~2@a " (+ x 1) (position tm) (length (tape tm)) ((lambda (x) (if (zero? x) " 0 (halted)" x)) (state tm))) (format #t "~%") (let ((from (apply min (cons (position tm) (tape tm)))) (to (apply max (cons (position tm) (tape tm))))) (do ((x from (inc! x))) ((> x to)) (format #t "~a" (if (zero? x) 0 " "))) (format #t "~%") (do ((x from (inc! x))) ((> x to)) (format #t "~a" (if (list-has? (tape tm) x) 1 0))) (format #t "~%") (do ((x from (inc! x))) ((> x to)) (format #t "~a" (if (= (position tm) x) "^" " "))) (format #t "~%") ) (when (equal? 0 (state tm)) (set! halted? #t) (set! result (length+ (tape tm))))))) (define-method tm-transition! ((tm <turing-machine-running>)) (set!-values ((tape tm) (position tm) (state tm)) (if (list-has? (tape tm) (position tm)) ; ex) that there's 3 in 'tape means the figure at position 3 is 1 (tm-do-instruction (nth (instructions tm) (- (* 2 (state tm)) 0)) (position tm) (tape tm)) (tm-do-instruction (nth (instructions tm) (- (* 2 (state tm)) 1)) (position tm) (tape tm))))) (define-method tm-do-instruction (instruction position tape) (values (if (nth instruction 1) (delete-duplicates (cons position tape)) (remove! (lambda (x) (equal? x position)) tape)) (if (nth instruction 2) (- position 1) (+ position 1)) (nth instruction 3))) ;(values tape-new position-new state-new) ;; (print "n=2") (run '((1 r 2) (1 l 2) (1 l 1) (1 r 0)) -1) (newline) (print "n=3") (run '((1 r 2) (1 r 0) (0 r 3) (1 r 2) (1 l 3) (1 l 1)) -1) (newline) (print "n=4") (run '((1 r 2) (1 l 2) (1 l 1) (0 l 3) (1 r 0) (1 l 4) (1 r 4) (0 r 1)) -1) (newline) ;; (run ;; '((1 r 2) ;; (1 l 3) ;; (1 r 3) ;; (1 r 2) ;; (1 r 4) ;; (0 l 5) ;; (1 l 1) ;; (1 l 4) ;; (1 r 0) ;; (0 l 1)) ;; -1)
