gistfile1.cl

(defstruct state
  name
  initial
  final
  epsilons
  transitions)

(defstruct transition
  input
  next-state)

(defun e-closure (state states)
  (let (closure)
    (push (state-name state) closure)
    (dolist (epsilon (state-epsilons state))
      (push epsilon closure))
    (dolist (other-state (remove (state-name state) (copy-list closure)))
      (unless (null (state-epsilons (get-state other-state states)))
	(dolist (epsilon (state-epsilons other-state))
	  (push epsilon closure))))
    (reverse closure)))

(defun map-e-closures (states)
  (let (new-states)
    (dolist (state states)
      (let ((e-closure (e-closure state states)))
	(if (= (length e-closure) 1)
	    (push (make-state :name (car e-closure)) new-states)
	    (push (make-state :name e-closure) new-states))))
    (dolist (new-state new-states)
      (if (not (listp (state-name new-state)))
	  (progn
	    (if (is-initial (get-state (state-name new-state) states))
		(setf (state-initial new-state) t))
	    (if (is-final (get-state (state-name new-state) states))
		(setf (state-final new-state) t)))
	  (dolist (state (state-name new-state))
	    (if (is-initial (get-state state states))
		(setf (state-initial new-state) t))
	    (if (is-final (get-state state states))
		(setf (state-final new-state) t)))))
    ;; The clean up here is to remove duplicates of states already combined.
    ;; This may or may not be okay, but based on the Ullman text, I'm going with it.
    (clean-up-states (reverse new-states))))
;;    (reverse new-states)))

(defun collect-transitions (new-states old-states)
  (dolist (new-state new-states)
    (let (zero-transitions one-transitions)
      (if (listp (state-name new-state))
	  (dolist (state (state-name new-state))
	    (let ((reach-zero (states-reachable (get-state state old-states) 0))
		  (reach-one (states-reachable (get-state state old-states) 1)))
	      (dolist (trans reach-zero)
		(if (and (not (member trans (mapcar #'state-name new-states))) 
			 (member trans (state-name new-state)))
		    (setf (nth (position trans reach-zero) reach-zero) (state-name new-state))))
	      (dolist (trans reach-one)
		(if (and (not (member trans (mapcar #'state-name new-states)))
			 (member trans (state-name new-state)))
		    (setf (nth (position trans reach-one) reach-one) (state-name new-state))))
	      (setf zero-transitions
		    (concatenate 'list reach-zero zero-transitions))
	      (setf one-transitions
		    (concatenate 'list reach-one one-transitions))))
	  (let ((reach-zero (states-reachable (get-state (state-name new-state) old-states) 0))
		(reach-one (states-reachable (get-state (state-name new-state) old-states) 1)))
	    (dolist (trans reach-zero)
	      (if (not (member trans (mapcar #'state-name new-states)))
		  (setf (nth (position trans reach-zero) reach-zero) (find-state new-states trans))))
	    (dolist (trans reach-one)
	      (if (not (member trans (mapcar #'state-name new-states)))
		  (setf (nth (position trans reach-one) reach-one) (find-state new-states trans))))
	    (setf zero-transitions reach-zero)
	    (setf one-transitions reach-one)))
      (dolist (trans (remove-duplicates zero-transitions))
	(push (make-transition
	       :input 0
	       :next-state trans) (state-transitions new-state)))
      (dolist (trans (remove-duplicates one-transitions))
	(push (make-transition
	       :input 1
	       :next-state trans) (state-transitions new-state)))))
  new-states)

(defun post-epsilon-dfa-conversion (states)
  (dolist (state states)
    (let ((transitions))
      (let ((reach-zero (states-reachable state 0))
	    (reach-one (states-reachable state 1)))
	(if (> (length reach-zero) 1)
	    (dolist (trans reach-zero)
	      (if (eql trans (state-name state))
		  (setf reach-zero (remove trans reach-zero)))))
	(if (> (length reach-one) 1)
	    (dolist (trans reach-one)
	      (if (eql trans (state-name state))
		  (setf reach-one (remove trans reach-one)))))
	(dolist (trans reach-zero)
	  (push (make-transition
		 :input 0
		 :next-state trans) transitions))
	(dolist (trans reach-one)
	  (push (make-transition
		 :input 1
		 :next-state trans) transitions))
	(setf (state-transitions state) transitions))))
  states)

(defun find-state (states trans)
  (let ((return-state nil))
    (dolist (state states)
      (if (and (listp (state-name state)) (member trans (state-name state)))
	  (setf return-state (state-name state))))
    return-state))

(defun clean-up-states (new-states)
  (dolist (new-state new-states)
    (if (listp (state-name new-state))
	(dolist (state (state-name new-state))
	  (unless (null (get-state state new-states))
	    (setf new-states (remove (get-state state new-states) new-states))))))
  new-states)

(defun print-state-table (states)
  (format t "STATE~10TEPSILONS~20T 0~30T 1~%")
  (dolist (state states)
    (format t "~A~10T~A~20T ~A~30T ~A~%"
	    (state-name state)
	    (state-epsilons state)
	    (states-reachable state 0)
	    (states-reachable state 1))))

(defun is-initial (state)
  (if (state-initial state)
      t
      nil))

(defun is-final (state)
  (if (state-final state)
      t
      nil))

(defun get-state (name states)
  (dolist (state states)
    (if (eql (state-name state) name)
	(return state))))

(defun states-reachable (this-state input)
  (let (states)
    (dolist (transition (state-transitions this-state))
      (if (eql (transition-input transition) input)
	  (push (transition-next-state transition) states)))
    (reverse states)))

(defun initial-state (states)
  (let ((return-state nil))
    (dolist (state states)
      (if (state-initial state)
	  (setf return-state state)))
    return-state))
  
(defun simulate-dfa (input-string states)
  (let* ((initial-state (initial-state states))
	 (current-state initial-state)
	 (final? nil))
    (format t "Starting in state ~A~%" (state-name initial-state))
    (dolist (input input-string)
      (let ((reachable (car (states-reachable current-state input))))
	(setf current-state (get-state reachable states))
	(if (is-final current-state)
	    (setf final? t)
	    (setf final? nil))
	(format t "Input ~A going to state ~A~%" input (state-name current-state))))
    (if (eql final? t)
	(format t "Acceptable string.")
	(format t "Unacceptable string."))))

(defun make-state-table-1 ()
  (list (make-state
	 :name 'q0
	 :initial t
	 :final nil
	 :transitions (list (make-transition
			     :input 0
			     :next-state 'q0)
			    (make-transition
			     :input 0
			     :next-state 'q1)
			    (make-transition
			     :input 1
			     :next-state 'q0)))
	(make-state
	 :name 'q1
	 :initial nil
	 :final nil
	 :transitions (list (make-transition
			     :input 1
			     :next-state 'q2)))
	(make-state
	 :name 'q2
	 :initial nil
	 :final t
	 :transitions nil)))

(defun make-state-table-2 ()
  (list (make-state
	 :name 0
	 :initial t
	 :final nil
	 :epsilons '(1 5)
	 :transitions ())
	(make-state 
	 :name 1
	 :initial nil
	 :final nil
	 :epsilons ()
	 :transitions (list 
		       (make-transition
			:input 0
			:next-state 1)
		       (make-transition
			:input 0
			:next-state 2)
		       (make-transition
			:input 1
			:next-state 1)))
	(make-state
	 :name 2
	 :initial nil
	 :final nil
	 :epsilons ()
	 :transitions (list
		       (make-transition
			:input 0
			:next-state 3)))
	(make-state
	 :name 3
	 :initial nil
	 :final nil
	 :epsilons '(4)
	 :transitions (list 
		       (make-transition
			:input 0
			:next-state 3)
		       (make-transition
			:input 1
			:next-state 3)))
	(make-state
	 :name 4
	 :initial nil
	 :final t
	 :epsilons ()
	 :transitions ())
	(make-state
	 :name 5
	 :initial nil
	 :final nil
	 :epsilons nil
	 :transitions (list
		       (make-transition
			:input 0
			:next-state 5)
		       (make-transition
			:input 1
			:next-state 5)
		       (make-transition
			:input 1
			:next-state 6)))
	(make-state 
	 :name 6
	 :initial nil
	 :final nil
	 :epsilons nil
	 :transitions (list
		       (make-transition
			:input 1
			:next-state 7)))
	(make-state
	 :name 7
	 :initial nil
	 :final nil
	 :epsilons '(4)
	 :transitions (list 
		       (make-transition
			:input 0
			:next-state 7)
		       (make-transition
			:input 1
			:next-state 7)))))

(defun make-state-table-3 ()
  (list
   (make-state 
    :name 0
    :initial t
    :final t
    :epsilons nil
    :transitions (list (make-transition
			:input 0
			:next-state 0)
		       (make-transition
			:input 1
			:next-state 1)))
   (make-state 
    :name 1
    :initial nil
    :final nil
    :epsilons nil
    :transitions (list (make-transition
			:input 0
			:next-state 2)
		       (make-transition
			:input 1
			:next-state 0)))
   (make-state 
    :name 2
    :initial nil
    :final nil
    :epsilons nil
    :transitions (list (make-transition
			:input 0
			:next-state 1)
		       (make-transition
			:input 1
			:next-state 2)))))