1 ;;;-*- Mode: Lisp; Package: metabang.graph -*-
4 $Id: graph.lisp,v 1.30 2005/09/07 16:17:06 gwking Exp $
6 Author: Gary W. King, et. al.
12 something is putting something on the vertexes plist's
17 (in-package #:metabang.graph)
19 ;;; ---------------------------------------------------------------------------
21 ;;; ---------------------------------------------------------------------------
23 (defcondition graph-error (error)
27 (:documentation "This is the root condition for errors that occur while running code in CL-Graph."))
29 ;;; ---------------------------------------------------------------------------
31 (defcondition edge-error (graph-error)
32 ((edge nil ir "The `edge` that is implicated in the condition."))
35 (:documentation "This is the root condition for graph errors that have to do with edges."))
37 ;;; ---------------------------------------------------------------------------
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))))
45 (:documentation "This condition is signaled when a vertex can not be found in a graph."))
47 ;;; ---------------------------------------------------------------------------
49 (defcondition graph-vertex-not-found-in-edge-error (edge-error)
51 (:report (lambda (c s)
52 (format s "Vertex ~S not found in ~A" (vertex c) (edge c))))
54 (:documentation "This condition is signaled when a vertex can not be found in an edge."))
56 ;;; ---------------------------------------------------------------------------
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))))
66 (:documentation "This condition is signaled when an edge cannot be found in a graph."))
68 ;;; ---------------------------------------------------------------------------
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]"))
83 (:export-slots vertex-id tag rank color previous-node next-node
84 discovery-time finish-time)
86 (:documentation "This is the root class for all vertexes in CL-Graph."))
88 ;;; ---------------------------------------------------------------------------
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))))
96 ;;; ---------------------------------------------------------------------------
98 (defmethod print-object ((vertex basic-vertex) stream)
99 (print-unreadable-object (vertex stream :identity nil)
101 (if (and (slot-exists-p vertex 'element) (slot-boundp vertex 'element))
102 (element vertex) "#unbound#"))))
104 ;;; ---------------------------------------------------------------------------
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]"))
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."))
117 ;;; ---------------------------------------------------------------------------
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))))
125 ;;; ---------------------------------------------------------------------------
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))))
131 ;;; ---------------------------------------------------------------------------
133 (defclass* directed-edge-mixin () ()
135 (:documentation "This mixin class is used to indicate that an edge is directed."))
137 ;;; ---------------------------------------------------------------------------
139 (defclass* weighted-edge-mixin ()
140 ((weight 1d0 ia "The value of the weight of this edge. Defaults to 1.0d0"))
143 (:documentation "This mixin class adds a `weight` slot to an edge."))
145 ;;; ---------------------------------------------------------------------------
147 (defmethod weight ((edge basic-edge)) (values 1.0))
149 ;;; ---------------------------------------------------------------------------
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)
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)
179 (:documentation "This is the root class for all graphs in CL-Graph."))
181 ;;; ---------------------------------------------------------------------------
183 (defmethod initialize-instance :after ((object basic-graph) &key initial-size
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)))
190 ;;; ---------------------------------------------------------------------------
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))))
197 ;;; ---------------------------------------------------------------------------
199 ;;; ---------------------------------------------------------------------------
201 (defmethod add-vertex
202 ((graph basic-graph) (value basic-vertex) &key if-duplicate-do)
203 (declare (ignore if-duplicate-do))
206 ;;; ---------------------------------------------------------------------------
208 (defmethod make-vertex-for-graph ((graph basic-graph) &rest args &key
209 (vertex-class (vertex-class graph))
211 (remf args :vertex-class)
212 (assert (subtypep vertex-class (vertex-class graph)) nil
213 "Vertex class '~A' must be a subtype of ~A" vertex-class (vertex-class graph))
214 (apply #'make-instance vertex-class :graph graph args))
216 ;;; ---------------------------------------------------------------------------
218 (defmethod make-edge-for-graph ((graph basic-graph)
219 (vertex-1 basic-vertex) (vertex-2 basic-vertex)
221 (edge-type (default-edge-type graph))
222 (edge-class (default-edge-class graph))
224 (remf args :edge-class)
225 (remf args :edge-type)
226 (assert (or (null edge-type)
227 (eq edge-type :directed)
228 (eq edge-type :undirected)) nil
229 "Edge-type must be nil, :directed or :undirected.")
231 (assert (or (null edge-class)
232 (subtypep edge-class (directed-edge-class graph))
233 (subtypep edge-class (undirected-edge-class graph))) nil
234 "Edge-class must be nil or a subtype of ~A or ~A"
235 (undirected-edge-class graph)
236 (directed-edge-class graph))
238 (apply #'make-instance
241 (:directed (directed-edge-class graph))
242 (:undirected (undirected-edge-class graph))
244 (undirected-edge-class graph))
246 :vertex-1 vertex-1 :vertex-2 vertex-2 args))
248 ;;; ---------------------------------------------------------------------------
250 (defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys)
251 (apply #'make-instance graph-type args))
253 ;;; ---------------------------------------------------------------------------
254 ;;; generic implementation
255 ;;; ---------------------------------------------------------------------------
257 (defmethod undirected-edge-p ((edge basic-edge))
258 (not (directed-edge-p edge)))
260 ;;; ---------------------------------------------------------------------------
262 (defmethod directed-edge-p ((edge basic-edge))
263 (typep edge 'directed-edge-mixin))
265 ;;; ---------------------------------------------------------------------------
267 (defmethod tagged-edge-p ((edge basic-edge))
270 ;;; ---------------------------------------------------------------------------
272 (defmethod untagged-edge-p ((edge basic-edge))
275 ;;; ---------------------------------------------------------------------------
277 (defmethod tag-all-edges ((graph basic-graph))
283 ;;; ---------------------------------------------------------------------------
285 (defmethod tag-all-edges ((vertex basic-vertex))
291 ;;; ---------------------------------------------------------------------------
293 (defmethod untag-all-edges ((graph basic-graph))
297 (setf (tag e) nil))))
299 ;;; ---------------------------------------------------------------------------
301 (defmethod untag-all-edges ((vertex basic-vertex))
305 (setf (tag e) nil))))
307 ;;; ---------------------------------------------------------------------------
309 (defmethod untag-edges ((edges list))
313 (setf (tag e) nil))))
315 ;;; ---------------------------------------------------------------------------
317 (defmethod tag-edges ((edges list))
324 ;;; ---------------------------------------------------------------------------
326 (defmethod (setf element) :around ((value t) (vertex basic-vertex))
327 (with-changing-vertex (vertex)
330 ;;; ---------------------------------------------------------------------------
332 ;; :ignore, :force, :replace, <function>
334 (defmethod add-vertex ((graph basic-graph) (value t) &rest args &key
335 (if-duplicate-do :ignore) &allow-other-keys)
336 (remf args :if-duplicate-do)
337 (let ((existing-vertex (find-vertex graph value nil)))
339 (apply #'make-vertex-for-graph graph :element value args))
341 (values (add-vertex graph (make-it)) why)))
343 (cond ((eq if-duplicate-do :ignore)
344 (values existing-vertex :ignore))
346 ((eq if-duplicate-do :force)
349 ((eq if-duplicate-do :replace)
350 (replace-vertex graph existing-vertex (make-it)))
352 ((eq if-duplicate-do :replace-value)
353 (setf (element existing-vertex) value)
354 (values existing-vertex :replace-value))
357 (values (funcall if-duplicate-do existing-vertex)
363 ;;; ---------------------------------------------------------------------------
365 (defmethod replace-vertex ((graph basic-graph) (old basic-vertex) (new basic-vertex))
366 ;; we need the graph and the new vertex to reference each other
367 ;; we need every edge of the old vertex to use the new-vertex
368 ;; we need to remove the old vertex
370 ;; since I'm tired today, let's ignore trying to make this elegant
372 ;; first, we connect the edges to the new vertex so that they don't get deleted
373 ;; when we delete the old vertex
377 (if (eq (vertex-1 e) old)
378 (setf (slot-value e 'vertex-1) new) (setf (slot-value e 'vertex-2) new))
379 (add-edge-to-vertex e new)))
381 (delete-vertex graph old)
382 (add-vertex graph new))
384 ;;; ---------------------------------------------------------------------------
386 (defmethod add-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
387 &rest args &key (if-duplicate-do :ignore)
389 (declare (ignore if-duplicate-do)
390 (dynamic-extent args))
391 (let ((v1 (or (find-vertex graph value-1 nil)
392 (add-vertex graph value-1 :if-duplicate-do :ignore)))
393 (v2 (or (find-vertex graph value-2 nil)
394 (add-vertex graph value-2 :if-duplicate-do :replace))))
395 (apply #'add-edge-between-vertexes graph v1 v2 args)))
397 ;;; ---------------------------------------------------------------------------
398 ;;; to-do - add-edge-between-vertexes needs to be able to grab the weight and
399 ;;; color from edges that inherit from weight and color mixins
400 ;;; ---------------------------------------------------------------------------
402 (defmethod add-edge-between-vertexes ((graph basic-graph)
403 (v-1 basic-vertex) (v-2 basic-vertex)
405 (value nil) (if-duplicate-do :ignore)
407 (declare (dynamic-extent args))
408 (remf args :if-duplicate-do)
410 (let ((edge (find-edge-between-vertexes graph v-1 v-2 :error-if-not-found? nil)))
414 (apply #'make-edge-for-graph graph v-1 v-2 args))
418 ((eq if-duplicate-do :ignore)
419 (values edge :ignore))
421 ((eq if-duplicate-do :force)
424 ((eq if-duplicate-do :force-if-different-value)
425 (if (equal (value edge) value)
430 ((eq if-duplicate-do :replace)
431 (warn "replace edges isn't really implemented, maybe you can use :replace-value")
432 (delete-edge graph edge)
435 ((eq if-duplicate-do :replace-value)
436 (setf (element edge) value)
437 (values edge :replace-value))
440 (setf edge (funcall if-duplicate-do edge))
441 (values edge :duplicate)))
447 ;;; ---------------------------------------------------------------------------
449 (defmethod add-edge-to-vertex ((edge basic-edge) (vertex basic-vertex))
452 ;;; ---------------------------------------------------------------------------
454 (defmethod find-edge-between-vertexes
455 ((graph basic-graph) (value-1 t) (value-2 t)
456 &key (error-if-not-found? t))
457 (let* ((v1 (find-vertex graph value-1 error-if-not-found?))
458 (v2 (find-vertex graph value-2 error-if-not-found?)))
459 (or (and v1 v2 (find-edge-between-vertexes graph v1 v2))
460 (when error-if-not-found?
461 (error 'graph-edge-not-found-error
462 :graph graph :vertex-1 v1 :vertex-2 v2)))))
464 ;;; ---------------------------------------------------------------------------
466 (defmethod delete-edge-between-vertexes ((graph basic-graph)
467 (value-or-vertex-1 t)
468 (value-or-vertex-2 t) &rest args)
469 (let ((edge (apply #'find-edge-between-vertexes
470 graph value-or-vertex-1 value-or-vertex-2 args)))
472 (delete-edge graph edge))))
474 ;;; ---------------------------------------------------------------------------
476 (defmethod delete-edge :after ((graph basic-graph) (edge basic-edge))
477 (delete-item (graph-edges graph) edge)
481 (defmethod delete-all-edges :after ((graph basic-graph))
482 (empty! (graph-edges graph))
485 ;;; ---------------------------------------------------------------------------
487 (defmethod delete-vertex ((graph basic-graph) value-or-vertex)
488 (delete-vertex graph (find-vertex graph value-or-vertex)))
490 ;;; ---------------------------------------------------------------------------
492 (defmethod delete-vertex ((graph basic-graph) (vertex basic-vertex))
493 (unless (eq graph (graph vertex))
494 (error 'graph-vertex-not-found-error
495 :graph graph :vertex vertex))
500 (delete-edge graph edge)))
502 (empty! (vertex-edges vertex))
503 (values vertex graph))
505 ;;; ---------------------------------------------------------------------------
507 (defmethod delete-vertex :after ((graph basic-graph)
508 (vertex basic-vertex))
509 (setf (slot-value vertex 'graph) nil)
510 (delete-item-at (graph-vertexes graph)
511 (funcall (vertex-key graph) (element vertex))))
513 ;;; ---------------------------------------------------------------------------
515 (defmethod insert-item ((graph basic-graph) value)
516 (add-vertex graph value))
518 ;;; ---------------------------------------------------------------------------
520 (defmethod source-edges ((vertex basic-vertex) &optional filter)
521 (collect-using #'iterate-source-edges filter vertex))
523 ;;; ---------------------------------------------------------------------------
525 (defmethod target-edges ((vertex basic-vertex) &optional filter)
526 (collect-using #'iterate-target-edges filter vertex))
528 ;;; ---------------------------------------------------------------------------
530 (defmethod child-vertexes (vertex &optional filter)
531 (collect-using #'iterate-children filter vertex))
533 ;;; ---------------------------------------------------------------------------
535 (defmethod parent-vertexes (vertex &optional filter)
536 (collect-using #'iterate-parents filter vertex))
538 ;;; ---------------------------------------------------------------------------
540 (defmethod neighbor-vertexes (vertex &optional filter)
541 (collect-using #'iterate-neighbors filter vertex))
543 ;;; ---------------------------------------------------------------------------
545 (defmethod adjacentp ((graph basic-graph) vertex-1 vertex-2)
546 (adjacentp graph (find-vertex graph vertex-1) (find-vertex graph vertex-2)))
548 ;;; ---------------------------------------------------------------------------
550 (defmethod adjacentp ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex))
554 (when (eq vertex vertex-2)
555 (return-from adjacentp t))))
558 ;;; ---------------------------------------------------------------------------
560 (defmethod number-of-neighbors (vertex)
561 (count-using #'iterate-neighbors nil vertex))
563 ;;; ---------------------------------------------------------------------------
565 (defmethod in-cycle-p ((graph basic-graph) (vertex t))
566 (in-cycle-p graph (find-vertex graph vertex)))
568 ;;; ---------------------------------------------------------------------------
570 (defmethod renumber-vertexes ((graph basic-graph))
572 (iterate-vertexes graph (lambda (vertex)
573 (setf (slot-value vertex 'vertex-id) count)
575 (setf (slot-value graph 'largest-vertex-id) count)))
577 ;;; ---------------------------------------------------------------------------
579 (defmethod renumber-edges ((graph basic-graph))
581 (iterate-edges graph (lambda (vertex)
582 (setf (slot-value vertex 'edge-id) count)
584 (setf (slot-value graph 'largest-edge-id) count)))
586 ;;; ---------------------------------------------------------------------------
589 (defmethod container->list ((graph basic-graph))
590 (collect-elements (graph-vertexes graph))))
592 ;;; ---------------------------------------------------------------------------
594 (defmethod add-vertex :before ((graph basic-graph) (vertex basic-vertex)
595 &key &allow-other-keys)
597 (assert (typep vertex (vertex-class graph)))
598 (setf (item-at (graph-vertexes graph)
599 (funcall (vertex-key graph) (element vertex))) vertex
600 (slot-value vertex 'graph) graph))
602 ;;; ---------------------------------------------------------------------------
604 (defmethod add-edge :before ((graph basic-graph) (edge basic-edge) &key force-new?)
605 (declare (ignore force-new?))
606 (insert-item (graph-edges graph) edge)
607 (setf (slot-value edge 'graph) graph)
608 (if (subtypep (class-name (class-of edge)) 'directed-edge-mixin)
609 (progn (setf (contains-directed-edge-p graph) t))
610 (progn (setf (contains-undirected-edge-p graph) t))))
612 ;;; ---------------------------------------------------------------------------
614 (defmethod find-vertex ((graph basic-graph) (value t)
615 &optional (error-if-not-found? t))
616 (or (find-item (graph-vertexes graph) (funcall (vertex-key graph) value))
617 (when error-if-not-found?
618 (error 'graph-vertex-not-found-error :vertex value :graph graph))))
620 (defmethod find-vertex ((graph basic-graph) (vertex basic-vertex)
621 &optional (error-if-not-found? t))
622 (cond ((eq graph (graph vertex))
625 (when error-if-not-found?
626 (error 'graph-vertex-not-found-error
627 :vertex vertex :graph graph)))))
629 (defmethod find-vertex ((edge basic-edge) (value t)
630 &optional (error-if-not-found? t))
634 (when (funcall (vertex-test (graph edge))
635 (funcall (vertex-key (graph edge)) (element vertex)) value)
636 (return-from find-vertex vertex))))
637 (when error-if-not-found?
638 (error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge)))
641 (defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex)
642 &key (key (vertex-key graph)) (test 'equal)
643 (error-if-not-found? t))
644 (or (search-for-node (graph-vertexes graph) vertex :test test :key key)
645 (when error-if-not-found?
646 (error "~A not found in ~A" vertex graph))))
648 (defmethod search-for-vertex ((graph basic-graph) (vertex t)
649 &key (key (vertex-key graph)) (test 'equal)
650 (error-if-not-found? t))
651 (or (search-for-element (graph-vertexes graph) vertex :test test :key key)
652 (when error-if-not-found?
653 (error "~A not found in ~A" vertex graph))))
655 (defmethod iterate-elements ((graph basic-graph) fn)
656 (iterate-elements (graph-vertexes graph)
657 (lambda (vertex) (funcall fn (element vertex)))))
659 ;;; ---------------------------------------------------------------------------
661 (defmethod iterate-nodes ((graph basic-graph) fn)
662 (iterate-nodes (graph-vertexes graph) fn))
664 ;;; ---------------------------------------------------------------------------
666 (defmethod iterate-vertexes ((graph basic-graph) fn)
667 (iterate-nodes (graph-vertexes graph) fn))
669 ;;; ---------------------------------------------------------------------------
671 (defmethod iterate-vertexes ((edge basic-edge) fn)
672 (funcall fn (vertex-1 edge))
673 (funcall fn (vertex-2 edge)))
675 ;;; ---------------------------------------------------------------------------
677 (defmethod size ((graph basic-graph))
678 (size (graph-vertexes graph)))
680 ;;; ---------------------------------------------------------------------------
682 (defmethod edges ((graph basic-graph))
683 (collect-using #'iterate-edges nil graph))
685 ;;; ---------------------------------------------------------------------------
687 (defmethod edges ((vertex basic-vertex))
688 (collect-using #'iterate-edges nil vertex))
690 ;;; ---------------------------------------------------------------------------
694 (defmethod vertex-count ((graph basic-graph))
697 ;;; ---------------------------------------------------------------------------
699 (defmethod vertexes ((graph basic-graph))
700 (collect-elements (graph-vertexes graph)))
702 ;;; ---------------------------------------------------------------------------
704 (defmethod source-edge-count ((vertex basic-vertex))
705 (count-using 'iterate-source-edges nil vertex))
707 ;;; ---------------------------------------------------------------------------
709 (defmethod target-edge-count ((vertex basic-vertex))
710 (count-using 'iterate-target-edges nil vertex))
712 ;;; ---------------------------------------------------------------------------
714 (defmethod graph-roots ((graph basic-graph))
715 (collect-elements (graph-vertexes graph) :filter #'rootp))
717 ;;; ---------------------------------------------------------------------------
719 (defmethod rootp ((vertex basic-vertex))
720 ;;?? this is inefficient in the same way that (zerop (length <list>)) is...
721 (zerop (source-edge-count vertex)))
723 ;;; ---------------------------------------------------------------------------
725 (defmethod find-vertex-if ((graph basic-graph) fn &key key)
726 (iterate-vertexes graph
728 (when (funcall fn (if key (funcall key v) v))
729 (return-from find-vertex-if v))))
732 ;;; ---------------------------------------------------------------------------
734 (defmethod find-vertex-if ((edge basic-edge) fn &key key)
735 (iterate-vertexes edge
737 (when (funcall fn (if key (funcall key v) v))
738 (return-from find-vertex-if v))))
741 ;;; ---------------------------------------------------------------------------
743 (defmethod find-edge-if ((graph basic-graph) fn &key key)
746 (when (funcall fn (if key (funcall key e) e))
747 (return-from find-edge-if e))))
750 ;;; ---------------------------------------------------------------------------
752 (defmethod find-edges-if ((graph basic-graph) fn)
753 (collect-using 'iterate-edges fn graph))
755 ;;; ---------------------------------------------------------------------------
757 (defmethod find-vertexes-if ((graph basic-graph) fn)
758 (collect-using 'iterate-vertexes fn graph))
760 ;;; ---------------------------------------------------------------------------
762 (defmethod empty! ((graph basic-graph))
763 (empty! (graph-edges graph))
764 (empty! (graph-vertexes graph))
765 (renumber-edges graph)
766 (renumber-vertexes graph)
769 ;;; ---------------------------------------------------------------------------
771 (defun neighbors-to-children (new-graph root &optional visited-list)
772 (pushnew root visited-list)
776 (when (not (member c visited-list))
777 (add-edge-between-vertexes
778 new-graph (value root) (value c) :edge-type :directed)
779 (neighbors-to-children new-graph c visited-list)))))
781 ;;; ---------------------------------------------------------------------------
783 (defmethod generate-directed-free-tree ((graph basic-graph) root)
784 (generate-directed-free-tree graph (find-vertex graph root)))
786 ;;; ---------------------------------------------------------------------------
788 (defmethod force-undirected ((graph basic-graph))
792 (change-class edge (undirected-edge-class graph)))))
796 ;;; ---------------------------------------------------------------------------
798 ;;; ---------------------------------------------------------------------------
800 (defmethod traverse-elements ((thing basic-graph) (style symbol) fn)
801 (let ((marker (gensym)))
805 (setf (tag vertex) marker)))
810 (traverse-elements-helper vertex style marker fn)))))
812 ;;; ---------------------------------------------------------------------------
814 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
815 (when (eq (tag thing) marker)
816 (setf (tag thing) nil)
820 (traverse-elements-helper vertex style marker fn)))
824 ;;; ---------------------------------------------------------------------------
826 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
827 (when (eq (tag thing) marker)
828 (setf (tag thing) nil)
834 (when (eq (tag vertex) marker)
835 (funcall fn vertex))))
840 (when (eq (tag vertex) marker)
841 (setf (tag vertex) nil)
842 (traverse-elements-helper vertex style marker fn)))))
844 ;;; ---------------------------------------------------------------------------
846 ;; also in metatilites
847 (defun graph-search-for-cl-graph (states goal-p successors combiner
848 &key (state= #'eql) old-states
849 (new-state-fn #'new-states))
850 "Find a state that satisfies goal-p. Start with states,
851 and search according to successors and combiner.
852 Don't try the same state twice."
853 (cond ((null states) nil)
854 ((funcall goal-p (first states)) (first states))
855 (t (graph-search-for-cl-graph
858 (funcall new-state-fn states successors state= old-states)
860 goal-p successors combiner
862 :old-states (adjoin (first states) old-states
864 :new-state-fn new-state-fn))))
866 (defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
867 (let ((first-time? t))
869 (graph-search-for-cl-graph
873 (setf first-time? nil)
874 (eq (find-vertex graph v) start-vertex)))
879 (lambda (states successors state= old-states)
880 ;; Generate successor states that have not been seen before but
881 ;; don't remove the start state.
884 (and (not (eq start-vertex state))
885 (or (member state states :test state=)
886 (member state old-states :test state=))))
887 (funcall successors (first states)))))))))
889 ;;; ---------------------------------------------------------------------------
891 (defmethod in-undirected-cycle-p
892 ((graph basic-graph) (current basic-vertex)
893 &optional (marked (make-container 'simple-associative-container))
896 (setf (item-at-1 marked current) t)
897 (iterate-children current
900 ((eq child previous) nil)
901 ((item-at-1 marked child) (return-from do-it t))
903 (in-undirected-cycle-p graph child marked current)))))))
905 ;;; ---------------------------------------------------------------------------
907 (defmethod any-undirected-cycle-p ((graph basic-graph))
908 (let ((marked (make-container 'simple-associative-container)))
909 (iterate-vertexes graph (lambda (v)
910 (unless (item-at-1 marked v)
911 (when (in-undirected-cycle-p graph v marked)
912 (return-from any-undirected-cycle-p v)))))
915 ;;; ---------------------------------------------------------------------------
917 (defun remove-list (original target)
918 "Removes all elements in original from target."
919 (remove-if (lambda (target-element)
920 (member target-element original))
923 ;;; ---------------------------------------------------------------------------
925 (defun get-nodelist-relatives (node-list)
926 "Collects set of unique relatives of nodes in node-list."
927 (let ((unique-relatives nil))
928 (dolist (node node-list)
929 (setf unique-relatives
930 (append-unique (neighbor-vertexes node) unique-relatives)))
933 ;;; ---------------------------------------------------------------------------
935 (defun get-transitive-closure (vertex-list &optional (depth nil))
936 "Given a list of vertices, returns a combined list of all of the nodes
937 in the transitive closure(s) of each of the vertices in the list
938 (without duplicates). Optional DEPTH limits the depth (in _both_ the
939 child and parent directions) to which the closure is gathered; default
940 nil gathers the entire closure(s)."
941 (labels ((collect-transitive-closure (remaining visited depth)
945 (fixnum (>= (decf depth) 0))))
947 (let* ((non-visited-relatives ;; list of relatives not yet visited
949 (get-nodelist-relatives remaining)))
950 (visited-nodes ;; list of nodes visited so far
951 (append-unique non-visited-relatives visited)))
952 (collect-transitive-closure non-visited-relatives
956 (collect-transitive-closure vertex-list vertex-list depth)))
958 ;;; ---------------------------------------------------------------------------
960 (defmethod edge-count ((graph basic-graph))
961 (count-using #'iterate-edges nil graph))
963 ;;; ---------------------------------------------------------------------------
965 (defmethod edge-count ((vertex basic-vertex))
966 (size (vertex-edges vertex)))
968 ;;; ---------------------------------------------------------------------------
970 (defmethod topological-sort ((graph basic-graph))
971 (assign-level graph 0)
972 (sort (collect-elements (graph-vertexes graph)) #'<
973 :key (lambda (x) (depth-level x))))
975 ;;; ---------------------------------------------------------------------------
977 (defmethod assign-level ((graph basic-graph) (level number))
978 (loop for node in (graph-roots graph)
979 do (assign-level node 0)))
981 ;;; ---------------------------------------------------------------------------
983 (defmethod assign-level ((node basic-vertex) (level number))
984 (if (or (not (depth-level node))
985 (> level (depth-level node)))
986 (setf (depth-level node) level))
987 (iterate-children node (lambda (x) (assign-level x (1+ level)))))
989 ;;; ---------------------------------------------------------------------------
991 (defmethod depth ((graph basic-graph))
992 (assign-level graph 0)
994 (iterate-vertexes graph (lambda (vertex)
995 (when (> (depth-level vertex) depth)
996 (setf depth (depth-level vertex)))))
999 ;;; ---------------------------------------------------------------------------
1001 ;;; ---------------------------------------------------------------------------
1003 (defun map-paths (graph start-vertex length fn &key (filter (constantly t)))
1004 "Apply fn to each path that starts at start-vertex and is of exactly length
1006 ;; a sort of depth first search
1007 (labels ((follow-path (next-vertex current-path length)
1008 (when (zerop length)
1009 (funcall fn (reverse current-path)))
1010 ; (format t "~%~A ~A ~A" current-path next-vertex length)
1011 (when (plusp length)
1015 (when (funcall filter v)
1017 (unless (find-item current-path v)
1018 (let ((new-path (copy-list current-path)))
1019 (follow-path v (push v new-path) (1- length))))))))))
1023 (when (funcall filter v)
1024 (follow-path v (list v start-vertex) (1- length))))))
1027 ;;; ---------------------------------------------------------------------------
1029 (defun map-shortest-paths
1030 (graph start-vertex depth fn &key (filter (constantly t)))
1031 "Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration."
1032 (let ((visited (make-container 'simple-associative-container
1035 (setf (item-at-1 visited p) t))
1037 (item-at-1 visited p))
1039 (loop for n from 1 to (1- depth) do
1040 (map-paths graph start-vertex n
1042 (visit (first (last p))))
1045 (visit start-vertex)
1046 (map-paths graph start-vertex depth
1048 (unless (visited-p (first (last p)))
1053 ;;; ---------------------------------------------------------------------------
1055 ;;; ---------------------------------------------------------------------------
1057 (defun append-unique (list1 list2)
1058 (remove-duplicates (append list1 list2)))
1060 ;;; ---------------------------------------------------------------------------
1061 ;;; project-bipartite-graph
1062 ;;; ---------------------------------------------------------------------------
1064 (defmethod project-bipartite-graph
1065 ((new-graph symbol) graph vertex-class vertex-classifier)
1066 (project-bipartite-graph
1067 (make-instance new-graph) graph vertex-class vertex-classifier))
1069 ;;; ---------------------------------------------------------------------------
1071 (defmethod project-bipartite-graph
1072 ((new-graph basic-graph) graph vertex-class vertex-classifier)
1076 (when (eq (funcall vertex-classifier v) vertex-class)
1077 (add-vertex new-graph (element v)))))
1082 (when (eq (funcall vertex-classifier v) vertex-class)
1085 (lambda (other-class-vertex)
1088 (lambda (this-class-vertex)
1089 (when (< (vertex-id v) (vertex-id this-class-vertex))
1090 (add-edge-between-vertexes
1091 new-graph (element v) (element this-class-vertex)
1092 :if-duplicate-do (lambda (e) (incf (weight e))))))))))))
1098 (setf (ds :g-5000-m-projection)
1099 (project-bipartite-graph
1100 'undirected-graph-container
1104 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1105 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1107 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1112 (setf (ds :g-5000-h-projection)
1113 (project-bipartite-graph
1114 'undirected-graph-container
1118 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1119 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1121 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1126 (project-bipartite-graph
1127 'undirected-graph-container
1131 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1132 (cond ((member vertex-class '(#\x #\y) :test #'char-equal)
1134 ((member vertex-class '(#\a #\b #\c) :test #'char-equal)