# HG changeset patch # User Steve Losh # Date 1478447846 0 # Node ID f5cdc0242ec030b24d739d1da58988258ebea499 # Parent f2f7da4fd4fbf4010825140cc09d12e760c738a7 Split systems diff -r f2f7da4fd4fb -r f5cdc0242ec0 cl-digraph.asd --- 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 " @@ -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))) diff -r f2f7da4fd4fb -r f5cdc0242ec0 cl-digraph.dot.asd --- /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 " + :license "MIT/X11" + + :depends-on (:cl-digraph + :cl-dot) + + :serial t + :components ((:file "package.dot") + (:module "src" :serial t + :components ((:file "dot"))))) diff -r f2f7da4fd4fb -r f5cdc0242ec0 cl-digraph.test.asd --- /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 " + :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))) diff -r f2f7da4fd4fb -r f5cdc0242ec0 package-test.lisp --- 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)) diff -r f2f7da4fd4fb -r f5cdc0242ec0 package.dot.lisp --- /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)) diff -r f2f7da4fd4fb -r f5cdc0242ec0 package.lisp --- 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)) diff -r f2f7da4fd4fb -r f5cdc0242ec0 package.test.lisp --- /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)) diff -r f2f7da4fd4fb -r f5cdc0242ec0 src/directed-graph.lisp --- 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*)) diff -r f2f7da4fd4fb -r f5cdc0242ec0 src/dot.lisp --- /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) + diff -r f2f7da4fd4fb -r f5cdc0242ec0 test/tests.lisp --- 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 -------------------------------------------------------------------- diff -r f2f7da4fd4fb -r f5cdc0242ec0 vendor/make-quickutils.lisp --- 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 diff -r f2f7da4fd4fb -r f5cdc0242ec0 vendor/quickutils.lisp --- 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 ;;;;