4 $Id: graph-container.lisp,v 1.12 2005/07/20 20:39:09 moody Exp $
12 (in-package #:metabang.graph)
14 ;;; ---------------------------------------------------------------------------
16 ;;; ---------------------------------------------------------------------------
18 (defclass* graph-container (iteratable-container-mixin
19 non-associative-container-mixin
20 initial-contents-mixin
22 container-uses-nodes-mixin)
23 ((vertex-pair->edge (make-container 'simple-associative-container
26 :vertex-class 'graph-container-vertex
27 :directed-edge-class 'graph-container-directed-edge
28 :undirected-edge-class 'graph-container-edge)
30 (:documentation "A graph container is essentially an adjacency list graph representation [?? The Bad name comes from it being implemented with containers... ugh]"))
32 ;;; ---------------------------------------------------------------------------
34 (defclass* graph-container-edge (basic-edge)
35 ((vertex-1 nil ir "`Vertex-1` is one of the two vertexes that an edge connects. In a directed-edge, `vertex-1` is also the `source-edge`.")
36 (vertex-2 nil ir "`Vertex-2` is one of the two vertexes that an edge connects. In a directed edge, `vertex-2` is also the `target-vertex`."))
37 (:export-slots vertex-1 vertex-2)
39 (:documentation "This is the root class for edges in graph-containers. It adds vertex-1 and vertex-2 slots."))
41 ;;; ---------------------------------------------------------------------------
43 (defmethod print-object ((object graph-container-edge) stream)
44 (print-unreadable-object (object stream :type t)
45 (format stream "<~A ~A ~A>" (vertex-1 object) (vertex-2 object)
48 ;;; ---------------------------------------------------------------------------
50 (defclass* weighted-edge (weighted-edge-mixin graph-container-edge)
53 (:documentation "A weighted edge is both a weighted-edge-mixin and a graph-container-edge."))
55 ;;; ---------------------------------------------------------------------------
57 (defclass* graph-container-vertex (basic-vertex)
58 ((vertex-edges nil r))
61 :vertex-edges-container-class 'vector-container)
62 (:documentation "A graph container vertex keeps track of its edges in the the vertex-edges slot. The storage for this defaults to a vector-container but can be changed using the vertex-edges-container-class initarg."))
64 ;;; ---------------------------------------------------------------------------
66 (defmethod make-vertex-edges-container ((vertex graph-container-vertex)
67 container-class &rest args)
68 (apply #'make-container container-class args))
70 ;;; ---------------------------------------------------------------------------
72 (defmethod initialize-instance :after ((object graph-container-vertex) &key
73 vertex-edges-container-class)
74 (setf (slot-value object 'vertex-edges)
75 (make-vertex-edges-container object vertex-edges-container-class)))
77 ;;; ---------------------------------------------------------------------------
79 (defmethod make-vertex-container ((graph graph-container) initial-size)
80 (make-container 'simple-associative-container
81 :initial-size initial-size
82 :test (vertex-test graph)))
84 ;;; ---------------------------------------------------------------------------
86 (defmethod make-edge-container ((graph graph-container) initial-size)
87 (make-container 'vector-container :initial-size initial-size
91 ;;; ---------------------------------------------------------------------------
92 ;;; graph-container-directed-edge
93 ;;; ---------------------------------------------------------------------------
95 (defclass* graph-container-directed-edge (directed-edge-mixin
99 (:documentation "A graph-container-directed-edge is both a directed-edge-mixin and a graph-container-edge."))
101 ;;; ---------------------------------------------------------------------------
103 (defmethod initialize-instance :after ((object graph-container-directed-edge)
104 &key source-vertex target-vertex)
105 (when (and source-vertex (vertex-1 object))
106 (error "Specify source-vertex or vertex-1, but not both"))
107 (when (and target-vertex (vertex-2 object))
108 (error "Specify target-vertex or vertex-2, but not both"))
110 (setf (slot-value object 'vertex-1) source-vertex))
112 (setf (slot-value object 'vertex-2) target-vertex)))
114 ;;; ---------------------------------------------------------------------------
115 ;;; vertex-1 is defined to be the source vertex of an undirected edge
116 ;;; ---------------------------------------------------------------------------
118 (defmethod source-vertex ((edge graph-container-edge))
121 ;;; ---------------------------------------------------------------------------
122 ;;; vertex-2 is defined to be the target vertex of an undirected edge
123 ;;; ---------------------------------------------------------------------------
125 (defmethod target-vertex ((edge graph-container-edge))
128 ;;; ---------------------------------------------------------------------------
130 (defmethod other-vertex ((edge graph-container-edge)
131 (v graph-container-vertex))
132 (cond ((eq v (vertex-1 edge))
133 (values (vertex-2 edge)))
135 ((eq v (vertex-2 edge))
136 (values (vertex-1 edge)))
138 (t (error "Vertex ~A not part of Edge ~A" v edge))))
140 ;;; ---------------------------------------------------------------------------
142 (defmethod other-vertex ((edge graph-container-edge)
144 (other-vertex edge (find-vertex edge value)))
146 ;;; ---------------------------------------------------------------------------
148 (defmethod add-edge ((graph graph-container) (edge graph-container-edge)
150 (declare (ignore force-new?))
152 (bind ((vertex-1 (vertex-1 edge))
153 (vertex-2 (vertex-2 edge)))
155 (cond ((eq vertex-1 vertex-2)
156 (add-edge-to-vertex edge vertex-1))
158 (add-edge-to-vertex edge vertex-1)
159 (add-edge-to-vertex edge vertex-2)))
160 (push edge (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))))
163 ;;; ---------------------------------------------------------------------------
165 (defmethod add-edge-to-vertex :around ((edge graph-container-edge)
166 (vertex graph-container-vertex))
167 (insert-item (vertex-edges vertex) edge))
169 ;;; ---------------------------------------------------------------------------
171 (defmethod make-node-for-container ((graph graph-container) (node t) &key)
172 (make-vertex-for-graph graph :element node))
174 ;;; ---------------------------------------------------------------------------
176 (defmethod find-edge-between-vertexes ((graph graph-container)
177 (vertex-1 graph-container-vertex)
178 (vertex-2 graph-container-vertex)
179 &key error-if-not-found?)
180 (multiple-value-bind (value found?)
181 (item-at-1 (vertex-pair->edge graph)
182 (cons vertex-1 vertex-2))
183 (when (and error-if-not-found?
185 (error 'graph-edge-not-found-error
186 :vertex-1 vertex-1 :vertex-2 vertex-1))
189 ;;; ---------------------------------------------------------------------------
191 (defmethod find-edge-between-vertexes-if ((graph graph-container)
192 (vertex-1 graph-container-vertex)
193 (vertex-2 graph-container-vertex)
195 &key error-if-not-found?)
196 (let ((it (search-for-match (vertex-edges vertex-1)
198 (and (eq vertex-2 (other-vertex edge vertex-1))
199 (funcall fn edge))))))
200 (when (and error-if-not-found? (not it))
201 (error 'graph-edge-not-found-error
202 :vertex-1 vertex-1 :vertex-2 vertex-1))
205 ;;; ---------------------------------------------------------------------------
207 (defmethod find-edge-between-vertexes-if ((graph graph-container)
211 &key error-if-not-found?)
212 (bind ((v1 (find-vertex graph value-1 error-if-not-found?))
213 (v2 (find-vertex graph value-2 error-if-not-found?)))
214 (or (and v1 v2 (find-edge-between-vertexes-if graph v1 v2 fn))
215 (when error-if-not-found?
216 (error 'graph-edge-not-found-error :vertex-1 v1 :vertex-2 v2)))))
218 ;;; ---------------------------------------------------------------------------
220 (defmethod find-edge ((graph graph-container) (edge graph-container-edge)
221 &optional error-if-not-found?)
222 (find-edge-between-vertexes
223 graph (vertex-1 edge) (vertex-2 edge)
224 :error-if-not-found? error-if-not-found?))
226 ;;; ---------------------------------------------------------------------------
228 (defmethod delete-edge ((graph graph-container) (edge graph-container-edge))
229 (let ((vertex-1 (vertex-1 edge))
230 (vertex-2 (vertex-2 edge)))
231 (delete-item (vertex-edges vertex-1) edge)
232 (delete-item (vertex-edges vertex-2) edge)
233 (setf (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))
235 (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))
239 (defmethod delete-all-edges ((graph graph-container))
243 (empty! (vertex-edges vertex))))
244 (empty! (vertex-pair->edge graph))
247 ;;; ---------------------------------------------------------------------------
249 (defmethod empty! :after ((graph graph-container))
250 (empty! (vertex-pair->edge graph)))
253 ;;; ---------------------------------------------------------------------------
255 ;;; ---------------------------------------------------------------------------
257 (defmethod iterate-edges ((graph graph-container) fn)
258 (iterate-elements (graph-edges graph) fn))
260 ;;; ---------------------------------------------------------------------------
262 (defmethod iterate-edges ((vertex graph-container-vertex) fn)
263 (iterate-elements (vertex-edges vertex) fn))
265 ;;; ---------------------------------------------------------------------------
267 (defmethod iterate-source-edges ((vertex graph-container-vertex) fn)
268 (iterate-elements (vertex-edges vertex)
270 (when (or (undirected-edge-p edge)
271 (eq vertex (source-vertex edge)))
272 (funcall fn edge)))))
274 ;;; ---------------------------------------------------------------------------
276 (defmethod iterate-target-edges ((vertex graph-container-vertex) fn)
277 (iterate-elements (vertex-edges vertex)
279 (when (or (undirected-edge-p edge)
280 (eq vertex (target-vertex edge)))
281 (funcall fn edge)))))
283 ;;; ---------------------------------------------------------------------------
285 (defmethod iterate-children ((vertex graph-container-vertex) fn)
286 (iterate-source-edges vertex
288 (funcall fn (other-vertex edge vertex)))))
290 ;;; ---------------------------------------------------------------------------
292 (defmethod iterate-parents ((vertex graph-container-vertex) fn)
293 (iterate-target-edges vertex
295 (funcall fn (other-vertex edge vertex)))))
297 ;;; ---------------------------------------------------------------------------
299 (defmethod iterate-neighbors ((vertex graph-container-vertex) fn)
300 (iterate-edges vertex
302 (funcall fn (other-vertex edge vertex)))))
304 ;;; ---------------------------------------------------------------------------
306 (defmethod vertexes ((edge graph-container-edge))
307 (collect-using #'iterate-vertexes nil edge))
309 ;;; ---------------------------------------------------------------------------
311 (defmethod has-children-p ((vertex graph-container-vertex))
312 (iterate-target-edges vertex
314 (declare (ignore edge))
315 (return-from has-children-p t)))
318 ;;; ---------------------------------------------------------------------------
320 (defmethod has-parent-p ((vertex graph-container-vertex))
321 (iterate-source-edges vertex
323 (declare (ignore edge))
324 (return-from has-parent-p t)))
327 ;;; ---------------------------------------------------------------------------
329 (defmethod vertices-share-edge-p ((vertex-1 graph-container-vertex)
330 (vertex-2 graph-container-vertex))
331 (iterate-target-edges vertex-1
333 (when (or (eq (target-vertex e) vertex-2)
334 (eq (source-vertex e) vertex-2))
335 (return-from vertices-share-edge-p t))))
337 (iterate-source-edges vertex-1
339 (when (or (eq (target-vertex e) vertex-2)
340 (eq (source-vertex e) vertex-2))
341 (return-from vertices-share-edge-p t))))
345 ;;; ---------------------------------------------------------------------------
347 (defmethod edge-count ((graph graph-container))
348 (size (graph-edges graph)))