4c06758934a2 v1.6.0

Add convenience builders and graphviz label override
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Wed, 21 Jun 2023 15:20:49 -0400
parents c8b94c57b283
children e5e1471cb234
branches/tags v1.6.0
files docs/03-reference.markdown docs/04-reference-dot.markdown docs/05-changelog.markdown package.lisp src/directed-graph.lisp src/dot.lisp test/tests.lisp

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)))))