1 ;; 2008-09-23 - these are the only bits that depend on moptilities
3 (in-package #:cl-graph)
6 ;;; make-filtered-graph
8 (defmethod complete-links ((new-graph basic-graph)
9 (old-graph basic-graph))
10 ;; Copy links from old-graph ONLY for nodes already in new-graph
14 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
18 (let* ((old-other-vertex (other-vertex old-edge old-graph-vertex))
19 (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil)))
20 (when (and new-other-vertex
21 (< (vertex-id vertex) (vertex-id new-other-vertex)))
22 (let* ((new-edge (mopu:copy-template old-edge)))
23 (if (eq old-graph-vertex (vertex-1 old-edge))
24 (setf (slot-value new-edge 'vertex-1) vertex
25 (slot-value new-edge 'vertex-2) new-other-vertex)
26 (setf (slot-value new-edge 'vertex-2) vertex
27 (slot-value new-edge 'vertex-1) new-other-vertex))
28 (add-edge new-graph new-edge))))))))))
31 (defmethod complete-links ((new-graph basic-graph)
32 (old-graph basic-graph))
33 ;; Copy links from old-graph ONLY for nodes already in new-graph
37 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
41 (let* ((old-other-vertex (other-vertex edge old-graph-vertex))
42 (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil))
43 (edge-type (if (directed-edge-p edge)
44 :directed :undirected)))
45 (when new-other-vertex
46 (if (and (directed-edge-p edge)
47 (eq old-graph-vertex (target-vertex edge)))
48 (add-edge-between-vertexes new-graph new-other-vertex vertex
51 (add-edge-between-vertexes new-graph vertex new-other-vertex
53 :edge-type edge-type))))))))))
56 (defmethod make-filtered-graph ((old-graph basic-graph)
59 (graph-completion-method nil)
62 (mopu:copy-template old-graph)))
63 (ecase graph-completion-method
66 (iterate-vertexes old-graph
68 (when (funcall test-fn vertex)
69 (add-vertex new-graph (value vertex))))))
70 ((:complete-closure-nodes-only
71 :complete-closure-with-links)
72 (let* ((old-graph-vertexes (collect-items old-graph :filter test-fn))
74 (get-transitive-closure old-graph-vertexes depth)))
75 (dolist (vertex closure-vertexes)
76 (add-vertex new-graph (mopu:copy-template vertex))))))
77 (ecase graph-completion-method
78 ((nil :complete-closure-nodes-only) nil)
80 :complete-closure-with-links)
81 (complete-links new-graph old-graph)))
85 (defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
86 &rest args &key (depth nil) (new-graph nil))
87 (declare (ignore depth new-graph))
88 (apply #'make-filtered-graph
92 :graph-completion-method :complete-closure-with-links
97 (defmethod make-graph-from-vertexes ((vertex-list list))
98 (bind ((edges-to-keep nil)
99 (g (mopu:copy-template (graph (first vertex-list)))))
104 (add-vertex g (element v))
108 (when (and (member (vertex-1 e) vertex-list)
109 (member (vertex-2 e) vertex-list))
110 (pushnew e edges-to-keep :test #'eq))))))
115 (bind ((v1 (source-vertex e))
116 (v2 (target-vertex e)))
117 ;;?? can we use copy here...
118 (add-edge-between-vertexes
119 g (element v1) (element v2)
120 :edge-type (if (directed-edge-p e)
123 :if-duplicate-do :force
124 :edge-class (type-of e)