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