Merge branch 'mob' of git://repo.or.cz/arxana into mob

[arxana.git] / elisp / search-expanded.el

;; search-expanded.el - network search routines

;; Copyright (C) 2013 Raymond S. Puzio

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Affero General Public License for more details.

;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; COMMENTARY:

;; a query language

;; We will implement the search as a pipeline which gradually
;; transforms the query into a series of expressions which produce
;; the sought-after result, then evaluate those expressions.  To
;; illustrate and explain this process, we will use the following
;; query as an example:
;;
;; This tells you the predicates that apply to the nodes
;; and the network relationships that apply to them.  The network relationships
;; function as wildcards.
;;
;; Basic model at the moment triplets that point to other triplets.
;;
;; (((a blue big) 
;;   (b funny)
;;   (c green small)
;;  ((b src a)
;;   (b snk c)
;;   (c src a))
;;
;; This asks us to find a funny link from a big blue object to a
;; small green link to the big blue object.
;;
;; The first step of processing is to put the quaerenda in some
;; order so that each item links up with at least one previous item:
;;
;; (scheduler
;;  '((b funny)
;;    (c green small))
;;  '((b src a)
;;    (b snk c)
;;    (c src a))
;;  '((a blue big)))
;;
;; =>
;;
;; ((c (green small) ((b snk c) (c src a)))
;;  (b (funny) ((b src a)))
;;  (a blue big))
;;
;; (Note that the order is reversed due to technicalities of
;; implementing "scheduler" --- that is to say, a is first and does
;; not link to any other variable, b is next and links to only a,
;; whilst c is last and links to both a and b.)
;;
;; At the same time, we have also rearranged things so that the
;; links to previous items to which a given object are listed
;; alongside that object.
;;
;; The next step is to replace the links with the commands which
;; generate a list of such objects:
;;
;; ((c (green small) ((b snk c) (c src a)))
;;  (b (funny) ((b src a)))
;;  (a blue big))
;;
;; =>
;;
;; ((c (green small) 
;;     (intersection (list (get-snk b)) (get-forward-links a))) 
;;  (b (funny) 
;;     (intersection (get-backward-links a))) 
;;  (a blue big))
;;
;; This is done using the function tplts2cmd, e.g.
;;
;; (tplts2cmd 'c  '((b snk c) (c src a)))
;;
;; => (intersection (list (get-snk b)) (get-forward-links a))
;;
;; Subsequently, we filter over the predicates:
;;
;; ((c (filter '(lambda (c) (and (green c) (small c))) 
;;     (intersection (list (get-snk b)) 
;;   (get-forward-links))))
;;  (b (filter '(lambda (b) (and (funny b)))
;;     (intersection (get-backward-links a)))))
;;
;; This is done with the command add-filt:
;;
;; (add-filt 'c 
;;   '(green small) 
;;   '((b snk c) (c src a)))
;;
;; (c (filter (quote (lambda (c) (and (green c) (small c))))
;;    (intersection (list (get-snk b))
;;  (get-forward-links a))))
;;
;;
;; This routine calls up the previously described routine tplts2cmd
;; to take care of the third argument.
;;
;; The last entry,
;;
;; (a blue big)
;;
;; gets processed a little differently because we don't as yet have
;; anything to filter over; instead, we generate the initial list by
;; looping over the current network:
;;
;; (a (let ((ans nil))
;;      (donet 'node 
;;     (when (and (blue (get-content node)) 
;;        (big (get-content node))) 
;;       (setq ans (cons node ans))))
;;      ans))
;;
;; This is done by invoking first2cmd:
;;
;; (first2cmd '(blue big))
;;
;; => 
;;
;; (let ((ans nil))
;;   (donet (quote node)
;;  (when (and (blue (get-content node))
;;     (big (get-content node)))
;;  (setq ans (cons node ans))))
;;  ans)
;;
;; (query2cmd
;;  '((c (green small) ((b snk c) (c src a)))
;;    (b (funny) ((b src a)))
;;    (a blue big)))
;;
;; =>
;;
;; ((c (filter (quote (lambda (c) (and (green c) (small c)))) 
;;     (intersection (list (get-snk b)) 
;;   (get-forward-links a))))
;;  (b (filter (quote (lambda (b) (and (funny b))))
;;     (intersection (get-forward-links a))))
;;  (a (let ((ans nil))
;;       (donet (quote node) 
;;      (when (and (blue (get-content node)) 
;; (big (get-content node))) 
;;        (setq ans (cons node ans)))) 
;;       ans)))
;;
;; To carry out these instructions in the correct order and generate
;; a set of variable assignments, we employ the matcher function.
;; Combining this last layer, we have the complete pipeline:
;;
;; (matcher nil
;;  (query2cmd
;;   (scheduler
;;    '((b funny)
;;      (c green small))
;;    '((b src a)
;;      (b snk c)
;;      (c src a))
;;    '((a blue big)))))
;;
;; This combination of operations is combined into the search
;; function.
;;
;; (search
;;  '(((a blue big) 
;;     (b funny)
;;     (c green small))
;;    ((b src a)
;;     (b snk c)
;;     (c src a))))

;; Having described what the functions are supposed to do and how
;; they work together, we now proceed to implement them.

;; The scheduler function takes a list search query and rearranges it
;; into an order suitable for computing the answer to that query.
;; Specifically, a search query is a pair of lists --- the first list
;; consists of lists whose heads are names of variables and whose
;; tails are predicates which the values of the variables should
;; satisfy and the second list consists of triples indicating the
;; relations between the values of the variables.

;; new-nodes is a list of items of the form (node &rest property)
;; links is a list of triplets
;; sched is a list whose items consist of triplets of the 
;;      form (node (&rest property) (&rest link)) 

;;; CODE:

;; We start with some preliminary definitions and generalities.

(require 'cl)

;; Returns the subset of stuff which satisfies the predicate pred.

(defun filter (pred stuff)
  (let ((ans nil))
    (dolist (item stuff (reverse ans))
      (if (funcall pred item)
            (setq ans (cons item ans))
        nil))))

;; Set-theoretic intersection operation.
;; More general than the version coming from the `cl' package
(defun intersection (&rest arg)
  (cond ((null arg) nil)
        ((null (cdr arg)) (car arg))
        (t (let ((ans nil))
                  (dolist (elmt (car arg) ans)
                           (let ((remainder (cdr arg)))
                                  (while (and remainder 
                                               (member elmt (car remainder)))
                                           (setq remainder (cdr remainder))
                                                  (when (null remainder) 
                                                     (setq ans (cons elmt ans))))))))))


(defun scheduler (new-nodes links sched)
  ;; If done, return answer.
  (if (null new-nodes)
      sched
    (let (
            ;; New nodes yet to be examined.
            (remaining-nodes new-nodes)
              ;; Element of remaining-nodes currently 
              ;; under consideration.
              (candidate nil)
                ;; List of links between candidate and old-nodes.
                (ties nil)
                  ;; List of nodes already scheduled.
                  (old-nodes (mapcar 'car sched)))
      ;; Loop through new nodes until find one linked
      ;; to an old node.
      (while (null ties)
        ;; Look at the next possible node.
        (setq candidate (car remaining-nodes))
        (setq remaining-nodes (cdr remaining-nodes))
        ;; Find the old nodes linking to the candidate
        ;; node and record the answer in "ties".
        (setq ties
                    ;; Pick out the triplets 
                    (filter '(lambda (x)
                                (or 
                                   ;; whose first element is the node
                                   ;; under consideration and whose third
                                   ;; element is already on the list
                                   (and (eq (first x) (car candidate))
                                               (member (third x) old-nodes))
                                     ;; or vice-versa.
                                     (and (member (first x) old-nodes)
                                            (eq (third x) (car candidate)))))
                                  links)))
      ;; Recursively add the rest of the nodes.
      (scheduler (remove candidate new-nodes)
                    links
                       (cons (list (car candidate) 
                                          (cdr candidate)
                                                 ties) 
                              sched)))))

(defun tplts2cmd (var tplts)
  (cons 'intersection
        (mapcar
          '(lambda (tplt)
                 (cond ((and (eq (third tplt) var)
                             (eq (second tplt) 'src))
                           `(get-flk ,(first tplt)))
                         ((and (eq (third tplt) var)
                               (eq (second tplt) 'snk))
                             `(get-blk ,(first tplt)))
                           ((and (eq (first tplt) var)
                                 (eq (second tplt) 'src))
                               `(list (get-src ,(third tplt))))
                             ((and (eq (first tplt) var)
                                   (eq (second tplt) 'snk))
                                 `(list (get-snk ,(third tplt))))
                               (t nil)))
           tplts)))

(defun add-filt (var preds tplts)
  `(,var 
    (filter
     '(lambda (,var)
        ,(cons 'and
                      (mapcar
                       '(lambda (pred)
                             (list pred 
                                    (list 'get-txt var)))
                       preds)))
     ,(tplts2cmd var tplts))))

(defun first2cmd (preds)
  `(let ((ans nil))
     (dolist (node (get-ids) ans)
       (when
              ,(cons 'and
                       (mapcar
                           '(lambda (pred)
                                    (cons pred '((get-txt node))))
                              preds))
          (setq ans (cons node ans))))))

(defun query2cmd (query)
  (let ((backwards (reverse query)))
    (reverse
     (cons 
      (list (caar backwards) 
                (first2cmd (cdar backwards)))
      (mapcar
       '(lambda (x)
            (add-filt (first x) (second x) (third x)))
       (cdr backwards))))))

(defun matcher (assgmt reqmts)
  (if (null reqmts) (list assgmt)
    (apply 'append
              (mapcar '(lambda (x)
                               (matcher (cons (list (caar reqmts) x) assgmt)
                                               (cdr reqmts)))
                         (apply 'intersection 
                                  (eval `(let ,assgmt
                                              (mapcar 'eval 
                                                         (cdar reqmts)))))))))

(defun search (query)
  (matcher nil
              (reverse
                   (query2cmd
                         (scheduler
                                (cdar query)
                                      (cadr query)
                                            (list (caar query)))))))

;; Here are some examples unrelated to what comes up in serching
;; triplets which illustrate how matcher works:
;;
;; (matcher '((x 1))
;;  '((y (list 1 3))
;;    (z (list (+ x y) (- y x)))))
;;
;; (((z 2) (y 1) (x 1))
;;  ((z 0) (y 1) (x 1))
;;  ((z 4) (y 3) (x 1))
;;  ((z 2) (y 3) (x 1)))
;;
;;
;; (matcher nil
;;  '((x (list 1))
;;    (y (list 1 3))
;;    (z (list (+ x y) (- y x)))))
;;
;; =>
;;
;; (((z 2) (y 1) (x 1))
;;  ((z 0) (y 1) (x 1))
;;  ((z 4) (y 3) (x 1))
;;  ((z 2) (y 3) (x 1)))