# HG changeset patch # User Steve Losh # Date 1478448896 0 # Node ID 8070c79ec77c18aec63b8e5a545f60cf31e29f0c # Parent f4a9b3af02a38b4db07d3c82180bcc9085ade6c8 Port to cl-digraph diff -r f4a9b3af02a3 -r 8070c79ec77c scully.asd --- a/scully.asd Sun Nov 06 16:01:00 2016 +0000 +++ b/scully.asd Sun Nov 06 16:14:56 2016 +0000 @@ -9,7 +9,8 @@ :depends-on (:iterate :losh - :cl-graph + :cl-digraph + :cl-digraph.dot :temperance :hunchentoot :smug @@ -32,8 +33,8 @@ (:file "package") (:module "src" :serial t :components ((:file "gdl") - #+no (:file "terms") - #+no (:file "zdd") + (:file "terms") + (:file "zdd") (:module "reasoners" :serial t :components ((:file "prolog"))) (:module "grounders" :serial t diff -r f4a9b3af02a3 -r 8070c79ec77c src/terms.lisp --- a/src/terms.lisp Sun Nov 06 16:01:00 2016 +0000 +++ b/src/terms.lisp Sun Nov 06 16:14:56 2016 +0000 @@ -76,33 +76,22 @@ -(defun find-vertex (graph element) - ; please kill me - (cl-graph:search-for-vertex graph element - :test #'equal - :key #'cl-graph::value ; because fuck you - :error-if-not-found? nil)) - (defun build-layer-graph (rules) - (let ((graph (cl-graph:make-graph 'cl-graph:graph-container - :default-edge-type :directed - :test #'equal))) - (map nil (curry #'cl-graph:add-vertex graph) - (remove-duplicates (mapcar #'first rules) :test #'equal)) + (let ((graph (digraph:make-digraph :test #'equal + :initial-vertices (mapcar #'first rules)))) (iterate (for (head . body) :in rules) - (for vhead = (find-vertex graph head)) (iterate (for term :in body) (when (negationp term) - (let ((vdep (find-vertex graph (bare-term term)))) - (cl-graph:add-edge-between-vertexes graph vhead vdep))))) + (let ((dependency (bare-term term))) + (when (digraph:contains-vertex-p graph dependency) + (digraph:insert-edge graph head dependency)))))) graph)) (defun order-rules (rules) (-<> rules build-layer-graph - cl-graph:topological-sort - (mapcar #'cl-graph::value <>))) ; eat shit + (digraph::map-topological #'identity <>))) @@ -111,22 +100,11 @@ '((t foo) a) '((t bar) a (not (t foo))) '((t baz) a (not (t bar))) + '((t dogs) a x) + '((t cats) a (not (t dogs))) ))) -(cl-graph:vertexes *g*) -(cl-graph:edges *g*) -(*g*) - (order-rules (list - '((t foo) a) - '((t bar) a (not (t foo))) - '((t baz) a (not (t bar))) - )) - - -(defparameter *g* - (cl-graph:make-graph 'cl-graph:graph-container - :default-edge-type :directed)) -(cl-graph:vertexes *g*) -(cl-graph:add-vertex *g* (list 1)) -(cl-graph:add-vertex *g* (list 1)) + '((t foo) a) + '((t bar) a (not (t foo))) + '((t baz) a (not (t bar)))))