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   ((vertex-pair->edge (make-container 'simple-associative-container
  24                                       :test #'equal) r))
  25   (:default-initargs
  26     :vertex-class 'graph-container-vertex
  27     :directed-edge-class 'graph-container-directed-edge
  28     :undirected-edge-class 'graph-container-edge)
  29   (:export-p t)
  30   (:documentation "A graph container is essentially an adjacency list graph representation [?? The Bad name comes from it being implemented with containers... ugh]"))
  31
  32 ;;; ---------------------------------------------------------------------------
  33
  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)
  38   (:export-p t)
  39   (:documentation "This is the root class for edges in graph-containers. It adds vertex-1 and vertex-2 slots."))
  40
  41 ;;; ---------------------------------------------------------------------------
  42
  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)
  46             (value object))))
  47
  48 ;;; ---------------------------------------------------------------------------
  49
  50 (defclass* weighted-edge (weighted-edge-mixin graph-container-edge)
  51   ()
  52   (:export-p t)
  53   (:documentation "A weighted edge is both a weighted-edge-mixin and a graph-container-edge."))
  54
  55 ;;; ---------------------------------------------------------------------------
  56
  57 (defclass* graph-container-vertex (basic-vertex)
  58   ((vertex-edges nil r))
  59   (:export-p t)
  60   (:default-initargs
  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."))
  63
  64 ;;; ---------------------------------------------------------------------------
  65
  66 (defmethod make-vertex-edges-container ((vertex graph-container-vertex)
  67                                         container-class &rest args)
  68   (apply #'make-container container-class args))
  69
  70 ;;; ---------------------------------------------------------------------------
  71
  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)))
  76
  77 ;;; ---------------------------------------------------------------------------
  78
  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)))
  83
  84 ;;; ---------------------------------------------------------------------------
  85
  86 (defmethod make-edge-container ((graph graph-container) initial-size)
  87   (make-container 'vector-container :initial-size initial-size
  88                   :fill-pointer 0))
  89
  90
  91 ;;; ---------------------------------------------------------------------------
  92 ;;; graph-container-directed-edge
  93 ;;; ---------------------------------------------------------------------------
  94
  95 (defclass* graph-container-directed-edge (directed-edge-mixin
  96                                           graph-container-edge)
  97   ()
  98   (:export-p t)
  99   (:documentation "A graph-container-directed-edge is both a directed-edge-mixin and a graph-container-edge."))
 100
 101 ;;; ---------------------------------------------------------------------------
 102
 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"))
 109   (when source-vertex
 110     (setf (slot-value object 'vertex-1) source-vertex))
 111   (when target-vertex
 112     (setf (slot-value object 'vertex-2) target-vertex)))
 113
 114 ;;; ---------------------------------------------------------------------------
 115 ;;; vertex-1 is defined to be the source vertex of an undirected edge
 116 ;;; ---------------------------------------------------------------------------
 117
 118 (defmethod source-vertex ((edge graph-container-edge))
 119   (vertex-1 edge))
 120
 121 ;;; ---------------------------------------------------------------------------
 122 ;;; vertex-2 is defined to be the target vertex of an undirected edge
 123 ;;; ---------------------------------------------------------------------------
 124
 125 (defmethod target-vertex ((edge graph-container-edge))
 126   (vertex-2 edge))
 127
 128 ;;; ---------------------------------------------------------------------------
 129
 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)))
 134
 135         ((eq v (vertex-2 edge))
 136          (values (vertex-1 edge)))
 137
 138         (t (error "Vertex ~A not part of Edge ~A" v edge))))
 139
 140 ;;; ---------------------------------------------------------------------------
 141
 142 (defmethod other-vertex ((edge graph-container-edge)
 143                          (value t))
 144   (other-vertex edge (find-vertex edge value)))
 145
 146 ;;; ---------------------------------------------------------------------------
 147
 148 (defmethod add-edge ((graph graph-container) (edge graph-container-edge)
 149                      &key force-new?)
 150   (declare (ignore force-new?))
 151
 152   (bind ((vertex-1 (vertex-1 edge))
 153          (vertex-2 (vertex-2 edge)))
 154
 155     (cond ((eq vertex-1 vertex-2)
 156            (add-edge-to-vertex edge vertex-1))
 157           (t
 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))))
 161   edge)
 162
 163 ;;; ---------------------------------------------------------------------------
 164
 165 (defmethod add-edge-to-vertex :around ((edge graph-container-edge)
 166                                        (vertex graph-container-vertex))
 167   (insert-item (vertex-edges vertex) edge))
 168
 169 ;;; ---------------------------------------------------------------------------
 170
 171 (defmethod make-node-for-container ((graph graph-container) (node t) &key)
 172   (make-vertex-for-graph graph :element node))
 173
 174 ;;; ---------------------------------------------------------------------------
 175
 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?
 184                (not found?))
 185       (error 'graph-edge-not-found-error
 186              :vertex-1 vertex-1 :vertex-2 vertex-1))
 187     (first value)))
 188
 189 ;;; ---------------------------------------------------------------------------
 190
 191 (defmethod find-edge-between-vertexes-if ((graph graph-container)
 192                                           (vertex-1 graph-container-vertex)
 193                                           (vertex-2 graph-container-vertex)
 194                                           fn
 195                                           &key error-if-not-found?)
 196   (declare (ignore error-if-not-found?))
 197   (search-for-match (vertex-edges vertex-1)
 198                     (lambda (edge)
 199                       (and (eq vertex-2 (other-vertex edge vertex-1))
 200                            (funcall fn edge)))))
 201
 202 ;;; ---------------------------------------------------------------------------
 203
 204 (defmethod find-edge-between-vertexes-if ((graph graph-container)
 205                                           (value-1 t)
 206                                           (value-2 t)
 207                                           fn
 208                                           &key error-if-not-found?)
 209   (bind ((v1 (find-vertex graph value-1 error-if-not-found?))
 210          (v2 (find-vertex graph value-2 error-if-not-found?)))
 211     (find-edge-between-vertexes-if
 212      graph v1 v2 fn
 213      :error-if-not-found? error-if-not-found?)))
 214
 215 ;;; ---------------------------------------------------------------------------
 216
 217 (defmethod find-edge ((graph graph-container) (edge graph-container-edge)
 218                       &optional error-if-not-found?)
 219   (find-edge-between-vertexes
 220    graph (vertex-1 edge) (vertex-2 edge)
 221    :error-if-not-found? error-if-not-found?))
 222
 223 ;;; ---------------------------------------------------------------------------
 224
 225 (defmethod delete-edge ((graph graph-container) (edge graph-container-edge))
 226   (let ((vertex-1 (vertex-1 edge))
 227         (vertex-2 (vertex-2 edge)))
 228     (delete-item (vertex-edges vertex-1) edge)
 229     (delete-item (vertex-edges vertex-2) edge)
 230     (setf (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))
 231           (delete (cons vertex-1 vertex-2)
 232                   (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))
 233                   :test #'equal)))
 234   edge)
 235
 236 ;;; ---------------------------------------------------------------------------
 237
 238 (defmethod empty! :after ((graph graph-container))
 239   (empty! (vertex-pair->edge graph)))
 240
 241
 242 ;;; ---------------------------------------------------------------------------
 243 ;;; iteration
 244 ;;; ---------------------------------------------------------------------------
 245
 246 (defmethod iterate-edges ((graph graph-container) fn)
 247   (iterate-elements (graph-edges graph) fn))
 248
 249 ;;; ---------------------------------------------------------------------------
 250
 251 (defmethod iterate-edges ((vertex graph-container-vertex) fn)
 252   (iterate-elements (vertex-edges vertex) fn))
 253
 254 ;;; ---------------------------------------------------------------------------
 255
 256 (defmethod iterate-source-edges ((vertex graph-container-vertex) fn)
 257   (iterate-elements (vertex-edges vertex)
 258                     (lambda (edge)
 259                       (when (or (undirected-edge-p edge)
 260                                 (eq vertex (target-vertex edge)))
 261                         (funcall fn edge)))))
 262
 263 ;;; ---------------------------------------------------------------------------
 264
 265 (defmethod iterate-target-edges ((vertex graph-container-vertex) fn)
 266   (iterate-elements (vertex-edges vertex)
 267                     (lambda (edge)
 268                       (when (or (undirected-edge-p edge)
 269                                 (eq vertex (source-vertex edge)))
 270                         (funcall fn edge)))))
 271
 272 ;;; ---------------------------------------------------------------------------
 273
 274 (defmethod iterate-children ((vertex graph-container-vertex) fn)
 275   (iterate-target-edges vertex
 276                         (lambda (edge)
 277                           (funcall fn (other-vertex edge vertex)))))
 278
 279 ;;; ---------------------------------------------------------------------------
 280
 281 (defmethod iterate-parents ((vertex graph-container-vertex) fn)
 282   (iterate-source-edges vertex
 283                         (lambda (edge)
 284                           (funcall fn (other-vertex edge vertex)))))
 285
 286 ;;; ---------------------------------------------------------------------------
 287
 288 (defmethod iterate-neighbors ((vertex graph-container-vertex) fn)
 289   (iterate-edges vertex
 290                  (lambda (edge)
 291                    (funcall fn (other-vertex edge vertex)))))
 292
 293 ;;; ---------------------------------------------------------------------------
 294
 295 (defmethod vertexes ((edge graph-container-edge))
 296   (collect-using #'iterate-vertexes nil edge))
 297
 298 ;;; ---------------------------------------------------------------------------
 299
 300 (defmethod has-children-p ((vertex graph-container-vertex))
 301   (iterate-target-edges vertex
 302                         (lambda (edge)
 303                           (declare (ignore edge))
 304                           (return-from has-children-p t)))
 305   (values nil))
 306
 307 ;;; ---------------------------------------------------------------------------
 308
 309 (defmethod has-parent-p ((vertex graph-container-vertex))
 310   (iterate-source-edges vertex
 311                         (lambda (edge)
 312                           (declare (ignore edge))
 313                           (return-from has-parent-p t)))
 314   (values nil))
 315
 316 ;;; ---------------------------------------------------------------------------
 317
 318 (defmethod vertices-share-edge-p ((vertex-1 graph-container-vertex)
 319                                   (vertex-2 graph-container-vertex))
 320   (iterate-target-edges vertex-1
 321                         (lambda (e)
 322                           (when (or (eq (target-vertex e) vertex-2)
 323                                     (eq (source-vertex e) vertex-2))
 324                             (return-from vertices-share-edge-p t))))
 325
 326   (iterate-source-edges vertex-1
 327                         (lambda (e)
 328                           (when (or (eq (target-vertex e) vertex-2)
 329                                     (eq (source-vertex e) vertex-2))
 330                             (return-from vertices-share-edge-p t))))
 331
 332   (values nil))
 333
 334 ;;; ---------------------------------------------------------------------------
 335
 336 (defmethod edge-count ((graph graph-container))
 337   (size (graph-edges graph)))
 338