dev/examples/class-hierarchy-to-dot.lisp

   1 (in-package #:metabang.graph)
   2
   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)
   8                    (add-vertex g vertex)
   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)))
  14     g))
  15
  16 ;;; ---------------------------------------------------------------------------
  17
  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)
  22     (lambda (cname)
  23       (when (funcall filter cname)
  24         (mapcar #'class-name (mopu:direct-subclasses (find-class cname)))))
  25     nil)
  26    output
  27    :graph-formatter (lambda (g stream)
  28                       (declare (ignore g))
  29                       (format stream "rankdir=LR"))
  30
  31    :vertex-labeler (lambda (vertex stream)
  32                      (format stream "~(~A~)" (symbol-name (element vertex))))
  33
  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\"")))))
  37
  38 ;;; ---------------------------------------------------------------------------
  39
  40 #+Test
  41 (class-hierarchy->dot 'abstract-container
  42                       nil
  43                       :filter (lambda (class-name)
  44                                 (not (subtypep class-name 'containers::abstract-generator))))
  45
  46
  47 #+Test
  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")
  53
  54 #+(or)
  55 ;; very sucky
  56 (let ((op (make-instance 'asdf:load-op)))
  57   (graph->dot
  58    (roots-and-child-function->graph
  59     (list (asdf:find-system 'cl-graph))
  60     (lambda (node)
  61       (print node)
  62       (typecase node
  63         (asdf:component
  64          (asdf:component-depends-on op node))
  65         (cons
  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)))))))
  70     4)
  71    #p"/tmp/out.dot"
  72    :vertex-labeler (lambda (v s)
  73                      (princ (or (ignore-errors
  74                                   (asdf:component-name (element v)))
  75                                 (element v)) s))
  76    :edge-labeler (lambda (e s)
  77                    (declare (ignore e s)))))