Coverage report: /home/ellis/comp/core/lib/obj/graph.lisp

Kind	Covered	All	%
expression	64	637	10.0
branch	6	46	13.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; lib/obj/graph.lisp --- Graphs

2

3

;; Graph objects and algorithms

4

5

;;; Commentary:

6

7

;; Mostly modeled off of eschulte's GRAPH library - see also DAT/DOT

8

9

;; ref: https://eschulte.github.io/graph/

10

11

;; Our goals are slightly different than the original library - we prioritize

12

;; flexibility over speed or code size. To this end the base GRAPH class

13

;; accepts NODE vectors in addition to hash-tables. We also make minimal

14

;; assumptions about the underling node types - it is a blank class

15

;; definition. Edges are a bit more complicated - they subclass ID which can be

16

17

;;; Code:

18

(in-package :obj/graph)

19

20

(in-readtable :std)

21

22

;;; Vertex

23

(defclass vertex (id node)

24

()

25

(:documentation "generic vertex mixin. The difference between this class and NODE is

26

that a vertex always carries an ID slot."))

27

28

;;; Edge

29

(defclass edge (node)

30

((in :initarg :in :accessor edge-in) (out :initarg :out :accessor edge-out))

31

(:documentation "generic edge mixin. Compatible with the NODE and ID protocols."))

32

33

(defmethod name ((self edge))

34

(cons (edge-in self) (edge-out self)))

35

36

(defclass edgex (edge id)

37

()

38

(:documentation "Edge compatible with the NODE and ID protocols."))

39

40

(defclass directed-edge (edge)

41

()

42

(:documentation "An edge with an implicit direction from node A to B."))

43

44

(defclass weighted-edge (edge)

45

((weight :initform 1d0 :initarg :weight :accessor weight-of)))

46

47

;;; Hashing

48

(defun copy-hash (hash &optional test comb)

49

"Return a copy of HASH.

50

Optional argument TEST specifies a new equality test to use for the

51

copy. Second optional argument COMB specifies a function to use to

52

combine the values of elements of HASH which collide in the copy due

53

to a new equality test specified with TEST."

54

(let ((comb (when comb (fdefinition comb)))

55

(copy (make-hash-table :test (or test (hash-table-test hash)))))

56

(maphash (lambda (k v) (setf (gethash k copy)

57

(if (and (gethash k copy) comb)

58

(funcall comb (gethash k copy) v)

59

v)))

60

hash)

61

copy))

62

63

(defun node-hash-equal (hash1 hash2)

64

"Test node hashes HASH1 and HASH2 for equality."

65

(set-equal (hash-table-alist hash1)

66

(hash-table-alist hash2)

67

:test (lambda (a b)

68

(and (equalp (car a) (car b))

69

(set-equal (cdr a) (cdr b) :test 'tree-equal)))))

70

71

(defun edge-hash-equal (hash1 hash2)

72

"Test edge hashes HASH1 and HASH2 for equality."

73

(set-equal (hash-table-alist hash1)

74

(hash-table-alist hash2)

75

:test 'equalp))

76

77

(defun edge-equalp (edge1 edge2)

78

(set-equal edge1 edge2 :test 'equal))

79

80

(defun directed-edge-equalp (edge1 edge2)

81

(tree-equal edge1 edge2))

82

83

(defun sxhash-edge (edge)

84

(sxhash (sort (copy-tree edge)

85

(cond

86

((and (numberp (car edge)) (numberp (cdr edge)))

87

(lambda (a b)

88

(or (< (imagpart a) (imagpart b))

89

(and (= (imagpart a) (imagpart b))

90

(< (realpart a) (realpart b))))))

91

((or (numberp (car edge)) (numberp (second edge)))

92

(lambda (a b) (declare (ignore a b)) t))

93

(t #'string<)))))

94

95

(sb-ext:define-hash-table-test edge-equalp sxhash-edge)

96

97

(sb-ext:define-hash-table-test directed-edge-equalp sxhash)

98

99

;;; Proto

100

(defgeneric nodes (graph))

101

(defgeneric (setf nodes) (graph nodes))

102

(defgeneric edges (graph))

103

(defgeneric (setf edges) (graph edges))

104

105

(defgeneric graph-equal (graph1 graph2))

106

107

(defgeneric subgraph (graph nodes)

108

(:documentation "Return the subgraph of GRAPH restricted to NODES."))

109

110

(defgeneric delete-node (graph node)

111

(:documentation "Delete NODE from GRAPH.

112

Delete and return the old edges of NODE in GRAPH."))

113

114

(defgeneric has-node-p (graph node)

115

(:documentation "Return non-nil if GRAPH has node NODE."))

116

(defgeneric has-edge-p (graph edge)

117

(:documentation "Return `true' if GRAPH has edge EDGE."))

118

119

(defgeneric edge-weight (edge &key &allow-other-keys)

120

(:method ((edge t) &key &allow-other-keys) (values 1.0)))

121

122

(defgeneric edge-value (graph edge)

123

(:method ((graph t) (edge t)) (values nil)))

124

125

(defgeneric (setf edge-value) (new graph edge))

126

127

(defgeneric delete-edge (graph edge)

128

(:documentation "Delete EDGE from GRAPH.

129

Return the old value of EDGE."))

130

131

(defgeneric node-edges (graph node)

132

(:documentation "Return the edges of NODE in GRAPH."))

133

134

(defgeneric (setf node-edges) (new graph node)

135

(:documentation "Set the edges of NODE in GRAPH to NEW.

136

Delete and return the old edges of NODE in GRAPH."))

137

138

(defgeneric add-node (graph node))

139

140

(defgeneric add-edge (graph edge &optional value))

141

142

;;; Graph

143

(defclass graph (node)

144

((nodes :initform (make-hash-table :test 'equal)

145

:type (or (vector node) hash-table)

146

:accessor nodes

147

:initarg :nodes)

148

(edges :initform (make-hash-table :test 'edge-equalp)

149

:type hash-table

150

:accessor edges

151

:initarg :edges))

152

(:documentation "generic graph object."))

153

154

(defmethod copy-graph ((graph graph))

155

(make-instance (type-of graph) :nodes (copy-hash (nodes graph)) :edges (copy-hash (edges graph))))

156

157

(defmethod subgraph ((graph graph) nodes)

158

(make-instance (type-of graph) :nodes nodes :edges (copy-hash (edges graph))))

159

160

(defmethod has-edge-p ((graph graph) edge)

161

(multiple-value-bind (value included) (gethash edge (edges graph))

162

(declare (ignorable value)) included))

163

164

(defmethod has-node-p ((graph graph) node)

165

(multiple-value-bind (value included) (gethash node (nodes graph))

166

(declare (ignorable value)) included))

167

168

(defmethod delete-node ((graph graph) node)

169

(prog1 (mapcar (lambda (edge) (cons edge (delete-edge graph edge)))

170

(node-edges graph node))

171

(remhash node (nodes graph))))

172

173

(defmethod delete-edge ((graph graph) edge)

174

(prog1 (edge-value graph edge)

175

(mapc (lambda (node) (setf (gethash node (nodes graph))

176

(remove edge (gethash node (nodes graph))

177

:test 'edge-equalp)))

178

edge)

179

(remhash edge (edges graph))))

180

181

(defmethod node-edges ((graph graph) node)

182

(multiple-value-bind (edges included) (gethash node (nodes graph))

183

(assert included (node graph) "~S doesn't include ~S" graph node)

184

edges))

185

186

(defmethod (setf node-edges) (new (graph graph) node)

187

(prog1 (mapc {delete-edge graph} (gethash node (nodes graph)))

188

(mapc {add-edge graph} new)))

189

190

(defmethod add-edge ((graph graph) edge &optional value)

191

(mapc (lambda (node)

192

(add-node graph node)

193

(pushnew (case (type-of graph)

194

(graph (remove-duplicates edge))

195

(directed-graph edge))

196

(gethash node (nodes graph))

197

:test 'edge-equalp))

198

edge)

199

(setf (gethash edge (edges graph)) value)

200

edge)

201

202

(defmethod edge-value ((graph graph) edge)

203

(multiple-value-bind (value included) (gethash edge (edges graph))

204

(assert included (edge graph) "~S doesn't include ~S" graph edge)

205

value))

206

207

(defmethod (setf edge-value) (new (graph graph) edge)

208

(setf (gethash edge (edges graph)) new))

209

210

(defgeneric merge-nodes (graph node1 node2 &key new)

211

(:documentation "Combine NODE1 and NODE2 in GRAPH into the node NEW.

212

All edges of NODE1 and NODE2 in GRAPH will be combined into a new node

213

of value NEW. Edges between only NODE1 and NODE2 will be removed."))

214

215

(defmethod merge-nodes ((graph graph) node1 node2 &key (new node1))

216

;; replace all removed edges with NEW instead of NODE1 or NODE2

217

(mapcar

218

(lambda (l)

219

(destructuring-bind(edge . value) l

220

(let ((e (mapcar (lambda (n) (if (member n (list node1 node2)) new n)) edge)))

221

(if (has-edge-p graph e)

222

(when (and (edge-value graph e) value)

223

(setf (edge-value graph e) (+ (edge-value graph e) value)))

224

(add-edge graph e value)))))

225

;; drop edges between only node1 and node2

226

(remove-if-not [{set-difference _ (list node1 node2)} #'car]

227

;; delete both nodes keeping their edges and values

228

(prog1 (append (delete-node graph node1)

229

(delete-node graph node2))

230

;; add the new node

231

(add-node graph new))))

232

graph)

233

234

(defgeneric merge-edges (graph edge1 edge2 &key value)

235

(:documentation "Combine EDGE1 and EDGE2 in GRAPH into a new EDGE.

236

Optionally provide a value for the new edge, the values of EDGE1 and

237

EDGE2 will be combined."))

238

239

(defmethod merge-edges ((graph graph) edge1 edge2 &key value)

240

(add-edge graph (remove-duplicates (append edge1 edge2))

241

(or value

242

(when (and (edge-value graph edge1) (edge-value graph edge2))

243

(+ (edge-value graph edge1) (edge-value graph edge2)))))

244

(append (delete-edge graph edge1)

245

(delete-edge graph edge2)))

246

247

(defgeneric degree (graph node)

248

(:documentation "Return the degree of NODE in GRAPH."))

249

250

(defmethod degree ((graph graph) node)

251

(length (node-edges graph node)))

252

253

(defmethod add-node ((graph graph) node)

254

;; NOTE: This is where our implementation breaks character from Eschulte's

255

;; implementation. We currently accept strings in addition to numbers and symbols.

256

(assert (or (numberp node) (symbolp node) (stringp node)) (node)

257

"Nodes must be numbers, symbols or keywords, not ~S.~%Invalid node:~S"

258

(type-of node) node)

259

(unless (has-node-p graph node)

260

(setf (gethash node (nodes graph)) nil)

261

node))

262

263

;;; Directed Graph

264

(defclass directed-graph (graph)

265

((edges :initform (make-hash-table :test 'directed-edge-equalp)

266

:type (or (vector directed-edge) hash-table)

267

:accessor edges

268

:initarg :edges))

269

(:documentation "graph with only directed edges."))

270

271

(defgeneric indegree (digraph node)

272

(:documentation "The number of edges directed to NODE in GRAPH."))

273

274

(defmethod indegree ((digraph directed-graph) node)

275

(length (remove-if-not [{member node} #'cdr] (node-edges digraph node))))

276

277

(defgeneric outdegree (digraph node)

278

(:documentation "The number of edges directed from NODE in DIGRAPH."))

279

280

(defmethod outdegree ((digraph directed-graph) node)

281

(length (remove-if-not [{equal node} #'car] (node-edges digraph node))))

282

283

;;; Shortest Path

284

(defgeneric shortest-path (graph a b &optional heuristic)

285

(:documentation "Return the shortest path in GRAPH from A to B.

286

Implemented using A* search. Optional argument HEURISTIC may be a

287

function which returns an estimated heuristic cost from an node to the

288

target B. The default value for HEURISTIC is the constant function of

289

0, reducing this implementation to Dijkstra's algorithm. The

290

HEURISTIC function must satisfy HEURITIC(x)≤d(x,y)+HEURITIC(y) ∀ x,y

291

in GRAPH allowing the more efficient monotonic or \"consistent\"

292

implementation of A*.")

293

(:method ((graph graph) a b

294

&optional

295

(heuristic (constantly 0))

296

&aux

297

(from (make-hash-table))

298

(fringe (sb-concurrency:make-queue))

299

(open (make-hash-table))

300

(closed (make-hash-table))

301

(g (make-hash-table))

302

(f (make-hash-table)))

303

(when (equal a b) (return-from shortest-path nil))

304

(labels ((reconstruct-path (current)

305

(destructuring-bind (node . edge) (gethash current from)

306

(cons edge (unless (member a edge) (reconstruct-path node))))))

307

(setf (gethash a g) 0

308

(gethash a f) (funcall heuristic a)

309

(gethash a open) t)

310

311

(sb-concurrency:enqueue fringe (gethash a f))

312

313

(do ((current (sb-concurrency:dequeue fringe) (sb-concurrency:dequeue fringe)))

314

((zerop (hash-table-count open))

315

(multiple-value-bind (value present-p) (gethash b f)

316

(when present-p

317

(values (nreverse (reconstruct-path b)) value))))

318

319

(when (eql current b)

320

(return-from shortest-path

321

(values (nreverse (reconstruct-path current))

322

(gethash current f))))

323

324

(remhash current open)

325

(setf (gethash current closed) t)

326

327

(mapc (lambda (edge)

328

(let ((weight (or (edge-value graph edge) 1)))

329

(mapc (lambda (next)

330

(unless (gethash next closed)

331

(setf (gethash next open) t)

332

(let ((tentative (+ (gethash current g) weight)))

333

(multiple-value-bind (value present-p)

334

(gethash next g)

335

(when (or (not present-p)

336

(< tentative value))

337

                                   (setf (gethash next from) (cons current edge)

338

(gethash next g) tentative

339

(gethash next f)

340

                                         (+ tentative (funcall heuristic next)))

341

                                   (sb-concurrency:enqueue fringe (gethash next f)))))))

342

(etypecase graph

343

(directed-graph (cdr (member current edge)))

344

(graph (remove current edge))))))

345

(node-edges graph current))))))

346

347

;;; Min Cut

348

;;

349

;; Stoer, M. and Wagner, Frank. 1997. A Simple Min-Cut Algorithm.

350

;; Journal of the ACM

351

;;

352

;; Theorem: Let s,t ∈ (nodes G), let G' be the result of merging s and

353

;; t in G. Then (min-cut G) is equal to the minimum of the

354

;; min cut of s and t in G and (min-cut G').

355

;;

356

(defun weigh-cut (graph cut)

357

(reduce #'+ (mapcar {edge-value graph}

358

(remove-if-not (lambda (edge)

359

(and (intersection edge (first cut))

360

                                             (intersection edge (second cut))))

361

(edges graph)))))

362

363

(defgeneric min-cut (graph)

364

(:documentation

365

"Return both the global min-cut of GRAPH and the weight of the cut."))

366

367

(defmethod min-cut ((graph graph))

368

(let ((g (copy-graph graph))

369

(merged-nodes (mapcar (lambda (n) (list n n)) (nodes graph)))

370

cuts-of-phase)

371

(flet ((connection-weight (group node)

372

;; return the weight of edges between GROUP and NODE

373

(reduce #'+ (mapcar {edge-value g}

374

(remove-if-not {intersection group}

375

                                                 (node-edges g node)))))

376

(my-merge (a b)

377

;; merge in the graph

378

(merge-nodes g a b)

379

;; update our merged nodes alist

380

(setf (cdr (assoc a merged-nodes))

381

(append (cdr (assoc a merged-nodes))

382

(cdr (assoc b merged-nodes))))

383

(setq merged-nodes

384

(remove-if (lambda (it) (eql (car it) b)) merged-nodes))))

385

(loop :while (> (length (nodes g)) 1) :do

386

(let* ((a (list (random (nodes g))))

387

(rest (remove (car a) (nodes g))))

388

(loop :while rest :do

389

;; grow A by adding the node most tightly connected to A

390

(let ((new (car (sort rest #'> :key {connection-weight a}))))

391

(setf rest (remove new rest))

392

(push new a)))

393

;; store the cut-of-phase

394

(push (cons (connection-weight (cdr a) (car a))

395

(cdr (assoc (car a) merged-nodes)))

396

cuts-of-phase)

397

;; merge two last added nodes

398

(my-merge (first a) (second a))))

399

;; return the minimum cut-of-phase

400

(let* ((half (cdar (sort cuts-of-phase #'< :key #'car)))

401

(cut (list half (set-difference (nodes graph) half))))

402

(values (sort cut #'< :key #'length) (weigh-cut graph cut))))))

403

404

;; https://en.wikipedia.org/wiki/Degeneracy_(graph_theory)

405

��