;;; -*- mode: lisp; syntax: common-lisp -*-

(defvar *display-states* nil
  "The Turing machine displays its state before every instruction when T.")

(defun display-turing-machine (state tape position)
  (when *display-states*
    (format t "~&State: ~a~%~{~[.~;O~]~^ ~}~%~?^~%"
            state (coerce tape 'list)
            (format nil "~~~d,0t" (* position 2)) nil)))

(defmacro turing (initial-tape initial-position &body body)
  "Runs a Turing-machine program and returns the modified tape and position.

INITIAL-TAPE is a sequence of 1s and 0s, containing the bits on the tape.
INITIAL-POSITION is the initial position on the tape.
BODY is a list of instructions having the form \(STATE COMMAND1 COMMAND2),
where STATE is an arbitrary symbol, and COMMAND1 and COMMAND2 are the commands
for the true and false value at the actual position, respectively. The commands
are given as lists of the form \(NEXT-STATE NEW-VALUE MOVEMENT), where
movement is one of LEFT and RIGHT. Undefined commands are represented by
anything that is not a cons, e.g. UNDEFINED or NIL.

The program always starts from state START, so it should be included.
Execution stops in state END."
  (flet ((command-generator (cmd)
           (if (consp cmd)
               `(setf state ',(first cmd)
                      (elt tape pos) ,(second cmd)
                      pos ,(ecase (third cmd)
                                  (left '(1- pos))
                                  (right '(1+ pos))))
               `(error "Undefined command: ~a" ',cmd))))
    `(let ((state 'start)
           (tape ,initial-tape)
           (pos ,initial-position))
       (do ()
           ((eq state 'end)
            (display-turing-machine state tape pos)
            (values tape pos))
         (display-turing-machine state tape pos)
         (case state
           ,@(mapcar (lambda (ins)
                       `(,(first ins)
                           (ecase (elt tape pos)
                             (1 ,(command-generator (second ins)))
                             (0 ,(command-generator (third ins))))))
                     body)
           (otherwise (error "Undefined state: ~a" state)))))))

(defmacro defturing (name &body body)
  "Define a function using Turing machine language."
  `(defun ,name (initial-tape initial-position)
     (turing initial-tape initial-position
       ,@body)))

(defmacro turing-combine (&rest functions)
  "Combine functions defined by DEFTURING."
  (labels ((rec (tape pos lst)
             (if (null lst)
                 `(values ,tape ,pos)
                 (let ((tape2 (gensym "TAPE"))
                       (pos2 (gensym "POS")))
                   `(multiple-value-bind (,tape2 ,pos2)
                        (,(first lst) ,tape ,pos)
                      ,(rec tape2 pos2 (rest lst)))))))
    `(lambda (initial-tape initial-position)
       ,(rec 'initial-tape 'initial-position functions))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Example : unary adder ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Goal   : add two unary numbers
;;; Input  : two unary numbers separated by a 0 value;
;;;          the initial position is to the left from the first number
;;; Output : one unary number on the left of the final position
(defturing unary-adder
  (start (start 1 right) (second-number 1 right))
  (second-number (second-number 1 right) (delete-one 0 left))
  (delete-one (delete-one 0 right) (end 0 left)))

;;; Try to add 4 + 3:
(let ((tape (vector 0 0 1 1 1 1 0 1 1 1 0 0 0))
      (*display-states* t))
  (unary-adder tape 2))

;;;;;;;;;;;;;;;;;;;;;;;
;;; Example: double ;;;
;;;;;;;;;;;;;;;;;;;;;;;
;;; Goal   : double a unary number
;;; Input  : one unary number on the right side of the initial position
;;; Output : one unary number on the left of the final position
(defturing double
  (start (to-end 0 right) start-0)
  (to-end (to-end 1 right) (write-first 0 right))
  (write-first (write-first 1 right) (write-second 1 right))
  (write-second write-second-1 (go-back 1 left))
  (go-back (go-back 1 left) (go-back-2 0 left))
  (go-back-2 (go-back-3 1 left) (processed 0 right))
  (go-back-3 (go-back-3 1 left) (start 0 right))
  (processed (go-through 1 right) (processed 0 right))
  (go-through (go-through 1 right) (at-the-end 0 right))
  (at-the-end at-the-end-1 (end 0 left)))

;;; Try to double 4:
(let ((tape (vector 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
      (*display-states* t))
  (double tape 0))

;;;;;;;;;;;;;;;;;;;;;
;;; Utility: back ;;;
;;;;;;;;;;;;;;;;;;;;;
;;; Goal   : go back to the start of a unary number
;;; Input  : one unary number on the left side of the initial position
;;; Output : one unary number on the right side of the final position
(defturing back
  (start (back 1 left) (start 0 left))
  (back (back 1 left) (end 0 right)))

;;; Now try to combine these functions: (4 + 3) * 2 = ?
(let ((tape (vector 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
      (*display-states* t))
  (funcall (turing-combine unary-adder back double) tape 1))