dev/graph-container.lisp

   1
   2 #| simple-header
   3
   4 $Id: graph-container.lisp,v 1.12 2005/07/20 20:39:09 moody Exp $
   5
   6 Author: Gary King
   7
   8 DISCUSSION
   9
  10 |#
  11
  12 (in-package metabang.graph)
  13
  14 ;;; ---------------------------------------------------------------------------
  15 ;;; class defs
  16 ;;; ---------------------------------------------------------------------------
  17
  18 (defclass* graph-container (iteratable-container-mixin
  19                             non-associative-container-mixin
  20                             initial-contents-mixin
  21                             basic-graph
  22                             container-uses-nodes-mixin)
  23   ()
  24   (:default-initargs
  25     :vertex-class 'graph-container-vertex
  26     :directed-edge-class 'graph-container-directed-edge
  27     :undirected-edge-class 'graph-container-edge)
  28   (:export-p t)
  29   (:documentation "A graph container is essentially an adjacency list graph representation [?? The Bad name comes from it being implemented with containers... ugh]"))
  30
  31 ;;; ---------------------------------------------------------------------------
  32
  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)
  37   (:export-p t)
  38   (:documentation "This is the root class for edges in graph-containers. It adds vertex-1 and vertex-2 slots."))
  39
  40 ;;; ---------------------------------------------------------------------------
  41
  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)
  45             (value object))))
  46
  47 ;;; ---------------------------------------------------------------------------
  48
  49 (defclass* weighted-edge (weighted-edge-mixin graph-container-edge)
  50   ()
  51   (:export-p t)
  52   (:documentation "A weighted edge is both a weighted-edge-mixin and a graph-container-edge."))
  53
  54 ;;; ---------------------------------------------------------------------------
  55
  56 (defclass* graph-container-vertex (basic-vertex)
  57   ((vertex-edges nil r))
  58   (:export-p t)
  59   (:default-initargs
  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."))
  62
  63 ;;; ---------------------------------------------------------------------------
  64
  65 (defmethod make-vertex-edges-container ((vertex graph-container-vertex)
  66                                         container-class &rest args)
  67   (apply #'make-container container-class args))
  68
  69 ;;; ---------------------------------------------------------------------------
  70
  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)))
  75
  76 ;;; ---------------------------------------------------------------------------
  77
  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)))
  82
  83 ;;; ---------------------------------------------------------------------------
  84
  85 (defmethod make-edge-container ((graph graph-container) initial-size)
  86   (make-container 'vector-container :initial-size initial-size
  87                   :fill-pointer 0))
  88
  89
  90 ;;; ---------------------------------------------------------------------------
  91 ;;; graph-container-directed-edge
  92 ;;; ---------------------------------------------------------------------------
  93
  94 (defclass* graph-container-directed-edge (directed-edge-mixin
  95                                           graph-container-edge)
  96   ()
  97   (:export-p t)
  98   (:documentation "A graph-container-directed-edge is both a directed-edge-mixin and a graph-container-edge."))
  99
 100 ;;; ---------------------------------------------------------------------------
 101
 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"))
 108   (when source-vertex
 109     (setf (slot-value object 'vertex-1) source-vertex))
 110   (when target-vertex
 111     (setf (slot-value object 'vertex-2) target-vertex)))
 112
 113 ;;; ---------------------------------------------------------------------------
 114 ;;; vertex-1 is defined to be the source vertex of an undirected edge
 115 ;;; ---------------------------------------------------------------------------
 116
 117 (defmethod source-vertex ((edge graph-container-edge))
 118   (vertex-1 edge))
 119
 120 ;;; ---------------------------------------------------------------------------
 121 ;;; vertex-2 is defined to be the target vertex of an undirected edge
 122 ;;; ---------------------------------------------------------------------------
 123
 124 (defmethod target-vertex ((edge graph-container-edge))
 125   (vertex-2 edge))
 126
 127 ;;; ---------------------------------------------------------------------------
 128
 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)))
 133
 134         ((eq v (vertex-2 edge))
 135          (values (vertex-1 edge)))
 136
 137         (t (error "Vertex ~A not part of Edge ~A" v edge))))
 138
 139 ;;; ---------------------------------------------------------------------------
 140
 141 (defmethod other-vertex ((edge graph-container-edge)
 142                          (value t))
 143   (other-vertex edge (find-vertex edge value)))
 144
 145 ;;; ---------------------------------------------------------------------------
 146
 147 (defmethod add-edge ((graph graph-container) (edge graph-container-edge)
 148                      &key force-new?)
 149   (declare (ignore force-new?))
 150
 151   (bind ((vertex-1 (vertex-1 edge))
 152          (vertex-2 (vertex-2 edge)))
 153
 154     (cond ((eq vertex-1 vertex-2)
 155            (add-edge-to-vertex edge vertex-1))
 156           (t
 157            (add-edge-to-vertex edge vertex-1)
 158            (add-edge-to-vertex edge vertex-2))))
 159   edge)
 160
 161 ;;; ---------------------------------------------------------------------------
 162
 163 (defmethod add-edge-to-vertex :around ((edge graph-container-edge)
 164                                        (vertex graph-container-vertex))
 165   (insert-item (vertex-edges vertex) edge))
 166
 167 ;;; ---------------------------------------------------------------------------
 168
 169 (defmethod make-node-for-container ((graph graph-container) (node t) &key)
 170   (make-vertex-for-graph graph :element node))
 171
 172 ;;; ---------------------------------------------------------------------------
 173
 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)
 180                     (lambda (edge)
 181                       (eq vertex-2 (other-vertex edge vertex-1)))))
 182
 183 ;;; ---------------------------------------------------------------------------
 184
 185 (defmethod find-edge-between-vertexes-if ((graph graph-container)
 186                                           (vertex-1 graph-container-vertex)
 187                                           (vertex-2 graph-container-vertex)
 188                                           fn
 189                                           &key error-if-not-found?)
 190   (declare (ignore error-if-not-found?))
 191   (search-for-match (vertex-edges vertex-1)
 192                     (lambda (edge)
 193                       (and (eq vertex-2 (other-vertex edge vertex-1))
 194                            (funcall fn edge)))))
 195
 196 ;;; ---------------------------------------------------------------------------
 197
 198 (defmethod find-edge-between-vertexes-if ((graph graph-container)
 199                                           (value-1 t)
 200                                           (value-2 t)
 201                                           fn
 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
 206      graph v1 v2 fn
 207      :error-if-not-found? error-if-not-found?)))
 208
 209 ;;; ---------------------------------------------------------------------------
 210
 211
 212 (defmethod find-edge ((graph graph-container) (edge graph-container-edge)
 213                       &optional error-if-not-found?)
 214   (find-edge-between-vertexes
 215    graph (vertex-1 edge) (vertex-2 edge)
 216    :error-if-not-found? error-if-not-found?))
 217
 218 ;;; ---------------------------------------------------------------------------
 219
 220 (defmethod delete-edge ((graph graph-container) (edge graph-container-edge))
 221   (delete-item (vertex-edges (vertex-1 edge)) edge)
 222   (delete-item (vertex-edges (vertex-2 edge)) edge)
 223   edge)
 224
 225 ;;; ---------------------------------------------------------------------------
 226
 227 (defmethod iterate-edges ((graph graph-container) fn)
 228   (iterate-elements (graph-edges graph) fn))
 229
 230 ;;; ---------------------------------------------------------------------------
 231
 232 (defmethod iterate-edges ((vertex graph-container-vertex) fn)
 233   (iterate-elements (vertex-edges vertex) fn))
 234
 235 ;;; ---------------------------------------------------------------------------
 236
 237 (defmethod iterate-source-edges ((vertex graph-container-vertex) fn)
 238   (iterate-elements (vertex-edges vertex)
 239                     (lambda (edge)
 240                       (when (or (undirected-edge-p edge)
 241                                 (eq vertex (target-vertex edge)))
 242                         (funcall fn edge)))))
 243
 244 ;;; ---------------------------------------------------------------------------
 245
 246 (defmethod iterate-target-edges ((vertex graph-container-vertex) fn)
 247   (iterate-elements (vertex-edges vertex)
 248                     (lambda (edge)
 249                       (when (or (undirected-edge-p edge)
 250                                 (eq vertex (source-vertex edge)))
 251                         (funcall fn edge)))))
 252
 253 ;;; ---------------------------------------------------------------------------
 254
 255 (defmethod iterate-children ((vertex graph-container-vertex) fn)
 256   (iterate-target-edges vertex
 257                         (lambda (edge)
 258                           (funcall fn (other-vertex edge vertex)))))
 259
 260 ;;; ---------------------------------------------------------------------------
 261
 262 (defmethod iterate-parents ((vertex graph-container-vertex) fn)
 263   (iterate-source-edges vertex
 264                         (lambda (edge)
 265                           (funcall fn (other-vertex edge vertex)))))
 266
 267 ;;; ---------------------------------------------------------------------------
 268
 269 (defmethod iterate-neighbors ((vertex graph-container-vertex) fn)
 270   (iterate-edges vertex
 271                  (lambda (edge)
 272                    (funcall fn (other-vertex edge vertex)))))
 273
 274 ;;; ---------------------------------------------------------------------------
 275
 276 (defmethod vertexes ((edge graph-container-edge))
 277   (collect-using #'iterate-vertexes nil edge))
 278
 279 ;;; ---------------------------------------------------------------------------
 280
 281 (defmethod has-children-p ((vertex graph-container-vertex))
 282   (iterate-target-edges vertex
 283                         (lambda (edge)
 284                           (declare (ignore edge))
 285                           (return-from has-children-p t)))
 286   (values nil))
 287
 288 ;;; ---------------------------------------------------------------------------
 289
 290 (defmethod has-parent-p ((vertex graph-container-vertex))
 291   (iterate-source-edges vertex
 292                         (lambda (edge)
 293                           (declare (ignore edge))
 294                           (return-from has-parent-p t)))
 295   (values nil))
 296
 297 ;;; ---------------------------------------------------------------------------
 298
 299 (defmethod vertices-share-edge-p ((vertex-1 graph-container-vertex)
 300                                   (vertex-2 graph-container-vertex))
 301   (iterate-target-edges vertex-1
 302                         (lambda (e)
 303                           (when (or (eq (target-vertex e) vertex-2)
 304                                     (eq (source-vertex e) vertex-2))
 305                             (return-from vertices-share-edge-p t))))
 306
 307   (iterate-source-edges vertex-1
 308                         (lambda (e)
 309                           (when (or (eq (target-vertex e) vertex-2)
 310                                     (eq (source-vertex e) vertex-2))
 311                             (return-from vertices-share-edge-p t))))
 312
 313   (values nil))
 314
 315
 316 ;;; ***************************************************************************
 317 ;;; *                              End of File                                *
 318 ;;; ***************************************************************************