dev/graph.lisp

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