--- a/package.lisp Thu Oct 13 22:23:39 2016 +0000
+++ b/package.lisp Thu Oct 13 22:23:47 2016 +0000
@@ -11,6 +11,15 @@
#:load-rules
#:redump-gdl))
+(defpackage #:scully.rule-trees
+ (:use
+ #:cl
+ #:losh
+ #:iterate
+ #:cl-arrows
+ #:scully.quickutils)
+ (:export))
+
(defpackage #:scully.reasoners.prolog
(:use
#:cl
--- a/scully.asd Thu Oct 13 22:23:39 2016 +0000
+++ b/scully.asd Thu Oct 13 22:23:47 2016 +0000
@@ -13,6 +13,8 @@
#:hunchentoot
#:optima
#:smug
+ #:cl-dot
+ #:cl-algebraic-data-type
#:cl-arrows
#:cl-ggp)
@@ -23,6 +25,7 @@
(:file "package")
(:module "src" :serial t
:components ((:file "gdl")
+ (:file "rule-trees")
(:module "reasoners" :serial t
:components ((:file "prolog")))
(:module "grounders" :serial t
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/rule-trees.lisp Thu Oct 13 22:23:47 2016 +0000
@@ -0,0 +1,157 @@
+(in-package #:scully.rule-trees)
+
+
+(adt:defdata rule-tree
+ (node t rule-tree rule-tree list)
+ (leaf list))
+
+
+(defun rule-head (rule)
+ (first rule))
+
+(defun rule-body (rule)
+ (rest rule))
+
+(defun rule-first-body (rule)
+ (first (rule-body rule)))
+
+(defun rule-empty-p (rule)
+ (null (rule-body rule)))
+
+
+(defun negationp (term)
+ (and (consp term) (eql 'not (first term))))
+
+(defun bare-term (term)
+ (if (negationp term)
+ (second term)
+ term))
+
+
+(defun %term< (t1 t2)
+ ;; symbol < number < cons
+ (ensure-boolean
+ (etypecase t1
+ (symbol (etypecase t2
+ (symbol (string< (symbol-name t1) (symbol-name t2)))
+ (number t)
+ (cons t)))
+ (number (etypecase t2
+ (symbol nil)
+ (number (< t1 t2))
+ (cons t)))
+ (cons (etypecase t2
+ (symbol nil)
+ (number nil)
+ (cons (cond
+ ((term< (car t1) (car t2)) t)
+ ((term< (car t2) (car t1)) nil)
+ (t (term< (cdr t1) (cdr t2))))))))))
+(defun term< (t1 t2)
+ ;; symbol < number < cons
+ (%term< (bare-term t1) (bare-term t2)))
+
+
+(defun sort-body (rule)
+ (destructuring-bind (head . body) rule
+ (list* head (sort body #'term<))))
+
+(defun drop-first (rule)
+ (destructuring-bind (head . body) rule
+ (list* head (rest body))))
+
+(defun find-smallest-body-term (rules)
+ (-<> rules
+ (mapcar #'rule-first-body <>)
+ (sort <> #'term<)
+ (first <>)))
+
+(defun partition-rules (rules)
+ (let ((element (bare-term (find-smallest-body-term rules))))
+ (labels
+ ((rule-requires (rule)
+ (equal (rule-first-body rule) element))
+ (rule-disallows (rule)
+ (equal (rule-first-body rule) `(not ,element)))
+ (rule-ignores (rule)
+ (not (or (rule-requires rule)
+ (rule-disallows rule)))))
+ (values element
+ (remove-if-not #'rule-disallows rules)
+ (remove-if-not #'rule-requires rules)
+ (remove-if-not #'rule-ignores rules)))))
+
+
+(defun make-rule-tree (rules)
+ (recursively ((rules (mapcar #'sort-body rules)))
+ (let* ((heads (-<> rules
+ (remove-if-not #'rule-empty-p <>)
+ (mapcar #'rule-head <>)
+ (remove-duplicates <> :test #'equal)))
+ (next-rules (remove-if (lambda (rule)
+ (member (rule-head rule) heads :test #'equal))
+ rules)))
+ (if (null next-rules)
+ (leaf heads)
+ (multiple-value-bind (term low high both)
+ (partition-rules next-rules)
+ (node term
+ (recur (append (mapcar #'drop-first low) both))
+ (recur (append (mapcar #'drop-first high) both))
+ heads))))))
+
+
+;;;; GraphViz
+(setf cl-dot:*dot-path* "/usr/local/bin/dot")
+
+(defmethod attrs (object &rest attributes)
+ (make-instance 'cl-dot:attributed
+ :object object
+ :attributes attributes))
+
+(defmethod cl-dot:graph-object-node ((graph (eql 'rule-tree))
+ (object rule-tree))
+ (make-instance 'cl-dot:node
+ :attributes (adt:match rule-tree object
+ ((leaf heads)
+ `(:label ,(format nil "+~S" heads)
+ :shape :ellipse))
+ ((node term _ _ heads)
+ `(:label ,(format nil "~S~A" term
+ (if heads
+ (format nil "~%+~S" heads)
+ ""))
+ :shape :box)))))
+
+(defmethod cl-dot:graph-object-points-to ((graph (eql 'rule-tree))
+ (object rule-tree))
+ (adt:match rule-tree object
+ ((leaf _) nil)
+ ((node _ low high _)
+ (list (attrs high :style :solid)
+ (attrs low :style :dashed)))))
+
+(defun draw-rule-tree (tree &optional (filename "tree.png"))
+ (cl-dot:dot-graph
+ (cl-dot:generate-graph-from-roots 'rule-tree (list tree))
+ filename
+ :format :png))
+
+
+;;;; Scratch
+(defparameter *rules* '(
+ (x (not b) a)
+ (x a c)
+ (y c)
+ (z b d)
+ (z d (not c))
+ ))
+(defparameter *rules* '(
+ (x (not b) a)
+ (x a c)
+ (y (true dogs))
+ (z d b)
+ (z (not c) d)
+ ))
+
+(draw-rule-tree (make-rule-tree *rules*))
--- a/vendor/make-quickutils.lisp Thu Oct 13 22:23:39 2016 +0000
+++ b/vendor/make-quickutils.lisp Thu Oct 13 22:23:47 2016 +0000
@@ -4,7 +4,9 @@
"quickutils.lisp"
:utilities '(
+ :compose
:curry
+ :ensure-boolean
:ensure-gethash
:ensure-list
:map-product
--- a/vendor/quickutils.lisp Thu Oct 13 22:23:39 2016 +0000
+++ b/vendor/quickutils.lisp Thu Oct 13 22:23:47 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-GETHASH :ENSURE-LIST :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :WITH-GENSYMS :WITH-OUTPUT-TO-FILE) :ensure-package T :package "SCULLY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :WITH-GENSYMS :WITH-OUTPUT-TO-FILE) :ensure-package T :package "SCULLY.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SCULLY.QUICKUTILS")
@@ -14,11 +14,12 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :CURRY :ENSURE-GETHASH :ENSURE-LIST
- :MAPPEND :MAP-PRODUCT :MKSTR
- :ONCE-ONLY :RCURRY :SET-EQUAL
- :STRING-DESIGNATOR :WITH-GENSYMS
- :WITH-OPEN-FILE* :WITH-OUTPUT-TO-FILE))))
+ :COMPOSE :CURRY :ENSURE-BOOLEAN
+ :ENSURE-GETHASH :ENSURE-LIST :MAPPEND
+ :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY
+ :SET-EQUAL :STRING-DESIGNATOR
+ :WITH-GENSYMS :WITH-OPEN-FILE*
+ :WITH-OUTPUT-TO-FILE))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
"Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -43,6 +44,35 @@
(fdefinition function-designator)))
) ; eval-when
+ (defun compose (function &rest more-functions)
+ "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+ (define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+
(defun curry (function &rest arguments)
"Returns a function that applies `arguments` and the arguments
it is called with to `function`."
@@ -63,6 +93,11 @@
(apply ,fun ,@curries more)))))
+ (defun ensure-boolean (x)
+ "Convert `x` into a Boolean value."
+ (and x t))
+
+
(defmacro ensure-gethash (key hash-table &optional default)
"Like `gethash`, but if `key` is not found in the `hash-table` saves the `default`
under key before returning it. Secondary return value is true if key was
@@ -258,7 +293,8 @@
,@body))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(curry ensure-gethash ensure-list map-product mkstr once-only rcurry
- set-equal with-gensyms with-unique-names with-output-to-file)))
+ (export '(compose curry ensure-boolean ensure-gethash ensure-list map-product
+ mkstr once-only rcurry set-equal with-gensyms with-unique-names
+ with-output-to-file)))
;;;; END OF quickutils.lisp ;;;;