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   (let ((it (search-for-match (vertex-edges vertex-1)
 197                               (lambda (edge)
 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))
 203     it))
 204
 205 ;;; ---------------------------------------------------------------------------
 206
 207 (defmethod find-edge-between-vertexes-if ((graph graph-container)
 208                                           (value-1 t)
 209                                           (value-2 t)
 210                                           fn
 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     (aif (and v1 v2 (find-edge-between-vertexes-if graph v1 v2 fn))
 215          it
 216          (when error-if-not-found?
 217            (error 'graph-edge-not-found-error :vertex-1 v1 :vertex-2 v2)))))
 218
 219 ;;; ---------------------------------------------------------------------------
 220
 221 (defmethod find-edge ((graph graph-container) (edge graph-container-edge)
 222                       &optional error-if-not-found?)
 223   (find-edge-between-vertexes
 224    graph (vertex-1 edge) (vertex-2 edge)
 225    :error-if-not-found? error-if-not-found?))
 226
 227 ;;; ---------------------------------------------------------------------------
 228
 229 (defmethod delete-edge ((graph graph-container) (edge graph-container-edge))
 230   (let ((vertex-1 (vertex-1 edge))
 231         (vertex-2 (vertex-2 edge)))
 232     (delete-item (vertex-edges vertex-1) edge)
 233     (delete-item (vertex-edges vertex-2) edge)
 234     (setf (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))
 235           (delete edge
 236                   (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))
 237                   :test #'eq)))
 238   edge)
 239
 240 ;;; ---------------------------------------------------------------------------
 241
 242 (defmethod empty! :after ((graph graph-container))
 243   (empty! (vertex-pair->edge graph)))
 244
 245
 246 ;;; ---------------------------------------------------------------------------
 247 ;;; iteration
 248 ;;; ---------------------------------------------------------------------------
 249
 250 (defmethod iterate-edges ((graph graph-container) fn)
 251   (iterate-elements (graph-edges graph) fn))
 252
 253 ;;; ---------------------------------------------------------------------------
 254
 255 (defmethod iterate-edges ((vertex graph-container-vertex) fn)
 256   (iterate-elements (vertex-edges vertex) fn))
 257
 258 ;;; ---------------------------------------------------------------------------
 259
 260 (defmethod iterate-source-edges ((vertex graph-container-vertex) fn)
 261   (iterate-elements (vertex-edges vertex)
 262                     (lambda (edge)
 263                       (when (or (undirected-edge-p edge)
 264                                 (eq vertex (target-vertex edge)))
 265                         (funcall fn edge)))))
 266
 267 ;;; ---------------------------------------------------------------------------
 268
 269 (defmethod iterate-target-edges ((vertex graph-container-vertex) fn)
 270   (iterate-elements (vertex-edges vertex)
 271                     (lambda (edge)
 272                       (when (or (undirected-edge-p edge)
 273                                 (eq vertex (source-vertex edge)))
 274                         (funcall fn edge)))))
 275
 276 ;;; ---------------------------------------------------------------------------
 277
 278 (defmethod iterate-children ((vertex graph-container-vertex) fn)
 279   (iterate-target-edges vertex
 280                         (lambda (edge)
 281                           (funcall fn (other-vertex edge vertex)))))
 282
 283 ;;; ---------------------------------------------------------------------------
 284
 285 (defmethod iterate-parents ((vertex graph-container-vertex) fn)
 286   (iterate-source-edges vertex
 287                         (lambda (edge)
 288                           (funcall fn (other-vertex edge vertex)))))
 289
 290 ;;; ---------------------------------------------------------------------------
 291
 292 (defmethod iterate-neighbors ((vertex graph-container-vertex) fn)
 293   (iterate-edges vertex
 294                  (lambda (edge)
 295                    (funcall fn (other-vertex edge vertex)))))
 296
 297 ;;; ---------------------------------------------------------------------------
 298
 299 (defmethod vertexes ((edge graph-container-edge))
 300   (collect-using #'iterate-vertexes nil edge))
 301
 302 ;;; ---------------------------------------------------------------------------
 303
 304 (defmethod has-children-p ((vertex graph-container-vertex))
 305   (iterate-target-edges vertex
 306                         (lambda (edge)
 307                           (declare (ignore edge))
 308                           (return-from has-children-p t)))
 309   (values nil))
 310
 311 ;;; ---------------------------------------------------------------------------
 312
 313 (defmethod has-parent-p ((vertex graph-container-vertex))
 314   (iterate-source-edges vertex
 315                         (lambda (edge)
 316                           (declare (ignore edge))
 317                           (return-from has-parent-p t)))
 318   (values nil))
 319
 320 ;;; ---------------------------------------------------------------------------
 321
 322 (defmethod vertices-share-edge-p ((vertex-1 graph-container-vertex)
 323                                   (vertex-2 graph-container-vertex))
 324   (iterate-target-edges vertex-1
 325                         (lambda (e)
 326                           (when (or (eq (target-vertex e) vertex-2)
 327                                     (eq (source-vertex e) vertex-2))
 328                             (return-from vertices-share-edge-p t))))
 329
 330   (iterate-source-edges vertex-1
 331                         (lambda (e)
 332                           (when (or (eq (target-vertex e) vertex-2)
 333                                     (eq (source-vertex e) vertex-2))
 334                             (return-from vertices-share-edge-p t))))
 335
 336   (values nil))
 337
 338 ;;; ---------------------------------------------------------------------------
 339
 340 (defmethod edge-count ((graph graph-container))
 341   (size (graph-edges graph)))
 342