aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 7387c8f97b
commit cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

35
Task/Universal-Turing-machine/Common-Lisp/universal-turing-machine-1.lisp Normal file
View file

@ -0,0 +1,35 @@
(defun turing (initial terminal blank rules tape &optional (verbose NIL))
(labels ((combine (front back)
(if front
(combine (cdr front) (cons (car front) back))
back))
(update-tape (old-front old-back new-content move)
(cond ((eq move 'right)
(list (cons new-content old-front)
(cdr old-back)))
((eq move 'left)
(list (cdr old-front)
(list* (car old-front) new-content (cdr old-back))))
(T (list old-front
(cons new-content (cdr old-back))))))
(show-tape (front back)
(format T "~{~a~}[~a]~{~a~}~%"
(nreverse (subseq front 0 (min 10 (length front))))
(or (car back) blank)
(subseq (cdr back) 0 (min 10 (length (cdr back)))))))
(loop for back = tape then new-back
for front = '() then new-front
for state = initial then new-state
for content = (or (car back) blank)
for (new-state new-content move) = (gethash (cons state content) rules)
for (new-front new-back) = (update-tape front back new-content move)
until (equal state terminal)
do (when verbose
(show-tape front back))
finally (progn
(when verbose
(show-tape front back))
(return (combine front back))))))

37
Task/Universal-Turing-machine/Common-Lisp/universal-turing-machine-2.lisp Normal file
View file

@ -0,0 +1,37 @@
(defun turing (initial terminal blank rules tape &optional (verbose NIL))
(labels ((run (state front back)
(if (equal state terminal)
(progn
(when verbose
(show-tape front back))
(combine front back))
(let ((current-content (or (car back) blank)))
(destructuring-bind
(new-state new-content move)
(gethash (cons state current-content) rules)
(when verbose
(show-tape front back))
(cond ((eq move 'right)
(run new-state
(cons new-content front)
(cdr back)))
((eq move 'left)
(run new-state
(cdr front)
(list* (car front) new-content (cdr back))))
(T (run new-state
front
(cons new-content (cdr back)))))))))
(show-tape (front back)
(format T "~{~a~}[~a]~{~a~}~%"
(nreverse (subseq front 0 (min 10 (length front))))
(or (car back) blank)
(subseq (cdr back) 0 (min 10 (length (cdr back))))))
(combine (front back)
(if front
(combine (cdr front) (cons (car front) back))
back)))
(run initial '() tape)))

55
Task/Universal-Turing-machine/Common-Lisp/universal-turing-machine-3.lisp Normal file
View file

@ -0,0 +1,55 @@
;; Helper function for creating the rules table
(defun make-rules-table (rules-list)
(let ((rules (make-hash-table :test 'equal)))
(loop for (state content new-content dir new-state) in rules-list
do (setf (gethash (cons state content) rules)
(list new-state new-content dir)))
rules))
(format T "Simple incrementer~%")
(turing 'q0 'qf 'B (make-rules-table '((q0 1 1 right q0) (q0 B 1 stay qf))) '(1 1 1) T)
(format T "Three-state busy beaver~%")
(turing 'a 'halt 0
(make-rules-table '((a 0 1 right b)
(a 1 1 left c)
(b 0 1 left a)
(b 1 1 right b)
(c 0 1 left b)
(c 1 1 stay halt)))
'() T)
(format T "Sort (final tape)~%")
(format T "~{~a~}~%"
(turing 'A 'H 0
(make-rules-table '((A 1 1 right A)
(A 2 3 right B)
(A 0 0 left E)
(B 1 1 right B)
(B 2 2 right B)
(B 0 0 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 0 0 right H)))
'(2 1 2 2 2 1 1)))
(format T "5-state busy beaver (first 20 cells)~%")
(format T "~{~a~}...~%"
(subseq (turing 'A 'H 0
(make-rules-table '((A 0 1 right B)
(A 1 1 left C)
(B 0 1 right C)
(B 1 1 right B)
(C 0 1 right D)
(C 1 0 left E)
(D 0 1 left A)
(D 1 1 left D)
(E 0 1 stay H)
(E 1 0 left A)))
'())
0 20))