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 graph-leafs ((graph basic-graph))
 648   (collect-elements (graph-vertexes graph) :filter #'leafp))
 649
 650
 651 (defmethod rootp ((vertex basic-vertex))
 652   ;;?? this is inefficient in the same way that (zerop (length <list>)) is...
 653   (zerop (target-edge-count vertex)))
 654
 655
 656 (defmethod leafp ((vertex basic-vertex))
 657   (zerop (source-edge-count vertex)))
 658
 659
 660 (defmethod find-vertex-if ((graph basic-graph) fn &key key)
 661   (iterate-vertexes graph
 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-vertex-if ((edge basic-edge) fn &key key)
 669   (iterate-vertexes edge
 670                     (lambda (v)
 671                       (when (funcall fn (if key (funcall key v) v))
 672                         (return-from find-vertex-if v))))
 673   (values nil))
 674
 675
 676 (defmethod find-edge-if ((graph basic-graph) fn &key key)
 677   (iterate-edges graph
 678                  (lambda (e)
 679                    (when (funcall fn (if key (funcall key e) e))
 680                      (return-from find-edge-if e))))
 681   (values nil))
 682
 683
 684 (defmethod find-edges-if ((graph basic-graph) fn)
 685   (collect-using 'iterate-edges fn graph))
 686
 687
 688 (defmethod find-vertexes-if ((graph basic-graph) fn)
 689   (collect-using 'iterate-vertexes fn graph))
 690
 691
 692 (defmethod empty! ((graph basic-graph))
 693   (empty! (graph-edges graph))
 694   (empty! (graph-vertexes graph))
 695   (renumber-edges graph)
 696   (renumber-vertexes graph)
 697   (values))
 698
 699
 700 (defun neighbors-to-children (new-graph root &optional visited-list)
 701   (pushnew root visited-list)
 702   (iterate-neighbors
 703    root
 704    (lambda (c)
 705      (when (not (member c visited-list))
 706        (add-edge-between-vertexes
 707         new-graph (value root) (value c) :edge-type :directed)
 708        (neighbors-to-children new-graph c visited-list)))))
 709
 710
 711 (defmethod generate-directed-free-tree ((graph basic-graph) root)
 712   (generate-directed-free-tree graph (find-vertex graph root)))
 713
 714
 715 (defmethod force-undirected ((graph basic-graph))
 716   (iterate-edges
 717    graph
 718    (lambda (edge)
 719      (change-class edge (undirected-edge-class graph)))))
 720
 721
 722
 723 ;;; traversal
 724
 725 (defmethod traverse-elements ((thing basic-graph) (style symbol) fn)
 726   (let ((marker (gensym)))
 727     (iterate-vertexes
 728      thing
 729      (lambda (vertex)
 730        (setf (tag vertex) marker)))
 731
 732     (iterate-elements
 733      (graph-roots thing)
 734      (lambda (vertex)
 735        (traverse-elements-helper vertex style marker fn)))))
 736
 737
 738 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
 739   (when (eq (tag thing) marker)
 740     (setf (tag thing) nil)
 741     (iterate-children
 742      thing
 743      (lambda (vertex)
 744        (traverse-elements-helper vertex style marker fn)))
 745
 746     (funcall fn thing)))
 747
 748
 749 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
 750   (when (eq (tag thing) marker)
 751     (setf (tag thing) nil)
 752     (funcall fn thing))
 753
 754   (iterate-neighbors
 755    thing
 756    (lambda (vertex)
 757      (when (eq (tag vertex) marker)
 758        (funcall fn vertex))))
 759
 760   (iterate-neighbors
 761    thing
 762    (lambda (vertex)
 763      (when (eq (tag vertex) marker)
 764        (setf (tag vertex) nil)
 765        (traverse-elements-helper vertex style marker fn)))))
 766
 767 ;; also in metatilites
 768 (defun graph-search-for-cl-graph (states goal-p successors combiner
 769                                   &key (state= #'eql) old-states
 770                                   (new-state-fn (error "argument required")))
 771   "Find a state that satisfies goal-p.  Start with states,
 772   and search according to successors and combiner.
 773   Don't try the same state twice."
 774   (cond ((null states) nil)
 775         ((funcall goal-p (first states)) (first states))
 776         (t (graph-search-for-cl-graph
 777              (funcall
 778                combiner
 779                (funcall new-state-fn states successors state= old-states)
 780                (rest states))
 781              goal-p successors combiner
 782              :state= state=
 783              :old-states (adjoin (first states) old-states
 784                                  :test state=)
 785              :new-state-fn new-state-fn))))
 786
 787 (defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
 788   (let ((first-time? t))
 789     (not (null
 790           (graph-search-for-cl-graph
 791            (list start-vertex)
 792            (lambda (v)
 793              (if first-time?
 794                (setf first-time? nil)
 795                (eq (find-vertex graph v) start-vertex)))
 796            (lambda (v)
 797              (child-vertexes v))
 798            #'append
 799            :new-state-fn
 800            (lambda (states successors state= old-states)
 801              ;; Generate successor states that have not been seen before but
 802              ;; don't remove the start state.
 803              (remove-if
 804               #'(lambda (state)
 805                   (and (not (eq start-vertex state))
 806                        (or (member state states :test state=)
 807                            (member state old-states :test state=))))
 808               (funcall successors (first states)))))))))
 809
 810
 811 (defmethod in-undirected-cycle-p
 812            ((graph basic-graph) (current basic-vertex)
 813             &optional (marked (make-container 'simple-associative-container))
 814             (previous nil))
 815   (block do-it
 816     (setf (item-at-1 marked current) t)
 817     (iterate-children current
 818                       (lambda (child)
 819                         (cond
 820                          ((eq child previous) nil)
 821                          ((item-at-1 marked child) (return-from do-it t))
 822                          (t
 823                           (in-undirected-cycle-p graph child marked current)))))))
 824
 825
 826 (defmethod any-undirected-cycle-p ((graph basic-graph))
 827   (let ((marked (make-container 'simple-associative-container)))
 828     (iterate-vertexes graph (lambda (v)
 829                               (unless (item-at-1 marked v)
 830                                 (when (in-undirected-cycle-p graph v marked)
 831                                   (return-from any-undirected-cycle-p v)))))
 832     (values nil)))
 833
 834
 835 (defun remove-list (original target)
 836   "Removes all elements in original from target."
 837   (remove-if (lambda (target-element)
 838                (member target-element original))
 839              target))
 840
 841
 842 (defun get-nodelist-relatives (node-list)
 843   "Collects set of unique relatives of nodes in node-list."
 844   (let ((unique-relatives nil))
 845     (dolist (node node-list)
 846       (setf unique-relatives
 847             (append-unique (neighbor-vertexes node) unique-relatives)))
 848     unique-relatives))
 849
 850
 851 (defun get-transitive-closure (vertex-list &optional (depth nil))
 852   "Given a list of vertices, returns a combined list of all of the nodes
 853 in the transitive closure(s) of each of the vertices in the list
 854 (without duplicates).  Optional DEPTH limits the depth (in _both_ the
 855 child and parent directions) to which the closure is gathered; default
 856 nil gathers the entire closure(s)."
 857   (labels ((collect-transitive-closure (remaining visited depth)
 858              (if (and remaining
 859                       (typecase depth
 860                         (null t)
 861                         (fixnum (>= (decf depth) 0))))
 862
 863               (let* ((non-visited-relatives     ;; list of relatives not yet visited
 864                        (remove-list visited
 865                                     (get-nodelist-relatives remaining)))
 866                       (visited-nodes            ;; list of nodes visited so far
 867                        (append-unique non-visited-relatives visited)))
 868                  (collect-transitive-closure non-visited-relatives
 869                                              visited-nodes
 870                                              depth))
 871                (values visited))))
 872     (collect-transitive-closure vertex-list vertex-list depth)))
 873
 874
 875 (defmethod edge-count ((graph basic-graph))
 876   (count-using #'iterate-edges nil graph))
 877
 878
 879 (defmethod edge-count ((vertex basic-vertex))
 880   (size (vertex-edges vertex)))
 881
 882
 883 (defmethod topological-sort ((graph basic-graph))
 884   (assign-level graph 0)
 885   (sort (collect-elements (graph-vertexes graph))  #'<
 886         :key (lambda (x) (depth-level x))))
 887
 888
 889 (defmethod assign-level ((graph basic-graph) (level number))
 890   (loop for node in (graph-roots graph)
 891         do (assign-level node 0)))
 892
 893
 894 (defmethod assign-level ((node basic-vertex) (level number))
 895   (if (or (not (depth-level node))
 896           (> level (depth-level node)))
 897     (setf (depth-level node) level))
 898   (iterate-children node (lambda (x) (assign-level x (1+ level)))))
 899
 900
 901 (defmethod depth ((graph basic-graph))
 902   (assign-level graph 0)
 903   (let ((depth 0))
 904     (iterate-vertexes graph (lambda (vertex)
 905                               (when (> (depth-level vertex) depth)
 906                                 (setf depth (depth-level vertex)))))
 907     depth))
 908
 909 ;;; mapping
 910
 911 (defun map-paths (graph start-vertex length fn &key (filter (constantly t)))
 912   "Apply fn to each path that starts at start-vertex and is of exactly length
 913 length"
 914   ;; a sort of depth first search
 915   (labels ((follow-path (next-vertex current-path length)
 916              (when (zerop length)
 917                (funcall fn (reverse current-path)))
 918              ; (format t "~%~A ~A ~A" current-path next-vertex length)
 919              (when (plusp length)
 920                (iterate-neighbors
 921                 next-vertex
 922                 (lambda (v)
 923                   (when (funcall filter v)
 924                     ;; no repeats
 925                     (unless (find-item current-path v)
 926                       (let ((new-path  (copy-list current-path)))
 927                         (follow-path v (push v new-path) (1- length))))))))))
 928     (iterate-neighbors
 929      start-vertex
 930      (lambda (v)
 931        (when (funcall filter v)
 932          (follow-path v (list v start-vertex) (1- length))))))
 933   (values graph))
 934
 935
 936 (defun map-shortest-paths
 937     (graph start-vertex depth fn &key (filter (constantly t)))
 938   "Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration."
 939   (let ((visited (make-container 'simple-associative-container
 940                                   :test #'equal)))
 941     (labels ((visit (p)
 942                (setf (item-at-1 visited p) t))
 943              (visited-p (p)
 944                (item-at-1 visited p))
 945              )
 946       (loop for n from 1 to (1- depth) do
 947             (map-paths graph start-vertex n
 948                        (lambda (p)
 949                          (visit (first (last p))))
 950                        :filter filter))
 951       ;(break)
 952       (visit start-vertex)
 953       (map-paths graph start-vertex depth
 954                  (lambda (p)
 955                    (unless (visited-p (first (last p)))
 956                      (funcall fn p)))
 957                  :filter filter))))
 958
 959
 960 ;;; utilities
 961
 962 (defun append-unique (list1 list2)
 963   (remove-duplicates (append list1 list2)))
 964
 965 ;;; project-bipartite-graph
 966
 967 (defmethod project-bipartite-graph
 968            ((new-graph symbol) graph vertex-class vertex-classifier)
 969   (project-bipartite-graph
 970    (make-instance new-graph) graph vertex-class  vertex-classifier))
 971
 972
 973 (defmethod project-bipartite-graph
 974            ((new-graph basic-graph) graph vertex-class vertex-classifier)
 975   (iterate-vertexes
 976    graph
 977    (lambda (v)
 978      (when (eq (funcall vertex-classifier v) vertex-class)
 979        (add-vertex new-graph (element v)))))
 980
 981   (iterate-vertexes
 982    graph
 983    (lambda (v)
 984      (when (eq (funcall vertex-classifier v) vertex-class)
 985        (iterate-neighbors
 986         v
 987         (lambda (other-class-vertex)
 988           (iterate-neighbors
 989            other-class-vertex
 990            (lambda (this-class-vertex)
 991              (when (< (vertex-id v) (vertex-id this-class-vertex))
 992                (add-edge-between-vertexes
 993                 new-graph (element v) (element this-class-vertex)
 994                 :if-duplicate-do (lambda (e) (incf (weight e))))))))))))
 995
 996   new-graph)
 997
 998 #+Test
 999 (pro:with-profiling
1000   (setf (ds :g-5000-m-projection)
1001         (project-bipartite-graph
1002          'undirected-graph-container
1003          (ds :g-5000)
1004          :m
1005          (lambda (v)
1006            (let ((vertex-class (aref (symbol-name (element v)) 0)))
1007              (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1008                     :m)
1009                    ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1010                     :h)))))))
1011
1012 #+Test
1013 (pro:with-profiling
1014   (setf (ds :g-5000-h-projection)
1015         (project-bipartite-graph
1016          'undirected-graph-container
1017          (ds :g-5000)
1018          :h
1019          (lambda (v)
1020            (let ((vertex-class (aref (symbol-name (element v)) 0)))
1021              (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1022                     :m)
1023                    ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1024                     :h)))))))
1025
1026 #+Test
1027 (pro:with-profiling
1028   (project-bipartite-graph
1029    'undirected-graph-container
1030    (ds :g-1000)
1031    :m
1032    (lambda (v)
1033      (let ((vertex-class (aref (symbol-name (element v)) 0)))
1034        (cond ((member vertex-class '(#\x #\y) :test #'char-equal)
1035               :m)
1036              ((member vertex-class '(#\a #\b #\c) :test #'char-equal)
1037               :h))))))
1038
1039
1040
1041