# TURING introduce turing machine model
# just for fun!
[hear] (define safe-tail /
? x /
if (> (list-length / x) 0)
(if (> (list-length / x) 1)
(tail /
x)
(vector /
vector))
(vector /
vector));
[hear] (define safe-head /
? x /
if (> (list-length / x) 0)
(head /
x)
(vector));
[hear] (define tape-read /
? tape /
let ((x (second / tape)))
(if (> (list-length / x) 0)
(head /
x)
(vector)));
[hear] (define tape-transition /
lambda (tape shift value)
(if (= (shift) 1)
(pair (prepend (value) (first / tape))
(safe-tail /
second /
tape))
(if (= (shift) 0)
(pair (safe-tail /
first /
tape)
(prepend
(safe-head /
first /
tape)
(prepend (value) (safe-tail / second / tape))))
(pair (first /
tape)
(prepend (value) (safe-tail / second / tape))))));
[hear] (define turing /
lambda (machine current last tape)
(if (= (current) (last))
(tape)
(let ((next (machine (current) (tape-read / tape))))
(turing
(machine)
(list-ref (next) 0)
(last)
(tape-transition
(tape)
(list-ref (next) 1)
(list-ref (next) 2))))));
[hear] (define make-tape /
? x /
pair (vector) (x));
[hear] (define remove-trail /
? x /
? lst /
if (> (list-length / lst) 0)
(if (equal (last / lst) (x))
(remove-trail (x) (except-last / lst))
(lst))
(lst));
[hear] (define extract-tape /
? x /
remove-trail (vector) (second / x));
[hear] (define tm-binary-increment /
make-hash /
vector
(pair right
(make-hash /
vector
(pair 0 (vector right 1 0))
(pair 1 (vector right 1 1))
(pair (vector) (vector inc 0 (vector)))))
(pair inc
(make-hash /
vector
(pair 0 (vector noinc 0 1))
(pair 1 (vector inc 0 0))
(pair (vector) (vector halt 2 1))))
(pair noinc
(make-hash /
vector
(pair 0 (vector noinc 0 0))
(pair 1 (vector noinc 0 1))
(pair (vector) (vector halt 1 (vector)))))
(pair halt (make-hash / vector)));
[hear] (list= (extract-tape /
turing
(tm-binary-increment)
right
halt
(make-tape /
vector 1 0 0 1))
(vector 1 0 1 0));
[hear] (list= (extract-tape /
turing
(tm-binary-increment)
right
halt
(make-tape /
vector 1 1 1))
(vector 1 0 0 0));
[hear] (list= (extract-tape /
turing
(tm-binary-increment)
right
halt
(make-tape /
vector 1 1 1 0 0 0 1 1 1))
(vector 1 1 1 0 0 1 0 0 0));