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