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