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