dev/graph.lisp

   1 ;;;-*- Mode: Lisp; Package: metabang.graph -*-
   2
   3 #|
   4 $Id: graph.lisp,v 1.30 2005/09/07 16:17:06 gwking Exp $
   5
   6 Author: Gary W. King, et. al.
   7
   8 |#
   9
  10 #| NOTES
  11
  12 something is putting something on the vertexes plist's
  13
  14 |#
  15
  16
  17 (in-package #:metabang.graph)
  18
  19 ;;; ---------------------------------------------------------------------------
  20 ;;; classes
  21 ;;; ---------------------------------------------------------------------------
  22
  23 (defcondition graph-error (error)
  24   ((graph nil ir))
  25   (:export-p t)
  26   (:export-slots-p t)
  27   (:documentation "This is the root condition for errors that occur while running code in CL-Graph."))
  28
  29 ;;; ---------------------------------------------------------------------------
  30
  31 (defcondition edge-error (graph-error)
  32   ((edge nil ir "The `edge` that is implicated in the condition."))
  33   (:export-p t)
  34   (:export-slots-p t)
  35   (:documentation "This is the root condition for graph errors that have to do with edges."))
  36
  37 ;;; ---------------------------------------------------------------------------
  38
  39 (defcondition graph-vertex-not-found-error (graph-error)
  40   ((vertex nil ir "The vertex or value that could not be found in the graph."))
  41   (:report (lambda (c s)
  42              (format s "Vertex ~S not found in ~A" (vertex c) (graph c))))
  43   (:export-p t)
  44   (:export-slots-p t)
  45   (:documentation "This condition is signaled when a vertex can not be found in a graph."))
  46
  47 ;;; ---------------------------------------------------------------------------
  48
  49 (defcondition graph-vertex-not-found-in-edge-error (edge-error)
  50   ((vertex nil ir))
  51   (:report (lambda (c s)
  52              (format s "Vertex ~S not found in ~A" (vertex c) (edge c))))
  53   (:export-p t)
  54   (:documentation "This condition is signaled when a vertex can not be found in an edge."))
  55
  56 ;;; ---------------------------------------------------------------------------
  57
  58 (defcondition graph-edge-not-found-error (graph-error)
  59   ((vertex-1 nil ir "One of the vertexes for which no connecting edge could be found.")
  60    (vertex-2 nil ir "One of the vertexes for which no connecting edge could be found."))
  61   (:report (lambda (c s)
  62              (format s "Edge between ~S and ~S not found in ~A"
  63                      (vertex-1 c) (vertex-2 c) (graph c))))
  64   (:export-p t)
  65   (:export-slots-p t)
  66   (:documentation "This condition is signaled when an edge cannot be found in a graph."))
  67
  68 ;;; ---------------------------------------------------------------------------
  69
  70 (defclass* basic-vertex (container-node-mixin)
  71   ((depth-level 0 ia :type number "`Depth-level` is used by some algorithms for bookkeeping.  [?? Should be in a mixin]")
  72    (vertex-id 0 ir "`Vertex-id` is used internally to keep track of vertexes.")
  73    (element :unbound ia :accessor value "The `element` is the value that this vertex represents.")
  74    (tag nil ia "The `tag` slot is used by some algorithms to keep track of which vertexes have been visited.")
  75    (graph nil ia "The graph in which this vertex is contained.")
  76    (color nil ia "The `color` slot is used by some algorithms for bookkeeping.")
  77    (rank nil ia "The `rank` is used by some algorithms for bookkeeping.  [?? Should be in a mixin]")
  78    (previous-node nil ia "`Previous-node` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
  79    (next-node nil ia "`Next-node` is used by some algorithms for bookkeeping.  [?? Should be in a mixin]")
  80    (discovery-time -1 ia "`Discovery-time` is used by some algorithms for bookkeeping.  [?? Should be in a mixin]")
  81    (finish-time -1 ia "`Finish-time` is used by some algorithms for bookkeeping.  [?? Should be in a mixin]"))
  82   (:export-p t)
  83   (:export-slots vertex-id tag rank color previous-node next-node
  84                  discovery-time finish-time)
  85   (:make-load-form-p t)
  86   (:documentation "This is the root class for all vertexes in CL-Graph."))
  87
  88 ;;; ---------------------------------------------------------------------------
  89
  90 (defmethod initialize-instance :after ((object basic-vertex) &key graph vertex-id)
  91   (when (and graph (not vertex-id))
  92     (setf (slot-value object 'vertex-id)
  93           (largest-vertex-id graph))
  94     (incf (slot-value graph 'largest-vertex-id))))
  95
  96 ;;; ---------------------------------------------------------------------------
  97
  98 (defmethod print-object ((vertex basic-vertex) stream)
  99   (print-unreadable-object (vertex stream :identity nil)
 100     (format stream "~A"
 101             (if (and (slot-exists-p vertex 'element) (slot-boundp vertex 'element))
 102               (element vertex) "#unbound#"))))
 103
 104 ;;; ---------------------------------------------------------------------------
 105
 106 (defclass* basic-edge ()
 107   ((edge-id 0 ia "The `edge-id` is used internally by CL-Graph for bookkeeping.")
 108    (element nil ia :accessor value :initarg :value)
 109    (tag nil ia "The `tag` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]")
 110    (graph nil ir "The `graph` of which this edge is a part.")
 111    (color nil ia "The `color` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]"))
 112   (:export-p t)
 113   (:export-slots edge-id element tag color)
 114   (:make-load-form-p t)
 115   (:documentation "This is the root class for all edges in CL-Graph."))
 116
 117 ;;; ---------------------------------------------------------------------------
 118
 119 (defmethod initialize-instance :after ((object basic-edge) &key graph edge-id)
 120   (when (and graph (not edge-id))
 121     (setf (slot-value object 'edge-id)
 122           (largest-edge-id graph))
 123     (incf (slot-value graph 'largest-edge-id))))
 124
 125 ;;; ---------------------------------------------------------------------------
 126
 127 (defmethod print-object ((object basic-edge) stream)
 128   (print-unreadable-object (object stream :type t)
 129     (format stream "<~A ~A>" (vertex-1 object) (vertex-2 object))))
 130
 131 ;;; ---------------------------------------------------------------------------
 132
 133 (defclass* directed-edge-mixin () ()
 134   (:export-p t)
 135   (:documentation "This mixin class is used to indicate that an edge is directed."))
 136
 137 ;;; ---------------------------------------------------------------------------
 138
 139 (defclass* weighted-edge-mixin ()
 140   ((weight 1d0 ia "The value of the weight of this edge. Defaults to 1.0d0"))
 141   :export-slots
 142   (:export-p t)
 143   (:documentation "This mixin class adds a `weight` slot to an edge."))
 144
 145 ;;; ---------------------------------------------------------------------------
 146
 147 (defmethod weight ((edge basic-edge)) (values 1.0))
 148
 149 ;;; ---------------------------------------------------------------------------
 150
 151 (defclass* basic-graph ()
 152   ((graph-vertexes :unbound ir)
 153    (graph-edges :unbound ir)
 154    (largest-vertex-id 0 r)
 155    (largest-edge-id 0 r)
 156    (vertex-class 'basic-vertex ir
 157                  "The class of the vertexes in the graph. This must extend the base-class for vertexes of the graph type. E.g., all vertexes of a graph-container must extend graph-container-vertex.")
 158    (directed-edge-class 'basic-directed-edge ir
 159                         "The class used to create directed edges in the graph. This must extend the base-class for edges of the graph type and directed-edge-mixin. E.g., the directed-edge-class of a graph-container must extend graph-container-edge and directed-edge-mixin.")
 160    (undirected-edge-class 'basic-edge ir
 161                           "The class used to create undirected edges in the graph. This must extend the base-class for edges of the graph type. E.g., all edges of a graph-container must extend graph-container-edge")
 162    (contains-directed-edge-p nil ar
 163                              "Returns true if graph contains at least one directed edge. [?? Not sure if this is really keep up-to-date.]")
 164    (contains-undirected-edge-p nil ar
 165                                "Returns true if graph contains at least one undirected edge. [?? Not sure if this is really keep up-to-date.]")
 166    (vertex-test #'eq ir)
 167    (vertex-key #'identity ir)
 168    (edge-test #'eq ir)
 169    (edge-key #'identity ir)
 170    (default-edge-type nil ir
 171      "The default edge type for the graph. This should be one of :undirected or :directed.")
 172    (default-edge-class nil ir
 173      "The default edge class for the graph."))
 174   (:make-load-form-p t)
 175   (:export-slots vertex-class directed-edge-class undirected-edge-class
 176                  default-edge-type default-edge-class)
 177   (:default-initargs
 178     :initial-size 25)
 179   (:documentation "This is the root class for all graphs in CL-Graph."))
 180
 181 ;;; ---------------------------------------------------------------------------
 182
 183 (defmethod initialize-instance :after ((object basic-graph) &key initial-size
 184                                        &allow-other-keys)
 185   (setf (slot-value object 'graph-vertexes)
 186         (make-vertex-container object initial-size))
 187   (setf (slot-value object 'graph-edges)
 188         (make-edge-container object initial-size)))
 189
 190 ;;; ---------------------------------------------------------------------------
 191
 192 (defmethod print-object ((graph basic-graph) stream)
 193   (print-unreadable-object (graph stream :type t :identity t)
 194     (format stream "[~A,~A]" (size graph) (edge-count graph))))
 195
 196
 197 ;;; ---------------------------------------------------------------------------
 198 ;;; internals
 199 ;;; ---------------------------------------------------------------------------
 200
 201 (defmethod add-vertex ((graph basic-graph) (value basic-vertex) &key if-duplicate-do)
 202   (declare (ignore if-duplicate-do))
 203   (values value))
 204
 205 ;;; ---------------------------------------------------------------------------
 206
 207 (defmethod make-vertex-for-graph ((graph basic-graph) &rest args &key
 208                                   (vertex-class (vertex-class graph))
 209                                   &allow-other-keys)
 210   (remf args :vertex-class)
 211   (assert (subtypep vertex-class (vertex-class graph)) nil
 212           "Vertex class '~A' must be a subtype of ~A" vertex-class (vertex-class graph))
 213   (apply #'make-instance vertex-class :graph graph args))
 214
 215 ;;; ---------------------------------------------------------------------------
 216
 217 (defmethod make-edge-for-graph ((graph basic-graph)
 218                                 (vertex-1 basic-vertex) (vertex-2 basic-vertex)
 219                                 &rest args &key
 220                                 (edge-type (default-edge-type graph))
 221                                 (edge-class (default-edge-class graph))
 222                                 &allow-other-keys)
 223   (remf args :edge-class)
 224   (remf args :edge-type)
 225   (assert (or (null edge-type)
 226               (eq edge-type :directed)
 227               (eq edge-type :undirected)) nil
 228           "Edge-type must be nil, :directed or :undirected.")
 229
 230   (assert (or (null edge-class)
 231               (subtypep edge-class (directed-edge-class graph))
 232               (subtypep edge-class (undirected-edge-class graph))) nil
 233           "Edge-class must be nil or a subtype of ~A or ~A"
 234           (undirected-edge-class graph)
 235           (directed-edge-class graph))
 236
 237   (apply #'make-instance
 238          (or edge-class
 239              (ecase edge-type
 240                (:directed (directed-edge-class graph))
 241                (:undirected (undirected-edge-class graph))
 242                ((nil) nil))
 243              (undirected-edge-class graph))
 244          :graph graph
 245          :vertex-1 vertex-1 :vertex-2 vertex-2 args))
 246
 247 ;;; ---------------------------------------------------------------------------
 248
 249 (defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys)
 250   (apply #'make-instance graph-type args))
 251
 252 ;;; ---------------------------------------------------------------------------
 253 ;;; generic implementation
 254 ;;; ---------------------------------------------------------------------------
 255
 256 (defmethod undirected-edge-p ((edge basic-edge))
 257   (not (directed-edge-p edge)))
 258
 259 ;;; ---------------------------------------------------------------------------
 260
 261 (defmethod directed-edge-p ((edge basic-edge))
 262   (typep edge 'directed-edge-mixin))
 263
 264 ;;; ---------------------------------------------------------------------------
 265
 266 (defmethod tagged-edge-p ((edge basic-edge))
 267   (tag edge))
 268
 269 ;;; ---------------------------------------------------------------------------
 270
 271 (defmethod untagged-edge-p ((edge basic-edge))
 272   (null (tag edge)))
 273
 274 ;;; ---------------------------------------------------------------------------
 275
 276 (defmethod tag-all-edges ((graph basic-graph))
 277   (iterate-edges
 278    graph
 279    (lambda (e)
 280      (setf (tag e) t))))
 281
 282 ;;; ---------------------------------------------------------------------------
 283
 284 (defmethod tag-all-edges ((vertex basic-vertex))
 285   (iterate-edges
 286    vertex
 287    (lambda (e)
 288      (setf (tag e) t))))
 289
 290 ;;; ---------------------------------------------------------------------------
 291
 292 (defmethod untag-all-edges ((graph basic-graph))
 293   (iterate-edges
 294    graph
 295    (lambda (e)
 296      (setf (tag e) nil))))
 297
 298 ;;; ---------------------------------------------------------------------------
 299
 300 (defmethod untag-all-edges ((vertex basic-vertex))
 301   (iterate-edges
 302    vertex
 303    (lambda (e)
 304      (setf (tag e) nil))))
 305
 306 ;;; ---------------------------------------------------------------------------
 307
 308 (defmethod untag-edges ((edges list))
 309   (iterate-nodes
 310    edges
 311    (lambda (e)
 312      (setf (tag e) nil))))
 313
 314 ;;; ---------------------------------------------------------------------------
 315
 316 (defmethod tag-edges ((edges list))
 317   (iterate-nodes
 318    edges
 319    (lambda (e)
 320      (setf (tag e) t))))
 321
 322
 323 ;;; ---------------------------------------------------------------------------
 324
 325 (defmethod (setf element) :around ((value t) (vertex basic-vertex))
 326   (with-changing-vertex (vertex)
 327     (call-next-method)))
 328
 329 ;;; ---------------------------------------------------------------------------
 330
 331 ;; :ignore, :force, :replace, <function>
 332
 333 (defmethod add-vertex ((graph basic-graph) (value t) &rest args &key
 334                        (if-duplicate-do :ignore) &allow-other-keys)
 335   (remf args :if-duplicate-do)
 336   (let ((existing-vertex (find-vertex graph value nil)))
 337     (labels ((make-it ()
 338                (apply #'make-vertex-for-graph graph :element value args))
 339              (add-it (why)
 340                (values (add-vertex graph (make-it)) why)))
 341       (if existing-vertex
 342         (cond ((eq if-duplicate-do :ignore)
 343                (values existing-vertex :ignore))
 344
 345               ((eq if-duplicate-do :force)
 346                (add-it :force))
 347
 348               ((eq if-duplicate-do :replace)
 349                (replace-vertex graph existing-vertex (make-it)))
 350
 351               ((eq if-duplicate-do :replace-value)
 352                (setf (element existing-vertex) value)
 353                (values existing-vertex :replace-value))
 354
 355               (t
 356                (values (funcall if-duplicate-do existing-vertex)
 357                        :duplicate)))
 358
 359         ;; not found, add
 360         (add-it :new)))))
 361
 362 ;;; ---------------------------------------------------------------------------
 363
 364 (defmethod replace-vertex ((graph basic-graph) (old basic-vertex) (new basic-vertex))
 365   ;; we need the graph and the new vertex to reference each other
 366   ;; we need every edge of the old vertex to use the new-vertex
 367   ;; we need to remove the old vertex
 368   ;;
 369   ;; since I'm tired today, let's ignore trying to make this elegant
 370
 371   ;; first, we connect the edges to the new vertex so that they don't get deleted
 372   ;; when we delete the old vertex
 373   (iterate-edges
 374    old
 375    (lambda (e)
 376      (if (eq (vertex-1 e) old)
 377        (setf (slot-value e 'vertex-1) new) (setf (slot-value e 'vertex-2) new))
 378      (add-edge-to-vertex e new)))
 379
 380   (delete-vertex graph old)
 381   (add-vertex graph new))
 382
 383 ;;; ---------------------------------------------------------------------------
 384
 385 (defmethod add-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
 386                                       &rest args &key (if-duplicate-do :ignore)
 387                                       &allow-other-keys)
 388   (declare (ignore if-duplicate-do)
 389            (dynamic-extent args))
 390   (let ((v1 (or (find-vertex graph value-1 nil)
 391                 (add-vertex graph value-1 :if-duplicate-do :ignore)))
 392         (v2 (or (find-vertex graph value-2 nil)
 393                 (add-vertex graph value-2  :if-duplicate-do :replace))))
 394     (apply #'add-edge-between-vertexes graph v1 v2 args)))
 395
 396 ;;; ---------------------------------------------------------------------------
 397 ;;; to-do - add-edge-between-vertexes needs to be able to grab the weight and
 398 ;;; color from edges that inherit from weight and color mixins
 399 ;;; ---------------------------------------------------------------------------
 400
 401 (defmethod add-edge-between-vertexes ((graph basic-graph)
 402                                       (v-1 basic-vertex) (v-2 basic-vertex)
 403                                       &rest args &key
 404                                       (value nil) (if-duplicate-do :ignore)
 405                                       &allow-other-keys)
 406   (declare (dynamic-extent args))
 407   (remf args :if-duplicate-do)
 408
 409   (let ((edge (find-edge-between-vertexes graph v-1 v-2 :error-if-not-found? nil)))
 410     (flet ((add-it (why)
 411              (values (add-edge
 412                       graph
 413                       (apply #'make-edge-for-graph graph v-1 v-2 args))
 414                      why)))
 415       (if edge
 416         (cond
 417          ((eq if-duplicate-do :ignore)
 418           (values edge :ignore))
 419
 420          ((eq if-duplicate-do :force)
 421           (add-it :force))
 422
 423          ((eq if-duplicate-do :force-if-different-value)
 424           (if (equal (value edge) value)
 425             (values :ignore)
 426             (add-it :force)))
 427
 428
 429          ((eq if-duplicate-do :replace)
 430           (warn "replace edges isn't really implemented, maybe you can use :replace-value")
 431           (delete-edge graph edge)
 432           (add-it :replace))
 433
 434          ((eq if-duplicate-do :replace-value)
 435           (setf (element edge) value)
 436           (values edge :replace-value))
 437
 438          (t
 439           (setf edge (funcall if-duplicate-do edge))
 440           (values edge :duplicate)))
 441
 442         ;; not found, add
 443         (add-it :new)))))
 444
 445
 446 ;;; ---------------------------------------------------------------------------
 447
 448 (defmethod add-edge-to-vertex ((edge basic-edge) (vertex basic-vertex))
 449   (values))
 450
 451 ;;; ---------------------------------------------------------------------------
 452
 453 (defmethod find-edge-between-vertexes
 454     ((graph basic-graph) (value-1 t) (value-2 t)
 455      &key (error-if-not-found? t))
 456   (let* ((v1 (find-vertex graph value-1 error-if-not-found?))
 457          (v2 (find-vertex graph value-2 error-if-not-found?)))
 458     (or (and v1 v2 (find-edge-between-vertexes graph v1 v2))
 459         (when error-if-not-found?
 460           (error 'graph-edge-not-found-error
 461                  :graph graph :vertex-1 v1 :vertex-2 v2)))))
 462
 463 ;;; ---------------------------------------------------------------------------
 464
 465 (defmethod delete-edge-between-vertexes ((graph basic-graph)
 466                                          (value-or-vertex-1 t)
 467                                          (value-or-vertex-2 t) &rest args)
 468   (let ((edge (apply #'find-edge-between-vertexes
 469                      graph value-or-vertex-1 value-or-vertex-2 args)))
 470     (when edge
 471       (delete-edge graph edge))))
 472
 473 ;;; ---------------------------------------------------------------------------
 474
 475 (defmethod delete-edge :after ((graph basic-graph) (edge basic-edge))
 476   (delete-item (graph-edges graph) edge)
 477   edge)
 478
 479
 480 (defmethod delete-all-edges :after ((graph basic-graph))
 481   (empty! (graph-edges graph))
 482   graph)
 483
 484 ;;; ---------------------------------------------------------------------------
 485
 486 (defmethod delete-vertex ((graph basic-graph) value-or-vertex)
 487   (delete-vertex graph (find-vertex graph value-or-vertex)))
 488
 489 ;;; ---------------------------------------------------------------------------
 490
 491 (defmethod delete-vertex ((graph basic-graph) (vertex basic-vertex))
 492   (unless (eq graph (graph vertex))
 493     (error 'graph-vertex-not-found-error
 494            :graph graph :vertex vertex))
 495
 496   (iterate-edges
 497    vertex
 498    (lambda (edge)
 499      (delete-edge graph edge)))
 500
 501   (empty! (vertex-edges vertex))
 502   (values vertex graph))
 503
 504 ;;; ---------------------------------------------------------------------------
 505
 506 (defmethod delete-vertex :after ((graph basic-graph)
 507                                  (vertex basic-vertex))
 508   (setf (slot-value vertex 'graph) nil)
 509   (delete-item-at (graph-vertexes graph)
 510                   (funcall (vertex-key graph) (element vertex))))
 511
 512 ;;; ---------------------------------------------------------------------------
 513
 514 (defmethod insert-item ((graph basic-graph) value)
 515   (add-vertex graph value))
 516
 517 ;;; ---------------------------------------------------------------------------
 518
 519 (defmethod source-edges ((vertex basic-vertex) &optional filter)
 520   (collect-using #'iterate-source-edges filter vertex))
 521
 522 ;;; ---------------------------------------------------------------------------
 523
 524 (defmethod target-edges ((vertex basic-vertex) &optional filter)
 525   (collect-using #'iterate-target-edges filter vertex))
 526
 527 ;;; ---------------------------------------------------------------------------
 528
 529 (defmethod child-vertexes (vertex &optional filter)
 530   (collect-using #'iterate-children filter vertex))
 531
 532 ;;; ---------------------------------------------------------------------------
 533
 534 (defmethod parent-vertexes (vertex &optional filter)
 535   (collect-using #'iterate-parents filter vertex))
 536
 537 ;;; ---------------------------------------------------------------------------
 538
 539 (defmethod neighbor-vertexes (vertex &optional filter)
 540   (collect-using #'iterate-neighbors filter vertex))
 541
 542 ;;; ---------------------------------------------------------------------------
 543
 544 (defmethod adjacentp ((graph basic-graph) vertex-1 vertex-2)
 545   (adjacentp graph (find-vertex graph vertex-1) (find-vertex graph vertex-2)))
 546
 547 ;;; ---------------------------------------------------------------------------
 548
 549 (defmethod adjacentp ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex))
 550   (iterate-neighbors
 551    vertex-1
 552    (lambda (vertex)
 553      (when (eq vertex vertex-2)
 554        (return-from adjacentp t))))
 555   (values nil))
 556
 557 ;;; ---------------------------------------------------------------------------
 558
 559 (defmethod number-of-neighbors (vertex)
 560   (count-using #'iterate-neighbors nil vertex))
 561
 562 ;;; ---------------------------------------------------------------------------
 563
 564 (defmethod in-cycle-p ((graph basic-graph) (vertex t))
 565   (in-cycle-p graph (find-vertex graph vertex)))
 566
 567 ;;; ---------------------------------------------------------------------------
 568
 569 (defmethod renumber-vertexes ((graph basic-graph))
 570   (let ((count 0))
 571     (iterate-vertexes graph (lambda (vertex)
 572                               (setf (slot-value vertex 'vertex-id) count)
 573                               (incf count)))
 574     (setf (slot-value graph 'largest-vertex-id) count)))
 575
 576 ;;; ---------------------------------------------------------------------------
 577
 578 (defmethod renumber-edges ((graph basic-graph))
 579   (let ((count 0))
 580     (iterate-edges graph (lambda (vertex)
 581                            (setf (slot-value vertex 'edge-id) count)
 582                            (incf count)))
 583     (setf (slot-value graph 'largest-edge-id) count)))
 584
 585 ;;; ---------------------------------------------------------------------------
 586
 587 (deprecated
 588   (defmethod container->list ((graph basic-graph))
 589     (collect-elements (graph-vertexes graph))))
 590
 591 ;;; ---------------------------------------------------------------------------
 592
 593 (defmethod add-vertex :before ((graph basic-graph) (vertex basic-vertex)
 594                                &key &allow-other-keys)
 595
 596   (assert (typep vertex (vertex-class graph)))
 597   (setf (item-at (graph-vertexes graph)
 598                  (funcall (vertex-key graph) (element vertex))) vertex
 599         (slot-value vertex 'graph) graph))
 600
 601 ;;; ---------------------------------------------------------------------------
 602
 603 (defmethod add-edge :before ((graph basic-graph) (edge basic-edge) &key force-new?)
 604   (declare (ignore force-new?))
 605   (insert-item (graph-edges graph) edge)
 606   (setf (slot-value edge 'graph) graph)
 607   (if (subtypep (class-name (class-of edge)) 'directed-edge-mixin)
 608     (progn (setf (contains-directed-edge-p graph) t))
 609     (progn (setf (contains-undirected-edge-p graph) t))))
 610
 611 ;;; ---------------------------------------------------------------------------
 612
 613 (defmethod find-vertex ((graph basic-graph) (value t)
 614                         &optional (error-if-not-found? t))
 615   (or (find-item (graph-vertexes graph) (funcall (vertex-key graph) value))
 616       (when error-if-not-found?
 617         (error 'graph-vertex-not-found-error :vertex value :graph graph))))
 618
 619 (defmethod find-vertex ((graph basic-graph) (vertex basic-vertex)
 620                         &optional (error-if-not-found? t))
 621   (cond ((eq graph (graph vertex))
 622          vertex)
 623         (t
 624          (when error-if-not-found?
 625            (error 'graph-vertex-not-found-error
 626                   :vertex vertex :graph graph)))))
 627
 628 (defmethod find-vertex ((edge basic-edge) (value t)
 629                         &optional (error-if-not-found? t))
 630   (iterate-vertexes
 631    edge
 632    (lambda (vertex)
 633      (when (funcall (vertex-test (graph edge))
 634                     (funcall (vertex-key (graph edge)) (element vertex)) value)
 635        (return-from find-vertex vertex))))
 636   (when error-if-not-found?
 637     (error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge)))
 638
 639
 640 (defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex)
 641                               &key (key (vertex-key graph)) (test 'equal)
 642                               (error-if-not-found? t))
 643   (or (search-for-node (graph-vertexes graph) vertex :test test :key key)
 644       (when error-if-not-found?
 645         (error "~A not found in ~A" vertex graph))))
 646
 647 (defmethod search-for-vertex ((graph basic-graph) (vertex t)
 648                               &key (key (vertex-key graph)) (test 'equal)
 649                               (error-if-not-found? t))
 650   (or (search-for-element (graph-vertexes graph) vertex :test test :key key)
 651       (when error-if-not-found?
 652         (error "~A not found in ~A" vertex graph))))
 653
 654 (defmethod iterate-elements ((graph basic-graph) fn)
 655    (iterate-elements (graph-vertexes graph)
 656                      (lambda (vertex) (funcall fn (element vertex)))))
 657
 658 ;;; ---------------------------------------------------------------------------
 659
 660 (defmethod iterate-nodes ((graph basic-graph) fn)
 661    (iterate-nodes (graph-vertexes graph) fn))
 662
 663 ;;; ---------------------------------------------------------------------------
 664
 665 (defmethod iterate-vertexes ((graph basic-graph) fn)
 666    (iterate-nodes (graph-vertexes graph) fn))
 667
 668 ;;; ---------------------------------------------------------------------------
 669
 670 (defmethod iterate-vertexes ((edge basic-edge) fn)
 671   (funcall fn (vertex-1 edge))
 672   (funcall fn (vertex-2 edge)))
 673
 674 ;;; ---------------------------------------------------------------------------
 675
 676 (defmethod size ((graph basic-graph))
 677   (size (graph-vertexes graph)))
 678
 679 ;;; ---------------------------------------------------------------------------
 680
 681 (defmethod edges ((graph basic-graph))
 682   (collect-using #'iterate-edges nil graph))
 683
 684 ;;; ---------------------------------------------------------------------------
 685
 686 (defmethod edges ((vertex basic-vertex))
 687   (collect-using #'iterate-edges nil vertex))
 688
 689 ;;; ---------------------------------------------------------------------------
 690
 691 (deprecated
 692   "Use size instead"
 693   (defmethod vertex-count ((graph basic-graph))
 694     (size graph)))
 695
 696 ;;; ---------------------------------------------------------------------------
 697
 698 (defmethod vertexes ((graph basic-graph))
 699   (collect-elements (graph-vertexes graph)))
 700
 701 ;;; ---------------------------------------------------------------------------
 702
 703 (defmethod source-edge-count ((vertex basic-vertex))
 704   (count-using 'iterate-source-edges nil vertex))
 705
 706 ;;; ---------------------------------------------------------------------------
 707
 708 (defmethod target-edge-count ((vertex basic-vertex))
 709   (count-using 'iterate-target-edges nil vertex))
 710
 711 ;;; ---------------------------------------------------------------------------
 712
 713 (defmethod graph-roots ((graph basic-graph))
 714   (collect-elements (graph-vertexes graph) :filter #'rootp))
 715
 716 ;;; ---------------------------------------------------------------------------
 717
 718 (defmethod rootp ((vertex basic-vertex))
 719   ;;?? this is inefficient in the same way that (zerop (length <list>)) is...
 720   (zerop (source-edge-count vertex)))
 721
 722 ;;; ---------------------------------------------------------------------------
 723
 724 (defmethod find-vertex-if ((graph basic-graph) fn &key key)
 725   (iterate-vertexes graph
 726                     (lambda (v)
 727                       (when (funcall fn (if key (funcall key v) v))
 728                         (return-from find-vertex-if v))))
 729   (values nil))
 730
 731 ;;; ---------------------------------------------------------------------------
 732
 733 (defmethod find-vertex-if ((edge basic-edge) fn &key key)
 734   (iterate-vertexes edge
 735                     (lambda (v)
 736                       (when (funcall fn (if key (funcall key v) v))
 737                         (return-from find-vertex-if v))))
 738   (values nil))
 739
 740 ;;; ---------------------------------------------------------------------------
 741
 742 (defmethod find-edge-if ((graph basic-graph) fn &key key)
 743   (iterate-edges graph
 744                  (lambda (e)
 745                    (when (funcall fn (if key (funcall key e) e))
 746                      (return-from find-edge-if e))))
 747   (values nil))
 748
 749 ;;; ---------------------------------------------------------------------------
 750
 751 (defmethod find-edges-if ((graph basic-graph) fn)
 752   (collect-using 'iterate-edges fn graph))
 753
 754 ;;; ---------------------------------------------------------------------------
 755
 756 (defmethod find-vertexes-if ((graph basic-graph) fn)
 757   (collect-using 'iterate-vertexes fn graph))
 758
 759 ;;; ---------------------------------------------------------------------------
 760
 761 (defmethod empty! ((graph basic-graph))
 762   (empty! (graph-edges graph))
 763   (empty! (graph-vertexes graph))
 764   (renumber-edges graph)
 765   (renumber-vertexes graph)
 766   (values))
 767
 768 ;;; ---------------------------------------------------------------------------
 769
 770 (defun neighbors-to-children (new-graph root &optional visited-list)
 771   (pushnew root visited-list)
 772   (iterate-neighbors
 773    root
 774    (lambda (c)
 775      (when (not (member c visited-list))
 776        (add-edge-between-vertexes
 777         new-graph (value root) (value c) :edge-type :directed)
 778        (neighbors-to-children new-graph c visited-list)))))
 779
 780 ;;; ---------------------------------------------------------------------------
 781
 782 (defmethod generate-directed-free-tree ((graph basic-graph) root)
 783   (generate-directed-free-tree graph (find-vertex graph root)))
 784
 785 ;;; ---------------------------------------------------------------------------
 786
 787 (defmethod force-undirected ((graph basic-graph))
 788   (iterate-edges
 789    graph
 790    (lambda (edge)
 791      (change-class edge (undirected-edge-class graph)))))
 792
 793
 794
 795 ;;; ---------------------------------------------------------------------------
 796 ;;; traversal
 797 ;;; ---------------------------------------------------------------------------
 798
 799 (defmethod traverse-elements ((thing basic-graph) (style symbol) fn)
 800   (let ((marker (gensym)))
 801     (iterate-vertexes
 802      thing
 803      (lambda (vertex)
 804        (setf (tag vertex) marker)))
 805
 806     (iterate-elements
 807      (graph-roots thing)
 808      (lambda (vertex)
 809        (traverse-elements-helper vertex style marker fn)))))
 810
 811 ;;; ---------------------------------------------------------------------------
 812
 813 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
 814   (when (eq (tag thing) marker)
 815     (setf (tag thing) nil)
 816     (iterate-children
 817      thing
 818      (lambda (vertex)
 819        (traverse-elements-helper vertex style marker fn)))
 820
 821     (funcall fn thing)))
 822
 823 ;;; ---------------------------------------------------------------------------
 824
 825 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
 826   (when (eq (tag thing) marker)
 827     (setf (tag thing) nil)
 828     (funcall fn thing))
 829
 830   (iterate-neighbors
 831    thing
 832    (lambda (vertex)
 833      (when (eq (tag vertex) marker)
 834        (funcall fn vertex))))
 835
 836   (iterate-neighbors
 837    thing
 838    (lambda (vertex)
 839      (when (eq (tag vertex) marker)
 840        (setf (tag vertex) nil)
 841        (traverse-elements-helper vertex style marker fn)))))
 842
 843 ;;; ---------------------------------------------------------------------------
 844
 845 ;; also in metatilites
 846 (defun graph-search-for-cl-graph (states goal-p successors combiner
 847                                   &key (state= #'eql) old-states
 848                                   (new-state-fn #'new-states))
 849   "Find a state that satisfies goal-p.  Start with states,
 850   and search according to successors and combiner.
 851   Don't try the same state twice."
 852   (cond ((null states) nil)
 853         ((funcall goal-p (first states)) (first states))
 854         (t (graph-search-for-cl-graph
 855              (funcall
 856                combiner
 857                (funcall new-state-fn states successors state= old-states)
 858                (rest states))
 859              goal-p successors combiner
 860              :state= state=
 861              :old-states (adjoin (first states) old-states
 862                                  :test state=)
 863              :new-state-fn new-state-fn))))
 864
 865 (defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
 866   (let ((first-time? t))
 867     (not (null
 868           (graph-search-for-cl-graph
 869            (list start-vertex)
 870            (lambda (v)
 871              (if first-time?
 872                (setf first-time? nil)
 873                (eq (find-vertex graph v) start-vertex)))
 874            (lambda (v)
 875              (child-vertexes v))
 876            #'append
 877            :new-state-fn
 878            (lambda (states successors state= old-states)
 879              ;; Generate successor states that have not been seen before but
 880              ;; don't remove the start state.
 881              (remove-if
 882               #'(lambda (state)
 883                   (and (not (eq start-vertex state))
 884                        (or (member state states :test state=)
 885                            (member state old-states :test state=))))
 886               (funcall successors (first states)))))))))
 887
 888 ;;; ---------------------------------------------------------------------------
 889
 890 (defmethod in-undirected-cycle-p
 891            ((graph basic-graph) (current basic-vertex)
 892             &optional (marked (make-container 'simple-associative-container))
 893             (previous nil))
 894   (block do-it
 895     (setf (item-at-1 marked current) t)
 896     (iterate-children current
 897                       (lambda (child)
 898                         (cond
 899                          ((eq child previous) nil)
 900                          ((item-at-1 marked child) (return-from do-it t))
 901                          (t
 902                           (in-undirected-cycle-p graph child marked current)))))))
 903
 904 ;;; ---------------------------------------------------------------------------
 905
 906 (defmethod any-undirected-cycle-p ((graph basic-graph))
 907   (let ((marked (make-container 'simple-associative-container)))
 908     (iterate-vertexes graph (lambda (v)
 909                               (unless (item-at-1 marked v)
 910                                 (when (in-undirected-cycle-p graph v marked)
 911                                   (return-from any-undirected-cycle-p v)))))
 912     (values nil)))
 913
 914 ;;; ---------------------------------------------------------------------------
 915
 916 (defun remove-list (original target)
 917   "Removes all elements in original from target."
 918   (remove-if (lambda (target-element)
 919                (member target-element original))
 920              target))
 921
 922 ;;; ---------------------------------------------------------------------------
 923
 924 (defun get-nodelist-relatives (node-list)
 925   "Collects set of unique relatives of nodes in node-list."
 926   (let ((unique-relatives nil))
 927     (dolist (node node-list)
 928       (setf unique-relatives
 929             (append-unique (neighbor-vertexes node) unique-relatives)))
 930     unique-relatives))
 931
 932 ;;; ---------------------------------------------------------------------------
 933
 934 (defun get-transitive-closure (vertex-list &optional (depth nil))
 935   "Given a list of vertices, returns a combined list of all of the nodes
 936 in the transitive closure(s) of each of the vertices in the list
 937 (without duplicates).  Optional DEPTH limits the depth (in _both_ the
 938 child and parent directions) to which the closure is gathered; default
 939 nil gathers the entire closure(s)."
 940   (labels ((collect-transitive-closure (remaining visited depth)
 941              (if (and remaining
 942                       (typecase depth
 943                         (null t)
 944                         (fixnum (>= (decf depth) 0))))
 945
 946               (let* ((non-visited-relatives     ;; list of relatives not yet visited
 947                        (remove-list visited
 948                                     (get-nodelist-relatives remaining)))
 949                       (visited-nodes            ;; list of nodes visited so far
 950                        (append-unique non-visited-relatives visited)))
 951                  (collect-transitive-closure non-visited-relatives
 952                                              visited-nodes
 953                                              depth))
 954                (values visited))))
 955     (collect-transitive-closure vertex-list vertex-list depth)))
 956
 957 ;;; ---------------------------------------------------------------------------
 958
 959 (defmethod edge-count ((graph basic-graph))
 960   (count-using #'iterate-edges nil graph))
 961
 962 ;;; ---------------------------------------------------------------------------
 963
 964 (defmethod edge-count ((vertex basic-vertex))
 965   (size (vertex-edges vertex)))
 966
 967 ;;; ---------------------------------------------------------------------------
 968
 969 (defmethod topological-sort ((graph basic-graph))
 970   (assign-level graph 0)
 971   (sort (collect-elements (graph-vertexes graph))  #'<
 972         :key (lambda (x) (depth-level x))))
 973
 974 ;;; ---------------------------------------------------------------------------
 975
 976 (defmethod assign-level ((graph basic-graph) (level number))
 977   (loop for node in (graph-roots graph)
 978         do (assign-level node 0)))
 979
 980 ;;; ---------------------------------------------------------------------------
 981
 982 (defmethod assign-level ((node basic-vertex) (level number))
 983   (if (or (not (depth-level node))
 984           (> level (depth-level node)))
 985     (setf (depth-level node) level))
 986   (iterate-children node (lambda (x) (assign-level x (1+ level)))))
 987
 988 ;;; ---------------------------------------------------------------------------
 989
 990 (defmethod depth ((graph basic-graph))
 991   (assign-level graph 0)
 992   (let ((depth 0))
 993     (iterate-vertexes graph (lambda (vertex)
 994                               (when (> (depth-level vertex) depth)
 995                                 (setf depth (depth-level vertex)))))
 996     depth))
 997
 998 ;;; ---------------------------------------------------------------------------
 999 ;;; mapping
1000 ;;; ---------------------------------------------------------------------------
1001
1002 (defun map-paths (graph start-vertex length fn &key (filter (constantly t)))
1003   "Apply fn to each path that starts at start-vertex and is of exactly length
1004 length"
1005   ;; a sort of depth first search
1006   (labels ((follow-path (next-vertex current-path length)
1007              (when (zerop length)
1008                (funcall fn (reverse current-path)))
1009              ; (format t "~%~A ~A ~A" current-path next-vertex length)
1010              (when (plusp length)
1011                (iterate-neighbors
1012                 next-vertex
1013                 (lambda (v)
1014                   (when (funcall filter v)
1015                     ;; no repeats
1016                     (unless (find-item current-path v)
1017                       (let ((new-path  (copy-list current-path)))
1018                         (follow-path v (push v new-path) (1- length))))))))))
1019     (iterate-neighbors
1020      start-vertex
1021      (lambda (v)
1022        (when (funcall filter v)
1023          (follow-path v (list v start-vertex) (1- length))))))
1024   (values graph))
1025
1026 ;;; ---------------------------------------------------------------------------
1027
1028 (defun map-shortest-paths (graph start-vertex depth fn &key (filter (constantly t)))
1029   "Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration."
1030   (bind ((visited (make-container 'simple-associative-container
1031                                   :test #'equal)))
1032     (labels ((visit (p)
1033                (setf (item-at-1 visited p) t))
1034              (visited-p (p)
1035                (item-at-1 visited p))
1036              )
1037       (loop for n from 1 to (1- depth) do
1038             (map-paths graph start-vertex n
1039                        (lambda (p)
1040                          (visit (first (last p))))
1041                        :filter filter))
1042       ;(break)
1043       (visit start-vertex)
1044       (map-paths graph start-vertex depth
1045                  (lambda (p)
1046                    (unless (visited-p (first (last p)))
1047                      (funcall fn p)))
1048                  :filter filter))))
1049
1050
1051 ;;; ---------------------------------------------------------------------------
1052 ;;; utilities
1053 ;;; ---------------------------------------------------------------------------
1054
1055 (defun append-unique (list1 list2)
1056   (remove-duplicates (append list1 list2)))
1057
1058 ;;; ---------------------------------------------------------------------------
1059 ;;; project-bipartite-graph
1060 ;;; ---------------------------------------------------------------------------
1061
1062 (defmethod project-bipartite-graph
1063            ((new-graph symbol) graph vertex-class vertex-classifier)
1064   (project-bipartite-graph
1065    (make-instance new-graph) graph vertex-class  vertex-classifier))
1066
1067 ;;; ---------------------------------------------------------------------------
1068
1069 (defmethod project-bipartite-graph
1070            ((new-graph basic-graph) graph vertex-class vertex-classifier)
1071   (iterate-vertexes
1072    graph
1073    (lambda (v)
1074      (when (eq (funcall vertex-classifier v) vertex-class)
1075        (add-vertex new-graph (element v)))))
1076
1077   (iterate-vertexes
1078    graph
1079    (lambda (v)
1080      (when (eq (funcall vertex-classifier v) vertex-class)
1081        (iterate-neighbors
1082         v
1083         (lambda (other-class-vertex)
1084           (iterate-neighbors
1085            other-class-vertex
1086            (lambda (this-class-vertex)
1087              (when (< (vertex-id v) (vertex-id this-class-vertex))
1088                (add-edge-between-vertexes
1089                 new-graph (element v) (element this-class-vertex)
1090                 :if-duplicate-do (lambda (e) (incf (weight e))))))))))))
1091
1092   new-graph)
1093
1094 #+Test
1095 (pro:with-profiling
1096   (setf (ds :g-5000-m-projection)
1097         (project-bipartite-graph
1098          'undirected-graph-container
1099          (ds :g-5000)
1100          :m
1101          (lambda (v)
1102            (let ((vertex-class (aref (symbol-name (element v)) 0)))
1103              (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1104                     :m)
1105                    ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1106                     :h)))))))
1107
1108 #+Test
1109 (pro:with-profiling
1110   (setf (ds :g-5000-h-projection)
1111         (project-bipartite-graph
1112          'undirected-graph-container
1113          (ds :g-5000)
1114          :h
1115          (lambda (v)
1116            (let ((vertex-class (aref (symbol-name (element v)) 0)))
1117              (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1118                     :m)
1119                    ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1120                     :h)))))))
1121
1122 #+Test
1123 (pro:with-profiling
1124   (project-bipartite-graph
1125    'undirected-graph-container
1126    (ds :g-1000)
1127    :m
1128    (lambda (v)
1129      (let ((vertex-class (aref (symbol-name (element v)) 0)))
1130        (cond ((member vertex-class '(#\x #\y) :test #'char-equal)
1131               :m)
1132              ((member vertex-class '(#\a #\b #\c) :test #'char-equal)
1133               :h))))))
1134
1135
1136
1137