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