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   (assert (or (null edge-type)
 226               (eq edge-type :directed)
 227               (eq edge-type :undirected)) nil
 228           "Edge-type must be nil, :directed or :undirected.")
 229
 230   (assert (or (null edge-class)
 231               (subtypep edge-class (directed-edge-class graph))
 232               (subtypep edge-class (undirected-edge-class graph))) nil
 233           "Edge-class must be nil or a subtype of ~A or ~A"
 234           (undirected-edge-class graph)
 235           (directed-edge-class graph))
 236
 237   (apply #'make-instance
 238          (or edge-class
 239              (ecase edge-type
 240                (:directed (directed-edge-class graph))
 241                (:undirected (undirected-edge-class graph))
 242                ((nil) nil))
 243              (undirected-edge-class graph))
 244          :graph graph
 245          :vertex-1 vertex-1 :vertex-2 vertex-2 args))
 246
 247 ;;; ---------------------------------------------------------------------------
 248
 249 (defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys)
 250   (apply #'make-instance graph-type args))
 251
 252 ;;; ---------------------------------------------------------------------------
 253
 254 (defmethod make-graph ((classes list) &rest args)
 255   (let ((name (dynamic-classes:find-or-create-class 'basic-graph classes)))
 256     (apply #'make-instance name args)))
 257
 258 ;;; ---------------------------------------------------------------------------
 259 ;;; generic implementation
 260 ;;; ---------------------------------------------------------------------------
 261
 262 (defmethod undirected-edge-p ((edge basic-edge))
 263   (not (directed-edge-p edge)))
 264
 265 ;;; ---------------------------------------------------------------------------
 266
 267 (defmethod directed-edge-p ((edge basic-edge))
 268   (typep edge 'directed-edge-mixin))
 269
 270 ;;; ---------------------------------------------------------------------------
 271
 272 (defmethod tagged-edge-p ((edge basic-edge))
 273   (tag edge))
 274
 275 ;;; ---------------------------------------------------------------------------
 276
 277 (defmethod untagged-edge-p ((edge basic-edge))
 278   (null (tag edge)))
 279
 280 ;;; ---------------------------------------------------------------------------
 281
 282 (defmethod tag-all-edges ((graph basic-graph))
 283   (iterate-edges
 284    graph
 285    (lambda (e)
 286      (setf (tag e) t))))
 287
 288 ;;; ---------------------------------------------------------------------------
 289
 290 (defmethod tag-all-edges ((vertex basic-vertex))
 291   (iterate-edges
 292    vertex
 293    (lambda (e)
 294      (setf (tag e) t))))
 295
 296 ;;; ---------------------------------------------------------------------------
 297
 298 (defmethod untag-all-edges ((graph basic-graph))
 299   (iterate-edges
 300    graph
 301    (lambda (e)
 302      (setf (tag e) nil))))
 303
 304 ;;; ---------------------------------------------------------------------------
 305
 306 (defmethod untag-all-edges ((vertex basic-vertex))
 307   (iterate-edges
 308    vertex
 309    (lambda (e)
 310      (setf (tag e) nil))))
 311
 312 ;;; ---------------------------------------------------------------------------
 313
 314 (defmethod untag-edges ((edges list))
 315   (iterate-nodes
 316    edges
 317    (lambda (e)
 318      (setf (tag e) nil))))
 319
 320 ;;; ---------------------------------------------------------------------------
 321
 322 (defmethod tag-edges ((edges list))
 323   (iterate-nodes
 324    edges
 325    (lambda (e)
 326      (setf (tag e) t))))
 327
 328
 329 ;;; ---------------------------------------------------------------------------
 330
 331 (defmethod (setf element) :around ((value t) (vertex basic-vertex))
 332   (with-changing-vertex (vertex)
 333     (call-next-method)))
 334
 335 ;;; ---------------------------------------------------------------------------
 336
 337 ;; :ignore, :force, :replace, <function>
 338
 339 (defmethod add-vertex ((graph basic-graph) (value t) &rest args &key
 340                        (if-duplicate-do :ignore) &allow-other-keys)
 341   (remf args :if-duplicate-do)
 342   (let ((existing-vertex (find-vertex graph value nil)))
 343     (labels ((make-it ()
 344                (apply #'make-vertex-for-graph graph :element value args))
 345              (add-it (why)
 346                (values (add-vertex graph (make-it)) why)))
 347       (if existing-vertex
 348         (cond ((eq if-duplicate-do :ignore)
 349                (values existing-vertex :ignore))
 350
 351               ((eq if-duplicate-do :force)
 352                (add-it :force))
 353
 354               ((eq if-duplicate-do :replace)
 355                (replace-vertex graph existing-vertex (make-it)))
 356
 357               ((eq if-duplicate-do :replace-value)
 358                (setf (element existing-vertex) value)
 359                (values existing-vertex :replace-value))
 360
 361               (t
 362                (values (funcall if-duplicate-do existing-vertex)
 363                        :duplicate)))
 364
 365         ;; not found, add
 366         (add-it :new)))))
 367
 368 ;;; ---------------------------------------------------------------------------
 369
 370 (defmethod replace-vertex ((graph basic-graph) (old basic-vertex) (new basic-vertex))
 371   ;; we need the graph and the new vertex to reference each other
 372   ;; we need every edge of the old vertex to use the new-vertex
 373   ;; we need to remove the old vertex
 374   ;;
 375   ;; since I'm tired today, let's ignore trying to make this elegant
 376
 377   ;; first, we connect the edges to the new vertex so that they don't get deleted
 378   ;; when we delete the old vertex
 379   (iterate-edges
 380    old
 381    (lambda (e)
 382      (if (eq (vertex-1 e) old)
 383        (setf (slot-value e 'vertex-1) new) (setf (slot-value e 'vertex-2) new))
 384      (add-edge-to-vertex e new)))
 385
 386   (delete-vertex graph old)
 387   (add-vertex graph new))
 388
 389 ;;; ---------------------------------------------------------------------------
 390
 391 (defmethod add-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
 392                                       &rest args &key (if-duplicate-do :ignore)
 393                                       &allow-other-keys)
 394   (declare (ignore if-duplicate-do)
 395            (dynamic-extent args))
 396   (let ((v1 (or (find-vertex graph value-1 nil)
 397                 (add-vertex graph value-1 :if-duplicate-do :ignore)))
 398         (v2 (or (find-vertex graph value-2 nil)
 399                 (add-vertex graph value-2  :if-duplicate-do :replace))))
 400     (apply #'add-edge-between-vertexes graph v1 v2 args)))
 401
 402 ;;; ---------------------------------------------------------------------------
 403 ;;; to-do - add-edge-between-vertexes needs to be able to grab the weight and
 404 ;;; color from edges that inherit from weight and color mixins
 405 ;;; ---------------------------------------------------------------------------
 406
 407 (defmethod add-edge-between-vertexes ((graph basic-graph)
 408                                       (v-1 basic-vertex) (v-2 basic-vertex)
 409                                       &rest args &key
 410                                       (value nil) (if-duplicate-do :ignore)
 411                                       &allow-other-keys)
 412   (declare (dynamic-extent args))
 413   (remf args :if-duplicate-do)
 414
 415   (let ((edge (find-edge-between-vertexes graph v-1 v-2 :error-if-not-found? nil)))
 416     (flet ((add-it (why)
 417              (values (add-edge
 418                       graph
 419                       (apply #'make-edge-for-graph graph v-1 v-2 args))
 420                      why)))
 421       (if edge
 422         (cond
 423          ((eq if-duplicate-do :ignore)
 424           (values edge :ignore))
 425
 426          ((eq if-duplicate-do :force)
 427           (add-it :force))
 428
 429          ((eq if-duplicate-do :force-if-different-value)
 430           (if (equal (value edge) value)
 431             (values :ignore)
 432             (add-it :force)))
 433
 434
 435          ((eq if-duplicate-do :replace)
 436           (warn "replace edges isn't really implemented, maybe you can use :replace-value")
 437           (delete-edge graph edge)
 438           (add-it :replace))
 439
 440          ((eq if-duplicate-do :replace-value)
 441           (setf (element edge) value)
 442           (values edge :replace-value))
 443
 444          (t
 445           (setf edge (funcall if-duplicate-do edge))
 446           (values edge :duplicate)))
 447
 448         ;; not found, add
 449         (add-it :new)))))
 450
 451
 452 ;;; ---------------------------------------------------------------------------
 453
 454 (defmethod add-edge-to-vertex ((edge basic-edge) (vertex basic-vertex))
 455   (values))
 456
 457 ;;; ---------------------------------------------------------------------------
 458
 459 (defmethod find-edge-between-vertexes
 460     ((graph basic-graph) (value-1 t) (value-2 t)
 461      &key (error-if-not-found? t))
 462   (let* ((v1 (find-vertex graph value-1 error-if-not-found?))
 463          (v2 (find-vertex graph value-2 error-if-not-found?)))
 464     (or (and v1 v2 (find-edge-between-vertexes graph v1 v2))
 465         (when error-if-not-found?
 466           (error 'graph-edge-not-found-error
 467                  :graph graph :vertex-1 v1 :vertex-2 v2)))))
 468
 469 ;;; ---------------------------------------------------------------------------
 470
 471 (defmethod delete-edge-between-vertexes ((graph basic-graph)
 472                                          (value-or-vertex-1 t)
 473                                          (value-or-vertex-2 t) &rest args)
 474   (let ((edge (apply #'find-edge-between-vertexes
 475                      graph value-or-vertex-1 value-or-vertex-2 args)))
 476     (when edge
 477       (delete-edge graph edge))))
 478
 479 ;;; ---------------------------------------------------------------------------
 480
 481 (defmethod delete-edge :after ((graph basic-graph) (edge basic-edge))
 482   (delete-item (graph-edges graph) edge)
 483   edge)
 484
 485
 486 (defmethod delete-all-edges :after ((graph basic-graph))
 487   (empty! (graph-edges graph))
 488   graph)
 489
 490 ;;; ---------------------------------------------------------------------------
 491
 492 (defmethod delete-vertex ((graph basic-graph) value-or-vertex)
 493   (delete-vertex graph (find-vertex graph value-or-vertex)))
 494
 495 ;;; ---------------------------------------------------------------------------
 496
 497 (defmethod delete-vertex ((graph basic-graph) (vertex basic-vertex))
 498   (unless (eq graph (graph vertex))
 499     (error 'graph-vertex-not-found-error
 500            :graph graph :vertex vertex))
 501
 502   (iterate-edges
 503    vertex
 504    (lambda (edge)
 505      (delete-edge graph edge)))
 506
 507   (empty! (vertex-edges vertex))
 508   (values vertex graph))
 509
 510 ;;; ---------------------------------------------------------------------------
 511
 512 (defmethod delete-vertex :after ((graph basic-graph)
 513                                  (vertex basic-vertex))
 514   (setf (slot-value vertex 'graph) nil)
 515   (delete-item-at (graph-vertexes graph)
 516                   (funcall (vertex-key graph) (element vertex))))
 517
 518 ;;; ---------------------------------------------------------------------------
 519
 520 (defmethod insert-item ((graph basic-graph) value)
 521   (add-vertex graph value))
 522
 523 ;;; ---------------------------------------------------------------------------
 524
 525 (defmethod source-edges ((vertex basic-vertex) &optional filter)
 526   (collect-using #'iterate-source-edges filter vertex))
 527
 528 ;;; ---------------------------------------------------------------------------
 529
 530 (defmethod target-edges ((vertex basic-vertex) &optional filter)
 531   (collect-using #'iterate-target-edges filter vertex))
 532
 533 ;;; ---------------------------------------------------------------------------
 534
 535 (defmethod child-vertexes (vertex &optional filter)
 536   (collect-using #'iterate-children filter vertex))
 537
 538 ;;; ---------------------------------------------------------------------------
 539
 540 (defmethod parent-vertexes (vertex &optional filter)
 541   (collect-using #'iterate-parents filter vertex))
 542
 543 ;;; ---------------------------------------------------------------------------
 544
 545 (defmethod neighbor-vertexes (vertex &optional filter)
 546   (collect-using #'iterate-neighbors filter vertex))
 547
 548 ;;; ---------------------------------------------------------------------------
 549
 550 (defmethod adjacentp ((graph basic-graph) vertex-1 vertex-2)
 551   (adjacentp graph (find-vertex graph vertex-1) (find-vertex graph vertex-2)))
 552
 553 ;;; ---------------------------------------------------------------------------
 554
 555 (defmethod adjacentp ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex))
 556   (iterate-neighbors
 557    vertex-1
 558    (lambda (vertex)
 559      (when (eq vertex vertex-2)
 560        (return-from adjacentp t))))
 561   (values nil))
 562
 563 ;;; ---------------------------------------------------------------------------
 564
 565 (defmethod number-of-neighbors (vertex)
 566   (count-using #'iterate-neighbors nil vertex))
 567
 568 ;;; ---------------------------------------------------------------------------
 569
 570 (defmethod in-cycle-p ((graph basic-graph) (vertex t))
 571   (in-cycle-p graph (find-vertex graph vertex)))
 572
 573 ;;; ---------------------------------------------------------------------------
 574
 575 (defmethod renumber-vertexes ((graph basic-graph))
 576   (let ((count 0))
 577     (iterate-vertexes graph (lambda (vertex)
 578                               (setf (slot-value vertex 'vertex-id) count)
 579                               (incf count)))
 580     (setf (slot-value graph 'largest-vertex-id) count)))
 581
 582 ;;; ---------------------------------------------------------------------------
 583
 584 (defmethod renumber-edges ((graph basic-graph))
 585   (let ((count 0))
 586     (iterate-edges graph (lambda (vertex)
 587                            (setf (slot-value vertex 'edge-id) count)
 588                            (incf count)))
 589     (setf (slot-value graph 'largest-edge-id) count)))
 590
 591 ;;; ---------------------------------------------------------------------------
 592
 593 (deprecated
 594   (defmethod container->list ((graph basic-graph))
 595     (collect-elements (graph-vertexes graph))))
 596
 597 ;;; ---------------------------------------------------------------------------
 598
 599 (defmethod add-vertex :before ((graph basic-graph) (vertex basic-vertex)
 600                                &key &allow-other-keys)
 601
 602   (assert (typep vertex (vertex-class graph)))
 603   (setf (item-at (graph-vertexes graph)
 604                  (funcall (vertex-key graph) (element vertex))) vertex
 605         (slot-value vertex 'graph) graph))
 606
 607 ;;; ---------------------------------------------------------------------------
 608
 609 (defmethod add-edge :before ((graph basic-graph) (edge basic-edge) &key force-new?)
 610   (declare (ignore force-new?))
 611   (insert-item (graph-edges graph) edge)
 612   (setf (slot-value edge 'graph) graph)
 613   (if (subtypep (class-name (class-of edge)) 'directed-edge-mixin)
 614     (progn (setf (contains-directed-edge-p graph) t))
 615     (progn (setf (contains-undirected-edge-p graph) t))))
 616
 617 ;;; ---------------------------------------------------------------------------
 618
 619 (defmethod find-vertex ((graph basic-graph) (value t)
 620                         &optional (error-if-not-found? t))
 621   (or (find-item (graph-vertexes graph) (funcall (vertex-key graph) value))
 622       (when error-if-not-found?
 623         (error 'graph-vertex-not-found-error :vertex value :graph graph))))
 624
 625 (defmethod find-vertex ((graph basic-graph) (vertex basic-vertex)
 626                         &optional (error-if-not-found? t))
 627   (cond ((eq graph (graph vertex))
 628          vertex)
 629         (t
 630          (when error-if-not-found?
 631            (error 'graph-vertex-not-found-error
 632                   :vertex vertex :graph graph)))))
 633
 634 (defmethod find-vertex ((edge basic-edge) (value t)
 635                         &optional (error-if-not-found? t))
 636   (iterate-vertexes
 637    edge
 638    (lambda (vertex)
 639      (when (funcall (vertex-test (graph edge))
 640                     (funcall (vertex-key (graph edge)) (element vertex)) value)
 641        (return-from find-vertex vertex))))
 642   (when error-if-not-found?
 643     (error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge)))
 644
 645
 646 (defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex)
 647                               &key (key (vertex-key graph)) (test 'equal)
 648                               (error-if-not-found? t))
 649   (or (search-for-node (graph-vertexes graph) vertex :test test :key key)
 650       (when error-if-not-found?
 651         (error "~A not found in ~A" vertex graph))))
 652
 653 (defmethod search-for-vertex ((graph basic-graph) (vertex t)
 654                               &key (key (vertex-key graph)) (test 'equal)
 655                               (error-if-not-found? t))
 656   (or (search-for-element (graph-vertexes graph) vertex :test test :key key)
 657       (when error-if-not-found?
 658         (error "~A not found in ~A" vertex graph))))
 659
 660 (defmethod iterate-elements ((graph basic-graph) fn)
 661    (iterate-elements (graph-vertexes graph)
 662                      (lambda (vertex) (funcall fn (element vertex)))))
 663
 664 ;;; ---------------------------------------------------------------------------
 665
 666 (defmethod iterate-nodes ((graph basic-graph) fn)
 667    (iterate-nodes (graph-vertexes graph) fn))
 668
 669 ;;; ---------------------------------------------------------------------------
 670
 671 (defmethod iterate-vertexes ((graph basic-graph) fn)
 672    (iterate-nodes (graph-vertexes graph) fn))
 673
 674 ;;; ---------------------------------------------------------------------------
 675
 676 (defmethod iterate-vertexes ((edge basic-edge) fn)
 677   (funcall fn (vertex-1 edge))
 678   (funcall fn (vertex-2 edge)))
 679
 680 ;;; ---------------------------------------------------------------------------
 681
 682 (defmethod size ((graph basic-graph))
 683   (size (graph-vertexes graph)))
 684
 685 ;;; ---------------------------------------------------------------------------
 686
 687 (defmethod edges ((graph basic-graph))
 688   (collect-using #'iterate-edges nil graph))
 689
 690 ;;; ---------------------------------------------------------------------------
 691
 692 (defmethod edges ((vertex basic-vertex))
 693   (collect-using #'iterate-edges nil vertex))
 694
 695 ;;; ---------------------------------------------------------------------------
 696
 697 (deprecated
 698   "Use size instead"
 699   (defmethod vertex-count ((graph basic-graph))
 700     (size graph)))
 701
 702 ;;; ---------------------------------------------------------------------------
 703
 704 (defmethod vertexes ((graph basic-graph))
 705   (collect-elements (graph-vertexes graph)))
 706
 707 ;;; ---------------------------------------------------------------------------
 708
 709 (defmethod source-edge-count ((vertex basic-vertex))
 710   (count-using 'iterate-source-edges nil vertex))
 711
 712 ;;; ---------------------------------------------------------------------------
 713
 714 (defmethod target-edge-count ((vertex basic-vertex))
 715   (count-using 'iterate-target-edges nil vertex))
 716
 717 ;;; ---------------------------------------------------------------------------
 718
 719 (defmethod graph-roots ((graph basic-graph))
 720   (collect-elements (graph-vertexes graph) :filter #'rootp))
 721
 722 ;;; ---------------------------------------------------------------------------
 723
 724 (defmethod rootp ((vertex basic-vertex))
 725   ;;?? this is inefficient in the same way that (zerop (length <list>)) is...
 726   (zerop (source-edge-count vertex)))
 727
 728 ;;; ---------------------------------------------------------------------------
 729
 730 (defmethod find-vertex-if ((graph basic-graph) fn &key key)
 731   (iterate-vertexes graph
 732                     (lambda (v)
 733                       (when (funcall fn (if key (funcall key v) v))
 734                         (return-from find-vertex-if v))))
 735   (values nil))
 736
 737 ;;; ---------------------------------------------------------------------------
 738
 739 (defmethod find-vertex-if ((edge basic-edge) fn &key key)
 740   (iterate-vertexes edge
 741                     (lambda (v)
 742                       (when (funcall fn (if key (funcall key v) v))
 743                         (return-from find-vertex-if v))))
 744   (values nil))
 745
 746 ;;; ---------------------------------------------------------------------------
 747
 748 (defmethod find-edge-if ((graph basic-graph) fn &key key)
 749   (iterate-edges graph
 750                  (lambda (e)
 751                    (when (funcall fn (if key (funcall key e) e))
 752                      (return-from find-edge-if e))))
 753   (values nil))
 754
 755 ;;; ---------------------------------------------------------------------------
 756
 757 (defmethod find-edges-if ((graph basic-graph) fn)
 758   (collect-using 'iterate-edges fn graph))
 759
 760 ;;; ---------------------------------------------------------------------------
 761
 762 (defmethod find-vertexes-if ((graph basic-graph) fn)
 763   (collect-using 'iterate-vertexes fn graph))
 764
 765 ;;; ---------------------------------------------------------------------------
 766
 767 (defmethod empty! ((graph basic-graph))
 768   (empty! (graph-edges graph))
 769   (empty! (graph-vertexes graph))
 770   (renumber-edges graph)
 771   (renumber-vertexes graph)
 772   (values))
 773
 774 ;;; ---------------------------------------------------------------------------
 775
 776 (defun neighbors-to-children (new-graph root &optional visited-list)
 777   (pushnew root visited-list)
 778   (iterate-neighbors
 779    root
 780    (lambda (c)
 781      (when (not (member c visited-list))
 782        (add-edge-between-vertexes
 783         new-graph (value root) (value c) :edge-type :directed)
 784        (neighbors-to-children new-graph c visited-list)))))
 785
 786 ;;; ---------------------------------------------------------------------------
 787
 788 (defmethod generate-directed-free-tree ((graph basic-graph) root)
 789   (generate-directed-free-tree graph (find-vertex graph root)))
 790
 791 ;;; ---------------------------------------------------------------------------
 792
 793 (defmethod force-undirected ((graph basic-graph))
 794   (iterate-edges
 795    graph
 796    (lambda (edge)
 797      (change-class edge (undirected-edge-class graph)))))
 798
 799
 800
 801 ;;; ---------------------------------------------------------------------------
 802 ;;; traversal
 803 ;;; ---------------------------------------------------------------------------
 804
 805 (defmethod traverse-elements ((thing basic-graph) (style symbol) fn)
 806   (let ((marker (gensym)))
 807     (iterate-vertexes
 808      thing
 809      (lambda (vertex)
 810        (setf (tag vertex) marker)))
 811
 812     (iterate-elements
 813      (graph-roots thing)
 814      (lambda (vertex)
 815        (traverse-elements-helper vertex style marker fn)))))
 816
 817 ;;; ---------------------------------------------------------------------------
 818
 819 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
 820   (when (eq (tag thing) marker)
 821     (setf (tag thing) nil)
 822     (iterate-children
 823      thing
 824      (lambda (vertex)
 825        (traverse-elements-helper vertex style marker fn)))
 826
 827     (funcall fn thing)))
 828
 829 ;;; ---------------------------------------------------------------------------
 830
 831 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
 832   (when (eq (tag thing) marker)
 833     (setf (tag thing) nil)
 834     (funcall fn thing))
 835
 836   (iterate-neighbors
 837    thing
 838    (lambda (vertex)
 839      (when (eq (tag vertex) marker)
 840        (funcall fn vertex))))
 841
 842   (iterate-neighbors
 843    thing
 844    (lambda (vertex)
 845      (when (eq (tag vertex) marker)
 846        (setf (tag vertex) nil)
 847        (traverse-elements-helper vertex style marker fn)))))
 848
 849 ;;; ---------------------------------------------------------------------------
 850
 851 ;; also in metatilites
 852 (defun graph-search-for-cl-graph (states goal-p successors combiner
 853                                   &key (state= #'eql) old-states
 854                                   (new-state-fn #'new-states))
 855   "Find a state that satisfies goal-p.  Start with states,
 856   and search according to successors and combiner.
 857   Don't try the same state twice."
 858   (cond ((null states) nil)
 859         ((funcall goal-p (first states)) (first states))
 860         (t (graph-search-for-cl-graph
 861              (funcall
 862                combiner
 863                (funcall new-state-fn states successors state= old-states)
 864                (rest states))
 865              goal-p successors combiner
 866              :state= state=
 867              :old-states (adjoin (first states) old-states
 868                                  :test state=)
 869              :new-state-fn new-state-fn))))
 870
 871 (defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
 872   (let ((first-time? t))
 873     (not (null
 874           (graph-search-for-cl-graph
 875            (list start-vertex)
 876            (lambda (v)
 877              (if first-time?
 878                (setf first-time? nil)
 879                (eq (find-vertex graph v) start-vertex)))
 880            (lambda (v)
 881              (child-vertexes v))
 882            #'append
 883            :new-state-fn
 884            (lambda (states successors state= old-states)
 885              ;; Generate successor states that have not been seen before but
 886              ;; don't remove the start state.
 887              (remove-if
 888               #'(lambda (state)
 889                   (and (not (eq start-vertex state))
 890                        (or (member state states :test state=)
 891                            (member state old-states :test state=))))
 892               (funcall successors (first states)))))))))
 893
 894 ;;; ---------------------------------------------------------------------------
 895
 896 (defmethod in-undirected-cycle-p
 897            ((graph basic-graph) (current basic-vertex)
 898             &optional (marked (make-container 'simple-associative-container))
 899             (previous nil))
 900   (block do-it
 901     (setf (item-at-1 marked current) t)
 902     (iterate-children current
 903                       (lambda (child)
 904                         (cond
 905                          ((eq child previous) nil)
 906                          ((item-at-1 marked child) (return-from do-it t))
 907                          (t
 908                           (in-undirected-cycle-p graph child marked current)))))))
 909
 910 ;;; ---------------------------------------------------------------------------
 911
 912 (defmethod any-undirected-cycle-p ((graph basic-graph))
 913   (let ((marked (make-container 'simple-associative-container)))
 914     (iterate-vertexes graph (lambda (v)
 915                               (unless (item-at-1 marked v)
 916                                 (when (in-undirected-cycle-p graph v marked)
 917                                   (return-from any-undirected-cycle-p v)))))
 918     (values nil)))
 919
 920 ;;; ---------------------------------------------------------------------------
 921
 922 (defun remove-list (original target)
 923   "Removes all elements in original from target."
 924   (remove-if (lambda (target-element)
 925                (member target-element original))
 926              target))
 927
 928 ;;; ---------------------------------------------------------------------------
 929
 930 (defun get-nodelist-relatives (node-list)
 931   "Collects set of unique relatives of nodes in node-list."
 932   (let ((unique-relatives nil))
 933     (dolist (node node-list)
 934       (setf unique-relatives
 935             (append-unique (neighbor-vertexes node) unique-relatives)))
 936     unique-relatives))
 937
 938 ;;; ---------------------------------------------------------------------------
 939
 940 (defun get-transitive-closure (vertex-list &optional (depth nil))
 941   "Given a list of vertices, returns a combined list of all of the nodes
 942 in the transitive closure(s) of each of the vertices in the list
 943 (without duplicates).  Optional DEPTH limits the depth (in _both_ the
 944 child and parent directions) to which the closure is gathered; default
 945 nil gathers the entire closure(s)."
 946   (labels ((collect-transitive-closure (remaining visited depth)
 947              (if (and remaining
 948                       (typecase depth
 949                         (null t)
 950                         (fixnum (>= (decf depth) 0))))
 951
 952               (let* ((non-visited-relatives     ;; list of relatives not yet visited
 953                        (remove-list visited
 954                                     (get-nodelist-relatives remaining)))
 955                       (visited-nodes            ;; list of nodes visited so far
 956                        (append-unique non-visited-relatives visited)))
 957                  (collect-transitive-closure non-visited-relatives
 958                                              visited-nodes
 959                                              depth))
 960                (values visited))))
 961     (collect-transitive-closure vertex-list vertex-list depth)))
 962
 963 ;;; ---------------------------------------------------------------------------
 964 ;;; make-filtered-graph
 965 ;;; ---------------------------------------------------------------------------
 966
 967 (defmethod complete-links ((new-graph basic-graph)
 968                            (old-graph basic-graph))
 969   ;; Copy links from old-graph ONLY for nodes already in new-graph
 970   (iterate-vertexes
 971    new-graph
 972    (lambda (vertex)
 973      (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
 974        (iterate-edges
 975         old-graph-vertex
 976         (lambda (old-edge)
 977           (let* ((old-other-vertex (other-vertex old-edge old-graph-vertex))
 978                  (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil)))
 979             (when (and new-other-vertex
 980                        (< (vertex-id vertex) (vertex-id new-other-vertex)))
 981               (let* ((new-edge (copy-template old-edge)))
 982                 (if (eq old-graph-vertex (vertex-1 old-edge))
 983                   (setf (slot-value new-edge 'vertex-1) vertex
 984                         (slot-value new-edge 'vertex-2) new-other-vertex)
 985                   (setf (slot-value new-edge 'vertex-2) vertex
 986                         (slot-value new-edge 'vertex-1) new-other-vertex))
 987                 (add-edge new-graph new-edge))))))))))
 988
 989 #+Old
 990 (defmethod complete-links ((new-graph basic-graph)
 991                            (old-graph basic-graph))
 992   ;; Copy links from old-graph ONLY for nodes already in new-graph
 993   (iterate-vertexes
 994    new-graph
 995    (lambda (vertex)
 996      (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
 997        (iterate-edges
 998         old-graph-vertex
 999         (lambda (edge)
1000           (let* ((old-other-vertex (other-vertex edge old-graph-vertex))
1001                  (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil))
1002                  (edge-type (if (directed-edge-p edge)
1003                               :directed :undirected)))
1004             (when new-other-vertex
1005               (if (and (directed-edge-p edge)
1006                        (eq old-graph-vertex (target-vertex edge)))
1007                 (add-edge-between-vertexes new-graph new-other-vertex vertex
1008                                            :value (value edge)
1009                                            :edge-type edge-type)
1010                 (add-edge-between-vertexes new-graph vertex new-other-vertex
1011                                            :value (value edge)
1012                                            :edge-type edge-type))))))))))
1013
1014 ;;; ---------------------------------------------------------------------------
1015
1016 (defmethod make-filtered-graph ((old-graph basic-graph)
1017                                 test-fn
1018                                 &key
1019                                 (graph-completion-method nil)
1020                                 (depth nil)
1021                                 (new-graph
1022                                  (copy-template old-graph)))
1023   (ecase graph-completion-method
1024     ((nil
1025       :complete-links)
1026      (iterate-vertexes old-graph
1027                        (lambda (vertex)
1028                          (when (funcall test-fn vertex)
1029                            (add-vertex new-graph (value vertex))))))
1030     ((:complete-closure-nodes-only
1031       :complete-closure-with-links)
1032      (let* ((old-graph-vertexes  (collect-items old-graph :filter test-fn))
1033             (closure-vertexes
1034              (get-transitive-closure old-graph-vertexes depth)))
1035        (dolist (vertex closure-vertexes)
1036          (add-vertex new-graph (copy-template vertex))))))
1037   (ecase graph-completion-method
1038       ((nil :complete-closure-nodes-only) nil)
1039       ((:complete-links
1040         :complete-closure-with-links)
1041        (complete-links new-graph old-graph)))
1042   new-graph)
1043
1044 ;;; ---------------------------------------------------------------------------
1045
1046 (defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
1047                                 &rest args &key (depth nil) (new-graph nil))
1048   (declare (ignore depth new-graph))
1049   (apply #'make-filtered-graph
1050          graph
1051          #'(lambda (v)
1052              (equal v vertex))
1053          :graph-completion-method :complete-closure-with-links
1054          args))
1055
1056 ;;; ---------------------------------------------------------------------------
1057
1058 (defmethod edge-count ((graph basic-graph))
1059   (count-using #'iterate-edges nil graph))
1060
1061 ;;; ---------------------------------------------------------------------------
1062
1063 (defmethod edge-count ((vertex basic-vertex))
1064   (size (vertex-edges vertex)))
1065
1066 ;;; ---------------------------------------------------------------------------
1067
1068 (defmethod topological-sort ((graph basic-graph))
1069   (assign-level graph 0)
1070   (sort (collect-elements (graph-vertexes graph))  #'<
1071         :key (lambda (x) (depth-level x))))
1072
1073 ;;; ---------------------------------------------------------------------------
1074
1075 (defmethod assign-level ((graph basic-graph) (level number))
1076   (loop for node in (graph-roots graph)
1077         do (assign-level node 0)))
1078
1079 ;;; ---------------------------------------------------------------------------
1080
1081 (defmethod assign-level ((node basic-vertex) (level number))
1082   (if (or (not (depth-level node))
1083           (> level (depth-level node)))
1084     (setf (depth-level node) level))
1085   (iterate-children node (lambda (x) (assign-level x (1+ level)))))
1086
1087 ;;; ---------------------------------------------------------------------------
1088
1089 (defmethod depth ((graph basic-graph))
1090   (assign-level graph 0)
1091   (let ((depth 0))
1092     (iterate-vertexes graph (lambda (vertex)
1093                               (when (> (depth-level vertex) depth)
1094                                 (setf depth (depth-level vertex)))))
1095     depth))
1096
1097 ;;; ---------------------------------------------------------------------------
1098 ;;; mapping
1099 ;;; ---------------------------------------------------------------------------
1100
1101 (defun map-paths (graph start-vertex length fn &key (filter (constantly t)))
1102   "Apply fn to each path that starts at start-vertex and is of exactly length
1103 length"
1104   ;; a sort of depth first search
1105   (labels ((follow-path (next-vertex current-path length)
1106              (when (zerop length)
1107                (funcall fn (reverse current-path)))
1108              ; (format t "~%~A ~A ~A" current-path next-vertex length)
1109              (when (plusp length)
1110                (iterate-neighbors
1111                 next-vertex
1112                 (lambda (v)
1113                   (when (funcall filter v)
1114                     ;; no repeats
1115                     (unless (find-item current-path v)
1116                       (let ((new-path  (copy-list current-path)))
1117                         (follow-path v (push v new-path) (1- length))))))))))
1118     (iterate-neighbors
1119      start-vertex
1120      (lambda (v)
1121        (when (funcall filter v)
1122          (follow-path v (list v start-vertex) (1- length))))))
1123   (values graph))
1124
1125 ;;; ---------------------------------------------------------------------------
1126
1127 (defun map-shortest-paths (graph start-vertex depth fn &key (filter (constantly t)))
1128   "Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration."
1129   (bind ((visited (make-container 'simple-associative-container
1130                                   :test #'equal)))
1131     (labels ((visit (p)
1132                (setf (item-at-1 visited p) t))
1133              (visited-p (p)
1134                (item-at-1 visited p))
1135              )
1136       (loop for n from 1 to (1- depth) do
1137             (map-paths graph start-vertex n
1138                        (lambda (p)
1139                          (visit (first (last p))))
1140                        :filter filter))
1141       ;(break)
1142       (visit start-vertex)
1143       (map-paths graph start-vertex depth
1144                  (lambda (p)
1145                    (unless (visited-p (first (last p)))
1146                      (funcall fn p)))
1147                  :filter filter))))
1148
1149
1150 ;;; ---------------------------------------------------------------------------
1151 ;;; utilities
1152 ;;; ---------------------------------------------------------------------------
1153
1154 (defun append-unique (list1 list2)
1155   (remove-duplicates (append list1 list2)))
1156
1157 ;;; ---------------------------------------------------------------------------
1158 ;;; project-bipartite-graph
1159 ;;; ---------------------------------------------------------------------------
1160
1161 (defmethod project-bipartite-graph
1162            ((new-graph symbol) graph vertex-class vertex-classifier)
1163   (project-bipartite-graph
1164    (make-instance new-graph) graph vertex-class  vertex-classifier))
1165
1166 ;;; ---------------------------------------------------------------------------
1167
1168 (defmethod project-bipartite-graph
1169            ((new-graph basic-graph) graph vertex-class vertex-classifier)
1170   (iterate-vertexes
1171    graph
1172    (lambda (v)
1173      (when (eq (funcall vertex-classifier v) vertex-class)
1174        (add-vertex new-graph (element v)))))
1175
1176   (iterate-vertexes
1177    graph
1178    (lambda (v)
1179      (when (eq (funcall vertex-classifier v) vertex-class)
1180        (iterate-neighbors
1181         v
1182         (lambda (other-class-vertex)
1183           (iterate-neighbors
1184            other-class-vertex
1185            (lambda (this-class-vertex)
1186              (when (< (vertex-id v) (vertex-id this-class-vertex))
1187                (add-edge-between-vertexes
1188                 new-graph (element v) (element this-class-vertex)
1189                 :if-duplicate-do (lambda (e) (incf (weight e))))))))))))
1190
1191   new-graph)
1192
1193 #+Test
1194 (pro:with-profiling
1195   (setf (ds :g-5000-m-projection)
1196         (project-bipartite-graph
1197          'undirected-graph-container
1198          (ds :g-5000)
1199          :m
1200          (lambda (v)
1201            (let ((vertex-class (aref (symbol-name (element v)) 0)))
1202              (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1203                     :m)
1204                    ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1205                     :h)))))))
1206
1207 #+Test
1208 (pro:with-profiling
1209   (setf (ds :g-5000-h-projection)
1210         (project-bipartite-graph
1211          'undirected-graph-container
1212          (ds :g-5000)
1213          :h
1214          (lambda (v)
1215            (let ((vertex-class (aref (symbol-name (element v)) 0)))
1216              (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1217                     :m)
1218                    ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1219                     :h)))))))
1220
1221 #+Test
1222 (pro:with-profiling
1223   (project-bipartite-graph
1224    'undirected-graph-container
1225    (ds :g-1000)
1226    :m
1227    (lambda (v)
1228      (let ((vertex-class (aref (symbol-name (element v)) 0)))
1229        (cond ((member vertex-class '(#\x #\y) :test #'char-equal)
1230               :m)
1231              ((member vertex-class '(#\a #\b #\c) :test #'char-equal)
1232               :h))))))
1233
1234
1235
1236