Mercurial > core / lisp/lib/dat/dot.lisp
changeset 667: |
bb8aa1eda12b |
parent: |
5bde4fedc5c1
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Mon, 23 Sep 2024 17:03:54 -0400 |
permissions: |
-rw-r--r-- |
description: |
graph, css vars, corfu-terminal fix |
1 ;;; dot.lisp --- Graphviz DOT format 7 ;; adapted from eschulte's graph library 9 ;; ref: https://github.com/eschulte/graph/blob/master/dot.lisp 14 (in-readtable :std) ;; uses curry macros 18 "The information needed to specify a DOT rank statement. VALUE 19 expects a string and NODE-LIST expects a list." 24 "Returns a string containing a DOT rank statement. R is a RANK structure." 26 (with-output-to-string (out) 27 (when (and (rank-value r) (rank-node-list r)) 28 (format out "{rank=~a;" (rank-value r)) 30 (format out " ~s;" n)) 32 (format out " }~%")))) 35 "The information needed to specify a DOT subgraph. NODE-ATTRIBUTES, 36 EDGE-ATTRIBUTES, and ATTRIBUTES expect assoc lists, and NODE-LIST 44 (defun subgraph-print (s) 45 "Returns a string containing a DOT subgraph statement. S is a 48 (with-output-to-string (out) 49 (format out "subgraph ~a {~%" (string (gensym "cluster_"))) 50 (when (subgraph-node-attributes s) 51 (format out " node [~a];~%" 53 (format out "~a=~a, " (car pair) (cdr pair))) 54 (subgraph-node-attributes s)))) 55 (when (subgraph-edge-attributes s) 56 (format out " edge [~a];~%" 58 (format out "~a=~a, " (car pair) (cdr pair))) 59 (subgraph-edge-attributes s)))) 60 (when (subgraph-attributes s) 62 (format out " ~a=\"~a\";~%" (car pair) (cdr pair))) 63 (subgraph-attributes s))) 64 (when (subgraph-ranks s) 65 (mapcar #'rank-print (subgraph-ranks s))) 66 (when (subgraph-node-list s) 68 (format out " ~a;~%" n)) 69 (subgraph-node-list s))) 70 (format out " }~%")))) 72 (defun edge-to-dot (edge graph attrs &optional stream) 73 (format stream " \"~a\" ~a \"~a\" ~{~a~^ ~};~%" 80 (destructuring-bind (attr . fn) l 81 (let ((val (funcall fn edge))) 83 (if (search "URL" (string attr)) 87 :end (- (length (string attr)) 3)) 89 (format nil "[~(~a~)=~a]" attr val)) "")))) 92 (defun node-to-dot (node attrs &optional stream) 93 (format stream " \"~a\" ~{~a~^ ~};~%" node 94 (mapcar (lambda (l) (destructuring-bind (attr . fn) l 95 (let ((val (funcall fn node))) 96 (if val (if (search "URL" (string attr)) 97 (format nil "[~a=~a]" attr val) 98 (format nil "[~(~a~)=~a]" attr val)) "")))) 101 (defgeneric to-dot (graph 102 &key stream attributes node-attrs edge-attrs 104 (:documentation "Print the dot code representing GRAPH. The keyword 105 argument ATTRIBUTES takes an assoc list with DOT graph attribute (name 106 . value) pairs. NODE-ATTRS and EDGE-ATTRS also take assoc lists of DOT 107 graph attributes and functions taking nodes or edges respectively and 108 returning values. The DOT graph, node, and edge attributes are 109 described at http://www.graphviz.org/doc/info/attrs.html. SUBGRAPHS is 110 a list of SUBGRAPH structures. RANKS is a list of RANK structures.")) 112 (defmethod to-dot ((graph graph) 113 &key stream attributes node-attrs edge-attrs 115 ;; by default edges are labeled with their values 116 (unless (assoc :label edge-attrs) 119 (let ((value (edge-value graph edge))) 121 (format nil "\"~A\"" value))))) 123 (format stream "~a to_dot {~%~{~a~}}~%" 125 (directed-graph "digraph") 129 (destructuring-bind (a . b) l 130 (if (search "URL" (string a)) 131 (format nil " ~a=~a;~%" a b) 132 (format nil " ~(~a~)=~a;~%" a b)))) 134 (mapcar {node-to-dot _ node-attrs} (hash-table-keys (nodes graph))) 135 (mapcar {edge-to-dot _ graph edge-attrs} (hash-table-keys (edges graph))) 136 (mapcar #'subgraph-print subgraphs) 137 (mapcar #'rank-print ranks)))) 139 (defgeneric to-dot-file (graph path &key attributes node-attrs edge-attrs 141 (:documentation "Write a dot representation of GRAPH to PATH.")) 143 (defmethod to-dot-file 144 ((object graph) path &key attributes node-attrs edge-attrs 146 (with-open-file (out path :direction :output :if-exists :supersede) 147 (to-dot object :stream out :attributes attributes :node-attrs node-attrs 148 :edge-attrs edge-attrs :subgraphs subgraphs :ranks ranks))) 150 (defun from-dot (dot-string) 151 "Parse the DOT format string DOT-STRING into a graph. 152 More robust behavior may be achieved through parsing the output of the 154 (flet ((string->symbol (string) (intern (string-upcase string)))) 155 (let* ((graph-type-re "^ *((di)?graph)") 156 (spec-re "[\\s]*(\\[([^]]+)\\])?;") 157 (node-name-re "[\\s]*\"?([a-zA-Z0-9_]+)\"?") 158 (node-spec-re (concatenate 'string node-name-re spec-re)) 159 (edge-spec-re (concatenate 'string 160 node-name-re "[\\s]+([->]+)" node-name-re spec-re)) 161 (label-name-re "label=(\"([^\"]+)\"|([^, ]+))[,\\]]") 162 (number-re "[0-9.\/e]+") 163 (graph (multiple-value-bind (string matches) 164 (cl-ppcre:scan-to-strings graph-type-re dot-string) 165 (declare (ignorable string)) 166 (make-instance (string->symbol (aref matches 0)))))) 168 (cl-ppcre:do-register-groups (node spec) (node-spec-re dot-string) 169 (declare (ignorable spec)) 170 (unless (member node '("node" "graph") :test 'string=) 171 (add-node graph (symbolicate node)))) 173 (cl-ppcre:do-register-groups (left arrow right spec) (edge-spec-re dot-string) 174 (declare (ignorable arrow)) 175 (multiple-value-bind (matchp regs) (cl-ppcre:scan-to-strings label-name-re spec) 177 (mapcar #'symbolicate (list left right)) 179 (if (cl-ppcre:scan number-re (aref regs 1)) 180 (read-from-string (aref regs 1))))))) 183 ;; (defun write-dot-stream (object stream) 184 ;; "Write OBJECT to STREAM in Graphviz DOT format.") 186 ;; (defun write-dot-file (path object) 187 ;; "Write OBJECT to file PATH in Graphviz DOT format.") 189 ;; (defun read-dot-stream (stream) 190 ;; "Read from STREAM in Graphviz DOT format.") 192 ;; (defun read-dot-file (path) 193 ;; "Read from file PATH in Graphviz DOT format.")