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)
25 :vertex-class 'graph-container-vertex
26 :directed-edge-class 'graph-container-directed-edge
27 :undirected-edge-class 'graph-container-edge)
29 (:documentation "A graph container is essentially an adjacency list graph representation [?? The Bad name comes from it being implemented with containers... ugh]"))
31 ;;; ---------------------------------------------------------------------------
33 (defclass* graph-container-edge (basic-edge)
34 ((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`.")
35 (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`."))
36 (:export-slots vertex-1 vertex-2)
38 (:documentation "This is the root class for edges in graph-containers. It adds vertex-1 and vertex-2 slots."))
40 ;;; ---------------------------------------------------------------------------
42 (defmethod print-object ((object graph-container-edge) stream)
43 (print-unreadable-object (object stream :type t)
44 (format stream "<~A ~A ~A>" (vertex-1 object) (vertex-2 object)
47 ;;; ---------------------------------------------------------------------------
49 (defclass* weighted-edge (weighted-edge-mixin graph-container-edge)
52 (:documentation "A weighted edge is both a weighted-edge-mixin and a graph-container-edge."))
54 ;;; ---------------------------------------------------------------------------
56 (defclass* graph-container-vertex (basic-vertex)
57 ((vertex-edges nil r))
60 :vertex-edges-container-class 'vector-container)
61 (: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."))
63 ;;; ---------------------------------------------------------------------------
65 (defmethod make-vertex-edges-container ((vertex graph-container-vertex)
66 container-class &rest args)
67 (apply #'make-container container-class args))
69 ;;; ---------------------------------------------------------------------------
71 (defmethod initialize-instance :after ((object graph-container-vertex) &key
72 vertex-edges-container-class)
73 (setf (slot-value object 'vertex-edges)
74 (make-vertex-edges-container object vertex-edges-container-class)))
76 ;;; ---------------------------------------------------------------------------
78 (defmethod make-vertex-container ((graph graph-container) initial-size)
79 (make-container 'simple-associative-container
80 :initial-size initial-size
81 :test (vertex-test graph)))
83 ;;; ---------------------------------------------------------------------------
85 (defmethod make-edge-container ((graph graph-container) initial-size)
86 (make-container 'vector-container :initial-size initial-size
90 ;;; ---------------------------------------------------------------------------
91 ;;; graph-container-directed-edge
92 ;;; ---------------------------------------------------------------------------
94 (defclass* graph-container-directed-edge (directed-edge-mixin
98 (:documentation "A graph-container-directed-edge is both a directed-edge-mixin and a graph-container-edge."))
100 ;;; ---------------------------------------------------------------------------
102 (defmethod initialize-instance :after ((object graph-container-directed-edge)
103 &key source-vertex target-vertex)
104 (when (and source-vertex (vertex-1 object))
105 (error "Specify source-vertex or vertex-1, but not both"))
106 (when (and target-vertex (vertex-2 object))
107 (error "Specify target-vertex or vertex-2, but not both"))
109 (setf (slot-value object 'vertex-1) source-vertex))
111 (setf (slot-value object 'vertex-2) target-vertex)))
113 ;;; ---------------------------------------------------------------------------
114 ;;; vertex-1 is defined to be the source vertex of an undirected edge
115 ;;; ---------------------------------------------------------------------------
117 (defmethod source-vertex ((edge graph-container-edge))
120 ;;; ---------------------------------------------------------------------------
121 ;;; vertex-2 is defined to be the target vertex of an undirected edge
122 ;;; ---------------------------------------------------------------------------
124 (defmethod target-vertex ((edge graph-container-edge))
127 ;;; ---------------------------------------------------------------------------
129 (defmethod other-vertex ((edge graph-container-edge)
130 (v graph-container-vertex))
131 (cond ((eq v (vertex-1 edge))
132 (values (vertex-2 edge)))
134 ((eq v (vertex-2 edge))
135 (values (vertex-1 edge)))
137 (t (error "Vertex ~A not part of Edge ~A" v edge))))
139 ;;; ---------------------------------------------------------------------------
141 (defmethod other-vertex ((edge graph-container-edge)
143 (other-vertex edge (find-vertex edge value)))
145 ;;; ---------------------------------------------------------------------------
147 (defmethod add-edge ((graph graph-container) (edge graph-container-edge)
149 (declare (ignore force-new?))
151 (bind ((vertex-1 (vertex-1 edge))
152 (vertex-2 (vertex-2 edge)))
154 (cond ((eq vertex-1 vertex-2)
155 (add-edge-to-vertex edge vertex-1))
157 (add-edge-to-vertex edge vertex-1)
158 (add-edge-to-vertex edge vertex-2))))
161 ;;; ---------------------------------------------------------------------------
163 (defmethod add-edge-to-vertex :around ((edge graph-container-edge)
164 (vertex graph-container-vertex))
165 (insert-item (vertex-edges vertex) edge))
167 ;;; ---------------------------------------------------------------------------
169 (defmethod make-node-for-container ((graph graph-container) (node t) &key)
170 (make-vertex-for-graph graph :element node))
172 ;;; ---------------------------------------------------------------------------
174 (defmethod find-edge-between-vertexes ((graph graph-container)
175 (vertex-1 graph-container-vertex)
176 (vertex-2 graph-container-vertex)
177 &key error-if-not-found?)
178 (declare (ignore error-if-not-found?))
179 (search-for-match (vertex-edges vertex-1)
181 (eq vertex-2 (other-vertex edge vertex-1)))))
183 ;;; ---------------------------------------------------------------------------
185 (defmethod find-edge-between-vertexes-if ((graph graph-container)
186 (vertex-1 graph-container-vertex)
187 (vertex-2 graph-container-vertex)
189 &key error-if-not-found?)
190 (declare (ignore error-if-not-found?))
191 (search-for-match (vertex-edges vertex-1)
193 (and (eq vertex-2 (other-vertex edge vertex-1))
194 (funcall fn edge)))))
196 ;;; ---------------------------------------------------------------------------
198 (defmethod find-edge-between-vertexes-if ((graph graph-container)
202 &key error-if-not-found?)
203 (bind ((v1 (find-vertex graph value-1 error-if-not-found?))
204 (v2 (find-vertex graph value-2 error-if-not-found?)))
205 (find-edge-between-vertexes-if
207 :error-if-not-found? error-if-not-found?)))
209 ;;; ---------------------------------------------------------------------------
211 (defmethod find-edge ((graph graph-container) (edge graph-container-edge)
212 &optional error-if-not-found?)
213 (find-edge-between-vertexes
214 graph (vertex-1 edge) (vertex-2 edge)
215 :error-if-not-found? error-if-not-found?))
217 ;;; ---------------------------------------------------------------------------
219 (defmethod delete-edge ((graph graph-container) (edge graph-container-edge))
220 (delete-item (vertex-edges (vertex-1 edge)) edge)
221 (delete-item (vertex-edges (vertex-2 edge)) edge)
224 ;;; ---------------------------------------------------------------------------
226 (defmethod iterate-edges ((graph graph-container) fn)
227 (iterate-elements (graph-edges graph) fn))
229 ;;; ---------------------------------------------------------------------------
231 (defmethod iterate-edges ((vertex graph-container-vertex) fn)
232 (iterate-elements (vertex-edges vertex) fn))
234 ;;; ---------------------------------------------------------------------------
236 (defmethod iterate-source-edges ((vertex graph-container-vertex) fn)
237 (iterate-elements (vertex-edges vertex)
239 (when (or (undirected-edge-p edge)
240 (eq vertex (target-vertex edge)))
241 (funcall fn edge)))))
243 ;;; ---------------------------------------------------------------------------
245 (defmethod iterate-target-edges ((vertex graph-container-vertex) fn)
246 (iterate-elements (vertex-edges vertex)
248 (when (or (undirected-edge-p edge)
249 (eq vertex (source-vertex edge)))
250 (funcall fn edge)))))
252 ;;; ---------------------------------------------------------------------------
254 (defmethod iterate-children ((vertex graph-container-vertex) fn)
255 (iterate-target-edges vertex
257 (funcall fn (other-vertex edge vertex)))))
259 ;;; ---------------------------------------------------------------------------
261 (defmethod iterate-parents ((vertex graph-container-vertex) fn)
262 (iterate-source-edges vertex
264 (funcall fn (other-vertex edge vertex)))))
266 ;;; ---------------------------------------------------------------------------
268 (defmethod iterate-neighbors ((vertex graph-container-vertex) fn)
269 (iterate-edges vertex
271 (funcall fn (other-vertex edge vertex)))))
273 ;;; ---------------------------------------------------------------------------
275 (defmethod vertexes ((edge graph-container-edge))
276 (collect-using #'iterate-vertexes nil edge))
278 ;;; ---------------------------------------------------------------------------
280 (defmethod has-children-p ((vertex graph-container-vertex))
281 (iterate-target-edges vertex
283 (declare (ignore edge))
284 (return-from has-children-p t)))
287 ;;; ---------------------------------------------------------------------------
289 (defmethod has-parent-p ((vertex graph-container-vertex))
290 (iterate-source-edges vertex
292 (declare (ignore edge))
293 (return-from has-parent-p t)))
296 ;;; ---------------------------------------------------------------------------
298 (defmethod vertices-share-edge-p ((vertex-1 graph-container-vertex)
299 (vertex-2 graph-container-vertex))
300 (iterate-target-edges vertex-1
302 (when (or (eq (target-vertex e) vertex-2)
303 (eq (source-vertex e) vertex-2))
304 (return-from vertices-share-edge-p t))))
306 (iterate-source-edges vertex-1
308 (when (or (eq (target-vertex e) vertex-2)
309 (eq (source-vertex e) vertex-2))
310 (return-from vertices-share-edge-p t))))
314 ;;; ---------------------------------------------------------------------------
316 (defmethod edge-count ((graph graph-container))
317 (size (graph-edges graph)))