Coverage report: /Users/mohacker/src/yurrriq/land-of-lisp/src/graphviz.lisp

KindCoveredAll%
expression7135 5.2
branch04 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :cl-user)
2
 (defpackage lol.graphviz
3
   (:use :cl :prove)
4
   (:export dot-name))
5
 (in-package :lol.graphviz)
6
 
7
 
8
 (defun dot-name (exp)
9
   (substitute-if #\_ (complement #'alphanumericp) (prin1-to-string exp)))
10
 
11
 
12
 (defparameter *max-label-length* 30)
13
 
14
 (defun dot-label (exp)
15
   (if exp
16
       (let ((s (write-to-string exp :pretty nil)))
17
         (if (> (length s) *max-label-length*)
18
             (concatenate 'string (subseq s 0 (- *max-label-length* 3)) "...")
19
             s))
20
       ""))
21
 
22
 
23
 (defun nodes->dot (nodes)
24
   (mapc (lambda (node)
25
           (fresh-line)
26
           (princ (dot-name (car node)))
27
           (princ "[label=\"")
28
           (princ (dot-label node))
29
           (princ "\"];"))
30
         nodes))
31
 
32
 
33
 (defun edges->dot (edges)
34
   (mapc (lambda (node)
35
           (mapc (lambda (edge)
36
                   (fresh-line)
37
                   (princ (dot-name (car node)))
38
                   (princ "->")
39
                   (princ (dot-name (car edge)))
40
                   (princ "[label=\"")
41
                   (princ (dot-label (cdr edge)))
42
                   (princ "\"];"))
43
                 (cdr node)))
44
         edges))
45
 
46
 
47
 (defun graph->dot (nodes edges)
48
   (princ "digraph{")
49
   (nodes->dot nodes)
50
   (edges->dot edges)
51
   (princ "}"))
52
 
53
 
54
 (defun dot->png (fname thunk)
55
   (with-open-file (*standard-output*
56
                    fname
57
                    :direction :output
58
                    :if-exists :supersede)
59
     (funcall thunk))
60
   (uiop:run-program (concatenate 'string "dot -Tpng -O " fname)))
61
 
62
 
63
 (defun graph->png (fname nodes edges)
64
   (dot->png fname
65
             (lambda ()
66
               (graph->dot nodes edges))))
67
 
68
 
69
 (defun uedges->dot (edges)
70
   (maplist (lambda (lst)
71
              (mapc (lambda (edge)
72
                      (unless (assoc (car edge) (cdr lst))
73
                        (fresh-line)
74
                        (princ (dot-name (caar lst)))
75
                        (princ "--")
76
                        (princ (dot-name (car edge)))
77
                        (princ "[label=\"")
78
                        (princ (dot-label (cdr edge)))
79
                        (princ "\"];")))
80
                    (cdar lst)))
81
            edges))
82
 
83
 
84
 (defun ugraph->dot (nodes edges)
85
   (princ "graph{")
86
   (nodes->dot nodes)
87
   (uedges->dot edges)
88
   (princ "}"))
89
 
90
 
91
 (defun ugraph->png (fname nodes edges)
92
   (dot->png fname
93
             (lambda ()
94
               (ugraph->dot nodes edges))))