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 ((graph basic-graph) (value basic-vertex) &key if-duplicate-do)
202 (declare (ignore if-duplicate-do))
205 ;;; ---------------------------------------------------------------------------
207 (defmethod make-vertex-for-graph ((graph basic-graph) &rest args &key
208 (vertex-class (vertex-class graph))
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))
215 ;;; ---------------------------------------------------------------------------
217 (defmethod make-edge-for-graph ((graph basic-graph)
218 (vertex-1 basic-vertex) (vertex-2 basic-vertex)
220 (edge-type (default-edge-type graph))
221 (edge-class (default-edge-class graph))
223 (remf args :edge-class)
224 (remf args :edge-type)
226 #| I removed 'em, gwk
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?)
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.")
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))
249 (apply #'make-instance
252 (:directed (directed-edge-class graph))
253 (:undirected (undirected-edge-class graph))
255 (undirected-edge-class graph))
257 :vertex-1 vertex-1 :vertex-2 vertex-2 args))
260 ;;; ---------------------------------------------------------------------------
262 (defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys)
263 (apply #'make-instance graph-type args))
265 ;;; ---------------------------------------------------------------------------
267 (defmethod make-graph ((classes list) &rest args)
268 (let ((name (find-or-create-class 'basic-graph classes)))
269 (apply #'make-instance name args)))
271 ;;; ---------------------------------------------------------------------------
272 ;;; generic implementation
273 ;;; ---------------------------------------------------------------------------
275 (defmethod undirected-edge-p ((edge basic-edge))
276 (not (directed-edge-p edge)))
278 ;;; ---------------------------------------------------------------------------
280 (defmethod directed-edge-p ((edge basic-edge))
281 (typep edge 'directed-edge-mixin))
283 ;;; ---------------------------------------------------------------------------
285 (defmethod tagged-edge-p ((edge basic-edge))
288 ;;; ---------------------------------------------------------------------------
290 (defmethod untagged-edge-p ((edge basic-edge))
293 ;;; ---------------------------------------------------------------------------
295 (defmethod tag-all-edges ((graph basic-graph))
301 ;;; ---------------------------------------------------------------------------
303 (defmethod tag-all-edges ((vertex basic-vertex))
309 ;;; ---------------------------------------------------------------------------
311 (defmethod untag-all-edges ((graph basic-graph))
315 (setf (tag e) nil))))
317 ;;; ---------------------------------------------------------------------------
319 (defmethod untag-all-edges ((vertex basic-vertex))
323 (setf (tag e) nil))))
325 ;;; ---------------------------------------------------------------------------
327 (defmethod untag-edges ((edges list))
331 (setf (tag e) nil))))
333 ;;; ---------------------------------------------------------------------------
335 (defmethod tag-edges ((edges list))
342 ;;; ---------------------------------------------------------------------------
344 (defmethod (setf element) :around ((value t) (vertex basic-vertex))
345 (with-changing-vertex (vertex)
348 ;;; ---------------------------------------------------------------------------
350 ;; :ignore, :force, :replace, <function>
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)))
357 (apply #'make-vertex-for-graph graph :element value args))
359 (values (add-vertex graph (make-it)) why)))
361 (cond ((eq if-duplicate-do :ignore)
362 (values existing-vertex :ignore))
364 ((eq if-duplicate-do :force)
367 ((eq if-duplicate-do :replace)
368 (replace-vertex graph existing-vertex (make-it)))
370 ((eq if-duplicate-do :replace-value)
371 (setf (element existing-vertex) value)
372 (values existing-vertex :replace-value))
375 (values (funcall if-duplicate-do existing-vertex)
381 ;;; ---------------------------------------------------------------------------
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
388 ;; since I'm tired today, let's ignore trying to make this elegant
390 ;; first, we connect the edges to the new vertex so that they don't get deleted
391 ;; when we delete the old vertex
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)))
399 (delete-vertex graph old)
400 (add-vertex graph new))
402 ;;; ---------------------------------------------------------------------------
404 (defmethod add-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
405 &rest args &key (if-duplicate-do :ignore)
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)))
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 ;;; ---------------------------------------------------------------------------
420 (defmethod add-edge-between-vertexes ((graph basic-graph)
421 (v-1 basic-vertex) (v-2 basic-vertex)
423 (value nil) (if-duplicate-do :ignore)
425 (declare (dynamic-extent args))
426 (remf args :if-duplicate-do)
428 (let ((edge (find-edge-between-vertexes graph v-1 v-2 :error-if-not-found? nil)))
432 (apply #'make-edge-for-graph graph v-1 v-2 args))
436 ((eq if-duplicate-do :ignore)
437 (values edge :ignore))
439 ((eq if-duplicate-do :force)
442 ((eq if-duplicate-do :force-if-different-value)
443 (if (equal (value edge) value)
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)
453 ((eq if-duplicate-do :replace-value)
454 (setf (element edge) value)
455 (values edge :replace-value))
458 (setf edge (funcall if-duplicate-do edge))
459 (values edge :duplicate)))
465 ;;; ---------------------------------------------------------------------------
467 (defmethod add-edge-to-vertex ((edge basic-edge) (vertex basic-vertex))
470 ;;; ---------------------------------------------------------------------------
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))
478 (when error-if-not-found?
479 (error 'graph-edge-not-found-error :vertex-1 v1 :vertex-2 v2)))))
481 ;;; ---------------------------------------------------------------------------
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)))
489 (delete-edge graph edge))))
491 ;;; ---------------------------------------------------------------------------
493 (defmethod delete-edge :after ((graph basic-graph) (edge basic-edge))
494 (delete-item (graph-edges graph) edge)
497 ;;; ---------------------------------------------------------------------------
499 (defmethod delete-vertex ((graph basic-graph) value-or-vertex)
500 (delete-vertex graph (find-vertex graph value-or-vertex)))
502 ;;; ---------------------------------------------------------------------------
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))
512 (delete-edge graph edge)))
514 (empty! (vertex-edges vertex))
515 (values vertex graph))
517 ;;; ---------------------------------------------------------------------------
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))))
525 ;;; ---------------------------------------------------------------------------
527 (defmethod insert-item ((graph basic-graph) value)
528 (add-vertex graph value))
530 ;;; ---------------------------------------------------------------------------
532 (defmethod source-edges ((vertex basic-vertex) &optional filter)
533 (collect-using #'iterate-source-edges filter vertex))
535 ;;; ---------------------------------------------------------------------------
537 (defmethod target-edges ((vertex basic-vertex) &optional filter)
538 (collect-using #'iterate-target-edges filter vertex))
540 ;;; ---------------------------------------------------------------------------
542 (defmethod child-vertexes (vertex &optional filter)
543 (collect-using #'iterate-children filter vertex))
545 ;;; ---------------------------------------------------------------------------
547 (defmethod parent-vertexes (vertex &optional filter)
548 (collect-using #'iterate-parents filter vertex))
550 ;;; ---------------------------------------------------------------------------
552 (defmethod neighbor-vertexes (vertex &optional filter)
553 (collect-using #'iterate-neighbors filter vertex))
555 ;;; ---------------------------------------------------------------------------
557 (defmethod adjacentp ((graph basic-graph) vertex-1 vertex-2)
558 (adjacentp graph (find-vertex graph vertex-1) (find-vertex graph vertex-2)))
560 ;;; ---------------------------------------------------------------------------
562 (defmethod adjacentp ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex))
566 (when (eq vertex vertex-2)
567 (return-from adjacentp t))))
570 ;;; ---------------------------------------------------------------------------
572 (defmethod number-of-neighbors (vertex)
573 (count-using #'iterate-neighbors nil vertex))
575 ;;; ---------------------------------------------------------------------------
577 (defmethod in-cycle-p ((graph basic-graph) (vertex t))
578 (in-cycle-p graph (find-vertex graph vertex)))
580 ;;; ---------------------------------------------------------------------------
582 (defmethod renumber-vertexes ((graph basic-graph))
584 (iterate-vertexes graph (lambda (vertex)
585 (setf (slot-value vertex 'vertex-id) count)
587 (setf (slot-value graph 'largest-vertex-id) count)))
589 ;;; ---------------------------------------------------------------------------
591 (defmethod renumber-edges ((graph basic-graph))
593 (iterate-edges graph (lambda (vertex)
594 (setf (slot-value vertex 'edge-id) count)
596 (setf (slot-value graph 'largest-edge-id) count)))
598 ;;; ---------------------------------------------------------------------------
601 (defmethod container->list ((graph basic-graph))
602 (collect-elements (graph-vertexes graph))))
604 ;;; ---------------------------------------------------------------------------
606 (defmethod add-vertex :before ((graph basic-graph) (vertex basic-vertex)
607 &key &allow-other-keys)
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))
614 ;;; ---------------------------------------------------------------------------
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))))
624 ;;; ---------------------------------------------------------------------------
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))
630 (when error-if-not-found?
631 (error 'graph-vertex-not-found-error :vertex value :graph graph))))
633 ;;; ---------------------------------------------------------------------------
635 (defmethod find-vertex ((edge basic-edge) (value t)
636 &optional (error-if-not-found? t))
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)))
646 ;;; ---------------------------------------------------------------------------
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)
653 (when error-if-not-found?
654 (error "~S not found in ~A using key ~S and test ~S" value graph key
657 ;;; ---------------------------------------------------------------------------
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)
664 (when error-if-not-found?
665 (error "~A not found in ~A" vertex graph))))
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)
674 (when error-if-not-found?
675 (error "~A not found in ~A" vertex graph))))
677 ;;; ---------------------------------------------------------------------------
679 (defmethod iterate-elements ((graph basic-graph) fn)
680 (iterate-elements (graph-vertexes graph)
681 (lambda (vertex) (funcall fn (element vertex)))))
683 ;;; ---------------------------------------------------------------------------
685 (defmethod iterate-nodes ((graph basic-graph) fn)
686 (iterate-nodes (graph-vertexes graph) fn))
688 ;;; ---------------------------------------------------------------------------
690 (defmethod iterate-vertexes ((graph basic-graph) fn)
691 (iterate-nodes (graph-vertexes graph) fn))
693 ;;; ---------------------------------------------------------------------------
695 (defmethod iterate-vertexes ((edge basic-edge) fn)
696 (funcall fn (vertex-1 edge))
697 (funcall fn (vertex-2 edge)))
699 ;;; ---------------------------------------------------------------------------
701 (defmethod size ((graph basic-graph))
702 (size (graph-vertexes graph)))
704 ;;; ---------------------------------------------------------------------------
706 (defmethod edges ((graph basic-graph))
707 (collect-using #'iterate-edges nil graph))
709 ;;; ---------------------------------------------------------------------------
711 (defmethod edges ((vertex basic-vertex))
712 (collect-using #'iterate-edges nil vertex))
714 ;;; ---------------------------------------------------------------------------
718 (defmethod vertex-count ((graph basic-graph))
721 ;;; ---------------------------------------------------------------------------
723 (defmethod vertexes ((graph basic-graph))
724 (collect-elements (graph-vertexes graph)))
726 ;;; ---------------------------------------------------------------------------
728 (defmethod source-edge-count ((vertex basic-vertex))
729 (count-using 'iterate-source-edges nil vertex))
731 ;;; ---------------------------------------------------------------------------
733 (defmethod target-edge-count ((vertex basic-vertex))
734 (count-using 'iterate-target-edges nil vertex))
736 ;;; ---------------------------------------------------------------------------
738 (defmethod graph-roots ((graph basic-graph))
739 (collect-elements (graph-vertexes graph) :filter #'rootp))
741 ;;; ---------------------------------------------------------------------------
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)))
747 ;;; ---------------------------------------------------------------------------
749 (defmethod find-vertex-if ((graph basic-graph) fn &key key)
750 (iterate-vertexes graph
752 (when (funcall fn (if key (funcall key v) v))
753 (return-from find-vertex-if v))))
756 ;;; ---------------------------------------------------------------------------
758 (defmethod find-vertex-if ((edge basic-edge) fn &key key)
759 (iterate-vertexes edge
761 (when (funcall fn (if key (funcall key v) v))
762 (return-from find-vertex-if v))))
765 ;;; ---------------------------------------------------------------------------
767 (defmethod find-edge-if ((graph basic-graph) fn &key key)
770 (when (funcall fn (if key (funcall key e) e))
771 (return-from find-edge-if e))))
774 ;;; ---------------------------------------------------------------------------
776 (defmethod find-edges-if ((graph basic-graph) fn)
777 (collect-using 'iterate-edges fn graph))
779 ;;; ---------------------------------------------------------------------------
781 (defmethod find-vertexes-if ((graph basic-graph) fn)
782 (collect-using 'iterate-vertexes fn graph))
784 ;;; ---------------------------------------------------------------------------
786 (defmethod empty! ((graph basic-graph))
787 (empty! (graph-edges graph))
788 (empty! (graph-vertexes graph))
789 (renumber-edges graph)
790 (renumber-vertexes graph)
793 ;;; ---------------------------------------------------------------------------
795 (defun neighbors-to-children (new-graph root &optional visited-list)
796 (pushnew root visited-list)
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)))))
805 ;;; ---------------------------------------------------------------------------
808 (defmethod generate-directed-free-tree ((graph basic-graph) (root basic-vertex))
809 (let ((new-graph (copy-top-level graph)))
811 (nilf (contains-undirected-edge-p new-graph))
812 (neighbors-to-children new-graph root)
815 ;;; ---------------------------------------------------------------------------
817 (defmethod generate-directed-free-tree ((graph basic-graph) root)
818 (generate-directed-free-tree graph (find-vertex graph root)))
820 ;;; ---------------------------------------------------------------------------
822 (defmethod force-undirected ((graph basic-graph))
826 (change-class edge (undirected-edge-class graph)))))
830 ;;; ---------------------------------------------------------------------------
832 ;;; ---------------------------------------------------------------------------
834 (defmethod traverse-elements ((thing basic-graph) (style symbol) fn)
835 (let ((marker (gensym)))
839 (setf (tag vertex) marker)))
844 (traverse-elements-helper vertex style marker fn)))))
846 ;;; ---------------------------------------------------------------------------
848 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
849 (when (eq (tag thing) marker)
854 (traverse-elements-helper vertex style marker fn)))
858 ;;; ---------------------------------------------------------------------------
860 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
861 (when (eq (tag thing) marker)
868 (when (eq (tag vertex) marker)
869 (funcall fn vertex))))
874 (when (eq (tag vertex) marker)
876 (traverse-elements-helper vertex style marker fn)))))
878 ;;; ---------------------------------------------------------------------------
880 (defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
881 (let ((first-time? t))
888 (eq (find-vertex graph v) start-vertex)))
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.
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)))))))))
903 ;;; ---------------------------------------------------------------------------
905 (defmethod in-undirected-cycle-p
906 ((graph basic-graph) (current basic-vertex)
907 &optional (marked (make-container 'simple-associative-container))
910 (tf (item-at-1 marked current))
911 (iterate-children current
914 ((eq child previous) nil)
915 ((item-at-1 marked child) (return-from do-it t))
917 (in-undirected-cycle-p graph child marked current)))))))
919 ;;; ---------------------------------------------------------------------------
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)))))
929 ;;; ---------------------------------------------------------------------------
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))
937 ;;; ---------------------------------------------------------------------------
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)))
947 ;;; ---------------------------------------------------------------------------
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)
959 (fixnum (>= (decf depth) 0))))
961 (let* ((non-visited-relatives ;; list of relatives not yet 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
970 (collect-transitive-closure vertex-list vertex-list depth)))
972 ;;; ---------------------------------------------------------------------------
973 ;;; make-filtered-graph
974 ;;; ---------------------------------------------------------------------------
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
982 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
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))))))))))
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
1005 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
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
1018 :edge-type edge-type)
1019 (add-edge-between-vertexes new-graph vertex new-other-vertex
1021 :edge-type edge-type))))))))))
1023 ;;; ---------------------------------------------------------------------------
1025 (defmethod make-filtered-graph ((old-graph basic-graph)
1028 (graph-completion-method nil)
1031 (copy-template old-graph)))
1032 (ecase graph-completion-method
1035 (iterate-vertexes old-graph
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))
1043 (get-transitive-closure old-graph-vertexes depth)))
1044 (dolist (vertex closure-vertexes)
1045 (add-vertex new-graph (copy-template vertex))))))
1047 (ecase graph-completion-method
1048 ((nil :complete-closure-nodes-only) nil)
1050 :complete-closure-with-links)
1051 (complete-links new-graph old-graph)))
1055 ;;; ---------------------------------------------------------------------------
1057 (defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
1058 &optional (depth nil))
1059 (make-filtered-graph graph
1062 :complete-closure-with-links
1065 ;;; ---------------------------------------------------------------------------
1067 (defmethod edge-count ((graph basic-graph))
1068 (length (edges graph)))
1070 ;;; ---------------------------------------------------------------------------
1072 (defmethod edge-count ((vertex basic-vertex))
1073 (size (vertex-edges vertex)))
1075 ;;; ---------------------------------------------------------------------------
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))))
1082 ;;; ---------------------------------------------------------------------------
1084 (defmethod assign-level ((graph basic-graph) (level number))
1085 (loop for node in (graph-roots graph)
1086 do (assign-level node 0)))
1088 ;;; ---------------------------------------------------------------------------
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)))))
1096 ;;; ---------------------------------------------------------------------------
1098 (defmethod depth ((graph basic-graph))
1099 (assign-level graph 0)
1101 (iterate-vertexes graph (lambda (vertex)
1102 (maxf depth (depth-level vertex))))
1105 ;;; ---------------------------------------------------------------------------
1107 ;;; ---------------------------------------------------------------------------
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
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)
1121 (when (funcall filter v)
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))))))))))
1129 (when (funcall filter v)
1130 (follow-path v (list v start-vertex) (1- length))))))
1133 ;;; ---------------------------------------------------------------------------
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
1140 (setf (item-at-1 visited p) t))
1142 (item-at-1 visited p))
1144 (loop for n from 1 to (1- depth) do
1145 (map-paths graph start-vertex n
1147 (visit (first (last p))))
1150 (visit start-vertex)
1151 (map-paths graph start-vertex depth
1153 (unless (visited-p (first (last p)))
1158 ;;; ---------------------------------------------------------------------------
1160 ;;; ---------------------------------------------------------------------------
1162 (defun append-unique (list1 list2)
1163 (remove-duplicates (append list1 list2)))
1165 ;;; ---------------------------------------------------------------------------
1166 ;;; project-bipartite-graph
1167 ;;; ---------------------------------------------------------------------------
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))
1174 ;;; ---------------------------------------------------------------------------
1176 (defmethod project-bipartite-graph
1177 ((new-graph basic-graph) graph vertex-class vertex-classifier)
1181 (when (eq (funcall vertex-classifier v) vertex-class)
1182 (add-vertex new-graph (element v)))))
1187 (when (eq (funcall vertex-classifier v) vertex-class)
1190 (lambda (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))))))))))))
1203 (setf (ds :g-5000-m-projection)
1204 (project-bipartite-graph
1205 'undirected-graph-container
1209 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1210 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1212 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1217 (setf (ds :g-5000-h-projection)
1218 (project-bipartite-graph
1219 'undirected-graph-container
1223 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1224 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1226 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1231 (project-bipartite-graph
1232 'undirected-graph-container
1236 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1237 (cond ((member vertex-class '(#\x #\y) :test #'char-equal)
1239 ((member vertex-class '(#\a #\b #\c) :test #'char-equal)