;; Convert a gturing program to one for Shelburne's Turing Machine
;; Simulator for Windows. -- Jesse Hughes (jesse@phiwumbda.org)

(defun gturing2tms () 
  "Converts a gturing program in the current buffer to a Turing Machine Simulator program.  The Turing Machine Simulator is a DOS program by Shelburne."
  (interactive)
  (let* ((buf (buffer-name))
	 (prog-name (if (string-match "^\\(.*\\)\\.[^\\.]*$" buf)
		       (match-string 1 buf)
		     buf))
	 (new-prog-buffer (generate-new-buffer (concat prog-name
						       ".tms")))
	 (state-alist nil))

    (defun gimme-state (n)
	  (while (rassoc n state-alist)
	      (setq n (+ n 1)))
	  n)

    (defun xlate-state (st)
      (or (cdr (assoc  st state-alist))
	  (let ((n (gimme-state st)))
	    (add-to-list 'state-alist (cons st n))
	    n)))

    (save-excursion
      (beginning-of-buffer)
      (while (progn
	       (if (looking-at "[ \t]*\\(#.*\\)?$") 
		   ;; Just a comment.
		   (insert-string (concat (match-string 0) "\n")
				  new-prog-buffer)
		 (if (looking-at
		      "\\s-*\\([0-9]+\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\([0-9]+\\)\\(.*\\)")
		     (let* ((st (string-to-number (match-string 1)))
			    (rd (if (string= (match-string 2) "_")
				    " "
				  (match-string 2)))
			    (wr (if (string= (match-string 3) "_")
				    " "
				  (match-string 3)))
			    (mv (match-string 4))
			    (nx-st (string-to-number (match-string 5)))
			    (rest (match-string 6))
			    (new-st (xlate-state st))
			    (new-nx-st (xlate-state nx-st)))		       
		       (insert-string (format "(%s,%s,%s,%s,%s) %s\n"
					      new-st
					      rd
					      wr
					      new-nx-st
					      mv
					      rest)
					     new-prog-buffer))
		   (if (looking-at "^.*$")
		       (insert-string (format "Oops. %s\n" (match-string 0)) new-prog-buffer)
		     (insert-string "Oops.  Really really.\n" new-prog-buffer))))
	       (= (forward-line 1) 0))
	       ))
    (let ((ln (line-number)))
      (if (one-window-p)
	  (split-window-horizontally))
      (other-window 1)
      (switch-to-buffer new-prog-buffer)
      (goto-line ln))))

(defun gturing-alphabet ()
  (let ((alpha ()))
      (save-excursion
      (beginning-of-buffer)
      (while (progn
	       (if (looking-at
		    "\\s-*\\([0-9]+\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\([0-9]+\\)\\(.*\\)")
		   (let ((rd (match-string 2))
			 (wr (match-string 3)))
		     (add-to-list 'alpha rd)
		     (add-to-list 'alpha wr)))
	       (= (forward-line 1) 0))))
      alpha))

(defun tms-alphabet ()
  (let ((alpha ()))
      (save-excursion
      (beginning-of-buffer)
      (while (progn
	       (if (looking-at "^.*(\\(..?\\),\\(.\\),\\(.\\),\\(..?\\),\\(.\\))\\(.*\\)$") 
		   (let* ((rd (if (string= (match-string 2) " ")
				  "_"
				(match-string 2)))
			  (wr (if (string= (match-string 3) " ")
				  "_"
				(match-string 3))))
		     (add-to-list 'alpha rd)
		     (add-to-list 'alpha wr)))
	       (= (forward-line 1) 0))))
      alpha))

  
(defun tms2gturing () 
  "Converts a Turing Machine Simulator program in the current buffer to a gturing program.  The Turing Machine Simulator is a DOS program by Shelburne."
  (interactive)
  (let* ((buf (buffer-name))
	 (prog-name (if (string-match "^\\(.*\\)\\.[^\\.]*$" buf)
		       (match-string 1 buf)
		     buf))
	 (new-prog-buffer (generate-new-buffer (concat prog-name
						       ".tur")))
	 (state-alist nil)
	 ;; We need to know the alphabet for translating "S" moves.
	 (alpha (tms-alphabet)))
    
  (defun make-comment (str)
    (if (or (string-match "^\\s-*#" str)
	    (string-match "^\\s-*$" str))
	str
      (concat "# " str)))

    (defun gimme-state (n)
	  (while (rassoc n state-alist)
	      (setq n (+ n 1)))
	  n)


    (defun xlate-state (st)
      (or (cdr (assoc  st state-alist))
	  (let ((n (gimme-state 0)))
	    (add-to-list 'state-alist (cons st n))
	    n)))

    (save-excursion
      (beginning-of-buffer)
      (while (progn
	       (if (looking-at "^.*(\\(..?\\),\\(.\\),\\(.\\),\\(..?\\),\\(.\\))\\(.*\\)$") 
		   (let* ((st  (match-string 1))
			  (rd (if (string= (match-string 2) " ")
				  "_"
				(match-string 2)))
			  (wr (if (string= (match-string 3) " ")
				  "_"
				(match-string 3)))
			  (mv (downcase (match-string 5)))
			  (nx-st (match-string 4))
			  (rest (match-string 6))
			  (new-mv (if (equal mv "s")
				      "l"
				    mv))
			  (new-rest (make-comment rest))
			  (new-st (xlate-state st))
			  (new-nx-st (xlate-state nx-st))
			  (stick-st (if (equal mv "s")
					(gimme-state (+ 5000 new-st))))
			  )
		     (insert-string (format "%s %s %s %s %s %s\n"
					    new-st
					    rd
					    wr
					    new-mv
					    (or stick-st
						new-nx-st)
					    new-rest)
				    new-prog-buffer)
		     (if stick-st
			 (let ((alp alpha))
			   (while alp
			     (let ((rd (car alp)))
			       (insert-string 
				(format "%s %s %s %s %s # Hack for skip.\n"
					stick-st
					rd
					rd
					"r"
					new-nx-st)
				new-prog-buffer)
			       (setq alp (cdr alp))))))		   
		     )
		 (if (looking-at "^.*$")
		       (insert-string (format "%s\n" (make-comment (match-string 0))) new-prog-buffer)
		   ))
	       (= (forward-line 1) 0))
	       ))
    (let ((ln (line-number)))
      (if (one-window-p)
	  (split-window-horizontally))
      (other-window 1)
      (switch-to-buffer new-prog-buffer)
      (goto-line ln))))

    
(defun gturing-compose (second-machine)
  "Compose two turing machines.  The machines should both be unary.  The user will be prompted for the second machine."
  (interactive "fSecond machine: ")
  (let* ((alpha (gturing-alphabet))
	 (first-buf (buffer-name))
	 (second-buf (buffer-name (find-file-noselect second-machine)))
	 (first-prefix (if (string-match "^\\(.*\\)\\.[^\\.]*$" first-buf)
			   (match-string 1 first-buf)
			 first-buf))
	 (second-prefix (if (string-match "^\\(.*\\)\\.[^\\.]*$" second-buf)
			    (match-string 1 second-buf)
			  second-buf))
	 (composite-name (concat second-prefix "-after-" first-prefix ".tur"))
	 (new-prog-buffer (generate-new-buffer composite-name))
	 (state-alist nil)
	 (state-alphalist nil))
    
	(defun gimme-state (n)
	  (while (rassoc n state-alist)
	      (setq n (+ n 1)))
	  n)

    (defun xlate-state (st machine)
      (or (cdr (assoc (cons machine st) state-alist))
	  (let ((n (gimme-state st)))
	    (add-to-list 'state-alist (cons (cons machine st) n))
	    (if (equal machine 0)
		(add-to-list 'state-alphalist (cons n (copy-list alpha))))
	    n)))

    (save-excursion
      (set-buffer first-buf)
      (beginning-of-buffer)
      (while (progn
	       (if (looking-at "[ \t]*\\(#.*\\)?$") 
		   ;; Just a comment.
		   (insert-string (concat (match-string 0) "\n")
				  new-prog-buffer)
		 (if (looking-at
		      "\\s-*\\([0-9]+\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\([0-9]+\\)\\(.*\\)")
		     (let* ((st (string-to-number (match-string 1)))
			    (rd (match-string 2))
			    (wr (match-string 3))
			    (mv (match-string 4))
			    (nx-st (string-to-number (match-string 5)))
			    (rest (match-string 6))
			    (new-st (xlate-state st 0))
			    (new-nx-st (xlate-state nx-st 0)))
		        
		       (insert-string (format "%s %s %s %s %s %s\n"
					      new-st
					      rd
					      wr
					      mv
					      new-nx-st
					      rest)
				      new-prog-buffer)

		       ;; Mark that we've seen an entry for "if new-st and read rd"
		       (let ((st-alpha (delete rd (cdr (assoc new-st state-alphalist)))))
			 (remassoc new-st state-alphalist)
			 (add-to-list 'state-alphalist (cons new-st st-alpha))))))
	       (= (forward-line 1) 0))))

    (let ((n nil)
	  (trans-st (xlate-state 1000 "x")))
      (while (setq n (car state-alphalist))
	(setq state-alphalist (cdr state-alphalist))
	(let ((alp (cdr n))
	      (st (car n)))
	  (while alp
	    (let ((rd (car alp)))
	      (insert-string (format "%s %s %s %s %s # Former halt state.\n"
				     st
				     rd
				     rd
				     "r"
				     trans-st)
			     new-prog-buffer))
	    (setq alp (cdr alp))))))
    (save-excursion
      (set-buffer second-buf)
      (beginning-of-buffer)
      (let ((base-st 100))
	(while (rassoc base-st state-alist)
	  (setq base-st (+ base-st 50)))
      (while (progn
	       (if (looking-at "[ \t]*\\(#.*\\)?$") 
		   ;; Just a comment.
		   (insert-string (concat (match-string 0) "\n")
				  new-prog-buffer)
		 (if (looking-at
		      "\\s-*\\([0-9]+\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\([0-9]+\\)\\(.*\\)")
		     (let* ((st (string-to-number (match-string 1)))
			    (rd (match-string 2))
			    (wr (match-string 3))
			    (mv (match-string 4))
			    (nx-st (string-to-number (match-string 5)))
			    (rest (match-string 6))
			    (new-st (xlate-state (+ st base-st) 1))
			    (new-nx-st (xlate-state (+ nx-st base-st) 1)))
		        
		       (insert-string (format "%s %s %s %s %s %s\n"
					      new-st
					      rd
					      wr
					      mv
					      new-nx-st
					      rest)
				      new-prog-buffer)
		       )))
	       (= (forward-line 1) 0))
	       )
	
      (let ((trans-st (xlate-state 1000 "x"))
	    )
      (while alpha
	(let ((ch (car alpha)))
	  (insert-string (format "%s %s %s %s %s #Goto start state, machine %s\n"
				 trans-st
				 ch
				 ch
				 "l"
				 base-st
				 second-prefix)
			 new-prog-buffer))
	(setq alpha (cdr alpha))))
    (let ((ln (line-number)))
      (if (one-window-p)
	  (split-window-horizontally))
      (other-window 1)
      (switch-to-buffer new-prog-buffer)
      (goto-line ln))))))
		  
	  

		       
(defun gturing-plunk (plunked-machine)
  "Insert another machine into the buffer, renaming the states.  The user has to figure out how to call and return from the plunked machine."
  (interactive "fSecond machine: ")
  (let* ((first-buf (buffer-name))
	 (second-buf (buffer-name (find-file-noselect plunked-machine)))
	 (state-alist nil))
    
	(defun gimme-state (n)
	  (while (rassoc n state-alist)
	      (setq n (+ n 1)))
	  n)

    (defun xlate-state (st)
      (or (cdr (assoc st state-alist))
	  (let ((n (gimme-state st)))
	    (add-to-list 'state-alist (cons st n))
	    n)))

    (save-excursion
      (set-buffer first-buf)
      (beginning-of-buffer)
      (while (progn
		 (if (looking-at
		      "\\s-*\\([0-9]+\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\([0-9]+\\)\\(.*\\)")
		     (let* ((st (string-to-number (match-string 1)))
			    (nx-st (string-to-number (match-string 5))))
		       (add-to-list 'state-alist (cons "x" st))
		       (add-to-list 'state-alist (cons "x" nx-st))))
	       (= (forward-line 1) 0))))
    (end-of-line)
    (insert-string (format "\n\n#Inserting %s here\n\n" second-buf))
    (save-excursion
      (set-buffer second-buf)
      (beginning-of-buffer)
      (let ((base-st 100))
	(while (rassoc base-st state-alist)
	  (setq base-st (+ base-st 50)))
      (while (progn
	       (if (looking-at "[ \t]*\\(#.*\\)?$") 
		   ;; Just a comment.
		   (insert-string (concat (match-string 0) "\n"))
		 (if (looking-at
		      "\\s-*\\([0-9]+\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\(\\S-\\)\\s-*\\([0-9]+\\)\\(.*\\)")
		     (let* ((st (string-to-number (match-string 1)))
			    (rd (match-string 2))
			    (wr (match-string 3))
			    (mv (match-string 4))
			    (nx-st (string-to-number (match-string 5)))
			    (rest (match-string 6))
			    (new-st (xlate-state (+ st base-st)))
			    (new-nx-st (xlate-state (+ nx-st base-st))))
		        
		       (insert-string (format "%s %s %s %s %s %s\n"
					      new-st
					      rd
					      wr
					      mv
					      new-nx-st
					      rest)
				      first-buf)
		       )))
	       (= (forward-line 1) 0))
	       )
	
))))