1 ;; 2008-09-23 - these are the only bits that depend on moptilities
3 (in-package #:cl-graph)
6 ;;; ---------------------------------------------------------------------------
7 ;;; make-filtered-graph
8 ;;; ---------------------------------------------------------------------------
10 (defmethod complete-links ((new-graph basic-graph)
11 (old-graph basic-graph))
12 ;; Copy links from old-graph ONLY for nodes already in new-graph
16 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
20 (let* ((old-other-vertex (other-vertex old-edge old-graph-vertex))
21 (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil)))
22 (when (and new-other-vertex
23 (< (vertex-id vertex) (vertex-id new-other-vertex)))
24 (let* ((new-edge (mopu:copy-template old-edge)))
25 (if (eq old-graph-vertex (vertex-1 old-edge))
26 (setf (slot-value new-edge 'vertex-1) vertex
27 (slot-value new-edge 'vertex-2) new-other-vertex)
28 (setf (slot-value new-edge 'vertex-2) vertex
29 (slot-value new-edge 'vertex-1) new-other-vertex))
30 (add-edge new-graph new-edge))))))))))
33 (defmethod complete-links ((new-graph basic-graph)
34 (old-graph basic-graph))
35 ;; Copy links from old-graph ONLY for nodes already in new-graph
39 (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
43 (let* ((old-other-vertex (other-vertex edge old-graph-vertex))
44 (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil))
45 (edge-type (if (directed-edge-p edge)
46 :directed :undirected)))
47 (when new-other-vertex
48 (if (and (directed-edge-p edge)
49 (eq old-graph-vertex (target-vertex edge)))
50 (add-edge-between-vertexes new-graph new-other-vertex vertex
53 (add-edge-between-vertexes new-graph vertex new-other-vertex
55 :edge-type edge-type))))))))))
57 ;;; ---------------------------------------------------------------------------
59 (defmethod make-filtered-graph ((old-graph basic-graph)
62 (graph-completion-method nil)
65 (mopu:copy-template old-graph)))
66 (ecase graph-completion-method
69 (iterate-vertexes old-graph
71 (when (funcall test-fn vertex)
72 (add-vertex new-graph (value vertex))))))
73 ((:complete-closure-nodes-only
74 :complete-closure-with-links)
75 (let* ((old-graph-vertexes (collect-items old-graph :filter test-fn))
77 (get-transitive-closure old-graph-vertexes depth)))
78 (dolist (vertex closure-vertexes)
79 (add-vertex new-graph (mopu:copy-template vertex))))))
80 (ecase graph-completion-method
81 ((nil :complete-closure-nodes-only) nil)
83 :complete-closure-with-links)
84 (complete-links new-graph old-graph)))
87 ;;; ---------------------------------------------------------------------------
89 (defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
90 &rest args &key (depth nil) (new-graph nil))
91 (declare (ignore depth new-graph))
92 (apply #'make-filtered-graph
96 :graph-completion-method :complete-closure-with-links
99 ;;; ---------------------------------------------------------------------------
101 ;;; ---------------------------------------------------------------------------
103 (defmethod make-graph-from-vertexes ((vertex-list list))
104 (bind ((edges-to-keep nil)
105 (g (mopu:copy-template (graph (first vertex-list)))))
110 (add-vertex g (element v))
114 (when (and (member (vertex-1 e) vertex-list)
115 (member (vertex-2 e) vertex-list))
116 (pushnew e edges-to-keep :test #'eq))))))
121 (bind ((v1 (source-vertex e))
122 (v2 (target-vertex e)))
123 ;;?? can we use copy here...
124 (add-edge-between-vertexes
125 g (element v1) (element v2)
126 :edge-type (if (directed-edge-p e)
129 :if-duplicate-do :force
130 :edge-class (type-of e)