;;; 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))
(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
;;; ---------------------------------------------------------------------------
&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)))))
;;; ---------------------------------------------------------------------------
(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)
(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
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 #'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-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))
&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
(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))
(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))
;;; ---------------------------------------------------------------------------
;;; ---------------------------------------------------------------------------
-(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)))
projects / cl-graph.git / blobdiff