Add convenience builders and graphviz label override
Changes
--- 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)
--- 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.
--- 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
------
--- 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
--- 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`.
--- 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
--- 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)))))