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