;;;=============================;;;
;;;       Joshua Taylor         ;;;
;;;        Spring 2004          ;;;
;;;    Computability & Logic    ;;;
;;;      Energetic Emu Code     ;;;
;;;=============================;;;
;;; (load "eemu.lisp")
;;;===========================
;;; The following section is 
;;; devoted to the Turing 
;;; Machine simulation

(defun state1 (l)
  "get the origin state of a transition"
  (first l))

(defun state2 (l)
  "get the destination state of a transition"
  (fourth l))

(defun read-symbol (l)
  "get the reading symbol of a transition"
  (second l))

(defun action (l)
  "the action to perform (or symbol to write) of a transition"
  (third l))

(defclass turing-machine ()
  ((transitions :initform (list)
		:initarg :transitions
		:accessor transitions)
   (left-tape :initform (list)
	      :initarg :left-tape
	      :accessor left-tape)
   (right-tape :initform (list 0)
	       :initarg :right-tape
	       :accessor right-tape)
   (halted :initform (list)
	   :accessor halted)
   (current-state :initarg :current-state
		  :initform (list)
		  :accessor current-state)
   (initial-state :initarg :initial-state
		  :accessor initial-state
		  :initform (list))))

(defmethod states ((tm turing-machine))
  "extracts the actual states from a turing machine
   since the machine only stores the transitions"
  (remove-duplicates (mapcan #'(lambda (x)
				 (list (state1 x) (state2 x)))
			     (transitions tm))))

(defmethod whole-tape ((tm turing-machine))
  "the tape is stored internally as left-tape and right-tape. This
   puts them together"
  (append (left-tape tm)
	  (right-tape tm)))

(defmethod current-symbol ((tm turing-machine))
  "Gets the symbol currently under the read/write head"
  (car (right-tape tm)))

(defmethod find-applicable-transitions ((tm turing-machine))
  "find the transitions which we can take given our current 
   state"
  (remove-if-not #'(lambda (x)
                     (equal (current-state tm)
                            (state1 x)))
                 (transitions tm)))

(defmethod find-action-to-take ((tm turing-machine))
  "find the transition which we actually want to take
   based on our current position of read head"
  (find-if #'(lambda (x)
               (equal (current-symbol tm)
                      (read-symbol x)))
           (find-applicable-transitions tm)))

(defmethod write-symbol (s (tm turing-machine))
  "write a symbol at the current position of the head"
  (setf (car (right-tape tm)) s))

(defmethod move-right ((tm turing-machine))
  "move right one square, this means adjust left and right tape"
  (setf (left-tape tm)
	(append (left-tape tm)
		(list (current-symbol tm))))
  (setf (right-tape tm)
	(cdr (right-tape tm)))
  (unless (current-symbol tm) ; don't go off end of tape
    (setf (right-tape tm)
	  (list 0))))
  
(defmethod move-left ((tm turing-machine))
  "moving left is similar to moving right"
  (unless (left-tape tm) ; don't go off end of tape
    (setf (left-tape tm)
	  (list 0)))
  (setf (right-tape tm)
	(append (last (left-tape tm))
		(right-tape tm)))
  (setf (left-tape tm)
	(reverse (cdr (reverse (left-tape tm))))))

(defmethod execute-transition ((tm turing-machine))
  "this makes the machine move ahead one transition"
  (let ((trans (find-action-to-take tm)))
    (cond (trans (case (action trans) 
                   (:left (move-left tm))
                   (:right (move-right tm))
                   (otherwise (write-symbol (action trans) tm)))
                 (setf (current-state tm)
		       (state2 trans)))
	  (t (setf (halted tm) t)
	     :halted))))

(defmethod run-turing-machine ((tm turing-machine) &optional steps)
  "this runs a turing machine until it halts or steps 
   steps have been executed"
  (cond (steps 
	 (loop for i from 0 below steps 
	       when (eql :halted (execute-transition tm))
	       do
	       (return)))
	(t (loop when (eql :halted (execute-transition tm))
		 do
		 (return)))))

(defmethod is-valid ((tm turing-machine))
  "Checks whether a turing-machine is valid, that is that there
   is at most one action to perform at a state when any particular
   symbol is read."
  (let ((tr (transitions tm)))
    (eql (length tr)
	 (length (remove-duplicates tr :test #'(lambda (t1 t2)
						 (equal (subseq t1 0 2)
							(subseq t2 0 2))))))))

;;;=========================
;;; This section deals then
;;; generation of Turing 
;;; Machines and transitions

(defun generalized-enumerate-tuples (l &rest r)
  "given an arbitrarily large number of lists, l1, l2, .. lN
   tuples <p1, p2, .. pN> such that l1 in p1, l2 in p2, etc"
  (if r (mapcan #'(lambda (f)
		    (mapcar #'(lambda (g)
				(cons f g))
			    (apply #'generalized-enumerate-tuples r)))
		l)
    (mapcar #'list l)))

(defun generate-tuples (alphabet motions states)
  "given an alphabet, actions, and states, generate all
   the possible transitions, note that they couldn't all
   be put onto a single TM"
  (generalized-enumerate-tuples states alphabet (append alphabet motions) states))

(defun generate-transition-sets (num &key (alphabet '(0 1)) (actions '(:left :right)))
  "this takes a number (representing total number of states), and generates
   all the possible transitions (directed arcs) of a turing machine built from
   those states, and alphabet and actions as provided. The return is a list
   of lists, each sublist contains transitions which all start at the same state 
   and read the same symbol, e.g. all the transitions which start from q0 and read 0."
  (let* ((states (loop for i from 0 to num collect (gensym)))
	 (state-symbol-pairs (generalized-enumerate-tuples states alphabet))
	 (transition-ending (generalized-enumerate-tuples
			     (append alphabet actions)
			     states)))
    (if (zerop num) 
	nil
      (mapcar #'(lambda (f)
		  (mapcar #'(lambda (s)
			      (append f s))
			  transition-ending))
	      state-symbol-pairs))))
  
(defun pick-constrained-tuples (size tuples)
  "this takes a size, and a list of lists, e.g
   (pick-constained-tuples 2 ((a b c) (1 2 3)))
   and gives back ((a 1) (a 2) (a 3) (b 1) ... (c 3))"
  (cond ((> size (length tuples)) :not-enough-tuples) ; not enough tuples to get this selection
	((<= size 0) :size-too-small) 
	((eql size 1) (mapcar #'list (apply #'append tuples))) ; base case
	(t (append (mapcan (lambda (x)
			     (mapcar (lambda (y)
				       (cons x y))
				     (pick-constrained-tuples (- size 1) (cdr tuples))))
			   (car tuples))
		   ;; this when needed in cases like this:
		   ;; pick 2 ((a b c) (1 2 3) (x y z))
		   ;; to get te ((1 x) (1 y) (1 z) .. (c x) (c y) (c z))
		   (when (< size (length tuples)) 
		     (pick-constrained-tuples size (cdr tuples)))))))

;;;==================================
;;; This section contains
;;; code for logical representations
;;; of Turing Machines. This could
;;; be useful in detecting isomorphs,
;;; cut currently is not used.

(defmethod fol-description-constant ((tm turing-machine))
  "generate the fol statement which represents the conjunction
   of the transitions of the machine, in their fol representation"
  (let ((state-assoc (mapcar #'(lambda (state)
                                 (cons state (gensym)))
                             (states tm))))
    (cons 'and (mapcar #'(lambda (trans)
                           `(trans ,(cdr (assoc (state1 trans) state-assoc))
                                   ,(read-symbol trans)
                                   ,(action trans)
                                   ,(cdr (assoc (state2 trans) state-assoc))))
                       (transitions tm)))))

(defmethod fol-description-variables ((tm turing-machine) &optional state-vars)
  "generates the fol statement where the states are represented with
   variables, which allows for isomorph checking"
  (let* ((vars (or state-vars (loop for i from 1 to (length (states tm)) collect (gensym "?"))))
	 (state-assoc (pairlis (states tm) vars)))
    (list 'exists vars
          (cons 'and (mapcar #'(lambda (trans)
                                 `(trans ,(cdr (assoc (state1 trans) state-assoc))
                                         ,(read-symbol trans)
                                         ,(action trans)
                                         ,(cdr (assoc (state2 trans) state-assoc))))
                                 (transitions tm))))))

;;;============================
;;; This is where I actually
;;; start to find some EE machines

(defun big-driver (arcs &optional (actions 20))
  "given a numebr of arcs (transitions) and optional number
   of steps, all machines with arcs transitions are simulated
   for actions steps. The lengths of ones on the tape are returned."
  (let* ((count 0)
	 (ts (generate-transition-sets arcs))
	 (ct (pick-constrained-tuples arcs ts))
	 (tms (mapcan (lambda (tran-set)
			(let ((tm (make-instance 'turing-machine
						 :transitions tran-set)))
			  (mapcar (lambda (s)
				    (make-instance 'turing-machine
						   :transitions (transitions tm)
						   :current-state s))
				  (states tm))))
		      ct))
	 (tapes (mapcar #'(lambda (tm)
			    (incf count)
			    (when (zerop (rem count 100))
			      (format t "Turing Machine Number ~A~%" count))
			    (run-turing-machine tm actions)
			    (remove-if #'zerop (whole-tape tm)))
			tms)))
    (sort (remove-duplicates (mapcar #'length tapes)) #'<)))

;(big-driver 2 19) => (0 1 10)         ;;   5328 machines 
;(big-driver 3 19) => (0 1 2 6 7 9 10) ;; 779264 machines