;;; 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 (dynamic-classes: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)))))
;;; ---------------------------------------------------------------------------
;;; ---------------------------------------------------------------------------
;; 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)
(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?
(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))
;;; ---------------------------------------------------------------------------
-(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