(defpackage :fathomr   (:export :fathom)   (:use :common-lisp :theoretica :english :radiplex :db :util)) (in-package :fathomr) ;;;; Implementation of Sliplogic. #| 1. pre-semantic matching    a. context items: pronouns (this, he, etc.)    b. question to goal matching 2. semantic matching    a. partial match/fill closures       i.  is it itself a Qexpr? if so, new goal, go to 2b       ii. goal satisfaction occurred? $           if so, selection cascade (future rev: undo selection)           - bindings of Q are also in Q; Q types propagate (nil, <>, etc.)             when we get those which the Q satisfies, get the bindings of that             which was satisfied, and when matching against that which is bound             in Q which satisfy any in those which are bound to the satisfied,             we should then make a Q around them. e.g. camera bound to its             properties, Q instance of camera leads to Q instances of those             properties           - is goal satisfaction merely carrying the answer upon the qexpr?           - we should only be using specific multi-Qs in a table, and as             closures use a generic Q, whose data can be the specific: thus             updates can be ephemeral upon the tables    b. solve for current goal if possible       i.   given existing context, try to obtain the resultant of the outer       ii.  utilizing ordering if possible, we are filling in Qs where we can            - if we have a multi, if there is an ordering, we can select              if the two ordered satisfy a common, a Q should be present            - it must be selected somewhere along the line, to be in context we              match the two ordering elements or those bound to the ordering              elements (its root is the condition where the ordering is relevant)              (bringing up the aside, if we have matched the two ordering elems,              the root condition, if not active, can become an existential qexpr)       iii. if we have a match, go to 2aii $       iv.  else, whatever is next is now a subgoal, go to i            - how do we know what is "next"?              to obtain resultant, what we are dependent on, in closure order    c. if subgoal cannot be solved, return to user    d. if resultant of primary goal is not solution, this is a new problem       i.  try to solve as new (primary) goal $    e. if resultant is solution, return to user    f. criteria for "solved" should be encoded in the goal (Q:nil, etc.) 3. output formation    a. idiomatic structure match (based on what context? not highest priority) |# (defun fathom (single)   (if single       (let ((sems (semantics single))             (out-tmp '())) ; could the syntax be its own database?         (dolist (sem sems)           (setf out-tmp (append out-tmp (contextualize sem)))) ; 2ai         (return-from fathom out-tmp)         (labels ((gather ()                    (let* ((matches (trigger)) ; 2a                           ; in trigger, do we put the outer closure in focus? 2aii                           (satisfied                            (cascade (selection (satisfaction matches (get-focus))))))                      (if (or (problem satisfied) (solve)) ; 2d, 2bi-ii                          ; that is, try to solve higher goals, now                          (gather) ; 2di, 2biii                        (immediate-form (distill satisfied)))))) ; 2e, 2c           (gather)))     (clear-session))) ; passing in nil clears the current session ; it is thought that in the case of a seek curl, the original query invokes a Q ; consisting of theories, which should invoke, when the seek curl is partially ; matched in the problem, the method, which has the Q/theories to select from. ; when we match on the same problem, the new Q/theories should not include the ; selected one of before, as it belongs in another, identical Q, because it has ; already been selected.... ; - where are we forming the multi-Qs? when we match something that is placed as ;   focus, we should place all that is bound to it in the bound of the session. ;   then, if something does not exist in a selection chain as Q, match its Q. ; ; incoming information may trigger precedence rules (e.g. ask simple questions, ; they are not that tech savvy) ; - how does it ask metaquestions, when a question cannot be found to ask? ; determines if the closure passed in is a solution or not (if not, then problem=T) ; - so we are checking if the Qs in the closure are solved, which brings up the ;   point of whether conditions for the Q could change? Q:nil means only one (or ;   perhaps none) would be a solution, and Q:>< would mean whatever is in the Q is ;   valid as the solution. Q:<> might mean that given a set of criteria, for that ;   set, all in the Q are valid as solutions... (defun problem (clo &optional (ctx (current-session)))   ; for now, a quick and dirty, check to see if the Q's are 1 or 0 in size   (when clo     (let ((q (get-q clo)))       (if (null q)           T         (when (< (list-length (gethash q (q-cache ctx))) 2)           (push clo (focus ctx))))))) ; side effect (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))))))) (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)) (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)))) (defun get-focus (&optional (ctx (current-session)))   (first (focus ctx))) ; - find all matches/satisfied matches ; - potentialize partial matches ; - are we returning only complete matches? ; - also, remove recursion? (defun trigger (&optional nod (ctx (current-session)))   (unless nod (setf nod (get-focus ctx)))   ;; better matching, to get potentialized, satisfied, and exact?   (let ((matches (all-matches nod ctx))         (results '()))     ;; 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))))             (if pot                 (let ((filled (follow nod match pot)))                   (unless (data filled) ; data is nil in complete closures                     ;; should we also satisfy other elements in matches?                     (setf (gethash (hashid filled) (satisfied ctx))                           filled) ; where are we using this?                     (push filled matches)                     (push (effect filled) results)                     (multiple-value-bind (match2 result2)                         (trigger filled ctx)                     (nconc matches match2)                     (nconc results result2))))               (potentialize nod match grandmatch ctx))))))     (values matches results))) ; 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))))))) ; - look at top focus, see if we have activated solutions, in order, for all its ;   constituents (defun solve (&optional (ctx (current-session)))   ; so in distill, we shouldn't return the problem? or anything whose q-list is solved?   ; - perhaps not to use distill here, but push onto the focus stack specific closures   ;   and have the outer enclosing closure where the goal is the root as activated but   ;   relatively hidden...   (let ((qfoc (get-q (get-focus))))     (when qfoc       (let ((q-list (gethash qfoc (q-cache ctx))))         (multiple-value-bind (ordered to-pop)             (order q-list ctx)         (when ordered           (when to-pop             (pop (focus (current-session))))           (if (qexprp ordered)               (progn                 (push ordered (focus ctx))                 (solve))             ordered))))))) ; if we can't solve given a set of theories, we must make a new problem to get a ; satisifaction of the theories to work with... ; - is it just to find the discriminants between an ordering, being then a theoretic? ; if there is an ordering that has been specified, utilize it, else balance ; (which is below) (defun order (closures &optional (ctx (current-session)))   ; go through, see if there is a precedence that is satisfied between each of   ; them, two at a time, if not, then we balance   ; - for each closure, if it is a qexpr, get the order-balance on its q-list   (let ((ordered '())         (metas '()))     (dolist (clo1 closures)       (dolist (clo2 closures)         (unless (eq clo1 clo2)           (multiple-value-bind (prec rule meta)               (precedent clo1 clo2 ctx)             (if prec                 (let ((compared (assoc prec ordered)))                   ; check this logic: applying new precedents to previous values                   (unless (eq rule (cdr compared))                     (let ((loser (assoc (if (eq prec clo1) clo2 clo1) ordered)))                       (when (eq rule (cdr loser))                         (setf ordered (remove loser ordered))))                     (push (cons prec rule) ordered)))               (when meta                 (if (singlep meta)                     (push (first meta) metas)                   (let ((meta-ordered (order meta ctx)))                     (if meta-ordered                         (push meta-ordered metas)                       (setf metas (nconc metas meta)))))))))))     (cond (ordered            (if (singlep ordered)                (values (caar ordered) T)              ; check this logic              (let ((meta (order (mapcar #'cdr ordered) ctx)))                (dolist (pair ordered)                  (when (eq (cdr pair) meta)                    (return-from order (car pair)))))))           (metas            ; if we have one single meta to play with, set it as a new focus            (if (singlep metas)                (first metas)              (let ((meta-ordered (order metas ctx)))                (when (singlep meta-ordered)                  (first meta-ordered)))))))) ; are we handling the ordering of rules correctly? if there were more than one ; rule that defines the precedent, should we account for them all? ; - also, heuristic ordering should be theoretic in nature, accounting for ones ;   that relate only through binding ; - removed call to order-balance ; return that which precedes, and what precedence (defun precedent (clo1 clo2 &optional (ctx (current-session)))   (let ((bindings1 (all-bindings clo1 ctx))         (bindings2 (all-bindings clo2 ctx))         (prec nil)         (rule nil)         (meta '()))     (flet ((sort (idx idy)              (let ((connx (get-one idx))                    (conny (get-one idy)))                (cond ((and (eq connx conny)                            (eq (curr connx) (hashid *free*)))                       ;; if it's a rule, set the precedent and rule                       (setf prec (prev connx))                       (setf rule connx))                      ; what if there are multiple precedents?                      ((and (eq (subs connx) (subs conny))                            (eq (curr connx) (curr conny))                            (eq (curr connx) (hashid *form*)))                       ;; if we have a commonality of form, we make of them a                       ;; qexpr that is a theory to satisfy...                       (let ((parentsx (get-parents connx))                             (parentsy (get-parents conny)))                         (dolist (x parentsx)                           (dolist (y parentsy)                             (let ((clox (get-one x))                                   (cloy (get-one y)))                               ;; same context, resulting in the same element                               (when (and (eq (func3 clox) idx)                                          (eq (func3 cloy) idy)                                          (eq (target clox)                                              (target cloy)))                                 (let ((one (clone clox)))                                   (setf (hashid one) (get-next-id))                                   (setf (source one)                                         (make-instance 'qnode                                                        :hashid (hashid *q*)                                                        :q (hashid *void*)))                                   (push one meta))))))))))))     (dolist (bind1 bindings1)       (dolist (bind2 bindings2)         (unless (eq bind1 bind2)           (sort bind1 bind2))))     (remove-duplicates meta :test 'equalp)     (dolist (qexpr meta)       (let ((id (get-next-id)))         (setf (hashid (source qexpr)) id)         (setf (source qexpr) id)         (add-one qexpr)))     (values prec rule meta)))) ; does this work for those that are bound to properties? ; - "simple is more important than complex" ; that which has most area in relation to the heuristic and the available nodes ; leading to the choices in focus is better equipped to handle the situation ; - should update with each iteration as Q lists are winnowed ; - for the sat figure, should we perform a uniqueness check between prefs? ;   (a b c) (c d) (d e) => (a b) () (e) (defun order-suspicion (closures pref1 pref2 foc                                  &optional (ctx (current-session)) best)   (if (null closures)       (when best (first best))     (let ((qfoc (gethash (get-q foc) (q-cache ctx)))           (clo (first closures))           (rem (rest closures)))       (when (qexprp clo)         (let* ((q-list (gethash (get-q clo) (q-cache ctx)))                (preflist (mapcar #'(lambda (qone)                                      (let* ((bound (all-bindings qone))                                             ;; pref1 is all properties bound to >                                             (bound1 (intersection pref1 bound))                                             ;; pref2 is all properties bound to <                                             (bound2 (intersection pref2 bound))                                             ;; sat will be all selections bound                                             (sat (intersection qfoc bound)))                                        (if (not (or pref1 pref2))                                            (if (> sat 0)                                                (cons (+ bound sat) '())                                              (list 0))                                          (cons (abs (- bound1 bound2)) sat))))                                  q-list)))           (setf preflist                 (mapcar #'(lambda (pref)                             (let ((gathered (cdr pref)))                               (labels ((sectl (lst)                                          (when lst                                            (let ((iter (first lst)))                                              (when (and (neq pref iter) gathered)                                                (let ((sect (intersection pref iter)))                                                  (setf (cdr iter)                                                        (set-difference (cdr iter) sect))                                                  (setf gathered                                                        (set-difference gathered sect)))))                                            (sectl (rest lst)))))                                 (sectl preflist)                                 (setf (cdr pref) gathered)))                             pref)                         preflist))           (setf preflist (mapcar #'(lambda (pref) (* (car pref)                                                      (list-length (cdr pref))))                                  preflist))           (let ((sum (apply #'+ preflist)))             (when (or (null best) (> sum (cdr best)))               (return-from order-suspicion (order-suspicion rem pref1 pref2 foc ctx                                                             (cons clo sum)))))))       (order-suspicion rem pref1 pref2 foc ctx best)))) ; q1 has 2 choices, 10 pref1, 5 pref2, 10 sat; 5 10 3: 50/-15 ; q2 has 3 choices, 6 pref1, 6 pref2, 9 sat; 1 8 9, 8 1 9: 0/-63/63 ; - what would be a no-win situation?            ; check to see if we can function, and then carry logic if necessary ; - in carry logic, we should first follow functions in order ; - see what following triggers, if anything, to return the most current that this ;   can fully determine (make sense of) ; - firstly, we must follow all the primitives ; - and make sure that we follow everywhere* ; - what of the POS closures? we need to follow those on the main closure... ;   * we need to check active connections and follow these, too ;     (are we using all-matches to get all of them? then all POSs before trying to ;     carry the heavyweight closures...) ; - in future version, we should be able to carry from uninclusive closure matches (defun follow (nod matched outer &optional (ctx (current-session)))   (let ((outer-obj (data outer)))     (loop for inst in (outs outer)           for conn in (outs outer-obj)           do (set-nodes nod inst matched (get-one conn)))     (loop for inst in (forwards outer)           for conn in (forwards outer-obj)           do (set-nodes nod inst matched (get-one conn)))     (if (and (source matched)              (func1 matched)              (target matched)              (func2 matched)              (func3 matched))         (progn           (setf (effect outer) (carry (get-one (effect outer-obj)) ctx))           (complete outer))       outer))) ; when either the outer is completely satisfied or has just the resultant unfilled, ; we will complete the outer, return it ; - if it doesn't, we need to get what the outer is instantiated from (store in data?) ; - form resultant closure by seeing what is satisfied in resultant's constituents, ;   see if it exists, add to satisfied: bind the most specific satisfaction ; in any case, add clo to where in the outer it is bound (defvar *auto-list* (list (hashid *form*)                           (hashid *void*)                           (hashid *free*)                           (hashid *bind*))) (defun set-nodes (nod inst matched conn &optional (ctx (current-session)) save)   (if (eq matched (prev conn))       (save-satisfy (setf (prev inst) (hashid nod)) matched save ctx)     (when (member (prev conn) *auto-list*)       (setf (prev inst) (prev conn))))   (if (eq matched (curr conn))       (save-satisfy (setf (curr inst) (hashid nod)) matched save ctx)     (when (member (curr conn) *auto-list*)       (setf (curr inst) (curr conn))))   (if (eq matched (subs conn))       (save-satisfy (setf (subs inst) (hashid nod)) matched save ctx)     (when (member (subs conn) *auto-list*)       (setf (subs inst) (subs conn))))) (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)))))))        ; a. see if we match what are bound to what is activated ; b. if so, we are activating these ; c. if not, create the binding between these, from what is satisfied ; - can we use what was matched previously to do this? ; - implement Q:q:node as specific instances of nodes (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)))) ; 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)     (if (and (source pot)              (func1 pot)              (target pot)              (func2 pot)              (func3 pot))         (progn           (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-q (qexpr)   (dolist (nod (explode qexpr))     (when (qnodep (get-one nod))       (return-from get-q nod)))) ; returns the Q in the qexpr (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 ((input-session (inputs))         (session (current-session))         (nod (get-one id)))     (multiple-value-bind (matches results)         (trigger nod session) ; not input-session for now...       (dolist (result results)         (let ((one (get-one result)))         (when (qexprp one)           (push one (focus session)))         (setf (gethash result (satisfied session)) one)))       results))   ; 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...   )