(defpackage :radiplex
  (:export :match :clear-session :add-parent
   :get-parents :form-q-potential :add-qnode :clear-parent-cache
   :*last-radiplex-layer* :radiplex-get :get-previous-layer
   :add-to-layer :get-grandparents :set-all-parents
   :all-matches :all-bindings :contains :inputs :outputs
   :current-session :clear-session :qexprp :get-parent-closures)
  (:use :common-lisp :theoretica :english :util :db))
(in-package :radiplex)

;;;; Implementation of Ontological Topology (otopology)


(defparameter *session* (make-instance 'session))

(defparameter *input-session* (make-instance 'session))

(defparameter *output-session* (make-instance 'session))

(defun current-session () *session*)

(defun inputs () *input-session*)

(defun outputs () *output-session*)

(defun clear-session ()
  (setf *session* (make-instance 'session)))


#|
what do we need for a general match?
- we are looking from the context pool what is active
  * what is immediate should be in the session already
- see what exactly matches, and what instantiates based on what is active
- cross-bindings are active relative to each other
  * directionality?
|#

(defgeneric all-matches (obj &optional ctx)
  (:documentation "Find what general object(s) matches the obj passed in."))
; in general, either they are in a context or have been activated, correct?


; variables: e.g. q1:noun is different from q2:noun, but both match noun
(defmethod all-matches ((qnod qnode) &optional (ctx *session*))
  (all-matches (q qnod) ctx))

(defmethod all-matches ((id integer) &optional (ctx *session*))
  (all-matches (get-one id) ctx))

; serendipitously, this may solve the question of when to use general forms
; to solve specific cases: if their satisfaction is active in the current
; context, they are matched against, it looks like...
(defmethod all-matches ((nod node) &optional (ctx *session*))
  (unless (gethash (hashid nod) (proper ctx))
    (return-from all-matches '()))
  (let* ((qmatched (unless (qnodep nod)
                     (gethash (hashid nod) (q-cache ctx))))
         (matched (push (hashid nod) qmatched)))
    (let ((parents (get-parents (hashid nod) nil)))
      (dolist (parent parents)
        (let ((one (get-one parent)))
          (when (connectionp one)
            ;; there doesn't need to be a match in the other direction, no?
            (when (eq (prev one) (hashid nod))
              (let ((match-curr (all-matches (get-one (curr one)) ctx)))
                (when (member (hashid *form*) match-curr)
                  (setf matched
                        (nconc matched
                               (all-matches (get-one (subs one)) ctx))))))))))
    (remove-duplicates matched)))
; shall we put Q-formation here?

; in all-matches for closures and connections, do we need also to check as in for
; node, if they satisfy or are satisfied, increasing their matches?

; get all satisfied closures(?) of a closure to match
(defmethod all-matches ((clo closure) &optional (ctx *session*))
  (unless (gethash (hashid clo) (proper ctx))
    (return-from all-matches '()))
  (let ((hash-all (list (all-matches (get-one (root clo)) ctx)))
        (matches '()))
    (dolist (out (outs clo))
      (push (all-matches (get-one out) ctx) hash-all))
    (dolist (fwd (forwards clo))
      (push (all-matches (get-one fwd) ctx) hash-all))
    (setf hash-all (reverse hash-all))
    ;; all permutations of each out and fwd in list
    (apply #'maperm #'(lambda (&rest args)
                        (let ((exists (get-one (apply #'make-hash args)))) 
                          (when exists (push (hashid exists) matches))))
           hash-all)
    (remove-duplicates matches)))
; removed satisfied check in ctx


; see permutations.lisp
(defun maperm (fn &rest lists)
  (cond ((endp lists) nil)
        ((endp (rest lists)) (mapc fn (first lists)))
        (t (mapc #'(lambda (x)
                     (apply #'maperm
                            #'(lambda (&rest args)
                                (apply fn x args))
                            (rest lists)))
                 (first lists))))
  (reduce #'* (mapcar #'length lists)))

; get all satisfied connections(?) of a connection to match
(defmethod all-matches ((conn connection) &optional (ctx *session*))
  (unless (gethash (hashid conn) (proper ctx))
    (return-from all-matches '()))
  (let ((prev-one (get-one (prev conn)))
        (curr-one (get-one (curr conn)))
        (subs-one (get-one (subs conn)))
        (q-list '()))
    (let ((prevs (if prev-one (all-matches prev-one ctx) q-list))
          (currs (if curr-one (all-matches curr-one ctx) q-list))
          (subss (if subs-one (all-matches subs-one ctx) q-list))
          (matches '()))
      (dolist (prev-id prevs)
        (dolist (curr-id currs)
          (dolist (subs-id subss)
            (let ((exists (get-one (make-hash prev-id curr-id subs-id))))
              (when exists
                (push (hashid exists) matches))))))
      matches)))
; removed satisfied check in ctx


(defmethod all-bindings (nod &optional (ctx *session*)
                             (bound-now (make-hash-table)))
  (let ((bound '())
        (parents (get-parents (hashid nod) nil)))
    (setf (gethash (hashid nod) bound-now) nod)
    (dolist (parent parents)
      (let ((one (get-one parent)))
        (when (connectionp one)
          (if (eq (subs one) (hashid nod))
              (when (not (gethash (prev one) bound-now))
                (let* ((match-curr (all-matches (get-one (curr one)) ctx))
                       (is-bind (member (hashid *bind*) match-curr)))
                  (when is-bind
                    (let ((bound-prev (all-bindings (get-one (prev one)) 
                                                    ctx bound-now)))
                      (setf bound (nconc bound bound-prev))))))
              (when (eq (prev one) (hashid nod))
                (let* ((match-curr (all-matches (get-one (curr one)) ctx))
                       (is-bind (member (hashid *bind*) match-curr)))
                  (when is-bind
                    (let ((bound-subs (all-bindings (get-one (subs one)) 
                                                    ctx bound-now)))
                      (setf bound (nconc bound bound-subs))))))))))
    (remove-duplicates bound)))



(defmacro setc (which)
  `(lambda (conn val) (setf (apply ,which (list conn)) val)))


; this is for matching against Qs passed in...
(defun form-q-potential (prev-id curr-id subs-id ctx exists)
  (let ((relevant '())
        (prev-now (get-one prev-id))
        (curr-now (get-one curr-id))
        (subs-now (get-one subs-id)))
    (flet ((get-relevant (lst match fn)
             (dolist (el lst)
               (when (eq match (apply fn (list (get-one el))))
                 (push (get-one el) relevant)))
             relevant))
      (let ((prev-parents (get-relevant (get-parents prev-id ctx)
                                        prev-id #'prev))
            (curr-parents (get-relevant (get-parents curr-id ctx)
                                        curr-id #'curr))
            (subs-parents (get-relevant (get-parents subs-id ctx)
                                        subs-id #'subs)))
        (flet ((get-which-intersect ()
                 (cond ((qnodep prev-now)
                        (values prev-now (setc #'prev)
                                (intersection curr-parents subs-parents)))
                       ((qnodep curr-now)
                        (values curr-now (setc #'curr)
                                (intersection prev-parents subs-parents)))
                       ((qnodep subs-now)
                        (values subs-now (setc #'subs)
                                (intersection curr-parents prev-parents))))))
          (multiple-value-bind (qn which tween)
              (get-which-intersect)
            (when tween
              (let ((qdata (mapcar which tween))
                    (qconn (make-instance 'connection
                                          :hashid (get-next-id)
                                          :prev prev-id
                                          :curr curr-id
                                          :subs subs-id)))
                (when ctx
                  (setf (gethash (hashid qconn) (proper ctx)) qconn)
                  (apply which (list qconn (hashid qn)))
                  (add-one-simple (get-syn-hash qconn) qconn)
                  ;; when a q exists already, exclude the previous elements
                  (when exists
                    (dolist (q exists)
                      (let ((qval (gethash q (q-cache ctx))))
                        (setf qdata (set-difference qdata qval)))))
                  ;; update q-cache
                  (setf (gethash (hashid qn) (q-cache ctx)) qdata)
                  ;; update reverse-q-cache
                  (dolist (qd qdata)
                    (let ((rev (gethash qd (reverse-q-cache ctx))))
                      (unless (member (hashid qn) rev)
                        (push (hashid qn) rev)
                        (setf (gethash qd (reverse-q-cache ctx)) rev)))))
                (add-one qconn)))))))))


(defgeneric contains (nod obj)
  (:documentation "Whether nod is contained in obj."))

(defmethod contains (nod1 (nod2 node))
  (eq nod1 nod2))

(defmethod contains (nod (conn connection))
  (or (contains nod (prev conn))
      (contains nod (curr conn))
      (contains nod (subs conn))))

(defmethod contains (nod (clo closure))
  (dolist (id (outs clo))
    (when (contains nod id)
      (return-from contains nod)))
  (dolist (id (forwards clo))
    (when (contains nod id)
      (return-from contains nod))))

(defmethod contains (nod (id integer))
  (contains nod (get-one id)))


(defun qexprp (obj) ; use q-pool
  (contains *q* obj))


;(defun add-void (id1 id2)
;  (setf (gethash id1 *void-table*) id2)
;  (setf (gethash id2 *void-table*) id1))

;(defun is-void (id1 id2)
;  (equal (gethash id1 *void-table*) id2))


(defun get-normalized-id (id)
  (hashid (get-one id)))



(defun add-qnode (nod &optional (ctx *session*))
  (let* ((q (hashid nod))
         (qval (q nod))
         (existing (reverse (gethash qval (q-cache ctx)))))
    (unless (member q existing)
      (setf (gethash qval (q-cache ctx)) 
            (reverse (push q existing))))))



(defparameter *parent-cache* (make-hash-table :test 'equal)
  "For an ID of a node, all parents that include the node, in a list.")

(defun clear-parent-cache ()
  (clrhash *parent-cache*))

#|
policy on parents in context?
- get-parents checks context
|#

(defun add-parent (id parent-id &optional (ctx *session*))
  (let ((parent-list (get-parents id nil)))
    (unless (member parent-id parent-list)
      (setf parent-list (push parent-id parent-list))
      (setf (gethash id *parent-cache*) parent-list))))
; ctx nil

(defun get-parents (id &optional (ctx *session*))
  ;(when (or (null ctx) (gethash id (satisfied ctx)))
    (let ((parents-raw (gethash id *parent-cache*))
          (parents '()))
      (dolist (parent parents-raw)
        (when (or (null ctx) (gethash parent (proper ctx)))
          (push parent parents)))
      parents));)

(defun get-grandparents (id &optional (ctx *session*))
  (let ((parents (get-parents id))
        (grandparents '()))
    (dolist (parent parents)
      (setf grandparents (union grandparents
                                (get-parents parent ctx))))
    grandparents))

(defun get-parent-closures (id &optional (ctx *session*))
  (let ((parents (get-parents id ctx))
        (closures '()))
    (dolist (parent parents)
      (let ((one (get-one parent)))
        (if (closurep one)
            (push one closures)
          (let ((grandparents (get-parents parent ctx)))
            (dolist (grandparent grandparents)
              (let ((grand (get-one grandparent)))
                (when (closurep grand)
                  (push grand closures))))))))
    (remove-duplicates closures)))
            
  

(defgeneric set-all-parents (obj)
  (:documentation "For all subelements of an object, add it as a parent of
subelement(s)."))

(defmethod set-all-parents ((clo closure))
  (dolist (fwd (forwards clo))
    (add-parent fwd (hashid clo))
    (set-all-parents (get-one fwd)))
  (dolist (out (outs clo))
    (add-parent out (hashid clo))
    (set-all-parents (get-one out))))

(defmethod set-all-parents ((conn connection))
  (add-parent (prev conn) (hashid conn))
  (add-parent (curr conn) (hashid conn))
  (add-parent (subs conn) (hashid conn)))

(defun get-intersecting-parents (id1 id2)
  (let ((parents1 (get-parents id1))
        (parents2 (get-parents id2)))
    (intersection parents1 parents2)))