79 lines
1.9 KiB
Common Lisp
79 lines
1.9 KiB
Common Lisp
(defun dot-name (exp)
|
|
(substitute-if #\_ (complement #'alphanumericp) (prin1-to-string exp)))
|
|
|
|
(defparameter *max-label-length* 30)
|
|
|
|
(defun dot-label (exp)
|
|
(if exp
|
|
(let ((s (write-to-string exp :pretty nil)))
|
|
(if (> (length s) *max-label-length*)
|
|
(concatenate 'string (subseq s 0 (- *max-label-length* 3)) "...")
|
|
s))
|
|
""))
|
|
|
|
(defun nodes->dot (nodes)
|
|
(mapc (lambda (node)
|
|
(fresh-line)
|
|
(princ (dot-name (car node)))
|
|
(princ "[label=\"")
|
|
(princ (dot-label node))
|
|
(princ "\"];"))
|
|
nodes))
|
|
|
|
(defun edges->dot (edges)
|
|
(mapc (lambda (node)
|
|
(mapc (lambda (edge)
|
|
(fresh-line)
|
|
(princ (dot-name (car node)))
|
|
(princ "->")
|
|
(princ (dot-name (car edge)))
|
|
(princ "[label=\"")
|
|
(princ (dot-label (cdr edge)))
|
|
(princ "\"];"))
|
|
(cdr node)))
|
|
edges))
|
|
|
|
(defun graph->dot (nodes edges)
|
|
(princ "digraph{")
|
|
(nodes->dot nodes)
|
|
(edges->dot edges)
|
|
(princ "}"))
|
|
|
|
(defun dot->png (fname thunk)
|
|
(with-open-file (*standard-output*
|
|
fname
|
|
:direction :output
|
|
:if-exists :supersede)
|
|
(funcall thunk))
|
|
(ext:shell (concatenate 'string "dot -Tpng -O " fname)))
|
|
|
|
(defun graph->png (fname nodes edges)
|
|
(dot->png fname
|
|
(lambda ()
|
|
(graph->dot nodes edges))))
|
|
|
|
(defun uedges->dot (edges)
|
|
(maplist (lambda (lst)
|
|
(mapc (lambda (edge)
|
|
(unless (assoc (car edge) (cdr lst))
|
|
(fresh-line)
|
|
(princ (dot-name (caar lst)))
|
|
(princ "--")
|
|
(princ (dot-name (car edge)))
|
|
(princ "[label=\"")
|
|
(princ (dot-label (cdr edge)))
|
|
(princ "\"];")))
|
|
(cdar lst)))
|
|
edges))
|
|
|
|
(defun ugraph->dot (nodes edges)
|
|
(princ "graph{")
|
|
(nodes->dot nodes)
|
|
(uedges->dot edges)
|
|
(princ "}"))
|
|
|
|
(defun ugraph->png (fname nodes edges)
|
|
(dot->png fname
|
|
(lambda ()
|
|
(ugraph->dot nodes edges))))
|