--- a/cl-digraph.asd Sun Nov 06 14:59:26 2016 +0000
+++ b/cl-digraph.asd Sun Nov 06 15:57:26 2016 +0000
@@ -1,5 +1,4 @@
(asdf:defsystem :cl-digraph
- :name "digraph"
:description "Simple directed graphs for Common Lisp."
:author "Steve Losh <steve@stevelosh.com>"
@@ -9,7 +8,7 @@
:depends-on ()
- :in-order-to ((asdf:test-op (asdf:test-op :digraph-test)))
+ :in-order-to ((asdf:test-op (asdf:test-op :cl-digraph.test)))
:serial t
:components ((:module "vendor" :serial t
@@ -18,20 +17,3 @@
(:file "package")
(:module "src" :serial t
:components ((:file "directed-graph")))))
-
-
-
-(asdf:defsystem #:digraph-test
- :name "digraph-test"
-
- :depends-on (#:1am)
-
- :serial t
- :components ((:file "package-test")
- (:module "test"
- :serial t
- :components ((:file "tests"))))
-
- :perform (asdf:test-op
- (op system)
- (uiop:symbol-call :digraph-test :run-tests)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cl-digraph.dot.asd Sun Nov 06 15:57:26 2016 +0000
@@ -0,0 +1,13 @@
+(asdf:defsystem :cl-digraph.dot
+ :description "cl-dot support for cl-digraph"
+
+ :author "Steve Losh <steve@stevelosh.com>"
+ :license "MIT/X11"
+
+ :depends-on (:cl-digraph
+ :cl-dot)
+
+ :serial t
+ :components ((:file "package.dot")
+ (:module "src" :serial t
+ :components ((:file "dot")))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cl-digraph.test.asd Sun Nov 06 15:57:26 2016 +0000
@@ -0,0 +1,18 @@
+(asdf:defsystem :cl-digraph.test
+ :description "Test suite for cl-digraph"
+
+ :author "Steve Losh <steve@stevelosh.com>"
+ :license "MIT/X11"
+
+ :depends-on (:cl-digraph
+ :1am)
+
+ :serial t
+ :components ((:file "package.test")
+ (:module "test"
+ :serial t
+ :components ((:file "tests"))))
+
+ :perform (asdf:test-op
+ (op system)
+ (uiop:symbol-call :digraph.test :run-tests)))
--- a/package-test.lisp Sun Nov 06 14:59:26 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,8 +0,0 @@
-(defpackage :digraph-test
- (:use
- :cl
- :1am
- :digraph
- :digraph.quickutils)
- (:export
- :run-tests))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/package.dot.lisp Sun Nov 06 15:57:26 2016 +0000
@@ -0,0 +1,3 @@
+(defpackage :digraph.dot
+ (:use :cl :digraph :digraph.quickutils)
+ (:export :draw))
--- a/package.lisp Sun Nov 06 14:59:26 2016 +0000
+++ b/package.lisp Sun Nov 06 15:57:26 2016 +0000
@@ -32,6 +32,9 @@
:map-vertices
:map-edges
- :copy-digraph
- ))
+ :map-depth-first
+ :map-breadth-first
+ :mapc-depth-first
+ :mapc-breadth-first
+ :copy-digraph))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/package.test.lisp Sun Nov 06 15:57:26 2016 +0000
@@ -0,0 +1,8 @@
+(defpackage :digraph.test
+ (:use
+ :cl
+ :1am
+ :digraph
+ :digraph.quickutils)
+ (:export
+ :run-tests))
--- a/src/directed-graph.lisp Sun Nov 06 14:59:26 2016 +0000
+++ b/src/directed-graph.lisp Sun Nov 06 15:57:26 2016 +0000
@@ -3,7 +3,7 @@
;;;; Utils --------------------------------------------------------------------
-(defun make-hash-table-portably (&key size test hash-function)
+(defun make-hash-table-portably (&key (size 0) test hash-function)
;; Only try to pass :hash-function if we were given it, so we don't explode in
;; implementations that don't support it.
;;
@@ -55,10 +55,10 @@
(defun predecessors (digraph object)
- (pred digraph object))
+ (copy-list (pred digraph object)))
(defun successors (digraph object)
- (succ digraph object))
+ (copy-list (succ digraph object)))
(defun neighbors (digraph object)
(union (predecessors digraph object)
@@ -89,6 +89,11 @@
(pushnew successor (succ digraph predecessor) :test (digraph-test digraph))
(values))
+(defun insert-chain (digraph predecessor successor &rest later-successors)
+ (insert-edge digraph predecessor successor)
+ (when later-successors
+ (apply #'insert-chain digraph successor later-successors)))
+
(defun remove-edge (digraph predecessor successor)
(removef (succ digraph predecessor) successor :test (digraph-test digraph))
@@ -96,8 +101,8 @@
(values))
(defun remove-vertex (digraph object)
- (let ((ps (predecessors digraph object))
- (ss (successors digraph object))
+ (let ((ps (pred digraph object))
+ (ss (succ digraph object))
(test (digraph-test digraph)))
(loop :for p :in ps :do (removef (succ digraph p) object :test test))
(loop :for s :in ss :do (removef (pred digraph s) object :test test)))
@@ -109,10 +114,10 @@
(length (neighbors digraph object)))
(defun degree-in (digraph object)
- (length (predecessors digraph object)))
+ (length (pred digraph object)))
(defun degree-out (digraph object)
- (length (successors digraph object)))
+ (length (succ digraph object)))
(defun size (digraph)
@@ -169,16 +174,116 @@
copy))
-;;;; Scratch ------------------------------------------------------------------
-(defparameter *d* (make-digraph))
+;;;; Traversal ----------------------------------------------------------------
+;;; Adapted from http://algorithms.wtf/
+
+(defun mapc-depth-first (function digraph start-vertex)
+ (let ((seen nil))
+ (labels ((recur (vertex)
+ (when (not (member vertex seen :test (digraph-test digraph)))
+ (push vertex seen)
+ (funcall function vertex)
+ (mapcar #'recur (succ digraph vertex)))))
+ (when (contains-vertex-p digraph start-vertex)
+ (recur start-vertex))))
+ nil)
+
+(defun mapc-breadth-first (function digraph start-vertex)
+ (let ((seen nil)
+ (remaining nil))
+ (labels ((recur (vertex)
+ (when (not (member vertex seen :test (digraph-test digraph)))
+ (push vertex seen)
+ (funcall function vertex)
+ ;;; todo maybe use jpl queues here...
+ (appendf remaining (succ digraph vertex)))
+ (when remaining
+ (recur (pop remaining)))))
+ (when (contains-vertex-p digraph start-vertex)
+ (recur start-vertex))))
+ nil)
+
+
+(defun map-depth-first (function digraph start-vertex)
+ (let ((result nil))
+ (mapc-depth-first (lambda (v) (push (funcall function v) result))
+ digraph start-vertex)
+ (nreverse result)))
+
+(defun map-breadth-first (function digraph start-vertex)
+ (let ((result nil))
+ (mapc-breadth-first (lambda (v) (push (funcall function v) result))
+ digraph start-vertex)
+ (nreverse result)))
+
+
+(defun roots (digraph)
+ (remove-if-not (lambda (v) (null (pred digraph v)))
+ (vertices digraph)))
+
+(defun leafs (digraph)
+ (remove-if-not (lambda (v) (null (succ digraph v)))
+ (vertices digraph)))
-(insert-vertex *d* 'a)
-(insert-vertex *d* 'b)
-(insert-vertex *d* 'c)
+(defun mapc-topological (function digraph)
+ (let ((status (make-hash-table-portably
+ :test (digraph-test digraph)
+ :hash-function (digraph-hash-function digraph))))
+ (labels
+ ((visit (vertex)
+ (ecase (gethash vertex status :new)
+ (:active
+ (error "Cycle detected during topological map involving vertex ~S"
+ vertex))
+ (:new (recur vertex))
+ (:done nil)))
+ (recur (vertex)
+ (setf (gethash vertex status) :active)
+ (mapc #'visit (succ digraph vertex))
+ (setf (gethash vertex status) :done)
+ (funcall function vertex)))
+ (mapc #'visit (roots digraph))))
+ nil)
+
+(defun map-topological (function digraph)
+ (let ((result nil))
+ (mapc-topological (lambda (v) (push (funcall function v) result)) digraph)
+ (nreverse result)))
+
-(insert-edge *d* 'b 'c)
+;;;; Scratch ------------------------------------------------------------------
+(defun make-test-digraph ()
+ ;; a ----> middle ----> z ORPHAN
+ ;; ^ ^ ^
+ ;; | | |
+ ;; B ---------+ |
+ ;; | | +-------------------+
+ ;; v | | v
+ ;; c --------> dogs FOO ----> bar ----> baz
+ ;; ^ |
+ ;; | |
+ ;; +------------------------+
+ (let ((g (make-digraph
+ :initial-vertices
+ '(a b c dogs middle z orphan foo bar baz))))
+ (insert-edge g 'a 'middle)
+ (insert-edge g 'b 'middle)
+ (insert-edge g 'b 'a)
+ (insert-edge g 'middle 'z)
+ ; (insert-edge g 'z 'z)
+ (insert-edge g 'b 'c)
+ (insert-edge g 'c 'dogs)
+ (insert-edge g 'dogs 'middle)
+ ; (insert-edge g 'dogs 'c)
+ (insert-edge g 'foo 'baz)
+ (insert-edge g 'foo 'bar)
+ (insert-edge g 'bar 'baz)
+ g))
-(remove-edge *d* 'a 'a)
-(remove-vertex *d* 'a)
-; (dump *d*)
+
+#+scratch
+(progn
+ (defparameter *d* (make-test-digraph))
+ (setf cl-dot:*dot-path* "/usr/local/bin/dot")
+ (digraph.dot:draw *d*))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/dot.lisp Sun Nov 06 15:57:26 2016 +0000
@@ -0,0 +1,39 @@
+(in-package :digraph.dot)
+
+
+(defun find-dot-roots (digraph)
+ (let ((nodes (vertices digraph))
+ (roots nil)
+ (test (digraph::digraph-test digraph)))
+ (labels ((descendents (vertex)
+ (map-depth-first #'identity digraph vertex))
+ (prune (vertex)
+ (setf nodes (set-difference nodes (descendents vertex)
+ :test test)))
+ (mark-root-and-prune (vertex)
+ (push vertex roots)
+ (prune vertex)))
+ (mapc #'mark-root-and-prune (digraph::roots digraph))
+ (loop :while nodes :do (mark-root-and-prune (pop nodes))))
+ roots))
+
+
+(defparameter *current-digraph* nil)
+
+
+(defmethod cl-dot:graph-object-node ((graph (eql 'digraph)) (vertex t))
+ (make-instance 'cl-dot:node
+ :attributes `(:label ,vertex :shape :circle)))
+
+(defmethod cl-dot:graph-object-points-to ((graph (eql 'digraph)) (vertex t))
+ (successors *current-digraph* vertex))
+
+
+(defun draw (digraph &key (filename "digraph.png"))
+ (let ((*current-digraph* digraph))
+ (cl-dot:dot-graph
+ (cl-dot:generate-graph-from-roots 'digraph (find-dot-roots digraph))
+ filename
+ :format :png))
+ digraph)
+
--- a/test/tests.lisp Sun Nov 06 14:59:26 2016 +0000
+++ b/test/tests.lisp Sun Nov 06 15:57:26 2016 +0000
@@ -1,4 +1,4 @@
-(in-package :digraph-test)
+(in-package :digraph.test)
;;;; Utils --------------------------------------------------------------------
--- a/vendor/make-quickutils.lisp Sun Nov 06 14:59:26 2016 +0000
+++ b/vendor/make-quickutils.lisp Sun Nov 06 15:57:26 2016 +0000
@@ -4,6 +4,7 @@
"quickutils.lisp"
:utilities '(
+ :appendf
:compose
:curry
:dohash
--- a/vendor/quickutils.lisp Sun Nov 06 14:59:26 2016 +0000
+++ b/vendor/quickutils.lisp Sun Nov 06 15:57:26 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DOHASH :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :HASH-TABLE-KEYS :MAPHASH-KEYS :MKSTR :ONCE-ONLY :RCURRY :REMOVEF :SYMB :WITH-GENSYMS) :ensure-package T :package "DIGRAPH.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:APPENDF :COMPOSE :CURRY :DOHASH :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :HASH-TABLE-KEYS :MAPHASH-KEYS :MKSTR :ONCE-ONLY :RCURRY :REMOVEF :SYMB :WITH-GENSYMS) :ensure-package T :package "DIGRAPH.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "DIGRAPH.QUICKUTILS")
@@ -13,13 +13,18 @@
(in-package "DIGRAPH.QUICKUTILS")
(when (boundp '*utilities*)
- (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :COMPOSE :CURRY :DOHASH
- :ENSURE-BOOLEAN :ENSURE-GETHASH
- :ENSURE-LIST :MAPHASH-KEYS
- :HASH-TABLE-KEYS :MKSTR :ONCE-ONLY
- :RCURRY :REMOVEF :SYMB
+ (setf *utilities* (union *utilities* '(:APPENDF :MAKE-GENSYM-LIST
+ :ENSURE-FUNCTION :COMPOSE :CURRY
+ :DOHASH :ENSURE-BOOLEAN
+ :ENSURE-GETHASH :ENSURE-LIST
+ :MAPHASH-KEYS :HASH-TABLE-KEYS :MKSTR
+ :ONCE-ONLY :RCURRY :REMOVEF :SYMB
:STRING-DESIGNATOR :WITH-GENSYMS))))
+
+ (define-modify-macro appendf (&rest lists) append
+ "Modify-macro for `append`. Appends `lists` to the place designated by the first
+argument.")
+
(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`,
@@ -264,8 +269,8 @@
`(with-gensyms ,names ,@forms))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compose curry dohash ensure-boolean ensure-gethash ensure-list
- hash-table-keys maphash-keys mkstr once-only rcurry removef symb
- with-gensyms with-unique-names)))
+ (export '(appendf compose curry dohash ensure-boolean ensure-gethash
+ ensure-list hash-table-keys maphash-keys mkstr once-only rcurry
+ removef symb with-gensyms with-unique-names)))
;;;; END OF quickutils.lisp ;;;;