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)
225 (assert (or (null edge-type)
226 (eq edge-type :directed)
227 (eq edge-type :undirected)) nil
228 "Edge-type must be nil, :directed or :undirected.")
230 (assert (or (null edge-class)
231 (subtypep edge-class (directed-edge-class graph))
232 (subtypep edge-class (undirected-edge-class graph))) nil
233 "Edge-class must be nil or a subtype of ~A or ~A"
234 (undirected-edge-class graph)
235 (directed-edge-class graph))
237 (apply #'make-instance
240 (:directed (directed-edge-class graph))
241 (:undirected (undirected-edge-class graph))
243 (undirected-edge-class graph))
245 :vertex-1 vertex-1 :vertex-2 vertex-2 args))
247 ;;; ---------------------------------------------------------------------------
249 (defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys)
250 (apply #'make-instance graph-type args))
252 ;;; ---------------------------------------------------------------------------
254 (defmethod make-graph ((classes list) &rest args)
255 (let ((name (dynamic-classes:find-or-create-class 'basic-graph classes)))
256 (apply #'make-instance name args)))
258 ;;; ---------------------------------------------------------------------------
259 ;;; generic implementation
260 ;;; ---------------------------------------------------------------------------
262 (defmethod undirected-edge-p ((edge basic-edge))
263 (not (directed-edge-p edge)))
265 ;;; ---------------------------------------------------------------------------
267 (defmethod directed-edge-p ((edge basic-edge))
268 (typep edge 'directed-edge-mixin))
270 ;;; ---------------------------------------------------------------------------
272 (defmethod tagged-edge-p ((edge basic-edge))
275 ;;; ---------------------------------------------------------------------------
277 (defmethod untagged-edge-p ((edge basic-edge))
280 ;;; ---------------------------------------------------------------------------
282 (defmethod tag-all-edges ((graph basic-graph))
288 ;;; ---------------------------------------------------------------------------
290 (defmethod tag-all-edges ((vertex basic-vertex))
296 ;;; ---------------------------------------------------------------------------
298 (defmethod untag-all-edges ((graph basic-graph))
302 (setf (tag e) nil))))
304 ;;; ---------------------------------------------------------------------------
306 (defmethod untag-all-edges ((vertex basic-vertex))
310 (setf (tag e) nil))))
312 ;;; ---------------------------------------------------------------------------
314 (defmethod untag-edges ((edges list))
318 (setf (tag e) nil))))
320 ;;; ---------------------------------------------------------------------------
322 (defmethod tag-edges ((edges list))
329 ;;; ---------------------------------------------------------------------------
331 (defmethod (setf element) :around ((value t) (vertex basic-vertex))
332 (with-changing-vertex (vertex)
335 ;;; ---------------------------------------------------------------------------
337 ;; :ignore, :force, :replace, <function>
339 (defmethod add-vertex ((graph basic-graph) (value t) &rest args &key
340 (if-duplicate-do :ignore) &allow-other-keys)
341 (remf args :if-duplicate-do)
342 (let ((existing-vertex (find-vertex graph value nil)))
344 (apply #'make-vertex-for-graph graph :element value args))
346 (values (add-vertex graph (make-it)) why)))
348 (cond ((eq if-duplicate-do :ignore)
349 (values existing-vertex :ignore))
351 ((eq if-duplicate-do :force)
354 ((eq if-duplicate-do :replace)
355 (replace-vertex graph existing-vertex (make-it)))
357 ((eq if-duplicate-do :replace-value)
358 (setf (element existing-vertex) value)
359 (values existing-vertex :replace-value))
362 (values (funcall if-duplicate-do existing-vertex)
368 ;;; ---------------------------------------------------------------------------
370 (defmethod replace-vertex ((graph basic-graph) (old basic-vertex) (new basic-vertex))
371 ;; we need the graph and the new vertex to reference each other
372 ;; we need every edge of the old vertex to use the new-vertex
373 ;; we need to remove the old vertex
375 ;; since I'm tired today, let's ignore trying to make this elegant
377 ;; first, we connect the edges to the new vertex so that they don't get deleted
378 ;; when we delete the old vertex
382 (if (eq (vertex-1 e) old)
383 (setf (slot-value e 'vertex-1) new) (setf (slot-value e 'vertex-2) new))
384 (add-edge-to-vertex e new)))
386 (delete-vertex graph old)
387 (add-vertex graph new))
389 ;;; ---------------------------------------------------------------------------
391 (defmethod add-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
392 &rest args &key (if-duplicate-do :ignore)
394 (declare (ignore if-duplicate-do)
395 (dynamic-extent args))
396 (let ((v1 (or (find-vertex graph value-1 nil)
397 (add-vertex graph value-1 :if-duplicate-do :ignore)))
398 (v2 (or (find-vertex graph value-2 nil)
399 (add-vertex graph value-2 :if-duplicate-do :replace))))
400 (apply #'add-edge-between-vertexes graph v1 v2 args)))
402 ;;; ---------------------------------------------------------------------------
403 ;;; to-do - add-edge-between-vertexes needs to be able to grab the weight and
404 ;;; color from edges that inherit from weight and color mixins
405 ;;; ---------------------------------------------------------------------------
407 (defmethod add-edge-between-vertexes ((graph basic-graph)
408 (v-1 basic-vertex) (v-2 basic-vertex)
410 (value nil) (if-duplicate-do :ignore)
412 (declare (dynamic-extent args))
413 (remf args :if-duplicate-do)
415 (let ((edge (find-edge-between-vertexes graph v-1 v-2 :error-if-not-found? nil)))
419 (apply #'make-edge-for-graph graph v-1 v-2 args))
423 ((eq if-duplicate-do :ignore)
424 (values edge :ignore))
426 ((eq if-duplicate-do :force)
429 ((eq if-duplicate-do :force-if-different-value)
430 (if (equal (value edge) value)
435 ((eq if-duplicate-do :replace)
436 (warn "replace edges isn't really implemented, maybe you can use :replace-value")
437 (delete-edge graph edge)
440 ((eq if-duplicate-do :replace-value)
441 (setf (element edge) value)
442 (values edge :replace-value))
445 (setf edge (funcall if-duplicate-do edge))
446 (values edge :duplicate)))
452 ;;; ---------------------------------------------------------------------------
454 (defmethod add-edge-to-vertex ((edge basic-edge) (vertex basic-vertex))
457 ;;; ---------------------------------------------------------------------------
459 (defmethod find-edge-between-vertexes
460 ((graph basic-graph) (value-1 t) (value-2 t)
461 &key (error-if-not-found? t))
462 (let* ((v1 (find-vertex graph value-1 error-if-not-found?))
463 (v2 (find-vertex graph value-2 error-if-not-found?)))
464 (or (and v1 v2 (find-edge-between-vertexes graph v1 v2)))
465 (when error-if-not-found?
466 (error 'graph-edge-not-found-error :vertex-1 v1 :vertex-2 v2))))
468 ;;; ---------------------------------------------------------------------------
470 (defmethod delete-edge-between-vertexes ((graph basic-graph)
471 (value-or-vertex-1 t)
472 (value-or-vertex-2 t) &rest args)
473 (let ((edge (apply #'find-edge-between-vertexes
474 graph value-or-vertex-1 value-or-vertex-2 args)))
476 (delete-edge graph edge))))
478 ;;; ---------------------------------------------------------------------------
480 (defmethod delete-edge :after ((graph basic-graph) (edge basic-edge))
481 (delete-item (graph-edges graph) edge)
485 (defmethod delete-all-edges :after ((graph basic-graph))
486 (empty! (graph-edges graph))
489 ;;; ---------------------------------------------------------------------------
491 (defmethod delete-vertex ((graph basic-graph) value-or-vertex)
492 (delete-vertex graph (find-vertex graph value-or-vertex)))
494 ;;; ---------------------------------------------------------------------------
496 (defmethod delete-vertex ((graph basic-graph) (vertex basic-vertex))
497 (unless (eq graph (graph vertex))
498 (error 'graph-vertex-not-found-error
499 :graph graph :vertex vertex))
504 (delete-edge graph edge)))
506 (empty! (vertex-edges vertex))
507 (values vertex graph))
509 ;;; ---------------------------------------------------------------------------
511 (defmethod delete-vertex :after ((graph basic-graph)
512 (vertex basic-vertex))
513 (setf (slot-value vertex 'graph) nil)
514 (delete-item-at (graph-vertexes graph)
515 (funcall (vertex-key graph) (element vertex))))
517 ;;; ---------------------------------------------------------------------------
519 (defmethod insert-item ((graph basic-graph) value)
520 (add-vertex graph value))
522 ;;; ---------------------------------------------------------------------------
524 (defmethod source-edges ((vertex basic-vertex) &optional filter)
525 (collect-using #'iterate-source-edges filter vertex))
527 ;;; ---------------------------------------------------------------------------
529 (defmethod target-edges ((vertex basic-vertex) &optional filter)
530 (collect-using #'iterate-target-edges filter vertex))
532 ;;; ---------------------------------------------------------------------------
534 (defmethod child-vertexes (vertex &optional filter)
535 (collect-using #'iterate-children filter vertex))
537 ;;; ---------------------------------------------------------------------------
539 (defmethod parent-vertexes (vertex &optional filter)
540 (collect-using #'iterate-parents filter vertex))
542 ;;; ---------------------------------------------------------------------------
544 (defmethod neighbor-vertexes (vertex &optional filter)
545 (collect-using #'iterate-neighbors filter vertex))
547 ;;; ---------------------------------------------------------------------------
549 (defmethod adjacentp ((graph basic-graph) vertex-1 vertex-2)
550 (adjacentp graph (find-vertex graph vertex-1) (find-vertex graph vertex-2)))
552 ;;; ---------------------------------------------------------------------------
554 (defmethod adjacentp ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex))
558 (when (eq vertex vertex-2)
559 (return-from adjacentp t))))
562 ;;; ---------------------------------------------------------------------------
564 (defmethod number-of-neighbors (vertex)
565 (count-using #'iterate-neighbors nil vertex))
567 ;;; ---------------------------------------------------------------------------
569 (defmethod in-cycle-p ((graph basic-graph) (vertex t))
570 (in-cycle-p graph (find-vertex graph vertex)))
572 ;;; ---------------------------------------------------------------------------
574 (defmethod renumber-vertexes ((graph basic-graph))
576 (iterate-vertexes graph (lambda (vertex)
577 (setf (slot-value vertex 'vertex-id) count)
579 (setf (slot-value graph 'largest-vertex-id) count)))
581 ;;; ---------------------------------------------------------------------------
583 (defmethod renumber-edges ((graph basic-graph))
585 (iterate-edges graph (lambda (vertex)
586 (setf (slot-value vertex 'edge-id) count)
588 (setf (slot-value graph 'largest-edge-id) count)))
590 ;;; ---------------------------------------------------------------------------
593 (defmethod container->list ((graph basic-graph))
594 (collect-elements (graph-vertexes graph))))
596 ;;; ---------------------------------------------------------------------------
598 (defmethod add-vertex :before ((graph basic-graph) (vertex basic-vertex)
599 &key &allow-other-keys)
601 (assert (typep vertex (vertex-class graph)))
602 (setf (item-at (graph-vertexes graph)
603 (funcall (vertex-key graph) (element vertex))) vertex
604 (slot-value vertex 'graph) graph))
606 ;;; ---------------------------------------------------------------------------
608 (defmethod add-edge :before ((graph basic-graph) (edge basic-edge) &key force-new?)
609 (declare (ignore force-new?))
610 (insert-item (graph-edges graph) edge)
611 (setf (slot-value edge 'graph) graph)
612 (if (subtypep (class-name (class-of edge)) 'directed-edge-mixin)
613 (progn (setf (contains-directed-edge-p graph) t))
614 (progn (setf (contains-undirected-edge-p graph) t))))
616 ;;; ---------------------------------------------------------------------------
618 (defmethod find-vertex ((graph basic-graph) (value t)
619 &optional (error-if-not-found? t))
620 (or (find-item (graph-vertexes graph) (funcall (vertex-key graph) value))
621 (when error-if-not-found?
622 (error 'graph-vertex-not-found-error :vertex value :graph graph))))
624 (defmethod find-vertex ((graph basic-graph) (vertex basic-vertex)
625 &optional (error-if-not-found? t))
626 (cond ((eq graph (graph vertex))
629 (when error-if-not-found?
630 (error 'graph-vertex-not-found-error
631 :vertex vertex :graph graph)))))
633 (defmethod find-vertex ((edge basic-edge) (value t)
634 &optional (error-if-not-found? t))
638 (when (funcall (vertex-test (graph edge))
639 (funcall (vertex-key (graph edge)) (element vertex)) value)
640 (return-from find-vertex vertex))))
641 (when error-if-not-found?
642 (error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge)))
645 (defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex)
646 &key (key (vertex-key graph)) (test 'equal)
647 (error-if-not-found? t))
648 (or (search-for-node (graph-vertexes graph) vertex :test test :key key)
649 (when error-if-not-found?
650 (error "~A not found in ~A" vertex graph))))
652 (defmethod search-for-vertex ((graph basic-graph) (vertex t)
653 &key (key (vertex-key graph)) (test 'equal)
654 (error-if-not-found? t))
655 (or (search-for-element (graph-vertexes graph) vertex :test test :key key)
656 (when error-if-not-found?
657 (error "~A not found in ~A" vertex graph))))
659 (defmethod iterate-elements ((graph basic-graph) fn)
660 (iterate-elements (graph-vertexes graph)
661 (lambda (vertex) (funcall fn (element vertex)))))
663 ;;; ---------------------------------------------------------------------------
665 (defmethod iterate-nodes ((graph basic-graph) fn)
666 (iterate-nodes (graph-vertexes graph) fn))
668 ;;; ---------------------------------------------------------------------------
670 (defmethod iterate-vertexes ((graph basic-graph) fn)
671 (iterate-nodes (graph-vertexes graph) fn))
673 ;;; ---------------------------------------------------------------------------
675 (defmethod iterate-vertexes ((edge basic-edge) fn)
676 (funcall fn (vertex-1 edge))
677 (funcall fn (vertex-2 edge)))
679 ;;; ---------------------------------------------------------------------------
681 (defmethod size ((graph basic-graph))
682 (size (graph-vertexes graph)))
684 ;;; ---------------------------------------------------------------------------
686 (defmethod edges ((graph basic-graph))
687 (collect-using #'iterate-edges nil graph))
689 ;;; ---------------------------------------------------------------------------
691 (defmethod edges ((vertex basic-vertex))
692 (collect-using #'iterate-edges nil vertex))
694 ;;; ---------------------------------------------------------------------------
698 (defmethod vertex-count ((graph basic-graph))
701 ;;; ---------------------------------------------------------------------------
703 (defmethod vertexes ((graph basic-graph))
704 (collect-elements (graph-vertexes graph)))
706 ;;; ---------------------------------------------------------------------------
708 (defmethod source-edge-count ((vertex basic-vertex))
709 (count-using 'iterate-source-edges nil vertex))
711 ;;; ---------------------------------------------------------------------------
713 (defmethod target-edge-count ((vertex basic-vertex))
714 (count-using 'iterate-target-edges nil vertex))
716 ;;; ---------------------------------------------------------------------------
718 (defmethod graph-roots ((graph basic-graph))
719 (collect-elements (graph-vertexes graph) :filter #'rootp))
721 ;;; ---------------------------------------------------------------------------
723 (defmethod rootp ((vertex basic-vertex))
724 ;;?? this is inefficient in the same way that (zerop (length <list>)) is...
725 (zerop (source-edge-count vertex)))
727 ;;; ---------------------------------------------------------------------------
729 (defmethod find-vertex-if ((graph basic-graph) fn &key key)
730 (iterate-vertexes graph
732 (when (funcall fn (if key (funcall key v) v))
733 (return-from find-vertex-if v))))
736 ;;; ---------------------------------------------------------------------------
738 (defmethod find-vertex-if ((edge basic-edge) fn &key key)
739 (iterate-vertexes edge
741 (when (funcall fn (if key (funcall key v) v))
742 (return-from find-vertex-if v))))
745 ;;; ---------------------------------------------------------------------------
747 (defmethod find-edge-if ((graph basic-graph) fn &key key)
750 (when (funcall fn (if key (funcall key e) e))
751 (return-from find-edge-if e))))
754 ;;; ---------------------------------------------------------------------------
756 (defmethod find-edges-if ((graph basic-graph) fn)
757 (collect-using 'iterate-edges fn graph))
759 ;;; ---------------------------------------------------------------------------
761 (defmethod find-vertexes-if ((graph basic-graph) fn)
762 (collect-using 'iterate-vertexes fn graph))
764 ;;; ---------------------------------------------------------------------------
766 (defmethod empty! ((graph basic-graph))
767 (empty! (graph-edges graph))
768 (empty! (graph-vertexes graph))
769 (renumber-edges graph)
770 (renumber-vertexes graph)
773 ;;; ---------------------------------------------------------------------------
775 (defun neighbors-to-children (new-graph root &optional visited-list)
776 (pushnew root visited-list)
780 (when (not (member c visited-list))
781 (add-edge-between-vertexes
782 new-graph (value root) (value c) :edge-type :directed)
783 (neighbors-to-children new-graph c visited-list)))))
785 ;;; ---------------------------------------------------------------------------
787 (defmethod generate-directed-free-tree ((graph basic-graph) root)
788 (generate-directed-free-tree graph (find-vertex graph root)))
790 ;;; ---------------------------------------------------------------------------
792 (defmethod force-undirected ((graph basic-graph))
796 (change-class edge (undirected-edge-class graph)))))
800 ;;; ---------------------------------------------------------------------------
802 ;;; ---------------------------------------------------------------------------
804 (defmethod traverse-elements ((thing basic-graph) (style symbol) fn)
805 (let ((marker (gensym)))
809 (setf (tag vertex) marker)))
814 (traverse-elements-helper vertex style marker fn)))))
816 ;;; ---------------------------------------------------------------------------
818 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
819 (when (eq (tag thing) marker)
820 (setf (tag thing) nil)
824 (traverse-elements-helper vertex style marker fn)))
828 ;;; ---------------------------------------------------------------------------
830 (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
831 (when (eq (tag thing) marker)
832 (setf (tag thing) nil)
838 (when (eq (tag vertex) marker)
839 (funcall fn vertex))))
844 (when (eq (tag vertex) marker)
845 (setf (tag vertex) nil)
846 (traverse-elements-helper vertex style marker fn)))))
848 ;;; ---------------------------------------------------------------------------
850 ;; also in metatilites
851 (defun graph-search (states goal-p successors combiner
852 &key (state= #'eql) old-states
853 (new-state-fn #'new-states))
854 "Find a state that satisfies goal-p. Start with states,
855 and search according to successors and combiner.
856 Don't try the same state twice."
857 (cond ((null states) nil)
858 ((funcall goal-p (first states)) (first states))
862 (funcall new-state-fn states successors state= old-states)
864 goal-p successors combiner
866 :old-states (adjoin (first states) old-states
868 :new-state-fn new-state-fn))))
870 (defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
871 (let ((first-time? t))
877 (setf first-time? nil)
878 (eq (find-vertex graph v) start-vertex)))
883 (lambda (states successors state= old-states)
884 ;; Generate successor states that have not been seen before but
885 ;; don't remove the start state.
888 (and (not (eq start-vertex state))
889 (or (member state states :test state=)
890 (member state old-states :test state=))))
891 (funcall successors (first states)))))))))
893 ;;; ---------------------------------------------------------------------------
895 (defmethod in-undirected-cycle-p
896 ((graph basic-graph) (current basic-vertex)
897 &optional (marked (make-container 'simple-associative-container))
900 (setf (item-at-1 marked current) t)
901 (iterate-children current
904 ((eq child previous) nil)
905 ((item-at-1 marked child) (return-from do-it t))
907 (in-undirected-cycle-p graph child marked current)))))))
909 ;;; ---------------------------------------------------------------------------
911 (defmethod any-undirected-cycle-p ((graph basic-graph))
912 (let ((marked (make-container 'simple-associative-container)))
913 (iterate-vertexes graph (lambda (v)
914 (unless (item-at-1 marked v)
915 (when (in-undirected-cycle-p graph v marked)
916 (return-from any-undirected-cycle-p v)))))
919 ;;; ---------------------------------------------------------------------------
921 (defun remove-list (original target)
922 "Removes all elements in original from target."
923 (remove-if (lambda (target-element)
924 (member target-element original))
927 ;;; ---------------------------------------------------------------------------
929 (defun get-nodelist-relatives (node-list)
930 "Collects set of unique relatives of nodes in node-list."
931 (let ((unique-relatives nil))
932 (dolist (node node-list)
933 (setf unique-relatives
934 (append-unique (neighbor-vertexes node) unique-relatives)))
937 ;;; ---------------------------------------------------------------------------
939 (defun get-transitive-closure (vertex-list &optional (depth nil))
940 "Given a list of vertices, returns a combined list of all of the nodes
941 in the transitive closure(s) of each of the vertices in the list
942 (without duplicates). Optional DEPTH limits the depth (in _both_ the
943 child and parent directions) to which the closure is gathered; default
944 nil gathers the entire closure(s)."
945 (labels ((collect-transitive-closure (remaining visited depth)
949 (fixnum (>= (decf depth) 0))))
951 (let* ((non-visited-relatives ;; list of relatives not yet visited
953 (get-nodelist-relatives remaining)))
954 (visited-nodes ;; list of nodes visited so far
955 (append-unique non-visited-relatives visited)))
956 (collect-transitive-closure non-visited-relatives
960 (collect-transitive-closure vertex-list vertex-list depth)))
962 ;;; ---------------------------------------------------------------------------
963 ;;; make-filtered-graph
964 ;;; ---------------------------------------------------------------------------
966 (defmethod complete-links ((new-graph basic-graph)
967 (old-graph basic-graph))
968 ;; Copy links from old-graph ONLY for nodes already in new-graph
972 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
976 (let* ((old-other-vertex (other-vertex old-edge old-graph-vertex))
977 (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil)))
978 (when (and new-other-vertex
979 (< (vertex-id vertex) (vertex-id new-other-vertex)))
980 (let* ((new-edge (copy-template old-edge)))
981 (if (eq old-graph-vertex (vertex-1 old-edge))
982 (setf (slot-value new-edge 'vertex-1) vertex
983 (slot-value new-edge 'vertex-2) new-other-vertex)
984 (setf (slot-value new-edge 'vertex-2) vertex
985 (slot-value new-edge 'vertex-1) new-other-vertex))
986 (add-edge new-graph new-edge))))))))))
989 (defmethod complete-links ((new-graph basic-graph)
990 (old-graph basic-graph))
991 ;; Copy links from old-graph ONLY for nodes already in new-graph
995 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
999 (let* ((old-other-vertex (other-vertex edge old-graph-vertex))
1000 (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil))
1001 (edge-type (if (directed-edge-p edge)
1002 :directed :undirected)))
1003 (when new-other-vertex
1004 (if (and (directed-edge-p edge)
1005 (eq old-graph-vertex (target-vertex edge)))
1006 (add-edge-between-vertexes new-graph new-other-vertex vertex
1008 :edge-type edge-type)
1009 (add-edge-between-vertexes new-graph vertex new-other-vertex
1011 :edge-type edge-type))))))))))
1013 ;;; ---------------------------------------------------------------------------
1015 (defmethod make-filtered-graph ((old-graph basic-graph)
1018 (graph-completion-method nil)
1021 (copy-template old-graph)))
1022 (ecase graph-completion-method
1025 (iterate-vertexes old-graph
1027 (when (funcall test-fn vertex)
1028 (add-vertex new-graph (value vertex))))))
1029 ((:complete-closure-nodes-only
1030 :complete-closure-with-links)
1031 (let* ((old-graph-vertexes (collect-items old-graph :filter test-fn))
1033 (get-transitive-closure old-graph-vertexes depth)))
1034 (dolist (vertex closure-vertexes)
1035 (add-vertex new-graph (copy-template vertex))))))
1036 (ecase graph-completion-method
1037 ((nil :complete-closure-nodes-only) nil)
1039 :complete-closure-with-links)
1040 (complete-links new-graph old-graph)))
1043 ;;; ---------------------------------------------------------------------------
1045 (defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
1046 &rest args &key (depth nil) (new-graph nil))
1047 (declare (ignore depth new-graph))
1048 (apply #'make-filtered-graph
1052 :graph-completion-method :complete-closure-with-links
1055 ;;; ---------------------------------------------------------------------------
1057 (defmethod edge-count ((graph basic-graph))
1058 (count-using #'iterate-edges nil graph))
1060 ;;; ---------------------------------------------------------------------------
1062 (defmethod edge-count ((vertex basic-vertex))
1063 (size (vertex-edges vertex)))
1065 ;;; ---------------------------------------------------------------------------
1067 (defmethod topological-sort ((graph basic-graph))
1068 (assign-level graph 0)
1069 (sort (collect-elements (graph-vertexes graph)) #'<
1070 :key (lambda (x) (depth-level x))))
1072 ;;; ---------------------------------------------------------------------------
1074 (defmethod assign-level ((graph basic-graph) (level number))
1075 (loop for node in (graph-roots graph)
1076 do (assign-level node 0)))
1078 ;;; ---------------------------------------------------------------------------
1080 (defmethod assign-level ((node basic-vertex) (level number))
1081 (if (or (not (depth-level node))
1082 (> level (depth-level node)))
1083 (setf (depth-level node) level))
1084 (iterate-children node (lambda (x) (assign-level x (1+ level)))))
1086 ;;; ---------------------------------------------------------------------------
1088 (defmethod depth ((graph basic-graph))
1089 (assign-level graph 0)
1091 (iterate-vertexes graph (lambda (vertex)
1092 (when (> (depth-level vertex) depth)
1093 (setf depth (depth-level vertex)))))
1096 ;;; ---------------------------------------------------------------------------
1098 ;;; ---------------------------------------------------------------------------
1100 (defun map-paths (graph start-vertex length fn &key (filter (constantly t)))
1101 "Apply fn to each path that starts at start-vertex and is of exactly length
1103 ;; a sort of depth first search
1104 (labels ((follow-path (next-vertex current-path length)
1105 (when (zerop length)
1106 (funcall fn (reverse current-path)))
1107 ; (format t "~%~A ~A ~A" current-path next-vertex length)
1108 (when (plusp length)
1112 (when (funcall filter v)
1114 (unless (find-item current-path v)
1115 (let ((new-path (copy-list current-path)))
1116 (follow-path v (push v new-path) (1- length))))))))))
1120 (when (funcall filter v)
1121 (follow-path v (list v start-vertex) (1- length))))))
1124 ;;; ---------------------------------------------------------------------------
1126 (defun map-shortest-paths (graph start-vertex depth fn &key (filter (constantly t)))
1127 "Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration."
1128 (bind ((visited (make-container 'simple-associative-container
1131 (setf (item-at-1 visited p) t))
1133 (item-at-1 visited p))
1135 (loop for n from 1 to (1- depth) do
1136 (map-paths graph start-vertex n
1138 (visit (first (last p))))
1141 (visit start-vertex)
1142 (map-paths graph start-vertex depth
1144 (unless (visited-p (first (last p)))
1149 ;;; ---------------------------------------------------------------------------
1151 ;;; ---------------------------------------------------------------------------
1153 (defun append-unique (list1 list2)
1154 (remove-duplicates (append list1 list2)))
1156 ;;; ---------------------------------------------------------------------------
1157 ;;; project-bipartite-graph
1158 ;;; ---------------------------------------------------------------------------
1160 (defmethod project-bipartite-graph
1161 ((new-graph symbol) graph vertex-class vertex-classifier)
1162 (project-bipartite-graph
1163 (make-instance new-graph) graph vertex-class vertex-classifier))
1165 ;;; ---------------------------------------------------------------------------
1167 (defmethod project-bipartite-graph
1168 ((new-graph basic-graph) graph vertex-class vertex-classifier)
1172 (when (eq (funcall vertex-classifier v) vertex-class)
1173 (add-vertex new-graph (element v)))))
1178 (when (eq (funcall vertex-classifier v) vertex-class)
1181 (lambda (other-class-vertex)
1184 (lambda (this-class-vertex)
1185 (when (< (vertex-id v) (vertex-id this-class-vertex))
1186 (add-edge-between-vertexes
1187 new-graph (element v) (element this-class-vertex)
1188 :if-duplicate-do (lambda (e) (incf (weight e))))))))))))
1194 (setf (ds :g-5000-m-projection)
1195 (project-bipartite-graph
1196 'undirected-graph-container
1200 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1201 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1203 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1208 (setf (ds :g-5000-h-projection)
1209 (project-bipartite-graph
1210 'undirected-graph-container
1214 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1215 (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
1217 ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
1222 (project-bipartite-graph
1223 'undirected-graph-container
1227 (let ((vertex-class (aref (symbol-name (element v)) 0)))
1228 (cond ((member vertex-class '(#\x #\y) :test #'char-equal)
1230 ((member vertex-class '(#\a #\b #\c) :test #'char-equal)