X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=dev%2Fgraph.lisp;h=60864ff9988ea8a09eddf5ad0e73abe566af74a5;hb=6dae43e4ee011ea0ef4fedeae7c2a492823a9812;hp=e0c5aeeff257562139cff75c8882f4aa67c7f928;hpb=a196e72eb584440a594f0665ff5c97037ce4cf70;p=cl-graph.git diff --git a/dev/graph.lisp b/dev/graph.lisp index e0c5aee..60864ff 100644 --- a/dev/graph.lisp +++ b/dev/graph.lisp @@ -14,11 +14,9 @@ something is putting something on the vertexes plist's |# -(in-package metabang.graph) +(in-package #:metabang.graph) -;;; --------------------------------------------------------------------------- ;;; classes -;;; --------------------------------------------------------------------------- (defcondition graph-error (error) ((graph nil ir)) @@ -26,7 +24,6 @@ something is putting something on the vertexes plist's (:export-slots-p t) (:documentation "This is the root condition for errors that occur while running code in CL-Graph.")) -;;; --------------------------------------------------------------------------- (defcondition edge-error (graph-error) ((edge nil ir "The `edge` that is implicated in the condition.")) @@ -34,7 +31,6 @@ something is putting something on the vertexes plist's (:export-slots-p t) (:documentation "This is the root condition for graph errors that have to do with edges.")) -;;; --------------------------------------------------------------------------- (defcondition graph-vertex-not-found-error (graph-error) ((vertex nil ir "The vertex or value that could not be found in the graph.")) @@ -44,7 +40,6 @@ something is putting something on the vertexes plist's (:export-slots-p t) (:documentation "This condition is signaled when a vertex can not be found in a graph.")) -;;; --------------------------------------------------------------------------- (defcondition graph-vertex-not-found-in-edge-error (edge-error) ((vertex nil ir)) @@ -53,7 +48,6 @@ something is putting something on the vertexes plist's (:export-p t) (:documentation "This condition is signaled when a vertex can not be found in an edge.")) -;;; --------------------------------------------------------------------------- (defcondition graph-edge-not-found-error (graph-error) ((vertex-1 nil ir "One of the vertexes for which no connecting edge could be found.") @@ -65,7 +59,6 @@ something is putting something on the vertexes plist's (:export-slots-p t) (:documentation "This condition is signaled when an edge cannot be found in a graph.")) -;;; --------------------------------------------------------------------------- (defclass* basic-vertex (container-node-mixin) ((depth-level 0 ia :type number "`Depth-level` is used by some algorithms for bookkeeping. [?? Should be in a mixin]") @@ -85,12 +78,6 @@ something is putting something on the vertexes plist's (:make-load-form-p t) (:documentation "This is the root class for all vertexes in CL-Graph.")) -;;; --------------------------------------------------------------------------- - -#+COPYING -(defcopy-methods basic-vertex :copy-all t) - -;;; --------------------------------------------------------------------------- (defmethod initialize-instance :after ((object basic-vertex) &key graph vertex-id) (when (and graph (not vertex-id)) @@ -98,7 +85,6 @@ something is putting something on the vertexes plist's (largest-vertex-id graph)) (incf (slot-value graph 'largest-vertex-id)))) -;;; --------------------------------------------------------------------------- (defmethod print-object ((vertex basic-vertex) stream) (print-unreadable-object (vertex stream :identity nil) @@ -106,7 +92,6 @@ something is putting something on the vertexes plist's (if (and (slot-exists-p vertex 'element) (slot-boundp vertex 'element)) (element vertex) "#unbound#")))) -;;; --------------------------------------------------------------------------- (defclass* basic-edge () ((edge-id 0 ia "The `edge-id` is used internally by CL-Graph for bookkeeping.") @@ -116,11 +101,9 @@ something is putting something on the vertexes plist's (color nil ia "The `color` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]")) (:export-p t) (:export-slots edge-id element tag color) - #+COPYING :copy-slots (:make-load-form-p t) (:documentation "This is the root class for all edges in CL-Graph.")) -;;; --------------------------------------------------------------------------- (defmethod initialize-instance :after ((object basic-edge) &key graph edge-id) (when (and graph (not edge-id)) @@ -128,34 +111,28 @@ something is putting something on the vertexes plist's (largest-edge-id graph)) (incf (slot-value graph 'largest-edge-id)))) -;;; --------------------------------------------------------------------------- (defmethod print-object ((object basic-edge) stream) (print-unreadable-object (object stream :type t) (format stream "<~A ~A>" (vertex-1 object) (vertex-2 object)))) -;;; --------------------------------------------------------------------------- -(defclass* directed-edge-mixin (#+COPYING copyable-mixin) () +(defclass* directed-edge-mixin () () (:export-p t) (:documentation "This mixin class is used to indicate that an edge is directed.")) -;;; --------------------------------------------------------------------------- -(defclass* weighted-edge-mixin (#+COPYING copyable-mixin) +(defclass* weighted-edge-mixin () ((weight 1d0 ia "The value of the weight of this edge. Defaults to 1.0d0")) - #+COPYING :copy-slots :export-slots (:export-p t) (:documentation "This mixin class adds a `weight` slot to an edge.")) -;;; --------------------------------------------------------------------------- (defmethod weight ((edge basic-edge)) (values 1.0)) -;;; --------------------------------------------------------------------------- -(defclass* basic-graph (#+COPYING copyable-mixin) +(defclass* basic-graph () ((graph-vertexes :unbound ir) (graph-edges :unbound ir) (largest-vertex-id 0 r) @@ -185,7 +162,6 @@ something is putting something on the vertexes plist's :initial-size 25) (:documentation "This is the root class for all graphs in CL-Graph.")) -;;; --------------------------------------------------------------------------- (defmethod initialize-instance :after ((object basic-graph) &key initial-size &allow-other-keys) @@ -194,22 +170,19 @@ something is putting something on the vertexes plist's (setf (slot-value object 'graph-edges) (make-edge-container object initial-size))) -;;; --------------------------------------------------------------------------- (defmethod print-object ((graph basic-graph) stream) (print-unreadable-object (graph stream :type t :identity t) (format stream "[~A,~A]" (size graph) (edge-count graph)))) -;;; --------------------------------------------------------------------------- ;;; internals -;;; --------------------------------------------------------------------------- -(defmethod add-vertex ((graph basic-graph) (value basic-vertex) &key if-duplicate-do) +(defmethod add-vertex + ((graph basic-graph) (value basic-vertex) &key if-duplicate-do) (declare (ignore if-duplicate-do)) (values value)) -;;; --------------------------------------------------------------------------- (defmethod make-vertex-for-graph ((graph basic-graph) &rest args &key (vertex-class (vertex-class graph)) @@ -219,7 +192,6 @@ something is putting something on the vertexes plist's "Vertex class '~A' must be a subtype of ~A" vertex-class (vertex-class graph)) (apply #'make-instance vertex-class :graph graph args)) -;;; --------------------------------------------------------------------------- (defmethod make-edge-for-graph ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex) @@ -229,18 +201,6 @@ something is putting something on the vertexes plist's &allow-other-keys) (remf args :edge-class) (remf args :edge-type) - - #| I removed 'em, gwk - - ;;; I added these - jjm - (remf args :vertex-test) - (remf args :vertex-key) - (remf args :edge-key) - (remf args :edge-test) - (remf args :force-new?) - -|# - (assert (or (null edge-type) (eq edge-type :directed) (eq edge-type :undirected)) nil @@ -264,40 +224,26 @@ something is putting something on the vertexes plist's :vertex-1 vertex-1 :vertex-2 vertex-2 args)) -;;; --------------------------------------------------------------------------- - (defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys) (apply #'make-instance graph-type args)) -;;; --------------------------------------------------------------------------- - -(defmethod make-graph ((classes list) &rest args) - (let ((name (find-or-create-class 'basic-graph classes))) - (apply #'make-instance name args))) - -;;; --------------------------------------------------------------------------- ;;; generic implementation -;;; --------------------------------------------------------------------------- (defmethod undirected-edge-p ((edge basic-edge)) (not (directed-edge-p edge))) -;;; --------------------------------------------------------------------------- (defmethod directed-edge-p ((edge basic-edge)) (typep edge 'directed-edge-mixin)) -;;; --------------------------------------------------------------------------- (defmethod tagged-edge-p ((edge basic-edge)) (tag edge)) -;;; --------------------------------------------------------------------------- (defmethod untagged-edge-p ((edge basic-edge)) (null (tag edge))) -;;; --------------------------------------------------------------------------- (defmethod tag-all-edges ((graph basic-graph)) (iterate-edges @@ -305,7 +251,6 @@ something is putting something on the vertexes plist's (lambda (e) (setf (tag e) t)))) -;;; --------------------------------------------------------------------------- (defmethod tag-all-edges ((vertex basic-vertex)) (iterate-edges @@ -313,7 +258,6 @@ something is putting something on the vertexes plist's (lambda (e) (setf (tag e) t)))) -;;; --------------------------------------------------------------------------- (defmethod untag-all-edges ((graph basic-graph)) (iterate-edges @@ -321,7 +265,6 @@ something is putting something on the vertexes plist's (lambda (e) (setf (tag e) nil)))) -;;; --------------------------------------------------------------------------- (defmethod untag-all-edges ((vertex basic-vertex)) (iterate-edges @@ -329,7 +272,6 @@ something is putting something on the vertexes plist's (lambda (e) (setf (tag e) nil)))) -;;; --------------------------------------------------------------------------- (defmethod untag-edges ((edges list)) (iterate-nodes @@ -337,7 +279,6 @@ something is putting something on the vertexes plist's (lambda (e) (setf (tag e) nil)))) -;;; --------------------------------------------------------------------------- (defmethod tag-edges ((edges list)) (iterate-nodes @@ -346,13 +287,11 @@ something is putting something on the vertexes plist's (setf (tag e) t)))) -;;; --------------------------------------------------------------------------- (defmethod (setf element) :around ((value t) (vertex basic-vertex)) (with-changing-vertex (vertex) (call-next-method))) -;;; --------------------------------------------------------------------------- ;; :ignore, :force, :replace, @@ -385,7 +324,6 @@ something is putting something on the vertexes plist's ;; not found, add (add-it :new))))) -;;; --------------------------------------------------------------------------- (defmethod replace-vertex ((graph basic-graph) (old basic-vertex) (new basic-vertex)) ;; we need the graph and the new vertex to reference each other @@ -406,7 +344,6 @@ something is putting something on the vertexes plist's (delete-vertex graph old) (add-vertex graph new)) -;;; --------------------------------------------------------------------------- (defmethod add-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t) &rest args &key (if-duplicate-do :ignore) @@ -419,10 +356,8 @@ something is putting something on the vertexes plist's (add-vertex graph value-2 :if-duplicate-do :replace)))) (apply #'add-edge-between-vertexes graph v1 v2 args))) -;;; --------------------------------------------------------------------------- ;;; to-do - add-edge-between-vertexes needs to be able to grab the weight and ;;; color from edges that inherit from weight and color mixins -;;; --------------------------------------------------------------------------- (defmethod add-edge-between-vertexes ((graph basic-graph) (v-1 basic-vertex) (v-2 basic-vertex) @@ -469,23 +404,21 @@ something is putting something on the vertexes plist's (add-it :new))))) -;;; --------------------------------------------------------------------------- (defmethod add-edge-to-vertex ((edge basic-edge) (vertex basic-vertex)) (values)) -;;; --------------------------------------------------------------------------- -(defmethod find-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t) - &key (error-if-not-found? t)) - (let ((v1 (find-vertex graph value-1 error-if-not-found?)) - (v2 (find-vertex graph value-2 error-if-not-found?))) - (aif (and v1 v2 (find-edge-between-vertexes graph v1 v2)) - it - (when error-if-not-found? - (error 'graph-edge-not-found-error :vertex-1 v1 :vertex-2 v2))))) +(defmethod find-edge-between-vertexes + ((graph basic-graph) (value-1 t) (value-2 t) + &key (error-if-not-found? t)) + (let* ((v1 (find-vertex graph value-1 error-if-not-found?)) + (v2 (find-vertex graph value-2 error-if-not-found?))) + (or (and v1 v2 (find-edge-between-vertexes graph v1 v2)) + (when error-if-not-found? + (error 'graph-edge-not-found-error + :graph graph :vertex-1 v1 :vertex-2 v2))))) -;;; --------------------------------------------------------------------------- (defmethod delete-edge-between-vertexes ((graph basic-graph) (value-or-vertex-1 t) @@ -495,18 +428,20 @@ something is putting something on the vertexes plist's (when edge (delete-edge graph edge)))) -;;; --------------------------------------------------------------------------- (defmethod delete-edge :after ((graph basic-graph) (edge basic-edge)) (delete-item (graph-edges graph) edge) edge) -;;; --------------------------------------------------------------------------- + +(defmethod delete-all-edges :after ((graph basic-graph)) + (empty! (graph-edges graph)) + graph) + (defmethod delete-vertex ((graph basic-graph) value-or-vertex) (delete-vertex graph (find-vertex graph value-or-vertex))) -;;; --------------------------------------------------------------------------- (defmethod delete-vertex ((graph basic-graph) (vertex basic-vertex)) (unless (eq graph (graph vertex)) @@ -521,7 +456,6 @@ something is putting something on the vertexes plist's (empty! (vertex-edges vertex)) (values vertex graph)) -;;; --------------------------------------------------------------------------- (defmethod delete-vertex :after ((graph basic-graph) (vertex basic-vertex)) @@ -529,42 +463,34 @@ something is putting something on the vertexes plist's (delete-item-at (graph-vertexes graph) (funcall (vertex-key graph) (element vertex)))) -;;; --------------------------------------------------------------------------- (defmethod insert-item ((graph basic-graph) value) (add-vertex graph value)) -;;; --------------------------------------------------------------------------- (defmethod source-edges ((vertex basic-vertex) &optional filter) (collect-using #'iterate-source-edges filter vertex)) -;;; --------------------------------------------------------------------------- (defmethod target-edges ((vertex basic-vertex) &optional filter) (collect-using #'iterate-target-edges filter vertex)) -;;; --------------------------------------------------------------------------- (defmethod child-vertexes (vertex &optional filter) (collect-using #'iterate-children filter vertex)) -;;; --------------------------------------------------------------------------- (defmethod parent-vertexes (vertex &optional filter) (collect-using #'iterate-parents filter vertex)) -;;; --------------------------------------------------------------------------- (defmethod neighbor-vertexes (vertex &optional filter) (collect-using #'iterate-neighbors filter vertex)) -;;; --------------------------------------------------------------------------- (defmethod adjacentp ((graph basic-graph) vertex-1 vertex-2) (adjacentp graph (find-vertex graph vertex-1) (find-vertex graph vertex-2))) -;;; --------------------------------------------------------------------------- (defmethod adjacentp ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex)) (iterate-neighbors @@ -574,17 +500,14 @@ something is putting something on the vertexes plist's (return-from adjacentp t)))) (values nil)) -;;; --------------------------------------------------------------------------- (defmethod number-of-neighbors (vertex) (count-using #'iterate-neighbors nil vertex)) -;;; --------------------------------------------------------------------------- (defmethod in-cycle-p ((graph basic-graph) (vertex t)) (in-cycle-p graph (find-vertex graph vertex))) -;;; --------------------------------------------------------------------------- (defmethod renumber-vertexes ((graph basic-graph)) (let ((count 0)) @@ -593,7 +516,6 @@ something is putting something on the vertexes plist's (incf count))) (setf (slot-value graph 'largest-vertex-id) count))) -;;; --------------------------------------------------------------------------- (defmethod renumber-edges ((graph basic-graph)) (let ((count 0)) @@ -602,13 +524,11 @@ something is putting something on the vertexes plist's (incf count))) (setf (slot-value graph 'largest-edge-id) count))) -;;; --------------------------------------------------------------------------- (deprecated (defmethod container->list ((graph basic-graph)) (collect-elements (graph-vertexes graph)))) -;;; --------------------------------------------------------------------------- (defmethod add-vertex :before ((graph basic-graph) (vertex basic-vertex) &key &allow-other-keys) @@ -618,7 +538,6 @@ something is putting something on the vertexes plist's (funcall (vertex-key graph) (element vertex))) vertex (slot-value vertex 'graph) graph)) -;;; --------------------------------------------------------------------------- (defmethod add-edge :before ((graph basic-graph) (edge basic-edge) &key force-new?) (declare (ignore force-new?)) @@ -628,16 +547,21 @@ something is putting something on the vertexes plist's (progn (setf (contains-directed-edge-p graph) t)) (progn (setf (contains-undirected-edge-p graph) t)))) -;;; --------------------------------------------------------------------------- (defmethod find-vertex ((graph basic-graph) (value t) &optional (error-if-not-found? t)) - (aif (find-item (graph-vertexes graph) (funcall (vertex-key graph) value)) - it - (when error-if-not-found? - (error 'graph-vertex-not-found-error :vertex value :graph graph)))) + (or (find-item (graph-vertexes graph) (funcall (vertex-key graph) value)) + (when error-if-not-found? + (error 'graph-vertex-not-found-error :vertex value :graph graph)))) -;;; --------------------------------------------------------------------------- +(defmethod find-vertex ((graph basic-graph) (vertex basic-vertex) + &optional (error-if-not-found? t)) + (cond ((eq graph (graph vertex)) + vertex) + (t + (when error-if-not-found? + (error 'graph-vertex-not-found-error + :vertex vertex :graph graph))))) (defmethod find-vertex ((edge basic-edge) (value t) &optional (error-if-not-found? t)) @@ -650,108 +574,77 @@ something is putting something on the vertexes plist's (when error-if-not-found? (error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge))) -;;; --------------------------------------------------------------------------- - -(defmethod search-for-vertex ((graph basic-graph) (value t) - &key (key (vertex-key graph)) (test 'equal) - (error-if-not-found? t)) - (aif (search-for-node graph value :test test :key key) - it - (when error-if-not-found? - (error "~S not found in ~A using key ~S and test ~S" value graph key - test)))) - -;;; --------------------------------------------------------------------------- (defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex) &key (key (vertex-key graph)) (test 'equal) (error-if-not-found? t)) - (aif (search-for-node (graph-vertexes graph) vertex :test test :key key) - it - (when error-if-not-found? - (error "~A not found in ~A" vertex graph)))) + (or (search-for-node (graph-vertexes graph) vertex :test test :key key) + (when error-if-not-found? + (error "~A not found in ~A" vertex graph)))) -;;; --------------------------------------------------------------------------- -;; TODO !!! dispatch is the same as the second method above (defmethod search-for-vertex ((graph basic-graph) (vertex t) &key (key (vertex-key graph)) (test 'equal) (error-if-not-found? t)) - (aif (search-for-element (graph-vertexes graph) vertex :test test :key key) - it - (when error-if-not-found? - (error "~A not found in ~A" vertex graph)))) - -;;; --------------------------------------------------------------------------- + (or (search-for-element (graph-vertexes graph) vertex :test test :key key) + (when error-if-not-found? + (error "~A not found in ~A" vertex graph)))) (defmethod iterate-elements ((graph basic-graph) fn) (iterate-elements (graph-vertexes graph) (lambda (vertex) (funcall fn (element vertex))))) -;;; --------------------------------------------------------------------------- (defmethod iterate-nodes ((graph basic-graph) fn) (iterate-nodes (graph-vertexes graph) fn)) -;;; --------------------------------------------------------------------------- (defmethod iterate-vertexes ((graph basic-graph) fn) (iterate-nodes (graph-vertexes graph) fn)) -;;; --------------------------------------------------------------------------- (defmethod iterate-vertexes ((edge basic-edge) fn) (funcall fn (vertex-1 edge)) (funcall fn (vertex-2 edge))) -;;; --------------------------------------------------------------------------- (defmethod size ((graph basic-graph)) (size (graph-vertexes graph))) -;;; --------------------------------------------------------------------------- (defmethod edges ((graph basic-graph)) (collect-using #'iterate-edges nil graph)) -;;; --------------------------------------------------------------------------- (defmethod edges ((vertex basic-vertex)) (collect-using #'iterate-edges nil vertex)) -;;; --------------------------------------------------------------------------- (deprecated "Use size instead" (defmethod vertex-count ((graph basic-graph)) (size graph))) -;;; --------------------------------------------------------------------------- (defmethod vertexes ((graph basic-graph)) (collect-elements (graph-vertexes graph))) -;;; --------------------------------------------------------------------------- (defmethod source-edge-count ((vertex basic-vertex)) (count-using 'iterate-source-edges nil vertex)) -;;; --------------------------------------------------------------------------- (defmethod target-edge-count ((vertex basic-vertex)) (count-using 'iterate-target-edges nil vertex)) -;;; --------------------------------------------------------------------------- (defmethod graph-roots ((graph basic-graph)) (collect-elements (graph-vertexes graph) :filter #'rootp)) -;;; --------------------------------------------------------------------------- (defmethod rootp ((vertex basic-vertex)) ;;?? this is inefficient in the same way that (zerop (length )) is... (zerop (source-edge-count vertex))) -;;; --------------------------------------------------------------------------- (defmethod find-vertex-if ((graph basic-graph) fn &key key) (iterate-vertexes graph @@ -760,7 +653,6 @@ something is putting something on the vertexes plist's (return-from find-vertex-if v)))) (values nil)) -;;; --------------------------------------------------------------------------- (defmethod find-vertex-if ((edge basic-edge) fn &key key) (iterate-vertexes edge @@ -769,7 +661,6 @@ something is putting something on the vertexes plist's (return-from find-vertex-if v)))) (values nil)) -;;; --------------------------------------------------------------------------- (defmethod find-edge-if ((graph basic-graph) fn &key key) (iterate-edges graph @@ -778,17 +669,14 @@ something is putting something on the vertexes plist's (return-from find-edge-if e)))) (values nil)) -;;; --------------------------------------------------------------------------- (defmethod find-edges-if ((graph basic-graph) fn) (collect-using 'iterate-edges fn graph)) -;;; --------------------------------------------------------------------------- (defmethod find-vertexes-if ((graph basic-graph) fn) (collect-using 'iterate-vertexes fn graph)) -;;; --------------------------------------------------------------------------- (defmethod empty! ((graph basic-graph)) (empty! (graph-edges graph)) @@ -797,7 +685,6 @@ something is putting something on the vertexes plist's (renumber-vertexes graph) (values)) -;;; --------------------------------------------------------------------------- (defun neighbors-to-children (new-graph root &optional visited-list) (pushnew root visited-list) @@ -809,22 +696,10 @@ something is putting something on the vertexes plist's new-graph (value root) (value c) :edge-type :directed) (neighbors-to-children new-graph c visited-list))))) -;;; --------------------------------------------------------------------------- -#+COPYING -(defmethod generate-directed-free-tree ((graph basic-graph) (root basic-vertex)) - (let ((new-graph (copy-top-level graph))) - (empty! new-graph) - (nilf (contains-undirected-edge-p new-graph)) - (neighbors-to-children new-graph root) - (values new-graph))) - -;;; --------------------------------------------------------------------------- - (defmethod generate-directed-free-tree ((graph basic-graph) root) (generate-directed-free-tree graph (find-vertex graph root))) -;;; --------------------------------------------------------------------------- (defmethod force-undirected ((graph basic-graph)) (iterate-edges @@ -834,9 +709,7 @@ something is putting something on the vertexes plist's -;;; --------------------------------------------------------------------------- ;;; traversal -;;; --------------------------------------------------------------------------- (defmethod traverse-elements ((thing basic-graph) (style symbol) fn) (let ((marker (gensym))) @@ -850,11 +723,10 @@ something is putting something on the vertexes plist's (lambda (vertex) (traverse-elements-helper vertex style marker fn))))) -;;; --------------------------------------------------------------------------- (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn) (when (eq (tag thing) marker) - (nilf (tag thing)) + (setf (tag thing) nil) (iterate-children thing (lambda (vertex) @@ -862,11 +734,10 @@ something is putting something on the vertexes plist's (funcall fn thing))) -;;; --------------------------------------------------------------------------- (defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn) (when (eq (tag thing) marker) - (nilf (tag thing)) + (setf (tag thing) nil) (funcall fn thing)) (iterate-neighbors @@ -879,19 +750,37 @@ something is putting something on the vertexes plist's thing (lambda (vertex) (when (eq (tag vertex) marker) - (nilf (tag vertex)) + (setf (tag vertex) nil) (traverse-elements-helper vertex style marker fn))))) -;;; --------------------------------------------------------------------------- +;; also in metatilites +(defun graph-search-for-cl-graph (states goal-p successors combiner + &key (state= #'eql) old-states + (new-state-fn (error "argument required"))) + "Find a state that satisfies goal-p. Start with states, + and search according to successors and combiner. + Don't try the same state twice." + (cond ((null states) nil) + ((funcall goal-p (first states)) (first states)) + (t (graph-search-for-cl-graph + (funcall + combiner + (funcall new-state-fn states successors state= old-states) + (rest states)) + goal-p successors combiner + :state= state= + :old-states (adjoin (first states) old-states + :test state=) + :new-state-fn new-state-fn)))) (defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex)) (let ((first-time? t)) (not (null - (graph-search + (graph-search-for-cl-graph (list start-vertex) (lambda (v) (if first-time? - (nilf first-time?) + (setf first-time? nil) (eq (find-vertex graph v) start-vertex))) (lambda (v) (child-vertexes v)) @@ -907,14 +796,13 @@ something is putting something on the vertexes plist's (member state old-states :test state=)))) (funcall successors (first states))))))))) -;;; --------------------------------------------------------------------------- (defmethod in-undirected-cycle-p ((graph basic-graph) (current basic-vertex) &optional (marked (make-container 'simple-associative-container)) (previous nil)) (block do-it - (tf (item-at-1 marked current)) + (setf (item-at-1 marked current) t) (iterate-children current (lambda (child) (cond @@ -923,7 +811,6 @@ something is putting something on the vertexes plist's (t (in-undirected-cycle-p graph child marked current))))))) -;;; --------------------------------------------------------------------------- (defmethod any-undirected-cycle-p ((graph basic-graph)) (let ((marked (make-container 'simple-associative-container))) @@ -933,7 +820,6 @@ something is putting something on the vertexes plist's (return-from any-undirected-cycle-p v))))) (values nil))) -;;; --------------------------------------------------------------------------- (defun remove-list (original target) "Removes all elements in original from target." @@ -941,7 +827,6 @@ something is putting something on the vertexes plist's (member target-element original)) target)) -;;; --------------------------------------------------------------------------- (defun get-nodelist-relatives (node-list) "Collects set of unique relatives of nodes in node-list." @@ -951,7 +836,6 @@ something is putting something on the vertexes plist's (append-unique (neighbor-vertexes node) unique-relatives))) unique-relatives)) -;;; --------------------------------------------------------------------------- (defun get-transitive-closure (vertex-list &optional (depth nil)) "Given a list of vertices, returns a combined list of all of the nodes @@ -976,123 +860,25 @@ nil gathers the entire closure(s)." (values visited)))) (collect-transitive-closure vertex-list vertex-list depth))) -;;; --------------------------------------------------------------------------- -;;; make-filtered-graph -;;; --------------------------------------------------------------------------- - -(defmethod complete-links ((new-graph basic-graph) - (old-graph basic-graph)) - ;; Copy links from old-graph ONLY for nodes already in new-graph - (iterate-vertexes - new-graph - (lambda (vertex) - (let ((old-graph-vertex (find-vertex old-graph (value vertex)))) - (iterate-edges - old-graph-vertex - (lambda (old-edge) - (let* ((old-other-vertex (other-vertex old-edge old-graph-vertex)) - (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil))) - (when (and new-other-vertex - (< (vertex-id vertex) (vertex-id new-other-vertex))) - (let* ((new-edge (copy-template old-edge))) - (if (eq old-graph-vertex (vertex-1 old-edge)) - (setf (slot-value new-edge 'vertex-1) vertex - (slot-value new-edge 'vertex-2) new-other-vertex) - (setf (slot-value new-edge 'vertex-2) vertex - (slot-value new-edge 'vertex-1) new-other-vertex)) - (add-edge new-graph new-edge)))))))))) - -#+Old -(defmethod complete-links ((new-graph basic-graph) - (old-graph basic-graph)) - ;; Copy links from old-graph ONLY for nodes already in new-graph - (iterate-vertexes - new-graph - (lambda (vertex) - (let ((old-graph-vertex (find-vertex old-graph (value vertex)))) - (iterate-edges - old-graph-vertex - (lambda (edge) - (let* ((old-other-vertex (other-vertex edge old-graph-vertex)) - (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil)) - (edge-type (if (directed-edge-p edge) - :directed :undirected))) - (when new-other-vertex - (if (and (directed-edge-p edge) - (eq old-graph-vertex (target-vertex edge))) - (add-edge-between-vertexes new-graph new-other-vertex vertex - :value (value edge) - :edge-type edge-type) - (add-edge-between-vertexes new-graph vertex new-other-vertex - :value (value edge) - :edge-type edge-type)))))))))) - -;;; --------------------------------------------------------------------------- - -(defmethod make-filtered-graph ((old-graph basic-graph) - test-fn - &optional - (graph-completion-method nil) - (depth nil)) - (let ((new-graph - (copy-template old-graph))) - (ecase graph-completion-method - ((nil - :complete-links) - (iterate-vertexes old-graph - (lambda (vertex) - (when (funcall test-fn vertex) - (add-vertex new-graph (value vertex)))))) - ((:complete-closure-nodes-only - :complete-closure-with-links) - (let* ((old-graph-vertexes (collect-items old-graph :filter test-fn)) - (closure-vertexes - (get-transitive-closure old-graph-vertexes depth))) - (dolist (vertex closure-vertexes) - (add-vertex new-graph (copy-template vertex)))))) - - (ecase graph-completion-method - ((nil :complete-closure-nodes-only) nil) - ((:complete-links - :complete-closure-with-links) - (complete-links new-graph old-graph))) - - new-graph)) - -;;; --------------------------------------------------------------------------- - -(defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex) - &optional (depth nil)) - (make-filtered-graph graph - #'(lambda (v) - (equal v vertex)) - :complete-closure-with-links - depth)) - -;;; --------------------------------------------------------------------------- (defmethod edge-count ((graph basic-graph)) - (length (edges graph))) + (count-using #'iterate-edges nil graph)) -;;; --------------------------------------------------------------------------- (defmethod edge-count ((vertex basic-vertex)) (size (vertex-edges vertex))) -;;; --------------------------------------------------------------------------- (defmethod topological-sort ((graph basic-graph)) (assign-level graph 0) (sort (collect-elements (graph-vertexes graph)) #'< :key (lambda (x) (depth-level x)))) -;;; --------------------------------------------------------------------------- (defmethod assign-level ((graph basic-graph) (level number)) (loop for node in (graph-roots graph) do (assign-level node 0))) -;;; --------------------------------------------------------------------------- (defmethod assign-level ((node basic-vertex) (level number)) (if (or (not (depth-level node)) @@ -1100,18 +886,16 @@ nil gathers the entire closure(s)." (setf (depth-level node) level)) (iterate-children node (lambda (x) (assign-level x (1+ level))))) -;;; --------------------------------------------------------------------------- (defmethod depth ((graph basic-graph)) (assign-level graph 0) (let ((depth 0)) (iterate-vertexes graph (lambda (vertex) - (maxf depth (depth-level vertex)))) + (when (> (depth-level vertex) depth) + (setf depth (depth-level vertex))))) depth)) -;;; --------------------------------------------------------------------------- ;;; mapping -;;; --------------------------------------------------------------------------- (defun map-paths (graph start-vertex length fn &key (filter (constantly t))) "Apply fn to each path that starts at start-vertex and is of exactly length @@ -1137,11 +921,11 @@ length" (follow-path v (list v start-vertex) (1- length)))))) (values graph)) -;;; --------------------------------------------------------------------------- -(defun map-shortest-paths (graph start-vertex depth fn &key (filter (constantly t))) +(defun map-shortest-paths + (graph start-vertex depth fn &key (filter (constantly t))) "Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration." - (bind ((visited (make-container 'simple-associative-container + (let ((visited (make-container 'simple-associative-container :test #'equal))) (labels ((visit (p) (setf (item-at-1 visited p) t)) @@ -1162,23 +946,18 @@ length" :filter filter)))) -;;; --------------------------------------------------------------------------- ;;; utilities -;;; --------------------------------------------------------------------------- (defun append-unique (list1 list2) (remove-duplicates (append list1 list2))) -;;; --------------------------------------------------------------------------- ;;; project-bipartite-graph -;;; --------------------------------------------------------------------------- (defmethod project-bipartite-graph ((new-graph symbol) graph vertex-class vertex-classifier) (project-bipartite-graph (make-instance new-graph) graph vertex-class vertex-classifier)) -;;; --------------------------------------------------------------------------- (defmethod project-bipartite-graph ((new-graph basic-graph) graph vertex-class vertex-classifier)