X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=dev%2Fgraph.lisp;h=2625aab89d0125fc18e9e088c8318dad1c35ac99;hb=44a5cff657760ffb78e34aa688f209283d899236;hp=663088bc7c925aa8037629957442d6d3d804463c;hpb=bf38951682661e4e59bfa0d3a6687bab94bee35a;p=cl-graph.git diff --git a/dev/graph.lisp b/dev/graph.lisp index 663088b..2625aab 100644 --- a/dev/graph.lisp +++ b/dev/graph.lisp @@ -198,7 +198,8 @@ something is putting something on the vertexes plist's ;;; 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)) @@ -250,12 +251,6 @@ something is putting something on the vertexes plist's (apply #'make-instance graph-type args)) ;;; --------------------------------------------------------------------------- - -(defmethod make-graph ((classes list) &rest args) - (let ((name (dynamic-classes:find-or-create-class 'basic-graph classes))) - (apply #'make-instance name args))) - -;;; --------------------------------------------------------------------------- ;;; generic implementation ;;; --------------------------------------------------------------------------- @@ -461,9 +456,10 @@ something is putting something on the vertexes plist's &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 :vertex-1 v1 :vertex-2 v2)))) + (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))))) ;;; --------------------------------------------------------------------------- @@ -848,15 +844,15 @@ something is putting something on the vertexes plist's ;;; --------------------------------------------------------------------------- ;; also in metatilites -(defun graph-search (states goal-p successors combiner - &key (state= #'eql) old-states - (new-state-fn #'new-states)) +(defun graph-search-for-cl-graph (states goal-p successors combiner + &key (state= #'eql) old-states + (new-state-fn #'new-states)) "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 + (t (graph-search-for-cl-graph (funcall combiner (funcall new-state-fn states successors state= old-states) @@ -870,7 +866,7 @@ something is putting something on the vertexes plist's (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? @@ -960,99 +956,6 @@ nil gathers the entire closure(s)." (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 - &key - (graph-completion-method nil) - (depth nil) - (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) - &rest args &key (depth nil) (new-graph nil)) - (declare (ignore depth new-graph)) - (apply #'make-filtered-graph - graph - #'(lambda (v) - (equal v vertex)) - :graph-completion-method :complete-closure-with-links - args)) - -;;; --------------------------------------------------------------------------- (defmethod edge-count ((graph basic-graph)) (count-using #'iterate-edges nil graph)) @@ -1123,7 +1026,8 @@ length" ;;; --------------------------------------------------------------------------- -(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 :test #'equal)))