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)
21 (defcondition graph-error (error)
25 (:documentation "This is the root condition for errors that occur while running code in CL-Graph."))
28 (defcondition edge-error (graph-error)
29 ((edge nil ir "The `edge` that is implicated in the condition."))
32 (:documentation "This is the root condition for graph errors that have to do with edges."))
35 (defcondition graph-vertex-not-found-error (graph-error)
36 ((vertex nil ir "The vertex or value that could not be found in the graph."))
37 (:report (lambda (c s)
38 (format s "Vertex ~S not found in ~A" (vertex c) (graph c))))
41 (:documentation "This condition is signaled when a vertex can not be found in a graph."))
44 (defcondition graph-vertex-not-found-in-edge-error (edge-error)
46 (:report (lambda (c s)
47 (format s "Vertex ~S not found in ~A" (vertex c) (edge c))))
49 (:documentation "This condition is signaled when a vertex can not be found in an edge."))
52 (defcondition graph-edge-not-found-error (graph-error)
53 ((vertex-1 nil ir "One of the vertexes for which no connecting edge could be found.")
54 (vertex-2 nil ir "One of the vertexes for which no connecting edge could be found."))
55 (:report (lambda (c s)
56 (format s "Edge between ~S and ~S not found in ~A"
57 (vertex-1 c) (vertex-2 c) (graph c))))
60 (:documentation "This condition is signaled when an edge cannot be found in a graph."))
63 (defclass* basic-vertex (container-node-mixin)
64 ((depth-level 0 ia :type number "`Depth-level` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
65 (vertex-id 0 ir "`Vertex-id` is used internally to keep track of vertexes.")
66 (element :unbound ia :accessor value "The `element` is the value that this vertex represents.")
67 (tag nil ia "The `tag` slot is used by some algorithms to keep track of which vertexes have been visited.")
68 (graph nil ia "The graph in which this vertex is contained.")
69 (color nil ia "The `color` slot is used by some algorithms for bookkeeping.")
70 (rank nil ia "The `rank` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
71 (previous-node nil ia "`Previous-node` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
72 (next-node nil ia "`Next-node` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
73 (discovery-time -1 ia "`Discovery-time` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
74 (finish-time -1 ia "`Finish-time` is used by some algorithms for bookkeeping. [?? Should be in a mixin]"))
76 (:export-slots vertex-id tag rank color previous-node next-node
77 discovery-time finish-time)
79 (:documentation "This is the root class for all vertexes in CL-Graph."))
82 (defmethod initialize-instance :after ((object basic-vertex) &key graph vertex-id)
83 (when (and graph (not vertex-id))
84 (setf (slot-value object 'vertex-id)
85 (largest-vertex-id graph))
86 (incf (slot-value graph 'largest-vertex-id))))
89 (defmethod print-object ((vertex basic-vertex) stream)
90 (print-unreadable-object (vertex stream :identity nil)
92 (if (and (slot-exists-p vertex 'element) (slot-boundp vertex 'element))
93 (element vertex) "#unbound#"))))
96 (defclass* basic-edge ()
97 ((edge-id 0 ia "The `edge-id` is used internally by CL-Graph for bookkeeping.")
98 (element nil ia :accessor value :initarg :value)
99 (tag nil ia "The `tag` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]")
100 (graph nil ir "The `graph` of which this edge is a part.")
101 (color nil ia "The `color` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]"))
103 (:export-slots edge-id element tag color)
104 (:make-load-form-p t)
105 (:documentation "This is the root class for all edges in CL-Graph."))
108 (defmethod initialize-instance :after ((object basic-edge) &key graph edge-id)
109 (when (and graph (not edge-id))
110 (setf (slot-value object 'edge-id)
111 (largest-edge-id graph))
112 (incf (slot-value graph 'largest-edge-id))))
115 (defmethod print-object ((object basic-edge) stream)
116 (print-unreadable-object (object stream :type t)
117 (format stream "<~A ~A>" (vertex-1 object) (vertex-2 object))))
120 (defclass* directed-edge-mixin () ()
122 (:documentation "This mixin class is used to indicate that an edge is directed."))
125 (defclass* weighted-edge-mixin ()
126 ((weight 1d0 ia "The value of the weight of this edge. Defaults to 1.0d0"))
129 (:documentation "This mixin class adds a `weight` slot to an edge."))
132 (defmethod weight ((edge basic-edge)) (values 1.0))
135 (defclass* basic-graph ()
136 ((graph-vertexes :unbound ir)
137 (graph-edges :unbound ir)
138 (largest-vertex-id 0 r)
139 (largest-edge-id 0 r)
140 (vertex-class 'basic-vertex ir
141 "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.")
142 (directed-edge-class 'basic-directed-edge ir
143 "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.")
144 (undirected-edge-class 'basic-edge ir
145 "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")
146 (contains-directed-edge-p nil ar
147 "Returns true if graph contains at least one directed edge. [?? Not sure if this is really keep up-to-date.]")
148 (contains-undirected-edge-p nil ar
149 "Returns true if graph contains at least one undirected edge. [?? Not sure if this is really keep up-to-date.]")
150 (vertex-test #'eq ir)
151 (vertex-key #'identity ir)
153 (edge-key #'identity ir)
154 (default-edge-type nil ir
155 "The default edge type for the graph. This should be one of :undirected or :directed.")
156 (default-edge-class nil ir
157 "The default edge class for the graph."))
158 (:make-load-form-p t)
159 (:export-slots vertex-class directed-edge-class undirected-edge-class
160 default-edge-type default-edge-class)
163 (:documentation "This is the root class for all graphs in CL-Graph."))
166 (defmethod initialize-instance :after ((object basic-graph) &key initial-size
168 (setf (slot-value object 'graph-vertexes)
169 (make-vertex-container object initial-size))
170 (setf (slot-value object 'graph-edges)
171 (make-edge-container object initial-size)))
174 (defmethod print-object ((graph basic-graph) stream)
175 (print-unreadable-object (graph stream :type t :identity t)
176 (format stream "[~A,~A]" (size graph) (edge-count graph))))
181 (defmethod add-vertex
182 ((graph basic-graph) (value basic-vertex) &key if-duplicate-do)
183 (declare (ignore if-duplicate-do))
187 (defmethod make-vertex-for-graph ((graph basic-graph) &rest args &key
188 (vertex-class (vertex-class graph))
190 (remf args :vertex-class)
191 (assert (subtypep vertex-class (vertex-class graph)) nil
192 "Vertex class '~A' must be a subtype of ~A" vertex-class (vertex-class graph))
193 (apply #'make-instance vertex-class :graph graph args))
196 (defmethod make-edge-for-graph ((graph basic-graph)
197 (vertex-1 basic-vertex) (vertex-2 basic-vertex)
199 (edge-type (default-edge-type graph))
200 (edge-class (default-edge-class graph))
202 (remf args :edge-class)
203 (remf args :edge-type)
204 (assert (or (null edge-type)
205 (eq edge-type :directed)
206 (eq edge-type :undirected)) nil
207 "Edge-type must be nil, :directed or :undirected.")
209 (assert (or (null edge-class)
210 (subtypep edge-class (directed-edge-class graph))
211 (subtypep edge-class (undirected-edge-class graph))) nil
212 "Edge-class must be nil or a subtype of ~A or ~A"
213 (undirected-edge-class graph)
214 (directed-edge-class graph))
216 (apply #'make-instance
219 (:directed (directed-edge-class graph))
220 (:undirected (undirected-edge-class graph))
222 (undirected-edge-class graph))
224 :vertex-1 vertex-1 :vertex-2 vertex-2 args))
227 (defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys)
228 (apply #'make-instance graph-type args))
230 ;;; generic implementation
232 (defmethod undirected-edge-p ((edge basic-edge))
233 (not (directed-edge-p edge)))
236 (defmethod directed-edge-p ((edge basic-edge))
237 (typep edge 'directed-edge-mixin))
240 (defmethod tagged-edge-p ((edge basic-edge))
244 (defmethod untagged-edge-p ((edge basic-edge))
248 (defmethod tag-all-edges ((graph basic-graph))
255 (defmethod tag-all-edges ((vertex basic-vertex))
262 (defmethod untag-all-edges ((graph basic-graph))
266 (setf (tag e) nil))))
269 (defmethod untag-all-edges ((vertex basic-vertex))
273 (setf (tag e) nil))))
276 (defmethod untag-edges ((edges list))
280 (setf (tag e) nil))))
283 (defmethod tag-edges ((edges list))
291 (defmethod (setf element) :around ((value t) (vertex basic-vertex))
292 (with-changing-vertex (vertex)
296 ;; :ignore, :force, :replace, <function>
298 (defmethod add-vertex ((graph basic-graph) (value t) &rest args &key
299 (if-duplicate-do :ignore) &allow-other-keys)
300 (remf args :if-duplicate-do)
301 (let ((existing-vertex (find-vertex graph value nil)))
303 (apply #'make-vertex-for-graph graph :element value args))
305 (values (add-vertex graph (make-it)) why)))
307 (cond ((eq if-duplicate-do :ignore)
308 (values existing-vertex :ignore))
310 ((eq if-duplicate-do :force)
313 ((eq if-duplicate-do :replace)
314 (replace-vertex graph existing-vertex (make-it)))
316 ((eq if-duplicate-do :replace-value)
317 (setf (element existing-vertex) value)
318 (values existing-vertex :replace-value))
321 (values (funcall if-duplicate-do existing-vertex)
328 (defmethod replace-vertex ((graph basic-graph) (old basic-vertex) (new basic-vertex))
329 ;; we need the graph and the new vertex to reference each other
330 ;; we need every edge of the old vertex to use the new-vertex
331 ;; we need to remove the old vertex
333 ;; since I'm tired today, let's ignore trying to make this elegant
335 ;; first, we connect the edges to the new vertex so that they don't get deleted
336 ;; when we delete the old vertex
340 (if (eq (vertex-1 e) old)
341 (setf (slot-value e 'vertex-1) new) (setf (slot-value e 'vertex-2) new))
342 (add-edge-to-vertex e new)))
344 (delete-vertex graph old)
345 (add-vertex graph new))
348 (defmethod add-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
349 &rest args &key (if-duplicate-do :ignore)
351 (declare (ignore if-duplicate-do)
352 (dynamic-extent args))
353 (let ((v1 (or (find-vertex graph value-1 nil)
354 (add-vertex graph value-1 :if-duplicate-do :ignore)))
355 (v2 (or (find-vertex graph value-2 nil)
356 (add-vertex graph value-2 :if-duplicate-do :replace))))
357 (apply #'add-edge-between-vertexes graph v1 v2 args)))
359 ;;; to-do - add-edge-between-vertexes needs to be able to grab the weight and
360 ;;; color from edges that inherit from weight and color mixins
362 (defmethod add-edge-between-vertexes ((graph basic-graph)
363 (v-1 basic-vertex) (v-2 basic-vertex)
365 (value nil) (if-duplicate-do :ignore)
367 (declare (dynamic-extent args))
368 (remf args :if-duplicate-do)
370 (let ((edge (find-edge-between-vertexes graph v-1 v-2 :error-if-not-found? nil)))
374 (apply #'make-edge-for-graph graph v-1 v-2 args))
378 ((eq if-duplicate-do :ignore)
379 (values edge :ignore))
381 ((eq if-duplicate-do :force)
384 ((eq if-duplicate-do :force-if-different-value)
385 (if (equal (value edge) value)
390 ((eq if-duplicate-do :replace)
391 (warn "replace edges isn't really implemented, maybe you can use :replace-value")
392 (delete-edge graph edge)
395 ((eq if-duplicate-do :replace-value)
396 (setf (element edge) value)
397 (values edge :replace-value))
400 (setf edge (funcall if-duplicate-do edge))
401 (values edge :duplicate)))
408 (defmethod add-edge-to-vertex ((edge basic-edge) (vertex basic-vertex))
412 (defmethod find-edge-between-vertexes
413 ((graph basic-graph) (value-1 t) (value-2 t)
414 &key (error-if-not-found? t))
415 (let* ((v1 (find-vertex graph value-1 error-if-not-found?))
416 (v2 (find-vertex graph value-2 error-if-not-found?)))
417 (or (and v1 v2 (find-edge-between-vertexes graph v1 v2))
418 (when error-if-not-found?
419 (error 'graph-edge-not-found-error
420 :graph graph :vertex-1 v1 :vertex-2 v2)))))
423 (defmethod delete-edge-between-vertexes ((graph basic-graph)
424 (value-or-vertex-1 t)
425 (value-or-vertex-2 t) &rest args)
426 (let ((edge (apply #'find-edge-between-vertexes
427 graph value-or-vertex-1 value-or-vertex-2 args)))
429 (delete-edge graph edge))))
432 (defmethod delete-edge :after ((graph basic-graph) (edge basic-edge))
433 (delete-item (graph-edges graph) edge)
437 (defmethod delete-all-edges :after ((graph basic-graph))
438 (empty! (graph-edges graph))
442 (defmethod delete-vertex ((graph basic-graph) value-or-vertex)
443 (delete-vertex graph (find-vertex graph value-or-vertex)))
446 (defmethod delete-vertex ((graph basic-graph) (vertex basic-vertex))
447 (unless (eq graph (graph vertex))
448 (error 'graph-vertex-not-found-error
449 :graph graph :vertex vertex))
454 (delete-edge graph edge)))
456 (empty! (vertex-edges vertex))
457 (values vertex graph))
460 (defmethod delete-vertex :after ((graph basic-graph)
461 (vertex basic-vertex))
462 (setf (slot-value vertex 'graph) nil)
463 (delete-item-at (graph-vertexes graph)
464 (funcall (vertex-key graph) (element vertex))))
467 (defmethod insert-item ((graph basic-graph) value)
468 (add-vertex graph value))
471 (defmethod source-edges ((vertex basic-vertex) &optional filter)
472 (collect-using #'iterate-source-edges filter vertex))
475 (defmethod target-edges ((vertex basic-vertex) &optional filter)
476 (collect-using #'iterate-target-edges filter vertex))
479 (defmethod child-vertexes (vertex &optional filter)
480 (collect-using #'iterate-children filter vertex))
483 (defmethod parent-vertexes (vertex &optional filter)
484 (collect-using #'iterate-parents filter vertex))
487 (defmethod neighbor-vertexes (vertex &optional filter)
488 (collect-using #'iterate-neighbors filter vertex))
491 (defmethod adjacentp ((graph basic-graph) vertex-1 vertex-2)
492 (adjacentp graph (find-vertex graph vertex-1) (find-vertex graph vertex-2)))
495 (defmethod adjacentp ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex))
499 (when (eq vertex vertex-2)
500 (return-from adjacentp t))))
504 (defmethod number-of-neighbors (vertex)
505 (count-using #'iterate-neighbors nil vertex))
508 (defmethod in-cycle-p ((graph basic-graph) (vertex t))
509 (in-cycle-p graph (find-vertex graph vertex)))
512 (defmethod renumber-vertexes ((graph basic-graph))
514 (iterate-vertexes graph (lambda (vertex)
515 (setf (slot-value vertex 'vertex-id) count)
517 (setf (slot-value graph 'largest-vertex-id) count)))
520 (defmethod renumber-edges ((graph basic-graph))
522 (iterate-edges graph (lambda (vertex)
523 (setf (slot-value vertex 'edge-id) count)
525 (setf (slot-value graph 'largest-edge-id) count)))
529 (defmethod container->list ((graph basic-graph))
530 (collect-elements (graph-vertexes graph))))
533 (defmethod add-vertex :before ((graph basic-graph) (vertex basic-vertex)
534 &key &allow-other-keys)
536 (assert (typep vertex (vertex-class graph)))
537 (setf (item-at (graph-vertexes graph)
538 (funcall (vertex-key graph) (element vertex))) vertex
539 (slot-value vertex 'graph) graph))
542 (defmethod add-edge :before ((graph basic-graph) (edge basic-edge) &key force-new?)
543 (declare (ignore force-new?))
544 (insert-item (graph-edges graph) edge)
545 (setf (slot-value edge 'graph) graph)
546 (if (subtypep (class-name (class-of edge)) 'directed-edge-mixin)
547 (progn (setf (contains-directed-edge-p graph) t))
548 (progn (setf (contains-undirected-edge-p graph) t))))
551 (defmethod find-vertex ((graph basic-graph) (value t)
552 &optional (error-if-not-found? t))
553 (or (find-item (graph-vertexes graph) (funcall (vertex-key graph) value))
554 (when error-if-not-found?
555 (error 'graph-vertex-not-found-error :vertex value :graph graph))))
557 (defmethod find-vertex ((graph basic-graph) (vertex basic-vertex)
558 &optional (error-if-not-found? t))
559 (cond ((eq graph (graph vertex))
562 (when error-if-not-found?
563 (error 'graph-vertex-not-found-error
564 :vertex vertex :graph graph)))))
566 (defmethod find-vertex ((edge basic-edge) (value t)
567 &optional (error-if-not-found? t))
571 (when (funcall (vertex-test (graph edge))
572 (funcall (vertex-key (graph edge)) (element vertex)) value)
573 (return-from find-vertex vertex))))
574 (when error-if-not-found?
575 (error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge)))
578 (defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex)
579 &key (key (vertex-key graph)) (test 'equal)
580 (error-if-not-found? t))
581 (or (search-for-node (graph-vertexes graph) vertex :test test :key key)
582 (when error-if-not-found?
583 (error "~A not found in ~A" vertex graph))))
585 (defmethod search-for-vertex ((graph basic-graph) (vertex t)
586 &key (key (vertex-key graph)) (test 'equal)
587 (error-if-not-found? t))
588 (or (search-for-element (graph-vertexes graph) vertex :test test :key key)
589 (when error-if-not-found?
590 (error "~A not found in ~A" vertex graph))))
592 (defmethod iterate-elements ((graph basic-graph) fn)
593 (iterate-elements (graph-vertexes graph)
594 (lambda (vertex) (funcall fn (element vertex)))))
597 (defmethod iterate-nodes ((graph basic-graph) fn)
598 (iterate-nodes (graph-vertexes graph) fn))
601 (defmethod iterate-vertexes ((graph basic-graph) fn)
602 (iterate-nodes (graph-vertexes graph) fn))
605 (defmethod iterate-vertexes ((edge basic-edge) fn)
606 (funcall fn (vertex-1 edge))
607 (funcall fn (vertex-2 edge)))
610 (defmethod size ((graph basic-graph))
611 (size (graph-vertexes graph)))
614 (defmethod edges ((graph basic-graph))
615 (collect-using #'iterate-edges nil graph))
618 (defmethod edges ((vertex basic-vertex))
619 (collect-using #'iterate-edges nil vertex))
624 (defmethod vertex-count ((graph basic-graph))
628 (defmethod vertexes ((graph basic-graph))
629 (collect-elements (graph-vertexes graph)))
632 (defmethod source-edge-count ((vertex basic-vertex))
633 (count-using 'iterate-source-edges nil vertex))
636 (defmethod target-edge-count ((vertex basic-vertex))
637 (count-using 'iterate-target-edges nil vertex))
640 (defmethod graph-roots ((graph basic-graph))
641 (collect-elements (graph-vertexes graph) :filter #'rootp))
644 (defmethod rootp ((vertex basic-vertex))
645 ;;?? this is inefficient in the same way that (zerop (length <list>)) is...
646 (zerop (source-edge-count vertex)))
649 (defmethod find-vertex-if ((graph basic-graph) fn &key key)
650 (iterate-vertexes graph
652 (when (funcall fn (if key (funcall key v) v))
653 (return-from find-vertex-if v))))
657 (defmethod find-vertex-if ((edge basic-edge) fn &key key)
658 (iterate-vertexes edge
660 (when (funcall fn (if key (funcall key v) v))
661 (return-from find-vertex-if v))))
665 (defmethod find-edge-if ((graph basic-graph) fn &key key)
668 (when (funcall fn (if key (funcall key e) e))
669 (return-from find-edge-if e))))
673 (defmethod find-edges-if ((graph basic-graph) fn)
674 (collect-using 'iterate-edges fn graph))
677 (defmethod find-vertexes-if ((graph basic-graph) fn)
678 (collect-using 'iterate-vertexes fn graph))
681 (defmethod empty! ((graph basic-graph))
682 (empty! (graph-edges graph))
683 (empty! (graph-vertexes graph))
684 (renumber-edges graph)
685 (renumber-vertexes graph)
689 (defun neighbors-to-children (new-graph root &optional visited-list)
690 (pushnew root visited-list)
694 (when (not (member c visited-list))
695 (add-edge-between-vertexes
696 new-graph (value root) (value c) :edge-type :directed)
697 (neighbors-to-children new-graph c visited-list)))))
700 (defmethod generate-directed-free-tree ((graph basic-graph) root)
701 (generate-directed-free-tree graph (find-vertex graph root)))
704 (defmethod force-undirected ((graph basic-graph))
708 (change-class edge (undirected-edge-class graph)))))
714 (defmethod traverse-elements ((thing basic-graph) (style symbol) fn)
715 (let ((marker (gensym)))
719 (setf (tag vertex) marker)))
724 (traverse-elements-helper vertex style marker fn)))))
727 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
728 (when (eq (tag thing) marker)
729 (setf (tag thing) nil)
733 (traverse-elements-helper vertex style marker fn)))
738 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
739 (when (eq (tag thing) marker)
740 (setf (tag thing) nil)
746 (when (eq (tag vertex) marker)
747 (funcall fn vertex))))
752 (when (eq (tag vertex) marker)
753 (setf (tag vertex) nil)
754 (traverse-elements-helper vertex style marker fn)))))
757 ;; also in metatilites
758 (defun graph-search-for-cl-graph (states goal-p successors combiner
759 &key (state= #'eql) old-states
760 (new-state-fn #'new-states))
761 "Find a state that satisfies goal-p. Start with states,
762 and search according to successors and combiner.
763 Don't try the same state twice."
764 (cond ((null states) nil)
765 ((funcall goal-p (first states)) (first states))
766 (t (graph-search-for-cl-graph
769 (funcall new-state-fn states successors state= old-states)
771 goal-p successors combiner
773 :old-states (adjoin (first states) old-states
775 :new-state-fn new-state-fn))))
777 (defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
778 (let ((first-time? t))
780 (graph-search-for-cl-graph
784 (setf first-time? nil)
785 (eq (find-vertex graph v) start-vertex)))
790 (lambda (states successors state= old-states)
791 ;; Generate successor states that have not been seen before but
792 ;; don't remove the start state.
795 (and (not (eq start-vertex state))
796 (or (member state states :test state=)
797 (member state old-states :test state=))))
798 (funcall successors (first states)))))))))
801 (defmethod in-undirected-cycle-p
802 ((graph basic-graph) (current basic-vertex)
803 &optional (marked (make-container 'simple-associative-container))
806 (setf (item-at-1 marked current) t)
807 (iterate-children current
810 ((eq child previous) nil)
811 ((item-at-1 marked child) (return-from do-it t))
813 (in-undirected-cycle-p graph child marked current)))))))
816 (defmethod any-undirected-cycle-p ((graph basic-graph))
817 (let ((marked (make-container 'simple-associative-container)))
818 (iterate-vertexes graph (lambda (v)
819 (unless (item-at-1 marked v)
820 (when (in-undirected-cycle-p graph v marked)
821 (return-from any-undirected-cycle-p v)))))
825 (defun remove-list (original target)
826 "Removes all elements in original from target."
827 (remove-if (lambda (target-element)
828 (member target-element original))
832 (defun get-nodelist-relatives (node-list)
833 "Collects set of unique relatives of nodes in node-list."
834 (let ((unique-relatives nil))
835 (dolist (node node-list)
836 (setf unique-relatives
837 (append-unique (neighbor-vertexes node) unique-relatives)))
841 (defun get-transitive-closure (vertex-list &optional (depth nil))
842 "Given a list of vertices, returns a combined list of all of the nodes
843 in the transitive closure(s) of each of the vertices in the list
844 (without duplicates). Optional DEPTH limits the depth (in _both_ the
845 child and parent directions) to which the closure is gathered; default
846 nil gathers the entire closure(s)."
847 (labels ((collect-transitive-closure (remaining visited depth)
851 (fixnum (>= (decf depth) 0))))
853 (let* ((non-visited-relatives ;; list of relatives not yet visited
855 (get-nodelist-relatives remaining)))
856 (visited-nodes ;; list of nodes visited so far
857 (append-unique non-visited-relatives visited)))
858 (collect-transitive-closure non-visited-relatives
862 (collect-transitive-closure vertex-list vertex-list depth)))
865 (defmethod edge-count ((graph basic-graph))
866 (count-using #'iterate-edges nil graph))
869 (defmethod edge-count ((vertex basic-vertex))
870 (size (vertex-edges vertex)))
873 (defmethod topological-sort ((graph basic-graph))
874 (assign-level graph 0)
875 (sort (collect-elements (graph-vertexes graph)) #'<
876 :key (lambda (x) (depth-level x))))
879 (defmethod assign-level ((graph basic-graph) (level number))
880 (loop for node in (graph-roots graph)
881 do (assign-level node 0)))
884 (defmethod assign-level ((node basic-vertex) (level number))
885 (if (or (not (depth-level node))
886 (> level (depth-level node)))
887 (setf (depth-level node) level))
888 (iterate-children node (lambda (x) (assign-level x (1+ level)))))
891 (defmethod depth ((graph basic-graph))
892 (assign-level graph 0)
894 (iterate-vertexes graph (lambda (vertex)
895 (when (> (depth-level vertex) depth)
896 (setf depth (depth-level vertex)))))
901 (defun map-paths (graph start-vertex length fn &key (filter (constantly t)))
902 "Apply fn to each path that starts at start-vertex and is of exactly length
904 ;; a sort of depth first search
905 (labels ((follow-path (next-vertex current-path length)
907 (funcall fn (reverse current-path)))
908 ; (format t "~%~A ~A ~A" current-path next-vertex length)
913 (when (funcall filter v)
915 (unless (find-item current-path v)
916 (let ((new-path (copy-list current-path)))
917 (follow-path v (push v new-path) (1- length))))))))))
921 (when (funcall filter v)
922 (follow-path v (list v start-vertex) (1- length))))))
926 (defun map-shortest-paths
927 (graph start-vertex depth fn &key (filter (constantly t)))
928 "Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration."
929 (let ((visited (make-container 'simple-associative-container
932 (setf (item-at-1 visited p) t))
934 (item-at-1 visited p))
936 (loop for n from 1 to (1- depth) do
937 (map-paths graph start-vertex n
939 (visit (first (last p))))
943 (map-paths graph start-vertex depth
945 (unless (visited-p (first (last p)))
952 (defun append-unique (list1 list2)
953 (remove-duplicates (append list1 list2)))
955 ;;; project-bipartite-graph
957 (defmethod project-bipartite-graph
958 ((new-graph symbol) graph vertex-class vertex-classifier)
959 (project-bipartite-graph
960 (make-instance new-graph) graph vertex-class vertex-classifier))
963 (defmethod project-bipartite-graph
964 ((new-graph basic-graph) graph vertex-class vertex-classifier)
968 (when (eq (funcall vertex-classifier v) vertex-class)
969 (add-vertex new-graph (element v)))))
974 (when (eq (funcall vertex-classifier v) vertex-class)
977 (lambda (other-class-vertex)
980 (lambda (this-class-vertex)
981 (when (< (vertex-id v) (vertex-id this-class-vertex))
982 (add-edge-between-vertexes
983 new-graph (element v) (element this-class-vertex)
984 :if-duplicate-do (lambda (e) (incf (weight e))))))))))))
990 (setf (ds :g-5000-m-projection)
991 (project-bipartite-graph
992 'undirected-graph-container
996 (let ((vertex-class (aref (symbol-name (element v)) 0)))
997 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
999 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1004 (setf (ds :g-5000-h-projection)
1005 (project-bipartite-graph
1006 'undirected-graph-container
1010 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1011 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1013 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1018 (project-bipartite-graph
1019 'undirected-graph-container
1023 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1024 (cond ((member vertex-class '(#\x #\y) :test #'char-equal)
1026 ((member vertex-class '(#\a #\b #\c) :test #'char-equal)