;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; ;-*-
;;;  Time-stamp: <2002-12-18 22:09:19>
;;;  Touched: Thu Apr  4 05:11:09 2002 <enometh@meer>
;;; machine.l
;;;
;;; NOTES
;;; - `logical' based on Matt Chapman's (csuoq@csv.warwick.ac.uk) model.
;;; - Nodes and Edges are symbols (either specified or gensymed)
;;;
(in-package :USER)

(defclass logical (node-info-mixin edge-info-mixin)
  ((states :initform nil :accessor states :initarg :states)
   (connections :initform nil :accessor connections :initarg :connections)
   (start-state :initform nil :accessor start-state :initarg :start-state))
  (:documentation "logical machine"))

;; NOTES: implementing node-info and edge-info -
;; Implement association lists of (indicator . value) pairs hanging
;; off the hashtables.  conserve space by deleting alists and hash
;; entries when empty. based on a usenet posting
;; From: Kent M Pitman <pitman@world.std.com>          			
;; Message-ID: <sfwzo05qky6.fsf@shell01.TheWorld.com>
;;
;; Essentially provide plist semantics to get and set properties of
;; (node and edge) symbols in an implicit object-local namespace.
;; TODO reimplement using defstruct once novelty has worn off
;;
(defun kmp-table-lookup (table key-designator)
  (let ((key (string key-designator)))
    (cdr (assoc key (rest table) :test #'string=))))
;;
(defun kmp-table-store (table key-designator value)
  (let ((key (string key-designator)))
    (let ((cell (assoc key (rest table) :test #'string=)))
      (if cell
	  (if value
	      (setf (cdr cell) value)
	      (setf table (delete cell table))) ; what does setq do?
	  (if value		  
	      (let ((new-cell (cons key value)))
		(push new-cell (rest table))
		value))))))
;;
(defclass edge-info-mixin ()
  ((edge-info :initform (make-hash-table :test #'equal) :accessor edge-info)))
;;
(defmethod get-edge-info ((m edge-info-mixin) indicator edge)
  (let ((table (gethash edge (edge-info m))))
    (if table (kmp-table-lookup table indicator) nil)))
;;
(defmethod (setf get-edge-info) (value (m edge-info-mixin) indicator edge)
  (let ((table (gethash edge (edge-info m))))
    (cond (table (kmp-table-store table indicator value)
		 (when (null (cdr table)) (remhash edge table)))
	  (t (let ((new-table (list edge)))
	       (kmp-table-store new-table indicator value)
	       (unless (null (cdr new-table))
		 (setf (gethash edge (edge-info m)) new-table)))))))
;;
;;
(defclass node-info-mixin ()
  ((node-info :initform (make-hash-table :test #'equal) :accessor node-info)))
;;
(defmethod get-node-info ((m node-info-mixin) indicator node)
  (let ((table (gethash node (node-info m))))
    (if table (kmp-table-lookup table indicator) nil)))
;;
(defmethod (setf get-node-info) (value (m node-info-mixin) indicator node)
  (let ((table (gethash node (node-info m))))
    (cond (table (kmp-table-store table indicator value)
		 (when (null (cdr table)) (remhash node table)))
	  (t (let ((new-table (list node)))
	       (kmp-table-store new-table indicator value)
	       (unless (null (cdr new-table))
		 (setf (gethash node (node-info m)) new-table)))))))
;;;

(defmethod clear ((m logical))
  (setf (states m) nil)
  (setf (connections m) nil)
  (setf (start-state m) nil)
  (clrhash (node-info m))
  (clrhash (node-info m)))
  

(defmethod add-state ((m logical) &optional state)
  (unless state (setq state (gensym)))
  (unless (find state (states m))
    (pushnew state (states m)))
  state)

(defmethod remove-state ((m logical) state)
  "also removes all connections involving the given state."
  (loop for c in (copy-seq (connections m))
	for src = (get-edge-info m 'from c)
	for dst = (get-edge-info m 'to c)
	when (or (eq state src) (eq state dst))
	do (remove-connection m c))
  (remhash state (node-info m))
  (when (eq state (start-state m))
    (setf (start-state m) nil))
  (setf (states m) (remove state (states m))))

(defmethod find-connection ((m logical) from to)
  (loop for c in (connections m)
	for src = (get-edge-info m 'from c)
	for dst = (get-edge-info m 'to c)
	when (and (eq from src) (eq to dst))
	return c))

(defmethod find-state ((m logical) state)
  (loop for s in (states m)
	when (eq state s)
	return s))

(defmethod add-connection ((m logical) from to (trans symbol))
  "add a connection between two given states for the given transition
character, adding the states if they dont exist"
  ;; handle adjacencies (afterthought)
  (let ((adjacencies (get-node-info m 'adjacencies from)))
    (setf (get-node-info m 'adjacencies from)
	  (pushnew to adjacencies)))
		 
  (let ((c (find-connection m from to)))
    (cond (c (let ((old (get-edge-info m 'trans c)))
	       (unless (find trans old)
		 (setf (get-edge-info m 'trans c)
		       (push trans old)))))
	  (t (setq c (gensym))
	     (setf (get-edge-info m 'trans c) (list trans))
	     (unless (find-state m from) (add-state m from))
	     (unless (find-state m to) (add-state m to))
	     (setf (get-edge-info m 'from c) from)
	     (setf (get-edge-info m 'to c) to)
	     (pushnew c (connections m)) c))))

(defmethod remove-connection ((m logical) connection)
  (let* ((head (get-edge-info m 'from connection))
	 (adjacencies (get-node-info m 'adjacencies head)))
    (if adjacencies
	(setf (get-node-info m 'adjacencies)
	      (delete (get-edge-info m 'from connection) adjacencies))))

  (remhash connection (edge-info c))
  (setf (connections m) (remove connection (connections m))))

(defmethod transitions ((m logical) state (trans character))
  (transitions m state (make-symbol (string trans))))

(defmethod transitions ((m logical) state (trans symbol))
  "the set of destination states of a given state and a transition character"
  (loop for c in (connections m)
	for src = (get-edge-info m 'from c)
	for dst = (get-edge-info m 'to c)
	when (and (eq src state)
		  (find trans (get-edge-info m 'trans c)))
	collect dst))

(defmethod make-start-state ((m logical) state)
  "mark given state as the start-state, adding it if it isnt there"
  (unless (find-state m state) (add-state m state))
  (setf (start-state m) state))

(defmethod make-accepting-state ((m logical) state)
  "mark given state as accepting, adding it if it isnt there"
  (unless (find-state m state) (add-state m state))
  (setf (get-node-info m 'accepting-p state) t))

(defmethod transition-alphabet ((m logical))
  (let ((connections (connections m))
	(ta nil))
    (mapcar #'(lambda (x) (setq ta (union ta (get-edge-info m 'trans x))))
	    connections)
    ta))

(defmethod make-graph ((m logical))
  (loop for node in (states m)
	for adjacencies = (get-node-info m 'adjacencies node)
	collect (if adjacencies
		    (list node adjacencies)
		    (list node))))
		    
(defmethod deterministic-p ((m logical) &aux (ta (transition-alphabet m)))
  (not (loop for s in (states m)
	     when (some #'(lambda (x) (> (length (transitions m s x)) 1)) ta)
	     return t)))

(defmethod print-object ((m logical) stream) ; clos protocol
  (print-unreadable-object (m stream)
    (call-next-method)
    (with-slots (states connections start-state) m
      (format stream "~&START: ~A~&" start-state)
      (format stream " STATES(~d) :~&" (length states))
      (loop for n in states do
	    (format stream " ~A" n)
	    (if (get-node-info m 'accepting-p n)
		(format stream "~T(accepting)~&")
		(format stream "~&")))
      (format stream " CONNECTIONS(~d)" (length connections))
      (loop for c in connections do
	    (format stream "~& ~A->~A~T~A"
		    (get-edge-info m 'from c)
		    (get-edge-info m 'to c)
		    (get-edge-info m 'trans c))))))

(defmethod simulate ((m logical) (input list))
  (let ((cstates (list (start-state m))) (result 'REJECTED))
    (loop with ta = (transition-alphabet m)
	  for newstates = nil
	  for trans in input
	  do
	  (unless (find trans ta) (error "alphabet not found: ~a" trans))
	  (loop for cs in cstates do
		(setq newstates (union newstates (transitions m cs trans))))
	  (setq cstates newstates)
	  finally
	  (loop for cs in cstates do
		(if (get-node-info m 'accepting-p cs)
		    (setq result 'ACCEPTED)))
	  (return result))))
	  
(defun q (m)
  "the largest power of 2 which divides m>0"
  (loop for j from 0 do
	(multiple-value-bind (f r) (floor m 2)
	  (setq m f)
	  (when (= r 1) (return j)))))

(defun powerset (set)
  "set of all subsets of the given set. Thanks MV Tamahankar[95]"
  (append
   (list nil)
   (loop with size = (length set)
	 with mask = (make-array size :initial-element 0)
	 with cardinality = 0
	 for m from 1
	 for j = (q m)
	 while (or (not (= cardinality 1))
		   (= (aref mask (- size 1)) 0))
	 collect (let ((x (aref mask j)))
		   (setf (aref mask j) (- 1 x))
		   (setq cardinality (+ cardinality -1 (* 2 (aref mask j))))
		   (loop for i from 0 to (- size 1)
			 when (= 1 (aref mask i))
			 collect (nth i set))))))

(defmethod nfa->dfa ((nfa logical))
  "also minimizes the resulting machine. beware of exponential blowup."
  (let* ((dfa (make-instance 'logical))	; new machine
	 (ta (transition-alphabet nfa))
	 (nfa-start (start-state nfa))	; start state of given nfa
	 (ts (loop for s in (states nfa) ; accepting states of given nfa
		   when (get-node-info nfa 'accepting-p s)
		   collect s))
	 ;; the states of the dfa correspond to the powerset of states
	 ;; of the given nfa
	 (nstates (powerset (states nfa))))
    ;; construct states for the new machine using existing states
    ;; where possible
    (loop for item in nstates
	  for n = (if (= (length item) 1) (add-state dfa (nth 0 item))
		      (add-state dfa))
	  do ;;(when item
	  (setf (get-node-info dfa 'nfa-states n) item)
	  ;;
	  (if (eq n nfa-start) (make-start-state dfa n))
	  (if (intersection TS item) (make-accepting-state dfa n)))
    ;; construct transition functions for all states of the new dfa
    (loop for n in (states dfa) do	; for all dfa states
	  (loop for x in ta		; for all transition characters
		for tset = (loop with l = nil
				 for s in (get-node-info dfa 'nfa-states n) do
				 (setq l (union l (transitions nfa s x)))
				 finally (return l))
		for to = (loop for s in (states dfa)
			       for item = (get-node-info dfa 'nfa-states s)
			       when (null (set-difference item tset))
			       return s)
		do (add-connection dfa n to x)))  dfa))

(defmethod directly-connected-states ((m logical) state)
  "all states reachable from the given state by one transition"
  (loop for c in (connections m)
	when (eq (get-edge-info m 'from c) state)
	collect (get-edge-info m 'to c)))

(defmethod copy-machine ((m logical))
  (let ((copy  (make-instance 'logical
			      :states (copy-seq (states m))
			      :connections (copy-seq (connections m))
			      :start-state (start-state m))))
    (with-slots (node-info edge-info) copy
      (maphash #'(lambda (key val) (setf (gethash key node-info) val))
	       (node-info m))
      (maphash #'(lambda (key val) (setf (gethash key edge-info) val))
	       (edge-info m)))
    copy))
	
(defmethod remove-inaccessible-states ((f logical) &aux (m (copy-machine f)))
  (let ((inaccessible-states (copy-seq (states m))))
    (labels ((remove-connected-states (state)
	       "find inaccessible states of m by recursively removing all directly connected states of the given state"
	       (when (find state inaccessible-states)
		 (setq inaccessible-states (remove state inaccessible-states))
		 (loop for s in (directly-connected-states m state) do
		       (remove-connected-states s)))))
      (remove-connected-states (start-state m)))
    (warn "inaccessible:~a" inaccessible-states)
    (loop for s in inaccessible-states do
	  (remove-state m s)))  m)

(defmethod complete ((f logical) &aux (m (copy-machine f)))
  (loop with ta = (transition-alphabet m)
	and dead-state = nil
	for state in (states m)
	do (loop for c in ta do
		 (when (null (transitions m state c))
		   (unless dead-state
		     (setq dead-state (add-state m))
		     (loop for u in ta do
			   (add-connection m dead-state dead-state u)))
		   (add-connection m state dead-state c)))) m)

(defun run-machine-tests ()
  (defparameter nfa (make-instance 'logical))
  (defparameter dfa nil)
;;;  (let ((nfa (make-instance 'logical))) ;)
;;;            [a]->foo ->[b]
;;;    ->start               ->end
;;;            [a]->bar ->[c]
    (add-state nfa 'start)
    (make-start-state nfa 'start)
    (add-connection nfa 'start 'foo 'a)
    (add-connection nfa 'start 'bar 'a)
    (add-connection nfa 'foo 'end 'b)
    (add-connection nfa 'bar 'end 'c)
    (make-accepting-state nfa 'end)
    (setq dfa (nfa->dfa nfa)))