# HG changeset patch # User Steve Losh # Date 1476397427 0 # Node ID 183f355ca2600e9c64bca185b67ece172ef58071 # Parent af5f6401a5c7a8c64dd0b977e9c0bb00045d7329 Initial sketch of rule trees diff -r af5f6401a5c7 -r 183f355ca260 package.lisp --- 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 diff -r af5f6401a5c7 -r 183f355ca260 scully.asd --- 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 diff -r af5f6401a5c7 -r 183f355ca260 src/rule-trees.lisp --- /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*)) diff -r af5f6401a5c7 -r 183f355ca260 vendor/make-quickutils.lisp --- 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 diff -r af5f6401a5c7 -r 183f355ca260 vendor/quickutils.lisp --- 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 ;;;;