--- a/package.lisp Mon Nov 21 15:33:17 2016 +0000
+++ b/package.lisp Mon Nov 21 16:52:13 2016 +0000
@@ -66,6 +66,14 @@
:scully.quickutils)
(:export))
+(defpackage :scully.logic
+ (:use
+ :cl
+ :losh
+ :iterate
+ :cl-arrows
+ :scully.quickutils))
+
(defpackage :scully.reasoners.prolog
(:use
:cl
--- a/scully.asd Mon Nov 21 15:33:17 2016 +0000
+++ b/scully.asd Mon Nov 21 16:52:13 2016 +0000
@@ -37,6 +37,7 @@
(:file "rule-trees")
(:file "zdd")
(:file "graphviz")
+ (:file "logic")
(:module "reasoners" :serial t
:components ((:file "prolog")))
(:module "grounders" :serial t
--- a/src/graphviz.lisp Mon Nov 21 15:33:17 2016 +0000
+++ b/src/graphviz.lisp Mon Nov 21 16:52:13 2016 +0000
@@ -10,20 +10,22 @@
;;;; Rule Trees ---------------------------------------------------------------
+(defparameter *rt-label-fn* #'identity)
+
(defmethod cl-dot:graph-object-node ((graph (eql 'rule-tree))
(object scully.rule-trees::rule-tree))
(make-instance 'cl-dot:node
:attributes (adt:match scully.rule-trees::rule-tree object
((scully.rule-trees::node term _ _)
- `(:label ,(aesthetic-string term)
- :shape :circle))
+ `(:label ,(aesthetic-string (funcall *rt-label-fn* term))
+ :shape :ellipse))
(scully.rule-trees::bottom
`(:label "⊥"
:shape :square))
((scully.rule-trees::top term)
- `(:label ,(aesthetic-string term)
+ `(:label ,(aesthetic-string (funcall *rt-label-fn* term))
:shape :rectangle)))))
(defmethod cl-dot:graph-object-points-to ((graph (eql 'rule-tree))
@@ -35,11 +37,14 @@
(scully.rule-trees::bottom nil)))
-(defun draw-rule-tree (rule-tree &key (filename "rule-tree.png"))
- (cl-dot:dot-graph
- (cl-dot:generate-graph-from-roots 'rule-tree (list rule-tree))
- filename
- :format :png)
+(defun draw-rule-tree (rule-tree &key
+ (filename "rule-tree.png")
+ (label-fn #'identity))
+ (let ((*rt-label-fn* label-fn))
+ (cl-dot:dot-graph
+ (cl-dot:generate-graph-from-roots 'rule-tree (list rule-tree))
+ filename
+ :format :png))
rule-tree)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/logic.lisp Mon Nov 21 16:52:13 2016 +0000
@@ -0,0 +1,42 @@
+(in-package :scully.logic)
+
+
+(defparameter *rules*
+ (scully.gdl::read-gdl "gdl/tictactoe-grounded.gdl"))
+
+
+(defun make-stratum-rule-trees (stratum)
+ (-<> stratum
+ (group-by #'car <>)
+ hash-table-values
+ (mapcar #'scully.rule-trees::make-rule-tree <>)))
+
+
+; (setf *print-length* 10000)
+(destructuring-bind (term->number number->term rule-layers)
+ (scully.terms::integerize-rules *rules*)
+ ; (let ((*print-length* 1000))
+ ; (print-hash-table number->term))
+ ; (print-hash-table rule-layers)
+ (flet ((draw (rt)
+ (scully.graphviz::draw-rule-tree
+ rt :label-fn (lambda (n)
+ (gethash n number->term)))
+ (break)))
+ (-<> rule-layers
+ (gethash :possible <>)
+ scully.terms::stratify-layer
+ (nth 0 <>)
+ (make-stratum-rule-trees <>)
+ (map nil #'draw <>)
+ ; (map nil #'pr <>)
+ ; (mapcar (curry #'group-by #'car) <>)
+ ; (map nil #'print-hash-table <>)
+ ; (hash-table-values <>)
+ ; (map nil (lambda (rule)
+ ; (-<> rule
+ ; (scully.rule-trees::make-rule-tree <>)
+ ; )
+ ; (break))
+ ; <>)
+ )))
--- a/src/rule-trees.lisp Mon Nov 21 15:33:17 2016 +0000
+++ b/src/rule-trees.lisp Mon Nov 21 16:52:13 2016 +0000
@@ -76,4 +76,4 @@
(500 19 17)
))
-(-<> *rule* make-rule-tree scully.graphviz::draw-rule-tree)
+; (-<> *rule* make-rule-tree scully.graphviz::draw-rule-tree)
--- a/src/terms.lisp Mon Nov 21 15:33:17 2016 +0000
+++ b/src/terms.lisp Mon Nov 21 16:52:13 2016 +0000
@@ -56,17 +56,16 @@
;;;; Dependency Graph ---------------------------------------------------------
-(defun build-dependency-graph (rules &key negations-only)
+(defun build-dependency-graph (rules &key includep)
(let ((graph (digraph:make-digraph :test #'equal)))
(labels
((mark-dependency (head dep)
- (digraph:insert-vertex graph head)
(digraph:insert-vertex graph dep)
(digraph:insert-edge graph head dep))
(mark-dependencies (head body)
(iterate (for b :in body)
- (when (or (negationp b)
- (not negations-only))
+ (when (or (null includep)
+ (funcall includep b))
(mark-dependency head (bare-term b))))))
(iterate (for rule :in rules)
(for (head . body) = (ensure-list rule))
@@ -170,7 +169,8 @@
(defun order-predicates (rules)
(let* ((dependencies (build-dependency-graph rules))
- (negation-dependencies (build-dependency-graph rules :negations-only t))
+ (negation-dependencies (build-dependency-graph rules
+ :includep #'negationp))
(layers (partition-rules dependencies rules)))
(let ((base (gethash :base layers))
(does (gethash :does layers))
@@ -193,9 +193,18 @@
;;;; Stratification -----------------------------------------------------------
+(defun build-single-layer-dependency-graph (rules)
+ (let* ((layer-heads (remove-duplicates (mapcar #'first rules))))
+ (build-dependency-graph
+ rules
+ :includep (lambda (b)
+ (and (negationp b)
+ (member (bare-term b) layer-heads))))))
+
(defun stratify-layer (rules)
(iterate
- (with dependencies = (build-dependency-graph rules :negations-only t))
+ (with dependencies = (build-single-layer-dependency-graph rules))
+ ; (initially (digraph.dot:draw dependencies))
(with remaining = rules)
(until (null remaining))
--- a/src/zdd.lisp Mon Nov 21 15:33:17 2016 +0000
+++ b/src/zdd.lisp Mon Nov 21 16:52:13 2016 +0000
@@ -392,6 +392,3 @@
; ; (aesthetic-string (gethash n number->term))))
; ; (print-through #'zdd-size <>)
; (never <>))))
-
-; (start-profiling '(scully.zdd))
-; (stop-profiling)
--- a/vendor/make-quickutils.lisp Mon Nov 21 15:33:17 2016 +0000
+++ b/vendor/make-quickutils.lisp Mon Nov 21 16:52:13 2016 +0000
@@ -12,6 +12,7 @@
:ensure-list
:flatten-once
:hash-table-keys
+ :hash-table-values
:map-product
:mkstr
:once-only
--- a/vendor/quickutils.lisp Mon Nov 21 15:33:17 2016 +0000
+++ b/vendor/quickutils.lisp Mon Nov 21 16:52:13 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :FLATTEN-ONCE :HASH-TABLE-KEYS :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 :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :FLATTEN-ONCE :HASH-TABLE-KEYS :HASH-TABLE-VALUES :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")
@@ -18,6 +18,7 @@
:ENSURE-BOOLEAN :ENSURE-GETHASH
:ENSURE-LIST :FLATTEN-ONCE
:MAPHASH-KEYS :HASH-TABLE-KEYS
+ :MAPHASH-VALUES :HASH-TABLE-VALUES
:MAPPEND :MAP-PRODUCT :MKSTR
:ONCE-ONLY :RCURRY :SET-EQUAL
:STRING-DESIGNATOR :WITH-GENSYMS
@@ -167,6 +168,24 @@
keys))
+ (declaim (inline maphash-values))
+ (defun maphash-values (function table)
+ "Like `maphash`, but calls `function` with each value in the hash table `table`."
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (funcall function v))
+ table))
+
+
+ (defun hash-table-values (table)
+ "Returns a list containing the values of hash table `table`."
+ (let ((values nil))
+ (maphash-values (lambda (v)
+ (push v values))
+ table)
+ values))
+
+
(defun mappend (function &rest lists)
"Applies `function` to respective element(s) of each `list`, appending all the
all the result list to a single list. `function` must return a list."
@@ -346,8 +365,8 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(compose copy-hash-table curry ensure-boolean ensure-gethash
- ensure-list flatten-once hash-table-keys map-product mkstr
- once-only rcurry set-equal with-gensyms with-unique-names
- with-output-to-file)))
+ ensure-list flatten-once hash-table-keys hash-table-values
+ map-product mkstr once-only rcurry set-equal with-gensyms
+ with-unique-names with-output-to-file)))
;;;; END OF quickutils.lisp ;;;;