lisp:land-of-lisp:ch7

lisp/land-of-lisp/ch7/graph-util-clean.lisp

@@ -0,0 +1,78 @@
+(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))))