(in-package :common-lisp-user)

;;;
;;; the node representation: to allow a structure like [FAA <1>, FEE <1>] where
;;; the underspecified values may later become atoms, all nodes including atoms
;;; must be encoded as `dag' instances.  for atomic nodes, we assume there to
;;; be no `arcs' and use the `type' slot as the value.  in turn, complex nodes
;;; make no use of `type' (though, in a typed feature structure universe they
;;; would).  the additional `copy' slot is only used when copying a structure.
;;;

(defstruct (dag (:copier x-copy-dag))
  (forward nil :type (or null dag))
  (type nil :type symbol)
  (arcs nil :type list)
  (copy nil :type (or null dag)))

(defun copy-dag (dag)
  ;;
  ;; create local recursive functions: to preserve coreference between nodes,
  ;; copies are recorded in the `copy' slot; when we visit a node twice, no
  ;; additional copying is necessary; instead, simply return the `copy' slot.
  ;;
  (labels 
      ((copy-dag! (dag)
         (let ((new (x-copy-dag dag)))
           (setf (dag-copy dag) new)
           (setf (dag-arcs new)
             (loop
                 for (attribute . value) in (dag-arcs dag)
                 collect (cons attribute
                               (if (dag-p value)
                                 (or (dag-copy value) (copy-dag! value))
                                 value))))
           new))
       (restore-dag (dag)
         (setf (dag-copy dag) nil)
         (loop 
             for arc in (dag-arcs dag)
             for value = (rest arc)
             when (dag-p value) do
               (restore-dag value))))
    (let ((new (copy-dag! dag)))
      (restore-dag dag)
      new)))

(defun deref-dag (dag)
  ;;
  ;; follow chain of `forward' pointers when appropriate.
  ;;
  (if (dag-forward dag) (deref-dag (dag-forward dag)) dag))

(defun unify (dag1 dag2)
  ;;
  ;; establish catch() for non-local (immediate) exit from unify-dags() once a
  ;; unification failure is encountered (at an arbitrary recursion level).
  ;;
  (catch :fail (unify-dags dag1 dag2)))

(defun unify-dags (dag1 dag2)
  ;;
  ;; all nodes, including atoms, have to be `dag' structures
  ;;
  (when (and (dag-p dag1) (dag-p dag2))
    (let* ((dag1 (deref-dag dag1))
           (dag2 (deref-dag dag2))
           (type1 (dag-type dag1))
           (type2 (dag-type dag2))
           (arcs1 (dag-arcs dag1))
           (arcs2 (dag-arcs dag2)))
      (cond
       ;;
       ;; token identity of nodes: they have been unified already
       ;;
       ((eq dag1 dag2))
       ;;
       ;; non-atomic nodes: iterate over features of .dag1. and recursively
       ;; unify values where .dag2. has a corresponding feature; if not, add
       ;; feature to `arcs' slot in .dag2.  forwarding .dag1. to .dag2. 
       ;; ensures that future references (e.g. from another path leading to the
       ;; same node) get to see the unification result rather than the original
       ;; structure.
       ;;
       ((or arcs1 arcs2)
        (when (or type1 type2) (throw :fail nil))
        (setf (dag-forward dag1) dag2)
        (loop
            for arc1 in arcs1
            for arc2 = (assoc (first arc1) arcs2)
            when arc2 do
              (unify-dags (rest arc1) (rest arc2))
            else do
              (push arc1 (dag-arcs dag2))))
       ;;
       ;; atomic nodes: test equality according to actual type of the atom.
       ;;
       (t
        (setf (dag-forward dag1) dag2)
        (unless
            (or (null type1) (null type2)
                (and (symbolp type1) (symbolp type2) (eq type1 type2))
                (and (numberp type1) (numberp type2) (= type1 type2))
                (and (stringp dag1) (stringp dag2) (string= dag1 dag2)))
          (throw :fail nil))))
      ;;
      ;; since unification is destructive, simply return the `target' dag;
      ;; returning .dag1. would be equivalent, since it is forwarded to .dag2.
      ;; however, why require an extra deref-dag() call?
      ;;
      dag2)))

#+:debug
(let* ((foo (let ((bar (make-dag :arcs `((bar . ,(make-dag :type 'yes))))))
              (make-dag :arcs (list
                               (cons 'faa bar)
                               (cons 'fee bar)))))
       (fee (let ((bar (make-dag)))
              (make-dag :arcs (list
                               (cons 'fee bar)
                               (cons 'fii bar)))))
       (fii (make-dag :arcs (list (cons 'fee (make-dag :type 'yes))))))
  (pprint (unify (copy-dag foo) (copy-dag fee)))
  (pprint (unify (copy-dag foo) (copy-dag fii)))
  (pprint (unify (copy-dag fee) (copy-dag fii))))