dev/graph.lisp

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