(defpackage :fathomr
  (:export :fathom)
  (:use :common-lisp :theoretica :english :radiplex :db :util))
(in-package :fathomr)

;;;; Implementation of Sliplogic.



(defun fathom (single)
  (if single

      (let ((sems (semantics single))
            (sem-eff nil)) 
        (dolist (sem sems)
          (let ((eff (contextualize sem)))
            (when eff (setf sem-eff eff)))) ; input

        ;; process
        (labels ((gather (expr)
                   (multiple-value-bind (matches incomplete)
                       (trigger expr)
                     (let* ((satisfied
                             (cycle
                              (cascade
                               (selection
                                (satisfaction matches (get-focus))))
                              (current-session)))
                            (resolved
                             (if satisfied
                                 (resolve nil satisfied)
                               (resolve expr nil))))
                       (if (or (problem resolved) (null (focus (current-session))))
                           (immediate-form (distill resolved)) ; output
                         (gather resolved))))))
          (gather sem-eff)))

    (clear-session))) ; passing in nil clears the current session




(defun problem (clo)
  "Determines if the closure passed in is a solution or not (if not, then T)."
  (get-q clo))


; one thinks: in order, the most specific qexpr/selector to return
; - what exactly are we expecting? what closure? why?
(defun distill (expr)
  (unless expr
    (setf expr (get-focus)))
  (let ((nodes (explode expr)))
    (labels ((node-check (lst)
               (if (null lst)
                   T
                 (let ((check (get-one (first lst))))
                   (when (and (not (closurep check)) (nodep check))
                     (node-check (rest lst)))))))
      (if (node-check nodes)
          expr
        (dolist (clo nodes)
          (when (qexprp clo)
            (return-from distill clo)))))))



; if the problem has been solved, get the next focus
; - otherwise, re-do the problem
(defun cycle (clo ctx)
  (when clo
    (let* ((prob (func3 clo))
           (q (get-q prob)))
      (if (singlep q)
          (get-focus)
        (start-focus prob ctx)))))
      


; match if any of the closures satisfy a Q element in the top focus
; - if so, return a list with the Q it was that was selected from and the selection
(defun satisfaction (closures top-focus
                     &optional (ctx (current-session)))
  (if (null closures)
      '()
    ;; check closures against foci
    (let ((clo (first closures)))
      (labels ((internal-sat (qs)
                 (if (null qs)
                     '()
                   (let ((q (first qs)))
                     (when (contains q top-focus)
                       (cons (cons q clo) (internal-sat (rest qs))))))))
        (let* ((qs (gethash clo (reverse-q-cache ctx)))
               (satisfied (internal-sat qs)))
          (let ((q-pair (q-match top-focus clo ctx)))
            (unless (null q-pair)
              (push q-pair satisfied)))
          (append satisfied (satisfaction (rest closures) top-focus ctx)))))))


; given a list of Qs and their selection, perform the selection
; - get all that are bound to the selection closures
; - pay attention here to why the Qs are being formed
(defun selection (satisfied &optional (ctx (current-session)))
  (let ((selected (make-hash-table))
        (top-focus (get-focus ctx)))
    (dolist (q-pair satisfied)
      (let ((bindings (all-bindings (cdr q-pair))))
        (dolist (bound bindings)
          (let ((qs (gethash bound (reverse-q-cache ctx))))
            ;; if a qexpr is added to the focus a second time, we reselect,
            ;; checking for dups
            (when (or (null qs) (eq bound (hashid top-focus)))
              (let ((parents (get-parents bound ctx))
                    (q (clone (get-one (car q-pair))))) ; q types propagate
                (setf (hashid q) (get-next-id))
                (add-one q)
                (dolist (parent parents)
                  (when (eq (curr (get-one parent)) (hashid *bind*))
                    (form-q-potential (if (eq bound (prev parent))
                                          (hashid q)
                                        (prev parent))
                                      (curr parent)
                                      (if (eq bound (subs parent))
                                          (hashid q)
                                        (subs parent))
                                      ctx
                                      qs)))))
            (setf qs (gethash bound (reverse-q-cache ctx)))
            (dolist (q qs)
              ; can the below be a macro?
              (let ((sel (gethash q selected)))
                (push bound sel)
                (setf (gethash q selected) sel)))))))
    selected))


; update the Qs with the selections (cascade them)
; - we need to return the pool of bindings for CPT sorting & resolution
(defun cascade (selected &optional (ctx (current-session)))
  (flet ((select (q n)
           (let ((qdata (data (get-one q))))
             (when (or (eq qdata (hashid *void*))
                       (eq qdata (hashid *bind*)))
               (setf (gethash q (q-cache ctx)) n)))))
    (loop for q being the hash-keys of selected
          for data being the hash-values of selected
          do (select q data)))

    (when (> (hash-table-count selected) 0)
      (pop (focus ctx))))


(defun q-match (qexpr clo &optional (ctx (current-session)))
  (let ((qexpr-el (explode qexpr))
        (clo-el (explode clo)))
    (loop for qe in qexpr-el
          for ce in clo-el
          do (when (qnodep qe)
               (let ((qlist (gethash qe (q-cache ctx))))
                 (when (member ce qlist)
                   (return-from q-match (cons qe ce))))))))

(defun q-member (clo lst)
  (when lst
    (let ((check (first lst)))
      (if (q-list-compare (explode clo) (explode check))
          check
        (q-member clo (rest lst))))))

(defun q-list-compare (lst1 lst2)
  (if (and (null lst1) (null lst2))
      T
    (let ((n1 (first lst1))
          (n2 (first lst2)))
      (when (q-equiv n1 n2)
        (q-list-compare (rest lst1) (rest lst2))))))
  
(defun q-equiv (node1 node2)
  (or (eq node1 node2)
      (and (qnodep node1) (qnodep node2))))



; - find all matches/satisfied matches
; - potentialize partial matches
; - are we returning only complete matches?
; - also, remove recursion?
(defun trigger (nod &optional (ctx (current-session)))
  (unless nod (setf nod (get-focus ctx)))
  ;; better matching, to get potentialized, satisfied, and exact?
  (let ((matches (all-matches nod ctx))
        (incomplete '()))
    ;; what when match = nod?
    (dolist (match matches)
      (let ((grandmatches (get-parent-closures match nil))) ; nil ctx
        (dolist (grandmatch grandmatches)
          ;; assumes potentials have hashid in potential field of session
          (let* ((pot (gethash grandmatch (potential ctx)))
                 (filled (if pot
                             (follow nod match pot)
                           (potentialize nod match grandmatch ctx))))
            (if (data filled) ; data is nil in complete closures
                ;; should we also satisfy other elements in matches?
                (progn
                  (setf (gethash (hashid filled) (proper ctx))
                        filled) ; where are we using this?
                  (push filled matches)
                  (push (effect filled) matches)
                  (multiple-value-bind (matched incompl)
                      (trigger filled ctx)
                    (nconc matches matched)
                    (setf incomplete (nconc incomplete incompl)))
                  (multiple-value-bind (matched incompl)
                      (trigger (effect filled) ctx)
                    (nconc matches matched)
                    (setf incomplete (nconc incomplete incompl)))
              (push filled incomplete))))))) 
    (values matches incomplete)))



(defun resolve (problem focus &optional (ctx (current-session)))
  ;; is focus nil? start new focus
  ;; - from the problem, which is the cat/Q
  (unless focus
    (setf focus (start-focus problem ctx)))
  (flet ((find-position ()
           (cond ((closurep (func2 focus)) (func1 focus))
                 ((func2 focus) (func2 focus))
                 (T (func3 focus))))
         
         (handle-cat ()
           (let ((bound (sort3 (all-bindings problem)))
                 (foc (func3 focus)))
             (let ((binds (first bound))
                   (prefs (second bound))
                   (cats (third bound))
                   (q (get-q foc))
                   (general (effect foc)))
               (dolist (cat cats)
                 (let ((sat (all-matches cat)))
                   (when (member general sat)
                     (let ((qone (gethash q (q-cache ctx))))
                       (setf (gethash q (q-cache ctx)) (push cat qone))))))
               (setf (func2 focus) prefs)
               (setf (func1 focus) binds)
               nil)))

         ;; find the correct pref, or set pref choice as categoric and resolve that
         (handle-pref ()
           (let ((thes (func1 focus))
                 (prefs (func2 focus))
                 (left-higher (make-hash-table))
                 (right-higher (make-hash-table))
                 (immediate '())
                 (highest '()))
             (dolist (pref prefs)
               (let ((one (get-one pref)))
                 (cond ((or (member (target one) thes) (member (effect one) thes))
                        (push pref immediate))
                       ((member (target one) prefs)
                        (setf (gethash (target one) left-higher) pref))
                       ((member (effect one) prefs)
                        (setf (gethash (effect one) right-higher) pref)))))
             (dolist (imm immediate)
               (let ((hold imm))
                 (loop while hold
                       do (let (higher)
                            (setf higher (gethash hold left-higher))
                            (unless higher
                              (setf higher (gethash hold right-higher)))
                            (unless higher
                              (push hold highest))
                            (setf hold higher)))))
             (cond ((null highest)
                    (setf problem (form-cat immediate ctx))
                    (setf focus nil))
                   ((singlep highest)
                    (setf (func2 focus)
                          (order-pref (first highest) immediate)))
                   (T (setf problem (form-cat highest ctx))
                      (setf focus nil)))
             nil))
         
         ;; order by the cat and pref, return the selection of theory
         (handle-bind ()
           (order-balance (func1 focus) (func2 focus) ctx)))

    (let* ((pos (find-position))
           (handle (cond ((eq pos (func3 focus)) (handle-cat))
                         ((eq pos (func2 focus)) (handle-pref))
                         ((eq pos (func1 focus)) (handle-bind)))))
      (if handle
          handle
        (resolve problem focus ctx)))))


; what could possibly go wrong?
(defun order-pref (highest immediate)
  (let* ((one (get-one highest))
         (targ (target one)))
    (if (member targ immediate)
        targ
      (order-pref targ immediate))))
      

(defun form-cat (q-list ctx)
  (let ((qnod (make-instance 'qnode
                             :hashid (get-next-id)
                             :q (hashid *void*))))
    (setf (gethash (hashid qnod) (q-cache ctx)) q-list)
    (implode (list (hashid qnod) (hashid *bind*) (hashid *q*) (hashid *free*)
                   (hashid *form*) (hashid *q*)))))


(defun start-focus (problem ctx)
  (let ((foc (implode (list nil nil nil nil problem nil))))
    (setf (focus ctx)
          (push foc (focus ctx)))
    foc))
        


; of the closures, build all bindings, separate them into C P T
; - belongs here: feedback loop on immediate C -> T -> bindings -> expanded C
(defun sort3 (closures)
  (let ((cats '())
        (prefs '())
        (thes '()))
    (dolist (clo closures)
      (cond ((detect-sat clo) (push clo cats))
            ((detect-ord clo) (push clo prefs))
            ((detect-bind clo) (push clo thes))))
    (list cats prefs thes)))


(defun detect-sat (clo &optional (form *form*))
  (and (eq (func3 clo) (hashid form))
       (not (is-q (source clo)))
       (not (is-q (effect clo)))))

(defun detect-ord (clo)
  (and (eq (func1 clo) (hashid *bind*))
       (eq (func2 clo) (hashid *free*))
       (not (is-q (target clo)))
       (not (is-q (effect clo)))))

(defun detect-bind (clo)
  (and (eq (func1 clo) (hashid *bind*))
       (eq (func2 clo) (hashid *free*))
       (not (is-q (source clo)))
       (not (is-q (target clo)))))


; or do we need just a check against *q*?
(defun is-q (nod)
  (or (eq nod *q*) (qnodep nod)))


(defun order-pairs (pref qs &optional (ctx (current-session)))
  (unless qs
    (return-from order-pairs '(0 . 0)))
  (let ((q (first qs))
        (conn (make-instance 'connection)))
    (labels ((find-pair (matches)
               (let ((p nil))
                 (loop while (and (not p) matches)
                       do (let* ((match (pop matches))
                                 (parents (get-parents match)))
                            (dolist (parent parents)
                              (unless p
                                (let ((one (get-one parent)))
                                  (when (detect-ord one)
                                    (when (eq q (target one))
                                      (setf p (cons q (hashid one))))
                                    (when (eq q (effect one))
                                      (setf p (cons (hashid one) q)))))))))
                 (if p
                     p
                   '(0 . 0)))))
      (let (matches)
        (setf (prev conn) q)
        (setf (curr conn) (hashid *bind*))
        (setf (subs conn) (target pref))
        (setf matches (all-matches conn ctx))
        (if matches
            (let ((pair (find-pair matches)))
              (list pair (order-pairs pref (rest qs) ctx)))
          (order-pairs pref (rest qs) ctx))))))


(defun order-by-pref (pref qs &optional (ctx (current-session)))
  "Given a preferential and a list of Qs, return a list of Qs in order of that
   preferential."
  (let ((sorted (order-pairs pref qs ctx))
        (ordered '())
        (next nil))
    (dolist (one sorted)
      (unless next
        (unless (member (car one) qs)
          (setf next one)
          (push (cdr one) ordered))))
    (loop while next
          do (let ((succ (assoc (cdr next) sorted)))
               (if succ
                   (let ((succ2 (assoc (cdr succ) sorted)))
                     (push (cdr succ) ordered)
                     (setf next succ2))
                 (setf next nil))))
    (setf ordered (reverse ordered))
    (setf next (rassoc (first ordered) sorted))
    (loop while next
          do (let ((pred (rassoc (car next) sorted)))
               (if pred
                   (let ((pred2 (rassoc (car pred) sorted)))
                     (push (car pred) ordered)
                     (setf next pred2))
                 (setf next nil))))
    ordered))


(defun order-balance (closures pref foc
                               &optional (ctx (current-session)) best)
  "Obtain from the (Q)closures passed in, based on the preferentials, the one that
   chooses from among the most and most distinct in the focus."
  (if (null closures)
      (when best (first best))
    (let ((qfoc (gethash (get-q foc) (q-cache ctx)))
          (clo (first closures))
          (res (rest closures))
          (s-list '())
          (b-list '())
          (boundhash (make-hash-table))
          (sathash (make-hash-table)))
      (let* ((q-list (gethash (get-q clo) (q-cache ctx)))
             (ordered-p (order-by-pref pref q-list ctx))
             (p-list (mapcar #'(lambda (qone)
                                 (let* ((bound (all-bindings qone))
                                        (boundx (mapcar #'(lambda (p)
                                                            (intersection (all-bindings p)
                                                                          bound))
                                                        ordered-p))
                                        (satx (mapcar #'(lambda (bound)
                                                          (intersection qfoc bound))
                                                      boundx)))
                                   (unless pref
                                     (push (intersection qfoc bound) s-list)
                                     (push bound b-list))
                                   (cons boundx satx)))
                             q-list)))
        (labels ((spread (val tbl)
                   (let ((saved (gethash val tbl)))
                     (if saved
                         (setf (gethash val tbl) (incf saved))
                       (setf (gethash val tbl) 1))))
                 (list-count (lst)
                   (if lst
                       (let ((one (first lst)))
                         (when (listp one)
                           (setf one (cdr one)))
                         (if (first lst)
                             (1+ (list-count (rest lst)))
                           (list-count (rest lst))))
                     0))
                 (factor (els tbl)
                   (mapcar #'(lambda (el)
                               (/ 1 (gethash el tbl)))
                           els)))
          (mapcar #'(lambda (st)
                      (dolist (s st)
                        (spread s sathash)))
                  s-list)
          (mapcar #'(lambda (bnd)
                      (dolist (b bnd)
                        (spread b boundhash)))
                  b-list)
          (let ((s-coll
                 (if pref
                     (mapcar #'(lambda (p)
                                 (let ((coll 0)
                                       (boundhash (make-hash-table))
                                       (sathash (make-hash-table)))
                                   (dolist (bnd (car p))
                                     (dolist (b bnd)
                                       (spread b boundhash)))
                                   (dolist (sat (cdr p))
                                     (dolist (s sat)
                                       (spread s sathash)))
                                   (dolist (pr p)
                                     (let ((cume 0)
                                           (cume-lst '()))
                                       (loop for bs in (car pr)
                                             for ss in (cdr pr)
                                             do (let ((bndc (factor bs boundhash))
                                                      (satc (factor ss sathash)))
                                                  (loop for bc in bndc
                                                        for sc in satc
                                                        do (push (* bc sc)
                                                                 cume-lst))
                                                  (setf cume
                                                        (+ cume
                                                           (* (apply #'+ cume-lst)
                                                              (list-count ss))))))
                                       (setf coll
                                             (+ coll cume))))
                                   coll))
                             p-list)
                   (loop for bnd in b-list
                         for sat in s-list
                         collect (let ((cume 0)
                                       (cume-lst '()))
                                   (loop for bs in bnd
                                         for ss in sat
                                         do (let ((bndc (factor bs boundhash))
                                                  (satc (factor ss sathash)))
                                              (loop for bc in bndc
                                                    for sc in satc
                                                    do (push (* bc sc)
                                                             cume-lst))
                                              (setf cume
                                                    (+ cume
                                                       (* (apply #'+ cume-lst)
                                                          (list-count ss))))))
                                   cume)))))
            (let ((acc (apply #'+ s-coll)))
              (if best
                  (let ((val (cdr best)))
                    (if (> acc val)
                        (order-balance res pref foc ctx (cons clo acc))
                      (order-balance res pref foc ctx best)))
                (order-balance res pref foc (cons clo acc))))))))))



(defun follow (nod match pot &optional (ctx (current-session)))
  "Check to see if we can function, and then carry logic if necessary."
  (let ((outer (data pot))
        (outer-list (explode (data pot)))
        (pot-list (explode pot))
        (id (hashid pot)))
    (setf pot-list (loop for inst in pot-list
                         for obj in outer-list
                         collect (let ((one (get-one obj)))
                                   (if (eq one match)
                                       (set-all-nodes nod match id ctx)
                                     inst))))
    (let ((pot (implode pot-list)))
      (setf (hashid pot) id)
      (setf (data pot) outer)
      (check-completion pot outer ctx))))



(defun save-satisfy (nod matched save &optional (ctx (current-session)))
  (when save
    (let ((saved-table (gethash save (potential ctx)))
          (save-conn (cache-of (make-connection -1
                                                (get-one nod) 
                                                *form* 
                                                (get-one matched)))))
      (unless saved-table
        (setf saved-table (make-hash-table))
        (setf (gethash save (potential ctx)) saved-table))
      (setf (gethash matched saved-table) save-conn)
      (setf (gethash save (potential ctx)) saved-table))))



(defun complete (inst)
  (flet ((complete-conn (conn)
           (setf (prev conn) (hashid (prev conn)))
           (setf (curr conn) (hashid (curr conn)))
           (setf (subs conn) (hashid (subs conn)))
           (cache-of conn)))
    (let ((new-outs '())
          (new-fwds '()))
      (setf (root inst) (hashid (prev (first (outs inst)))))
    (dolist (out (reverse (outs inst)))
      (push (hashid (complete-conn out)) new-outs))
    (setf (outs inst) new-outs)
    (dolist (fwd (reverse (forwards inst)))
      (push (hashid (complete-conn fwd)) new-fwds))
    (setf (forwards inst) new-fwds)
    (let ((exists (get-one (get-syn-hash inst))))
      (if exists
          exists
        (progn
          (setf (hashid inst) (get-next-id))
          (setf (data inst) nil)
          (add-one inst)))))))

      

(defun carry (clo saved &optional (ctx (current-session)))
  (let ((saved-table (gethash saved (potential ctx))))
    (let ((src (carry-node (source clo) saved-table))
          (f1 (carry-node (func1 clo) saved-table))
          (targ (carry-node (target clo) saved-table))
          (f2 (carry-node (func2 clo) saved-table))
          (f3 (carry-node (func3 clo) saved-table))
          (eff (carry-node (effect clo) saved-table)))
    (let ((new-out1 (make-connection -1 src f1 targ))
          (new-out2 (make-connection -1 src f3 eff))
          (new-fwd (make-connection -1 targ f2 eff)))
      (let ((out1 (cache-of new-out1))
            (out2 (cache-of new-out2))
            (fwd (cache-of new-fwd)))
        (let* ((carried (make-closure -1 (get-one (prev out1))
                                      (list out1 out2)
                                      (list fwd)))
               (cached (get-one (get-syn-hash carried))))
          (if cached
              cached
            (progn
              (setf (hashid carried) saved)
              (add-one carried)
              (set-all-parents carried)
              carried))))))))


(defun carry-node (nod saved-table)
  (let ((satisfy (gethash nod saved-table)))
    (get-one (prev satisfy))))




(defvar *auto-list* (list (hashid *form*)
                          (hashid *void*)
                          (hashid *free*)
                          (hashid *bind*)))



; instantiate the outer, place clo within in (carry?), put instance in potentials
(defun potentialize (nod match outer &optional (ctx (current-session)))
  (let* ((outer-list (explode outer))
         (id (get-next-id))
         (pot-list (mapcar #'(lambda (n)
                               (let ((one (get-one n)))
                                 (cond ((eq n match)
                                        (set-all-nodes nod match id ctx))
                                       ((member n *auto-list*)
                                        one))))
                                   
                           outer-list))
         (pot (implode pot-list)))
                                   
    (setf (hashid pot) id)
    (setf (data pot) outer)
    (setf (gethash (hashid outer) (potential ctx)) pot)
    (check-completion pot outer ctx)))

(defun check-completion (pot outer &optional (ctx (current-session)))
  (when (and (source pot)
             (func1 pot)
             (target pot)
             (func2 pot)
             (func3 pot))
    (setf (effect pot) (carry (get-one (effect outer)) (hashid pot) ctx))
    (complete pot))
  pot)

(defun set-all-nodes (nod match id &optional (ctx (current-session)))
  (setf nod (get-one nod))
  (setf match (get-one match))
  (when (closurep match)
    (let ((match-list (explode match))
          (nod-list (explode nod)))
      (loop for m in match-list
            for n in nod-list
            do (save-satisfy n m id ctx))))
  nod)



(defun get-focus (&optional (ctx (current-session)))
  (first (focus ctx)))


(defun get-q (qexpr)
  (dolist (nod (explode qexpr))
    (when (qnodep (get-one nod))
      (return-from get-q nod))))
; returns the Q in the qexpr



; we can hold the user (unknown) object in the IO section
(defun immediate-form (clo)
  T)
;((search for most specific form of clo in immediate-list) piecemeal, if necessary))
; how to do piecemeal? is it set up in contextualize?
; - are there sentential formation structures, which we carry the clo passed in with?
; - semantic form -T-> syntactic form, carried: would a context be word satisfactions?


(defun contextualize (id)
  ; isn't this just triggering semantic relations?
  ; - if so, is there a "grammar session" we could use?
  ; - in the grammar session, can we store pronouns, replacing them with the one to
  ;   which they refer to?
  ; we should also know which word is which, using Q:word/Q:POS to hold place
  ; do we put the closure & its constituents in (satisfied (current-session)) here?
  ; we do put the resultant closure in (focus (current-session))...
  (let ((session (current-session))
        (nod (get-one id)))
    (first (last (trigger nod session))))) ; returning the most current effect
                                           ; of what was completed, if any
; now we need to hook up input/output for sentential to semantics, or is that
; done somehow in the triggering?
; - set up outputs here, too: the syntactic form should already be piecemeal,
;   but set up word satisfaction contexts...