1 (in-package #:metabang.graph)
3 (defun roots-and-child-function->graph (roots child-function max-depth)
4 (let ((g (make-graph 'graph-container)))
5 (labels ((init-vertex (vertex depth)
6 (when (or (not max-depth) (< depth max-depth))
7 (unless (find-vertex g vertex nil)
9 (loop for child in (funcall child-function vertex) do
10 (init-vertex child (1+ depth))
11 (add-edge-between-vertexes g vertex child))))))
12 (loop for root in roots do
13 (init-vertex root 0)))
16 ;;; ---------------------------------------------------------------------------
18 (defun class-hierarchy->dot (base-class-or-classes output &key (filter (constantly t)))
19 (metabang.graph:graph->dot
20 (roots-and-child-function->graph
21 (ensure-list base-class-or-classes)
23 (when (funcall filter cname)
24 (mapcar #'class-name (mopu:direct-subclasses (find-class cname)))))
27 :graph-formatter (lambda (g stream)
29 (format stream "rankdir=LR"))
31 :vertex-labeler (lambda (vertex stream)
32 (format stream "~(~A~)" (symbol-name (element vertex))))
34 :vertex-formatter (lambda (vertex stream)
35 (when (subtypep (element vertex) 'containers::concrete-container)
36 (format stream "color=\"blue\", style=\"filled\", fontcolor=\"white\", fillcolor=\"blue\"")))))
38 ;;; ---------------------------------------------------------------------------
41 (class-hierarchy->dot 'abstract-container
43 :filter (lambda (class-name)
44 (not (subtypep class-name 'containers::abstract-generator))))
48 (class-hierarchy->dot '(containers::abstract-generator
49 containers::transforming-iterator-mixin
50 containers::basic-filtered-iterator-mixin
51 containers::circular-iterator-mixin)
52 "thousand-parsers:iterators.dot")
56 (let ((op (make-instance 'asdf:load-op)))
58 (roots-and-child-function->graph
59 (list (asdf:find-system 'cl-graph))
64 (asdf:component-depends-on op node))
66 (let ((op (car node)))
67 (loop for name in (rest node)
68 when (asdf:find-system name nil) append
69 (asdf:component-depends-on op (asdf:find-system name)))))))
72 :vertex-labeler (lambda (v s)
73 (princ (or (ignore-errors
74 (asdf:component-name (element v)))
76 :edge-labeler (lambda (e s)
77 (declare (ignore e s)))))