src/rule-trees.lisp @ d930dc9c101a

(in-package :scully.rule-trees)
(in-readtable :fare-quasiquote)

;;;; Rule Trees ---------------------------------------------------------------
(adt:defdata rule-tree
  (node t rule-tree rule-tree)
  (top t)
  bottom)

(defun rule-tree-hi (tree)
  (adt:match rule-tree tree
    ((node _ hi _) hi)
    (_ (error "No hi for rule tree ~S" tree))))

(defun rule-tree-lo (tree)
  (adt:match rule-tree tree
    ((node _ _ lo) lo)
    (_ (error "No lo for rule tree ~S" tree))))


(defun find-smallest-body-term (bodies)
  "Find the smallest body term in `bodies`.

  Each body in `bodies` must already be sorted.  No body should be empty.

  "
  (first (extremum bodies #'term< :key #'first)))

(defun partition (bodies)
  "Partition `bodies` into exclusive groups based on the smallest element.

  `bodies` must each be already sorted.

  Four values will be returned:

  1. The smallest element in any body.
  2. All bodies that DISALLOW that element.
  3. All bodies that REQUIRE that element.
  4. All bodies that DON'T CARE about that element.

  "
  (let* ((element (bare-term (find-smallest-body-term bodies)))
         (negation `(ggp-rules::not ,element)))
    (labels
        ((disallows (body)
           (equal (first body) negation))
         (requires (body)
           (equal (first body) element))
         (ignores (body)
           (not (or (requires body)
                    (disallows body)))))
      (values element
              (remove-if-not #'disallows bodies)
              (remove-if-not #'requires bodies)
              (remove-if-not #'ignores bodies)))))


(defun make-node (cache term hi lo)
  (if (eql hi lo)
    hi
    (ensure-gethash (list term hi lo) cache
                    (node term hi lo))))

(defun sort-body (body)
  (sort body #'term<))

(defun make-rule-tree (rules)
  "Make a rule tree for `rules`.

  All rules must have the same head (this is not checked).  Bodies do not need
  to be sorted.

  "
  (let* ((head (rule-head (first rules)))
         (top (top head))
         (cache (make-hash-table :test #'equal)))
    (recursively ((bodies (mapcar (compose #'sort-body #'rule-body) rules)))
      (cond
        ((null bodies) bottom)
        ((some #'null bodies) top)
        (t (multiple-value-bind (term disallows requires ignores)
               (partition bodies)
             (make-node cache
                        term
                        (recur (append (mapcar #'rest requires) ignores))
                        (recur (append (mapcar #'rest disallows) ignores)))))))))


;;;; Scratch ------------------------------------------------------------------
(defparameter *rule* '(
                       (500 1 2 (ggp-rules::not 3))
                       (500 4 2 3 15)
                       (500 (ggp-rules::not 19) 18)
                       (500 19 17)
                       ))

; (-<> *rule*
;   make-rule-tree
;   (rule-tree-hi <>)
;   (rule-tree-hi <>)
;   ; (advance-tree <> 6)
;   scully.graphviz::draw-rule-tree
;   ; scully.graphviz::draw-rule-tree
;   )