# HG changeset patch # User Steve Losh # Date 1687375249 14400 # Node ID 4c06758934a21484fcc60721bf36d34e46fa127b # Parent c8b94c57b283c3ec627289b1dcd449edefcfaa42 Add convenience builders and graphviz label override diff -r c8b94c57b283 -r 4c06758934a2 docs/03-reference.markdown --- a/docs/03-reference.markdown Wed Feb 08 21:43:28 2023 -0500 +++ b/docs/03-reference.markdown Wed Jun 21 15:20:49 2023 -0400 @@ -22,6 +22,38 @@ +### `BUILD-FROM-LEAFS` (function) + + (BUILD-FROM-LEAFS LEAFS PREDECESSOR-FUNCTION &KEY (TEST #'EQL) (HASH-FUNCTION NIL)) + +Build a fresh `digraph` starting from `leafs` using `predecessor-function`. + + This is a convenience function to build a digraph object if you have some + leafs and a function that can find their parents. + + `leafs` must be a list. + + `predecessor-function` must be a function that takes a vertex and returns + a list of its predecessors. + + + +### `BUILD-FROM-ROOTS` (function) + + (BUILD-FROM-ROOTS ROOTS SUCCESSOR-FUNCTION &KEY (TEST #'EQL) (HASH-FUNCTION NIL)) + +Build a fresh `digraph` starting from `roots` using `successor-function`. + + This is a convenience function to build a digraph object if you have some + roots and a function that can find their children. + + `roots` must be a list. + + `successor-function` must be a function that takes a vertex and returns a list + of its successors. + + + ### `CONTAINS-EDGE-P` (function) (CONTAINS-EDGE-P DIGRAPH PREDECESSOR SUCCESSOR) diff -r c8b94c57b283 -r 4c06758934a2 docs/04-reference-dot.markdown --- a/docs/04-reference-dot.markdown Wed Feb 08 21:43:28 2023 -0500 +++ b/docs/04-reference-dot.markdown Wed Jun 21 15:20:49 2023 -0400 @@ -9,7 +9,8 @@ ### `DRAW` (function) - (DRAW DIGRAPH &KEY (FILENAME digraph.png) (FORMAT :PNG) (SHAPE :CIRCLE)) + (DRAW DIGRAPH &KEY (FILENAME digraph.png) (FORMAT :PNG) (SHAPE :CIRCLE) + (LABEL #'PRINC-TO-STRING)) Draw `digraph` with cl-dot. diff -r c8b94c57b283 -r 4c06758934a2 docs/05-changelog.markdown --- a/docs/05-changelog.markdown Wed Feb 08 21:43:28 2023 -0500 +++ b/docs/05-changelog.markdown Wed Jun 21 15:20:49 2023 -0400 @@ -5,6 +5,16 @@ [TOC] +v1.6.0 +------ + +Added `build-from-roots` and `build-from-leafs` convenience functions to help +build digraphs when you have some roots/leafs and a way to generated their +successors/predecessors. + +Added `label` argument to `digraph.dot:draw` to change the label function of the +nodes. + v1.5.0 ------ diff -r c8b94c57b283 -r 4c06758934a2 package.lisp --- a/package.lisp Wed Feb 08 21:43:28 2023 -0500 +++ b/package.lisp Wed Jun 21 15:20:49 2023 -0400 @@ -53,6 +53,9 @@ :copy-digraph + :build-from-roots + :build-from-leafs + :digraph-error :missing-vertex :missing-predecessor diff -r c8b94c57b283 -r 4c06758934a2 src/directed-graph.lisp --- a/src/directed-graph.lisp Wed Feb 08 21:43:28 2023 -0500 +++ b/src/directed-graph.lisp Wed Jun 21 15:20:49 2023 -0400 @@ -281,6 +281,52 @@ (null (succ digraph vertex))) +;;;; Build -------------------------------------------------------------------- +(defun build-from-roots (roots successor-function &key (test #'eql) (hash-function nil)) + "Build a fresh `digraph` starting from `roots` using `successor-function`. + + This is a convenience function to build a digraph object if you have some + roots and a function that can find their children. + + `roots` must be a list. + + `successor-function` must be a function that takes a vertex and returns a list + of its successors. + + " + (let ((result (make-digraph :test test :hash-function hash-function))) + (labels ((recur (node) + (insert-vertex result node) + (dolist (succ (funcall successor-function node)) + (insert-vertex result succ) + (insert-edge result node succ) + (recur succ)))) + (map nil #'recur roots)) + result)) + +(defun build-from-leafs (leafs predecessor-function &key (test #'eql) (hash-function nil)) + "Build a fresh `digraph` starting from `leafs` using `predecessor-function`. + + This is a convenience function to build a digraph object if you have some + leafs and a function that can find their parents. + + `leafs` must be a list. + + `predecessor-function` must be a function that takes a vertex and returns + a list of its predecessors. + + " + (let ((result (make-digraph :test test :hash-function hash-function))) + (labels ((recur (node) + (insert-vertex result node) + (dolist (pred (funcall predecessor-function node)) + (insert-vertex result pred) + (insert-edge result pred node) + (recur pred)))) + (map nil #'recur leafs)) + result)) + + ;;;; Iteration ---------------------------------------------------------------- (defun mapc-vertices (function digraph) "Call `function` on each vertex in `digraph`. diff -r c8b94c57b283 -r 4c06758934a2 src/dot.lisp --- a/src/dot.lisp Wed Feb 08 21:43:28 2023 -0500 +++ b/src/dot.lisp Wed Jun 21 15:20:49 2023 -0400 @@ -20,20 +20,23 @@ (defparameter *current-digraph* nil) (defparameter *shape* nil) +(defparameter *label* #'princ-to-string) (defmethod cl-dot:graph-object-node ((graph (eql 'digraph)) (vertex t)) (make-instance 'cl-dot:node - :attributes `(:label ,(format nil "~A" vertex) :shape ,*shape*))) + :attributes `(:label ,(funcall *label* vertex) :shape ,*shape*))) (defmethod cl-dot:graph-object-points-to ((graph (eql 'digraph)) (vertex t)) (successors *current-digraph* vertex)) -(defun draw (digraph &key (filename "digraph.png") (format :png) (shape :circle)) +(defun draw (digraph &key (filename "digraph.png") (format :png) + (shape :circle) (label #'princ-to-string)) "Draw `digraph` with cl-dot." (let ((*current-digraph* digraph) - (*shape* shape)) + (*shape* shape) + (*label* label)) (cl-dot:dot-graph (cl-dot:generate-graph-from-roots 'digraph (find-dot-roots digraph)) filename diff -r c8b94c57b283 -r 4c06758934a2 test/tests.lisp --- a/test/tests.lisp Wed Feb 08 21:43:28 2023 -0500 +++ b/test/tests.lisp Wed Jun 21 15:20:49 2023 -0400 @@ -307,3 +307,40 @@ (insert-edge g 'd 'b) (has-topo-error g '(b c d)) (remove-edge g 'd 'b))) + + +(define-test convenience-builders + ;; a --> b --> c + ;; | + ;; v e --> f + ;; d + (let ((g (build-from-roots '(a e) (lambda (v) (ecase v + (a '(b)) + (b '(c d)) + (c '()) + (d '()) + (e '(f)) + (f '())))))) + (is (same '(a b c d e f) (vertices g))) + (is (same '((a . b) + (b . c) (b . d) + (e . f)) + (edges g)))) + (let ((g (build-from-leafs '(c d f) (lambda (v) (ecase v + (a '()) + (b '(a)) + (c '(b)) + (d '(b)) + (e '()) + (f '(e))))))) + (is (same '(a b c d e f) (vertices g))) + (is (same '((a . b) + (b . c) (b . d) + (e . f)) + (edges g)))) + (let ((g (build-from-roots '() (lambda (v) (ecase v))))) + (is (same '() (vertices g))) + (is (same '() (edges g)))) + (let ((g (build-from-leafs '() (lambda (v) (ecase v))))) + (is (same '() (vertices g))) + (is (same '() (edges g)))))