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 ;;; ---------------------------------------------------------------------------
91 (defcopy-methods basic-vertex :copy-all t)
93 ;;; ---------------------------------------------------------------------------
95 (defmethod initialize-instance :after ((object basic-vertex) &key graph vertex-id)
96 (when (and graph (not vertex-id))
97 (setf (slot-value object 'vertex-id)
98 (largest-vertex-id graph))
99 (incf (slot-value graph 'largest-vertex-id))))
101 ;;; ---------------------------------------------------------------------------
103 (defmethod print-object ((vertex basic-vertex) stream)
104 (print-unreadable-object (vertex stream :identity nil)
106 (if (and (slot-exists-p vertex 'element) (slot-boundp vertex 'element))
107 (element vertex) "#unbound#"))))
109 ;;; ---------------------------------------------------------------------------
111 (defclass* basic-edge ()
112 ((edge-id 0 ia "The `edge-id` is used internally by CL-Graph for bookkeeping.")
113 (element nil ia :accessor value :initarg :value)
114 (tag nil ia "The `tag` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]")
115 (graph nil ir "The `graph` of which this edge is a part.")
116 (color nil ia "The `color` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]"))
118 (:export-slots edge-id element tag color)
119 #+COPYING :copy-slots
120 (:make-load-form-p t)
121 (:documentation "This is the root class for all edges in CL-Graph."))
123 ;;; ---------------------------------------------------------------------------
125 (defmethod initialize-instance :after ((object basic-edge) &key graph edge-id)
126 (when (and graph (not edge-id))
127 (setf (slot-value object 'edge-id)
128 (largest-edge-id graph))
129 (incf (slot-value graph 'largest-edge-id))))
131 ;;; ---------------------------------------------------------------------------
133 (defmethod print-object ((object basic-edge) stream)
134 (print-unreadable-object (object stream :type t)
135 (format stream "<~A ~A>" (vertex-1 object) (vertex-2 object))))
137 ;;; ---------------------------------------------------------------------------
139 (defclass* directed-edge-mixin (#+COPYING copyable-mixin) ()
141 (:documentation "This mixin class is used to indicate that an edge is directed."))
143 ;;; ---------------------------------------------------------------------------
145 (defclass* weighted-edge-mixin (#+COPYING copyable-mixin)
146 ((weight 1d0 ia "The value of the weight of this edge. Defaults to 1.0d0"))
147 #+COPYING :copy-slots
150 (:documentation "This mixin class adds a `weight` slot to an edge."))
152 ;;; ---------------------------------------------------------------------------
154 (defmethod weight ((edge basic-edge)) (values 1.0))
156 ;;; ---------------------------------------------------------------------------
158 (defclass* basic-graph (#+COPYING copyable-mixin)
159 ((graph-vertexes :unbound ir)
160 (graph-edges :unbound ir)
161 (largest-vertex-id 0 r)
162 (largest-edge-id 0 r)
163 (vertex-class 'basic-vertex ir
164 "The class of the vertexes in the graph. This must extend the base-class for vertexes of the graph type. E.g., all vertexes of a graph-container must extend graph-container-vertex.")
165 (directed-edge-class 'basic-directed-edge ir
166 "The class used to create directed edges in the graph. This must extend the base-class for edges of the graph type and directed-edge-mixin. E.g., the directed-edge-class of a graph-container must extend graph-container-edge and directed-edge-mixin.")
167 (undirected-edge-class 'basic-edge ir
168 "The class used to create undirected edges in the graph. This must extend the base-class for edges of the graph type. E.g., all edges of a graph-container must extend graph-container-edge")
169 (contains-directed-edge-p nil ar
170 "Returns true if graph contains at least one directed edge. [?? Not sure if this is really keep up-to-date.]")
171 (contains-undirected-edge-p nil ar
172 "Returns true if graph contains at least one undirected edge. [?? Not sure if this is really keep up-to-date.]")
173 (vertex-test #'eq ir)
174 (vertex-key #'identity ir)
176 (edge-key #'identity ir)
177 (default-edge-type nil ir
178 "The default edge type for the graph. This should be one of :undirected or :directed.")
179 (default-edge-class nil ir
180 "The default edge class for the graph."))
181 (:make-load-form-p t)
182 (:export-slots vertex-class directed-edge-class undirected-edge-class
183 default-edge-type default-edge-class)
186 (:documentation "This is the root class for all graphs in CL-Graph."))
188 ;;; ---------------------------------------------------------------------------
190 (defmethod initialize-instance :after ((object basic-graph) &key initial-size
192 (setf (slot-value object 'graph-vertexes)
193 (make-vertex-container object initial-size))
194 (setf (slot-value object 'graph-edges)
195 (make-edge-container object initial-size)))
197 ;;; ---------------------------------------------------------------------------
199 (defmethod print-object ((graph basic-graph) stream)
200 (print-unreadable-object (graph stream :type t :identity t)
201 (format stream "~A" (size graph))))
204 ;;; ---------------------------------------------------------------------------
206 ;;; ---------------------------------------------------------------------------
208 (defmethod add-vertex ((graph basic-graph) (value basic-vertex) &key if-duplicate-do)
209 (declare (ignore if-duplicate-do))
212 ;;; ---------------------------------------------------------------------------
214 (defmethod make-vertex-for-graph ((graph basic-graph) &rest args &key
215 (vertex-class (vertex-class graph))
217 (remf args :vertex-class)
218 (assert (subtypep vertex-class (vertex-class graph)) nil
219 "Vertex class '~A' must be a subtype of ~A" vertex-class (vertex-class graph))
220 (apply #'make-instance vertex-class :graph graph args))
222 ;;; ---------------------------------------------------------------------------
224 (defmethod make-edge-for-graph ((graph basic-graph)
225 (vertex-1 basic-vertex) (vertex-2 basic-vertex)
227 (edge-type (default-edge-type graph))
228 (edge-class (default-edge-class graph))
230 (remf args :edge-class)
231 (remf args :edge-type)
233 #| I removed 'em, gwk
235 ;;; I added these - jjm
236 (remf args :vertex-test)
237 (remf args :vertex-key)
238 (remf args :edge-key)
239 (remf args :edge-test)
240 (remf args :force-new?)
244 (assert (or (null edge-type)
245 (eq edge-type :directed)
246 (eq edge-type :undirected)) nil
247 "Edge-type must be nil, :directed or :undirected.")
249 (assert (or (null edge-class)
250 (subtypep edge-class (directed-edge-class graph))
251 (subtypep edge-class (undirected-edge-class graph))) nil
252 "Edge-class must be nil or a subtype of ~A or ~A"
253 (undirected-edge-class graph)
254 (directed-edge-class graph))
256 (apply #'make-instance
259 (:directed (directed-edge-class graph))
260 (:undirected (undirected-edge-class graph))
262 (undirected-edge-class graph))
264 :vertex-1 vertex-1 :vertex-2 vertex-2 args))
267 ;;; ---------------------------------------------------------------------------
269 (defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys)
270 (apply #'make-instance graph-type args))
272 ;;; ---------------------------------------------------------------------------
274 (defmethod make-graph ((classes list) &rest args)
275 (let ((name (find-or-create-class 'basic-graph classes)))
276 (apply #'make-instance name args)))
278 ;;; ---------------------------------------------------------------------------
279 ;;; generic implementation
280 ;;; ---------------------------------------------------------------------------
282 (defmethod undirected-edge-p ((edge basic-edge))
283 (not (directed-edge-p edge)))
285 ;;; ---------------------------------------------------------------------------
287 (defmethod directed-edge-p ((edge basic-edge))
288 (typep edge 'directed-edge-mixin))
290 ;;; ---------------------------------------------------------------------------
292 (defmethod tagged-edge-p ((edge basic-edge))
295 ;;; ---------------------------------------------------------------------------
297 (defmethod untagged-edge-p ((edge basic-edge))
300 ;;; ---------------------------------------------------------------------------
302 (defmethod tag-all-edges ((graph basic-graph))
308 ;;; ---------------------------------------------------------------------------
310 (defmethod tag-all-edges ((vertex basic-vertex))
316 ;;; ---------------------------------------------------------------------------
318 (defmethod untag-all-edges ((graph basic-graph))
322 (setf (tag e) nil))))
324 ;;; ---------------------------------------------------------------------------
326 (defmethod untag-all-edges ((vertex basic-vertex))
330 (setf (tag e) nil))))
332 ;;; ---------------------------------------------------------------------------
334 (defmethod untag-edges ((edges list))
338 (setf (tag e) nil))))
340 ;;; ---------------------------------------------------------------------------
342 (defmethod tag-edges ((edges list))
349 ;;; ---------------------------------------------------------------------------
351 (defmethod (setf element) :around ((value t) (vertex basic-vertex))
352 (with-changing-vertex (vertex)
355 ;;; ---------------------------------------------------------------------------
357 ;; :ignore, :force, :replace, <function>
359 (defmethod add-vertex ((graph basic-graph) (value t) &rest args &key
360 (if-duplicate-do :ignore) &allow-other-keys)
361 (remf args :if-duplicate-do)
362 (let ((existing-vertex (find-vertex graph value nil)))
364 (apply #'make-vertex-for-graph graph :element value args))
366 (values (add-vertex graph (make-it)) why)))
368 (cond ((eq if-duplicate-do :ignore)
369 (values existing-vertex :ignore))
371 ((eq if-duplicate-do :force)
374 ((eq if-duplicate-do :replace)
375 (replace-vertex graph existing-vertex (make-it)))
377 ((eq if-duplicate-do :replace-value)
378 (setf (element existing-vertex) value)
379 (values existing-vertex :replace-value))
382 (values (funcall if-duplicate-do existing-vertex)
388 ;;; ---------------------------------------------------------------------------
390 (defmethod replace-vertex ((graph basic-graph) (old basic-vertex) (new basic-vertex))
391 ;; we need the graph and the new vertex to reference each other
392 ;; we need every edge of the old vertex to use the new-vertex
393 ;; we need to remove the old vertex
395 ;; since I'm tired today, let's ignore trying to make this elegant
397 ;; first, we connect the edges to the new vertex so that they don't get deleted
398 ;; when we delete the old vertex
402 (if (eq (vertex-1 e) old)
403 (setf (slot-value e 'vertex-1) new) (setf (slot-value e 'vertex-2) new))
404 (add-edge-to-vertex e new)))
406 (delete-vertex graph old)
407 (add-vertex graph new))
409 ;;; ---------------------------------------------------------------------------
411 (defmethod add-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
412 &rest args &key (if-duplicate-do :ignore)
414 (declare (ignore if-duplicate-do)
415 (dynamic-extent args))
416 (let ((v1 (or (find-vertex graph value-1 nil)
417 (add-vertex graph value-1 :if-duplicate-do :ignore)))
418 (v2 (or (find-vertex graph value-2 nil)
419 (add-vertex graph value-2 :if-duplicate-do :replace))))
420 (apply #'add-edge-between-vertexes graph v1 v2 args)))
422 ;;; ---------------------------------------------------------------------------
423 ;;; to-do - add-edge-between-vertexes needs to be able to grab the weight and
424 ;;; color from edges that inherit from weight and color mixins
425 ;;; ---------------------------------------------------------------------------
427 (defmethod add-edge-between-vertexes ((graph basic-graph)
428 (v-1 basic-vertex) (v-2 basic-vertex)
430 (value nil) (if-duplicate-do :ignore)
432 (declare (dynamic-extent args))
433 (remf args :if-duplicate-do)
435 (let ((edge (find-edge-between-vertexes graph v-1 v-2 :error-if-not-found? nil)))
439 (apply #'make-edge-for-graph graph v-1 v-2 args))
443 ((eq if-duplicate-do :ignore)
444 (values edge :ignore))
446 ((eq if-duplicate-do :force)
449 ((eq if-duplicate-do :force-if-different-value)
450 (if (equal (value edge) value)
455 ((eq if-duplicate-do :replace)
456 (warn "replace edges isn't really implemented, maybe you can use :replace-value")
457 (delete-edge graph edge)
460 ((eq if-duplicate-do :replace-value)
461 (setf (element edge) value)
462 (values edge :replace-value))
465 (setf edge (funcall if-duplicate-do edge))
466 (values edge :duplicate)))
472 ;;; ---------------------------------------------------------------------------
474 (defmethod add-edge-to-vertex ((edge basic-edge) (vertex basic-vertex))
477 ;;; ---------------------------------------------------------------------------
479 (defmethod find-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
480 &key (error-if-not-found? t))
481 (let ((v1 (find-vertex graph value-1 error-if-not-found?))
482 (v2 (find-vertex graph value-2 error-if-not-found?)))
483 (aif (and v1 v2 (find-edge-between-vertexes graph v1 v2))
485 (when error-if-not-found?
486 (error 'graph-edge-not-found-error :vertex-1 v1 :vertex-2 v2)))))
488 ;;; ---------------------------------------------------------------------------
490 (defmethod delete-edge-between-vertexes ((graph basic-graph)
491 (value-or-vertex-1 t)
492 (value-or-vertex-2 t) &rest args)
493 (let ((edge (apply #'find-edge-between-vertexes
494 graph value-or-vertex-1 value-or-vertex-2 args)))
496 (delete-edge graph edge))))
498 ;;; ---------------------------------------------------------------------------
500 (defmethod delete-edge :after ((graph basic-graph) (edge basic-edge))
501 (delete-item (graph-edges graph) edge)
504 ;;; ---------------------------------------------------------------------------
506 (defmethod delete-vertex ((graph basic-graph) value-or-vertex)
507 (delete-vertex graph (find-vertex graph value-or-vertex)))
509 ;;; ---------------------------------------------------------------------------
511 (defmethod delete-vertex ((graph basic-graph) (vertex basic-vertex))
512 (unless (eq graph (graph vertex))
513 (error 'graph-vertex-not-found-error
514 :graph graph :vertex vertex))
519 (delete-edge graph edge)))
521 (empty! (vertex-edges vertex))
522 (values vertex graph))
524 ;;; ---------------------------------------------------------------------------
526 (defmethod delete-vertex :after ((graph basic-graph)
527 (vertex basic-vertex))
528 (setf (slot-value vertex 'graph) nil)
529 (delete-item-at (graph-vertexes graph)
530 (funcall (vertex-key graph) (element vertex))))
532 ;;; ---------------------------------------------------------------------------
534 (defmethod insert-item ((graph basic-graph) value)
535 (add-vertex graph value))
537 ;;; ---------------------------------------------------------------------------
539 (defmethod source-edges ((vertex basic-vertex) &optional filter)
540 (collect-using #'iterate-source-edges filter vertex))
542 ;;; ---------------------------------------------------------------------------
544 (defmethod target-edges ((vertex basic-vertex) &optional filter)
545 (collect-using #'iterate-target-edges filter vertex))
547 ;;; ---------------------------------------------------------------------------
549 (defmethod child-vertexes (vertex &optional filter)
550 (collect-using #'iterate-children filter vertex))
552 ;;; ---------------------------------------------------------------------------
554 (defmethod parent-vertexes (vertex &optional filter)
555 (collect-using #'iterate-parents filter vertex))
557 ;;; ---------------------------------------------------------------------------
559 (defmethod neighbor-vertexes (vertex &optional filter)
560 (collect-using #'iterate-neighbors filter vertex))
562 ;;; ---------------------------------------------------------------------------
564 (defmethod adjacentp ((graph basic-graph) vertex-1 vertex-2)
565 (adjacentp graph (find-vertex graph vertex-1) (find-vertex graph vertex-2)))
567 ;;; ---------------------------------------------------------------------------
569 (defmethod adjacentp ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex))
573 (when (eq vertex vertex-2)
574 (return-from adjacentp t))))
577 ;;; ---------------------------------------------------------------------------
579 (defmethod number-of-neighbors (vertex)
580 (count-using #'iterate-neighbors nil vertex))
582 ;;; ---------------------------------------------------------------------------
584 (defmethod in-cycle-p ((graph basic-graph) (vertex t))
585 (in-cycle-p graph (find-vertex graph vertex)))
587 ;;; ---------------------------------------------------------------------------
589 (defmethod renumber-vertexes ((graph basic-graph))
591 (iterate-vertexes graph (lambda (vertex)
592 (setf (slot-value vertex 'vertex-id) count)
594 (setf (slot-value graph 'largest-vertex-id) count)))
596 ;;; ---------------------------------------------------------------------------
598 (defmethod renumber-edges ((graph basic-graph))
600 (iterate-edges graph (lambda (vertex)
601 (setf (slot-value vertex 'edge-id) count)
603 (setf (slot-value graph 'largest-edge-id) count)))
605 ;;; ---------------------------------------------------------------------------
608 (defmethod container->list ((graph basic-graph))
609 (collect-elements (graph-vertexes graph))))
611 ;;; ---------------------------------------------------------------------------
613 (defmethod add-vertex :before ((graph basic-graph) (vertex basic-vertex)
614 &key &allow-other-keys)
616 (assert (typep vertex (vertex-class graph)))
617 (setf (item-at (graph-vertexes graph)
618 (funcall (vertex-key graph) (element vertex))) vertex
619 (slot-value vertex 'graph) graph))
621 ;;; ---------------------------------------------------------------------------
623 (defmethod add-edge :before ((graph basic-graph) (edge basic-edge) &key force-new?)
624 (declare (ignore force-new?))
625 (insert-item (graph-edges graph) edge)
626 (setf (slot-value edge 'graph) graph)
627 (if (subtypep (class-name (class-of edge)) 'directed-edge-mixin)
628 (progn (setf (contains-directed-edge-p graph) t))
629 (progn (setf (contains-undirected-edge-p graph) t))))
631 ;;; ---------------------------------------------------------------------------
633 (defmethod find-vertex ((graph basic-graph) (value t)
634 &optional (error-if-not-found? t))
635 (aif (find-item (graph-vertexes graph) (funcall (vertex-key graph) value))
637 (when error-if-not-found?
638 (error 'graph-vertex-not-found-error :vertex value :graph graph))))
640 ;;; ---------------------------------------------------------------------------
642 (defmethod find-vertex ((edge basic-edge) (value t)
643 &optional (error-if-not-found? t))
647 (when (funcall (vertex-test (graph edge))
648 (funcall (vertex-key (graph edge)) (element vertex)) value)
649 (return-from find-vertex vertex))))
650 (when error-if-not-found?
651 (error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge)))
653 ;;; ---------------------------------------------------------------------------
655 (defmethod search-for-vertex ((graph basic-graph) (value t)
656 &key (key (vertex-key graph)) (test 'equal)
657 (error-if-not-found? t))
658 (aif (search-for-node graph value :test test :key key)
660 (when error-if-not-found?
661 (error "~S not found in ~A using key ~S and test ~S" value graph key
664 ;;; ---------------------------------------------------------------------------
666 (defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex)
667 &key (key (vertex-key graph)) (test 'equal)
668 (error-if-not-found? t))
669 (aif (search-for-node (graph-vertexes graph) vertex :test test :key key)
671 (when error-if-not-found?
672 (error "~A not found in ~A" vertex graph))))
674 ;;; ---------------------------------------------------------------------------
676 (defmethod search-for-vertex ((graph basic-graph) (vertex t)
677 &key (key (vertex-key graph)) (test 'equal)
678 (error-if-not-found? t))
679 (aif (search-for-element (graph-vertexes graph) vertex :test test :key key)
681 (when error-if-not-found?
682 (error "~A not found in ~A" vertex graph))))
684 ;;; ---------------------------------------------------------------------------
686 (defmethod iterate-elements ((graph basic-graph) fn)
687 (iterate-elements (graph-vertexes graph)
688 (lambda (vertex) (funcall fn (element vertex)))))
690 ;;; ---------------------------------------------------------------------------
692 (defmethod iterate-nodes ((graph basic-graph) fn)
693 (iterate-nodes (graph-vertexes graph) fn))
695 ;;; ---------------------------------------------------------------------------
697 (defmethod iterate-vertexes ((graph basic-graph) fn)
698 (iterate-nodes (graph-vertexes graph) fn))
700 ;;; ---------------------------------------------------------------------------
702 (defmethod iterate-vertexes ((edge basic-edge) fn)
703 (funcall fn (vertex-1 edge))
704 (funcall fn (vertex-2 edge)))
706 ;;; ---------------------------------------------------------------------------
708 (defmethod size ((graph basic-graph))
709 (size (graph-vertexes graph)))
711 ;;; ---------------------------------------------------------------------------
713 (defmethod edges ((graph basic-graph))
714 (collect-using #'iterate-edges nil graph))
716 ;;; ---------------------------------------------------------------------------
718 (defmethod edges ((vertex basic-vertex))
719 (collect-using #'iterate-edges nil vertex))
721 ;;; ---------------------------------------------------------------------------
725 (defmethod vertex-count ((graph basic-graph))
728 ;;; ---------------------------------------------------------------------------
730 (defmethod vertexes ((graph basic-graph))
731 (collect-elements (graph-vertexes graph)))
733 ;;; ---------------------------------------------------------------------------
735 (defmethod source-edge-count ((vertex basic-vertex))
736 (count-using 'iterate-source-edges nil vertex))
738 ;;; ---------------------------------------------------------------------------
740 (defmethod target-edge-count ((vertex basic-vertex))
741 (count-using 'iterate-target-edges nil vertex))
743 ;;; ---------------------------------------------------------------------------
745 (defmethod graph-roots ((graph basic-graph))
746 (collect-elements (graph-vertexes graph) :filter #'rootp))
748 ;;; ---------------------------------------------------------------------------
750 (defmethod rootp ((vertex basic-vertex))
751 ;;?? this is inefficient in the same way that (zerop (length <list>)) is...
752 (zerop (source-edge-count vertex)))
754 ;;; ---------------------------------------------------------------------------
756 (defmethod find-vertex-if ((graph basic-graph) fn &key key)
757 (iterate-vertexes graph
759 (when (funcall fn (if key (funcall key v) v))
760 (return-from find-vertex-if v))))
763 ;;; ---------------------------------------------------------------------------
765 (defmethod find-vertex-if ((edge basic-edge) fn &key key)
766 (iterate-vertexes edge
768 (when (funcall fn (if key (funcall key v) v))
769 (return-from find-vertex-if v))))
772 ;;; ---------------------------------------------------------------------------
774 (defmethod find-edge-if ((graph basic-graph) fn &key key)
777 (when (funcall fn (if key (funcall key e) e))
778 (return-from find-edge-if e))))
781 ;;; ---------------------------------------------------------------------------
783 (defmethod find-edges-if ((graph basic-graph) fn)
784 (collect-using 'iterate-edges fn graph))
786 ;;; ---------------------------------------------------------------------------
788 (defmethod find-vertexes-if ((graph basic-graph) fn)
789 (collect-using 'iterate-vertexes fn graph))
791 ;;; ---------------------------------------------------------------------------
793 (defmethod empty! ((graph basic-graph))
794 (empty! (graph-edges graph))
795 (empty! (graph-vertexes graph))
796 (renumber-edges graph)
797 (renumber-vertexes graph)
800 ;;; ---------------------------------------------------------------------------
802 (defun neighbors-to-children (new-graph root &optional visited-list)
803 (pushnew root visited-list)
807 (when (not (member c visited-list))
808 (add-edge-between-vertexes
809 new-graph (value root) (value c) :edge-type :directed)
810 (neighbors-to-children new-graph c visited-list)))))
812 ;;; ---------------------------------------------------------------------------
815 (defmethod generate-directed-free-tree ((graph basic-graph) (root basic-vertex))
816 (let ((new-graph (copy-top-level graph)))
818 (nilf (contains-undirected-edge-p new-graph))
819 (neighbors-to-children new-graph root)
822 ;;; ---------------------------------------------------------------------------
824 (defmethod generate-directed-free-tree ((graph basic-graph) root)
825 (generate-directed-free-tree graph (find-vertex graph root)))
827 ;;; ---------------------------------------------------------------------------
829 (defmethod force-undirected ((graph basic-graph))
833 (change-class edge (undirected-edge-class graph)))))
837 ;;; ---------------------------------------------------------------------------
839 ;;; ---------------------------------------------------------------------------
841 (defmethod traverse-elements ((thing basic-graph) (style symbol) fn)
842 (let ((marker (gensym)))
846 (setf (tag vertex) marker)))
851 (traverse-elements-helper vertex style marker fn)))))
853 ;;; ---------------------------------------------------------------------------
855 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
856 (when (eq (tag thing) marker)
861 (traverse-elements-helper vertex style marker fn)))
865 ;;; ---------------------------------------------------------------------------
867 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
868 (when (eq (tag thing) marker)
875 (when (eq (tag vertex) marker)
876 (funcall fn vertex))))
881 (when (eq (tag vertex) marker)
883 (traverse-elements-helper vertex style marker fn)))))
885 ;;; ---------------------------------------------------------------------------
887 (defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
888 (let ((first-time? t))
895 (eq (find-vertex graph v) start-vertex)))
900 (lambda (states successors state= old-states)
901 ;; Generate successor states that have not been seen before but
902 ;; don't remove the start state.
905 (and (not (eq start-vertex state))
906 (or (member state states :test state=)
907 (member state old-states :test state=))))
908 (funcall successors (first states)))))))))
910 ;;; ---------------------------------------------------------------------------
912 (defmethod in-undirected-cycle-p
913 ((graph basic-graph) (current basic-vertex)
914 &optional (marked (make-container 'simple-associative-container))
917 (tf (item-at-1 marked current))
918 (iterate-children current
921 ((eq child previous) nil)
922 ((item-at-1 marked child) (return-from do-it t))
924 (in-undirected-cycle-p graph child marked current)))))))
926 ;;; ---------------------------------------------------------------------------
928 (defmethod any-undirected-cycle-p ((graph basic-graph))
929 (let ((marked (make-container 'simple-associative-container)))
930 (iterate-vertexes graph (lambda (v)
931 (unless (item-at-1 marked v)
932 (when (in-undirected-cycle-p graph v marked)
933 (return-from any-undirected-cycle-p v)))))
936 ;;; ---------------------------------------------------------------------------
938 (defun remove-list (original target)
939 "Removes all elements in original from target."
940 (remove-if (lambda (target-element)
941 (member target-element original))
944 ;;; ---------------------------------------------------------------------------
946 (defun get-nodelist-relatives (node-list)
947 "Collects set of unique relatives of nodes in node-list."
948 (let ((unique-relatives nil))
949 (dolist (node node-list)
950 (setf unique-relatives
951 (append-unique (neighbor-vertexes node) unique-relatives)))
954 ;;; ---------------------------------------------------------------------------
956 (defun get-transitive-closure (vertex-list &optional (depth nil))
957 "Given a list of vertices, returns a combined list of all of the nodes
958 in the transitive closure(s) of each of the vertices in the list
959 (without duplicates). Optional DEPTH limits the depth (in _both_ the
960 child and parent directions) to which the closure is gathered; default
961 nil gathers the entire closure(s)."
962 (labels ((collect-transitive-closure (remaining visited depth)
966 (fixnum (>= (decf depth) 0))))
968 (let* ((non-visited-relatives ;; list of relatives not yet visited
970 (get-nodelist-relatives remaining)))
971 (visited-nodes ;; list of nodes visited so far
972 (append-unique non-visited-relatives visited)))
973 (collect-transitive-closure non-visited-relatives
977 (collect-transitive-closure vertex-list vertex-list depth)))
979 ;;; ---------------------------------------------------------------------------
980 ;;; make-filtered-graph
981 ;;; ---------------------------------------------------------------------------
983 (defmethod complete-links ((new-graph basic-graph)
984 (old-graph basic-graph))
985 ;; Copy links from old-graph ONLY for nodes already in new-graph
989 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
993 (let* ((old-other-vertex (other-vertex old-edge old-graph-vertex))
994 (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil)))
995 (when (and new-other-vertex
996 (< (vertex-id vertex) (vertex-id new-other-vertex)))
997 (let* ((new-edge (copy-template old-edge)))
998 (if (eq old-graph-vertex (vertex-1 old-edge))
999 (setf (slot-value new-edge 'vertex-1) vertex
1000 (slot-value new-edge 'vertex-2) new-other-vertex)
1001 (setf (slot-value new-edge 'vertex-2) vertex
1002 (slot-value new-edge 'vertex-1) new-other-vertex))
1003 (add-edge new-graph new-edge))))))))))
1006 (defmethod complete-links ((new-graph basic-graph)
1007 (old-graph basic-graph))
1008 ;; Copy links from old-graph ONLY for nodes already in new-graph
1012 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
1016 (let* ((old-other-vertex (other-vertex edge old-graph-vertex))
1017 (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil))
1018 (edge-type (if (directed-edge-p edge)
1019 :directed :undirected)))
1020 (when new-other-vertex
1021 (if (and (directed-edge-p edge)
1022 (eq old-graph-vertex (target-vertex edge)))
1023 (add-edge-between-vertexes new-graph new-other-vertex vertex
1025 :edge-type edge-type)
1026 (add-edge-between-vertexes new-graph vertex new-other-vertex
1028 :edge-type edge-type))))))))))
1030 ;;; ---------------------------------------------------------------------------
1032 (defmethod make-filtered-graph ((old-graph basic-graph)
1035 (graph-completion-method nil)
1038 (copy-template old-graph)))
1039 (ecase graph-completion-method
1042 (iterate-vertexes old-graph
1044 (when (funcall test-fn vertex)
1045 (add-vertex new-graph (value vertex))))))
1046 ((:complete-closure-nodes-only
1047 :complete-closure-with-links)
1048 (let* ((old-graph-vertexes (collect-items old-graph :filter test-fn))
1050 (get-transitive-closure old-graph-vertexes depth)))
1051 (dolist (vertex closure-vertexes)
1052 (add-vertex new-graph (copy-template vertex))))))
1054 (ecase graph-completion-method
1055 ((nil :complete-closure-nodes-only) nil)
1057 :complete-closure-with-links)
1058 (complete-links new-graph old-graph)))
1062 ;;; ---------------------------------------------------------------------------
1064 (defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
1065 &optional (depth nil))
1066 (make-filtered-graph graph
1069 :complete-closure-with-links
1072 ;;; ---------------------------------------------------------------------------
1074 (defmethod edge-count ((graph basic-graph))
1075 (length (edges graph)))
1077 ;;; ---------------------------------------------------------------------------
1079 (defmethod edge-count ((vertex basic-vertex))
1080 (size (vertex-edges vertex)))
1082 ;;; ---------------------------------------------------------------------------
1084 (defmethod topological-sort ((graph basic-graph))
1085 (assign-level graph 0)
1086 (sort (collect-elements (graph-vertexes graph)) #'<
1087 :key (lambda (x) (depth-level x))))
1089 ;;; ---------------------------------------------------------------------------
1091 (defmethod assign-level ((graph basic-graph) (level number))
1092 (loop for node in (graph-roots graph)
1093 do (assign-level node 0)))
1095 ;;; ---------------------------------------------------------------------------
1097 (defmethod assign-level ((node basic-vertex) (level number))
1098 (if (or (not (depth-level node))
1099 (> level (depth-level node)))
1100 (setf (depth-level node) level))
1101 (iterate-children node (lambda (x) (assign-level x (1+ level)))))
1103 ;;; ---------------------------------------------------------------------------
1105 (defmethod depth ((graph basic-graph))
1106 (assign-level graph 0)
1108 (iterate-vertexes graph (lambda (vertex)
1109 (maxf depth (depth-level vertex))))
1112 ;;; ---------------------------------------------------------------------------
1114 ;;; ---------------------------------------------------------------------------
1116 (defun map-paths (graph start-vertex length fn &key (filter (constantly t)))
1117 "Apply fn to each path that starts at start-vertex and is of exactly length
1119 ;; a sort of depth first search
1120 (labels ((follow-path (next-vertex current-path length)
1121 (when (zerop length)
1122 (funcall fn (reverse current-path)))
1123 ; (format t "~%~A ~A ~A" current-path next-vertex length)
1124 (when (plusp length)
1128 (when (funcall filter v)
1130 (unless (find-item current-path v)
1131 (let ((new-path (copy-list current-path)))
1132 (follow-path v (push v new-path) (1- length))))))))))
1136 (when (funcall filter v)
1137 (follow-path v (list v start-vertex) (1- length))))))
1140 ;;; ---------------------------------------------------------------------------
1142 (defun map-shortest-paths (graph start-vertex depth fn &key (filter (constantly t)))
1143 "Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration."
1144 (bind ((visited (make-container 'simple-associative-container
1147 (setf (item-at-1 visited p) t))
1149 (item-at-1 visited p))
1151 (loop for n from 1 to (1- depth) do
1152 (map-paths graph start-vertex n
1154 (visit (first (last p))))
1157 (visit start-vertex)
1158 (map-paths graph start-vertex depth
1160 (unless (visited-p (first (last p)))
1165 ;;; ---------------------------------------------------------------------------
1167 ;;; ---------------------------------------------------------------------------
1169 (defun append-unique (list1 list2)
1170 (remove-duplicates (append list1 list2)))
1172 ;;; ---------------------------------------------------------------------------
1173 ;;; project-bipartite-graph
1174 ;;; ---------------------------------------------------------------------------
1176 (defmethod project-bipartite-graph
1177 ((new-graph symbol) graph vertex-class vertex-classifier)
1178 (project-bipartite-graph
1179 (make-instance new-graph) graph vertex-class vertex-classifier))
1181 ;;; ---------------------------------------------------------------------------
1183 (defmethod project-bipartite-graph
1184 ((new-graph basic-graph) graph vertex-class vertex-classifier)
1188 (when (eq (funcall vertex-classifier v) vertex-class)
1189 (add-vertex new-graph (element v)))))
1194 (when (eq (funcall vertex-classifier v) vertex-class)
1197 (lambda (other-class-vertex)
1200 (lambda (this-class-vertex)
1201 (when (< (vertex-id v) (vertex-id this-class-vertex))
1202 (add-edge-between-vertexes
1203 new-graph (element v) (element this-class-vertex)
1204 :if-duplicate-do (lambda (e) (incf (weight e))))))))))))
1210 (setf (ds :g-5000-m-projection)
1211 (project-bipartite-graph
1212 'undirected-graph-container
1216 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1217 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1219 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1224 (setf (ds :g-5000-h-projection)
1225 (project-bipartite-graph
1226 'undirected-graph-container
1230 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1231 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1233 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1238 (project-bipartite-graph
1239 'undirected-graph-container
1243 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1244 (cond ((member vertex-class '(#\x #\y) :test #'char-equal)
1246 ((member vertex-class '(#\a #\b #\c) :test #'char-equal)