Anonymous user
Universal Turing machine: Difference between revisions
Improvements to my Scheme implementation.
Cyril Nocton (talk | contribs) |
(Improvements to my Scheme implementation.) |
||
Line 9,943:
{{works with|Chez Scheme}}
'''The Implementation'''
<lang scheme>;----------------------------------------------------------------------------------------------
; The
; to the cell on its right, and the car is a vector containing: 0: the value of the cell;
; 1: pointer to the cell on this cell's left; 2: #t if the cell has never been written.
; Make a new cell with the given contents, but linked to no other cell(s).
; (This is the only place that a cell can be marked as un-written.)
(define make-cell
(lambda (val . opt-unwrit)
(list (vector val '() (if (pair? opt-unwrit) (car opt-unwrit) #f)))))
; Return the un-written flag of the cell.
(define cell-unwrit?
(lambda (cell)
(vector-ref (car cell) 2)))
; Return the value of the cell.
(define cell-get
(lambda (cell)
(
; Store the value of the cell.
; Clears the un-written flag of the cell.
(define cell-set!
(lambda (cell val)
(vector-set
(vector-set! (car cell) 2 #f)))
; Return the cell to the right of the given cell on the tape.
Line 9,967 ⟶ 9,982:
(define cell-left
(lambda (cell)
(
; Return the cell to the right of the given cell on the tape.
; Extends the tape with the give blank symbol if there is no cell to the right.
; Optionally, passes the given un-written flag to make-cell (if needed).
(define cell-extend-right
(lambda (cell blank . opt-unwrit)
(if (null? (cdr cell))
(let ((new (
(vector-set! (car new) 1 cell)
(set-cdr! cell new)
new)
(
; Return the cell to the left of the given cell on the tape.
; Extends the tape with the give blank symbol if there is no cell to the left.
; Optionally, passes the given un-written flag to make-cell (if needed).
(define cell-extend-left
(lambda (cell blank . opt-unwrit)
(if (null? (
(let ((new (
(set-cdr!
(vector-set! (car cell) 1 new)
new)
(
; Make a new tape whose cells contain the values in the given list.
; Optionally, pad the tape per the given blank symbol, left-padding and right-padding amounts.
(define make-tape
(lambda (values . opt-pads)
(
(
(cell tape (cell-extend-right cell (
((null? values) cell))))
(when (pair? opt-pads)
(let ((blank (list-ref opt-pads 0))
(left (list-ref opt-pads 1))
(right (list-ref opt-pads 2)))
(unless (and (integer? left) (integer? right))
(error 'make-tape "padding arguments must be integers" opt-pads))
(do ((count 0 (1+ count))
(cell last (cell-extend-right cell blank #t)))
((>= count right)))
(do ((count 0 (1+ count))
(cell tape (cell-extend-left cell blank #t)))
((>= count left)))))
tape)))
Line 10,002 ⟶ 10,035:
(define tape-copy
(lambda (tape)
(let ((copy (
(do ((tape (cdr tape) (cdr tape))
(cell copy (cell-extend-right cell (cell-get tape))))
Line 10,009 ⟶ 10,042:
; Return the first cell on a tape.
; Optionally, leading blank symbols are not included (will return last cell of blank tape).
(define tape-fst
(lambda (cell . opt-blank)
Line 10,019 ⟶ 10,052:
; Return the last cell on a tape.
; Optionally, trailing blank symbols are not included (will return first cell of blank tape).
(define tape-lst
(lambda (cell . opt-blank)
Line 10,028 ⟶ 10,061:
((or (null? (cell-left lst)) (not (eq? (car opt-blank) (cell-get lst)))) lst))))))
; Return true if the given tape is empty. (I.e. contains nothing but blank symbols.)
(define tape-empty?
(lambda (cell blank)
(let ((fst (tape-fst cell blank)))
(
; Convert the contents of a tape to a string.
Line 10,041 ⟶ 10,071:
; Prints the entire contents regardless of which cell is given.
; Optionally, leading and trailing instances of the given blank symbol are suppressed.
; The values of un-written cells are not shown, though space for them is included.
(define tape->string
(lambda (cell mark . opt-blank)
(let ((strlst (list #\[))
(marked-prev #f)
(fst (if (null? opt-blank) (tape-fst cell) (tape-fst cell (car opt-blank))))
(lst (if (null? opt-blank) (tape-lst cell) (tape-lst cell (car opt-blank)))))
(do ((cell fst (cell-right cell)))
((eq? cell (cell-right lst)))
(
(fmtstr (cond (mark-now " {~a}") (marked-prev " ~a") (else " ~a")))
(
(set! marked-prev mark-now)))
(list->string (append strlst (string->list (if marked-prev " ]" " ]")))))))
;----------------------------------------------------------------------------------------------
; A Turing Machine contains the 7-tuple that formally defines it, stored in an array to
Line 10,127 ⟶ 10,163:
; Return the transitions of a Turing Machine.
(define-syntax turing-transitions (syntax-rules () ((_ tm) (vector-ref tm 6))))
; Return the q_i (current state) of alist element transition.
(define-syntax tran-q_i (syntax-rules () ((_ atran) (car (car atran)))))
; Return the s_j (symbol read from the tape) of alist element transition.
(define-syntax tran-s_j (syntax-rules () ((_ atran) (cdr (car atran)))))
; Return the s_ij (symbol written) of alist element transition.
Line 10,141 ⟶ 10,183:
(lambda (state symbol tm)
(assoc (cons state symbol) (turing-transitions tm))))
; Convert the given Turing Machine transition to a string.
(define tran->string
(lambda (atran)
(format "(~a ~a ~a ~a ~a)"
(tran-q_i atran) (tran-s_j atran) (tran-s_ij atran) (tran-d_ij atran) (tran-q_ij atran))))
; Convert the given Turing Machine definition to a string.
; Options (zero or more) are, in order: component prefix string (default "");
; component suffix string (default ""); component separator string (default newline).
(define turing->string
(lambda (tm . opts)
(let ((prestr (if (> (length opts) 0) (list-ref opts 0) ""))
(sufstr (if (> (length opts) 1) (list-ref opts 1) ""))
(sepstr (if (> (length opts) 2) (list-ref opts 2) (make-string 1 #\newline)))
(strlst '()))
(set! strlst (append strlst (string->list
(format "~a~a~a~a" prestr (turing-symbols tm) sufstr sepstr))))
(set! strlst (append strlst (string->list
(format "~a~a~a~a" prestr (turing-blank tm) sufstr sepstr))))
(set! strlst (append strlst (string->list
(format "~a~a~a~a" prestr (turing-inputs tm) sufstr sepstr))))
(set! strlst (append strlst (string->list
(format "~a~a~a~a" prestr (turing-states tm) sufstr sepstr))))
(set! strlst (append strlst (string->list
(format "~a~a~a~a" prestr (turing-initial tm) sufstr sepstr))))
(set! strlst (append strlst (string->list
(format "~a~a~a~a" prestr (turing-finals tm) sufstr
(if (> (length (turing-transitions tm)) 0) sepstr "")))))
(do ((index 0 (1+ index)))
((>= index (length (turing-transitions tm))))
(set! strlst (append strlst (string->list
(format "~a~a~a~a" prestr (tran->string (list-ref (turing-transitions tm) index)) sufstr
(if (< index (1- (length (turing-transitions tm)))) sepstr ""))))))
(list->string strlst))))
;----------------------------------------------------------------------------------------------
; Run the given Turing Machine on the given input tape.
Line 10,148 ⟶ 10,227:
(define turing-run
(lambda (tm cell show-log? . opt-abort)
; Validate contents of input tape. (
(
(let
((eq? cell (cell-right lst)))
(unless (memq (cell-get cell) (turing-inputs tm))
(error 'turing-run "input tape has disallowed content" (cell-get cell)))))))
; Initialize state and head.
(let ((state (turing-initial tm)) (head cell) (atran #f)
Line 10,165 ⟶ 10,247:
(atrns-lookup state (cell-get head) tm)))
((or (not atran) (memq state (turing-finals tm)) (and abort (>= count abort)))
; Display final progress (optional).
(when show-log?
(let* ((string (format "~a" state))
(strlen (string-length string))
(padlen (max 1 (- 25 strlen)))
(strpad (make-string padlen #\ )))
(printf "~a~a~a~%" string strpad (tape->string cell head))))
; Return resultant count, accepting state (or void), and tape.
(values count (if (memq state (turing-finals tm)) state (void)) head))
; Display progress (optional).
(when show-log?
(let* ((string (format "~
(tran-s_ij atran) (tran-d_ij atran) (tran-q_ij atran)))
(strlen (string-length string))
(padlen (max 1 (-
(strpad (make-string padlen #\ )))
(printf "~a~a~a~%" string strpad (tape->string cell head))))
Line 10,179 ⟶ 10,270:
((L) (cell-extend-left head (turing-blank tm)))
((R) (cell-extend-right head (turing-blank tm)))
((N) head)))))))
;----------------------------------------------------------------------------------------------</lang>
'''Test Runner'''
<lang scheme>;----------------------------------------------------------------------------------------------
; Run specified tests: A caption string, a Turing machine, a list of tests, and options (if
; 'notm present, do not output the Turing Machine definition (otherwise display it); if 'supp
; present, suppress leading/trailing blanks; 'mark present, mark the output tape; if 'supp
; present, suppress leading/trailing blanks; if 'leng present, print only the length of the
; output tape, not the contents of either; if 'show present, show an empty input tape (by
; default empty inputs are not shown)). A test is a list of: limit count (0 = unlimited),
; #t to log progress, and the input tape.
(define run-tm-tests
(lambda (caption tm test-lst . opts)
(printf "~%~a...~%" caption)
(unless (memq 'notm opts) (printf "~%~a~%" (turing->string tm)))
(let ((input #f))
(let loop ((tests test-lst))
Line 10,206 ⟶ 10,305:
(tape->string output (if (memq 'mark opts) output #f)))))
(printf "count = ~d~%accept = ~a~%" count accepting)
(
(printf "input = ~a~%" instr))
(printf "output = ~a~%" outstr))))
(loop (cdr tests)))))))
;----------------------------------------------------------------------------------------------</lang>
'''The Task'''
<lang scheme>(run-tm-tests
Line 10,224 ⟶ 10,326:
(list 0 #t (make-tape '(1 1 1)))
(list 0 #t (make-tape '(B)))
) 'notm 'mark)
(run-tm-tests
Line 10,242 ⟶ 10,344:
'(c 1 1 N halt))
(list
(list 0 #t (make-tape '(0) 0 3 2)) ; padding determined empirically
) 'notm 'mark)
(run-tm-tests
Line 10,266 ⟶ 10,368:
(list
(list 0 #f (make-tape '(0)))
) 'notm 'leng)</lang>
{{out}}
<pre style="height: 75ex; overflow: scroll">
Simple incrementer...
q0 1
q0 1
q0 1
q0 B
qf [ 1 1 1 {1} ]
count = 4
accept = qf
input = [ 1 1 1 ]
output = [ 1 1 1 {1} ]
q0 B
qf [ {1} ]
count = 1
accept = qf
Line 10,287 ⟶ 10,391:
Three-state busy beaver...
a 0
b 0
a 1
c 0
b 0
a 0
b 1
b 1
b 1
b 1
b 0
a 1
c 1
halt [ 1 1 1 {1} 1 1 ]
count = 13
accept = halt
output = [ 1 1 1 {1} 1 1 ]
5-state 2-symbol probable busy beaver...
Line 10,322 ⟶ 10,427:
'(A 1 1 R A)
'(A 2 3 R B)
'(A 0 0 L
'(B 1 1 R B)
'(B 2 2 R B)
'(B 0 0 L
'(C 1 2 L
'(C 2 2 L
'(C 3 2 L
'(D 1 1 L
'(D 2 2 L
'(D 3 1 R A)
'(E 1 1 L
'(E 0 0 R STOP))
(list
(list 0 #t (make-tape '(2 2 2 1 2 2 1 2 1 2 1 2 1 2) 0 1 1)) ; padding determined empirically
) 'notm 'supp)
(run-tm-tests
Line 10,358 ⟶ 10,463:
'(s5 1 1 L s5))
(list
(list 0 #t (make-tape '(1 1 1) 0 0 4)) ; padding determined empirically
) 'notm 'supp)
(run-tm-tests
Line 10,376 ⟶ 10,481:
(list
(list 20 #t (make-tape '(_)))
) 'notm 'mark)
(run-tm-tests
Line 10,384 ⟶ 10,489:
'_
'(1 2)
'(
'
'(odd even)
; branch to look for 1 or 2 at end
'(
'(
'(
; walk right to end for 1
'(r1 1 1 R r1)
Line 10,396 ⟶ 10,501:
'(r1 _ _ L e1)
; check end symbol for 1
'(e1 1 _ L
'(e1 _ _ N odd)
; walk right to end for 2
'(r2 2 2 R r2)
Line 10,407 ⟶ 10,508:
'(r2 _ _ L e2)
; check end symbol for 2
'(e2 2 _ L
'(e2 _ _ N odd)
; walk left to
'(
'(
'(
(list
(list 0 #t (make-tape '(1 2 1)))
Line 10,423 ⟶ 10,524:
(list 0 #f (make-tape '(1 1 2 2 1 1)))
(list 0 #f (make-tape '(1 1 2 2 1 2)))
) 'notm 'mark)</lang>
{{out}}
<pre style="height: 107ex; overflow: scroll">
Sorting test...
A 2
B 2
B 2
B 1
B 2
B 2
B 1
B 2
B 1
B 2
B 1
B 2
B 1
B 2
B 0
C 2
C 1
D 2
D 1
D 2
D 1
D 2
D 1
D 2
D 2
D 1
D 2
D 2
D 3
A 2
B 2
B 1
B 2
B 2
B 1
B 2
B 1
B 2
B 1
B 2
B 2
B 2
B 0
C 2
C 2
C 2
C 1
D 2
D 1
D 2
D 1
D 2
D 2
D 1
D 2
D 3
A 2
B 1
B 2
B 2
B 1
B 2
B 1
B 2
B 2
B 2
B 2
B 2
B 0
C 2
C 2
C 2
C 2
C 2
C 1
D 2
D 1
D 2
D 2
D 1
D 3
A 1
A 2
B 2
B 1
B 2
B 2
B 2
B 2
B 2
B 2
B 2
B 0
C 2
C 2
C 2
C 2
C 2
C 2
C 2
C 1
D 2
D 3
A 2
B 2
B 2
B 2
B 2
B 2
B 2
B 2
B 2
B 0
C 2
C 2
C 2
C 2
C 2
C 2
C 2
C 2
C 3
E 1
E 1
E 1
E 1
E 1
E 0
STOP [ 0 {1} 1 1 1 1 2 2 2 2 2 2 2 2 2 0 ]
count = 128
accept = STOP
input = [ 2 2 2 1 2 2 1 2 1 2 1 2 1 2 ]
output = [ 1 1 1 1 1 2 2 2 2 2 2 2 2 2 ]
Duplicate sequence of 1s...
s1 1
s2 1
s2 1
s2 0
s3 0
s4 0
s5 1
s5 1
s5 0
s1 1
s2 1
s2 0
s3 1
s3 0
s4 1
s4 0
s5 1
s5 0
s1 1
s2 0
s3 1
s3 1
s3 0
s4 1
s4 1
s4 0
s5 0
s1 0
H [ 1 1 1 {0} 1 1 1 ]
count = 28
accept = H
input = [ 1 1 1 ]
output = [ 1 1 1 0 1 1 1 ]
Turing's first example from On Computable Numbers...
b _
c _
e _
f _
b _
c _
e _
f _
b _
c _
e _
f _
b _
c _
e _
f _
b _
c _
e _
f _
b [ 0 _ 1 _ 0 _ 1 _ 0 _ 1 _ 0 _ 1 _ 0 _ 1 _ {_} ]
count = 20
accept = #<void>
output = [ 0 _ 1 _ 0 _ 1 _ 0 _ 1 _ 0 _ 1 _ 0 _ 1 _ {_} ]
Palindrome checker...
r1 2
r1 1
r1 _
e1 1
r2 _
e2 _
odd [ _ {_} _ _ ]
count = 10
accept = odd
input = [ 1 2 1 ]
output = [ _ {_} _ _ ]
r1 2
r1 2
r1 _
e1 [ _ 2 {2} _ ]
count = 4
accept = #<void>
input = [ 1 2 2 ]
output = [ _ 2 {2} _ ]
r1 1
r1 _
e1 1
even [ _ {_} _ ]
count = 6
accept = even
input = [ 1 1 ]
output = [ _ {_} _ ]
r2 1
r2 _
e2 [ _ {1} _ ]
count = 3
accept = #<void>
input = [ 2 1 ]
output = [ _ {1} _ ]
r1 _
e1 _
odd [ {_} _ ]
count = 3
accept = odd
input = [ 1 ]
output = [ {_} _ ]
count = 21
accept = odd
input = [ 2 1 1 1 2 ]
output = [ _ _ {_} _ _ _ ]
count = 15
accept = #<void>
input = [ 2 1 1 2 2 ]
output = [ _ _ 1 {2} _ _ ]
count = 28
accept = even
input = [ 1 1 2 2 1 1 ]
output = [ _ _ _ {_} _ _ _ ]
count = 7
accept = #<void>
input = [ 1 1 2 2 1 2 ]
output = [ _ 1 2 2 1 {2} _ ]
</pre>
| |||