Coverage report: /home/ellis/comp/core/lib/dat/dot.lisp

Kind	Covered	All	%
expression	0	333	0.0
branch	0	32	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; dot.lisp --- Graphviz DOT format

2

3

;;

4

5

;;; Commentary:

6

7

;; adapted from eschulte's graph library

8

9

;; ref: https://github.com/eschulte/graph/blob/master/dot.lisp

10

11

;;; Code:

12

(in-package :dat/dot)

13

14

(in-readtable :std) ;; uses curry macros

15

16

;;; Visualization

17

(defstruct rank

18

"The information needed to specify a DOT rank statement. VALUE

19

expects a string and NODE-LIST expects a list."

20

value

21

node-list)

22

23

(defun rank-print (r)

24

"Returns a string containing a DOT rank statement. R is a RANK structure."

25

(when (rank-p r))

26

(with-output-to-string (out)

27

(when (and (rank-value r) (rank-node-list r))

28

(format out "{rank=~a;" (rank-value r))

29

(mapc (lambda (n)

30

(format out " ~s;" n))

31

(rank-node-list r))

32

(format out " }~%"))))

33

34

(defstruct subgraph

35

"The information needed to specify a DOT subgraph. NODE-ATTRIBUTES,

36

EDGE-ATTRIBUTES, and ATTRIBUTES expect assoc lists, and NODE-LIST

37

expects a list."

38

node-attributes

39

edge-attributes

40

attributes

41

ranks

42

node-list)

43

44

(defun subgraph-print (s)

45

"Returns a string containing a DOT subgraph statement. S is a

46

SUBGRAPH structure."

47

(when (subgraph-p s)

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];~%"

52

(mapc (lambda (pair)

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];~%"

57

(mapc (lambda (pair)

58

(format out "~a=~a, " (car pair) (cdr pair)))

59

(subgraph-edge-attributes s))))

60

(when (subgraph-attributes s)

61

(mapc (lambda (pair)

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)

67

(mapc (lambda (n)

68

(format out " ~a;~%" n))

69

(subgraph-node-list s)))

70

(format out " }~%"))))

71

72

(defun edge-to-dot (edge graph attrs &optional stream)

73

(format stream " \"~a\" ~a \"~a\" ~{~a~^ ~};~%"

74

(first edge)

75

(etypecase graph

76

(directed-graph "->")

77

(graph "--"))

78

(second edge)

79

(mapcar (lambda (l)

80

(destructuring-bind (attr . fn) l

81

(let ((val (funcall fn edge)))

82

(if val

83

(if (search "URL" (string attr))

84

(format nil "[~a=~a]"

85

(string-downcase

86

(string attr)

87

                                          :end (- (length (string attr)) 3))

88

val)

89

(format nil "[~(~a~)=~a]" attr val)) ""))))

90

attrs)))

91

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

99

attrs)))

100

101

(defun graph-to-dot (graph

102

&key stream attributes node-attrs edge-attrs

103

subgraphs ranks)

104

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

107

attributes and functions taking nodes or edges respectively and returning

108

values. The DOT graph, node, and edge attributes are described at

109

http://www.graphviz.org/doc/info/attrs.html. SUBGRAPHS is a list of SUBGRAPH

110

structures. RANKS is a list of RANK structures."

111

;; by default edges are labeled with their values

112

(declare (graph graph))

113

(unless (assoc :label edge-attrs)

114

(push (cons :label

115

(lambda (edge)

116

(let ((value (edge-value graph edge)))

117

(when value

118

(format nil "\"~A\"" value)))))

119

edge-attrs))

120

(format stream "~a to_dot {~%~{~a~}}~%"

121

(etypecase graph

122

(directed-graph "digraph")

123

(graph "graph"))

124

(append

125

(mapcar (lambda (l)

126

(destructuring-bind (a . b) l

127

(if (search "URL" (string a))

128

(format nil " ~a=~a;~%" a b)

129

(format nil " ~(~a~)=~a;~%" a b))))

130

attributes)

131

(mapcar {node-to-dot _ node-attrs} (hash-table-keys (nodes graph)))

132

(mapcar {edge-to-dot _ graph edge-attrs} (hash-table-keys (edges graph)))

133

(mapcar #'subgraph-print subgraphs)

134

(mapcar #'rank-print ranks))))

135

136

(defun graph-to-dot-file (graph path

137

&key attributes node-attrs edge-attrs

138

subgraphs ranks)

139

"Write a dot representation of GRAPH to PATH."

140

(with-open-file (out path :direction :output :if-exists :supersede)

141

(graph-to-dot graph :stream out :attributes attributes :node-attrs node-attrs

142

:edge-attrs edge-attrs :subgraphs subgraphs :ranks ranks)))

143

144

(defun graph-from-dot (dot-string)

145

"Parse the DOT format string DOT-STRING into a graph.

146

More robust behavior may be achieved through parsing the output of the

147

dot executable."

148

(flet ((string->symbol (string) (intern (string-upcase string))))

149

(let* ((graph-type-re "^ *((di)?graph)")

150

(spec-re "[\\s]*(\\[([^]]+)\\])?;")

151

(node-name-re "[\\s]*\"?([a-zA-Z0-9_]+)\"?")

152

(node-spec-re (concatenate 'string node-name-re spec-re))

153

(edge-spec-re (concatenate 'string

154

                                        node-name-re "[\\s]+([->]+)" node-name-re spec-re))

155

(label-name-re "label=(\"([^\"]+)\"|([^, ]+))[,\\]]")

156

(number-re "[0-9.\/e]+")

157

(graph (multiple-value-bind (string matches)

158

(cl-ppcre:scan-to-strings graph-type-re dot-string)

159

(declare (ignorable string))

160

(make-instance (string->symbol (aref matches 0))))))

161

;; add nodes

162

(cl-ppcre:do-register-groups (node spec) (node-spec-re dot-string)

163

(declare (ignorable spec))

164

(unless (member node '("node" "graph") :test 'string=)

165

(add-node graph (symbolicate node))))

166

;; add edges

167

(cl-ppcre:do-register-groups (left arrow right spec) (edge-spec-re dot-string)

168

(declare (ignorable arrow))

169

(multiple-value-bind (matchp regs) (cl-ppcre:scan-to-strings label-name-re spec)

170

(add-edge graph

171

(mapcar #'symbolicate (list left right))

172

(when matchp

173

(if (cl-ppcre:scan number-re (aref regs 1))

174

(read-from-string (aref regs 1)))))))

175

graph)))

176

177

178

(defmethod serialize ((self graph) (fmt (eql :dot))

179

&key stream path attributes node-attrs edge-attrs

180

subgraphs ranks)

181

(declare (ignore fmt))

182

(cond

183

((and stream path) (error "passed both STREAM and PATH - pick one"))

184

(stream (graph-to-dot self :stream stream :attributes attributes :node-attrs node-attrs

185

                                :edge-attrs edge-attrs :subgraphs subgraphs :ranks ranks))

186

(path (graph-to-dot-file self path :attributes attributes :node-attrs node-attrs

187

                              :edge-attrs edge-attrs :subgraphs subgraphs :ranks ranks))))

188

189

(defmethod deserialize ((from string) (fmt (eql :dot)) &key)

190

(declare (ignore fmt))

191

(graph-from-dot from))

192

193

;; (defun write-dot-stream (object stream)

194

;; "Write OBJECT to STREAM in Graphviz DOT format.")

195

196

;; (defun write-dot-file (path object)

197

;; "Write OBJECT to file PATH in Graphviz DOT format.")

198

199

;; (defun read-dot-stream (stream)

200

;; "Read from STREAM in Graphviz DOT format.")

201

202

;; (defun read-dot-file (path)

203

;; "Read from file PATH in Graphviz DOT format.")

204

205

;;; Serde

206

;; TODO 2025-03-27: