From 63b8fd870436113d8d196d94f1e6f2eabfe7f786 Mon Sep 17 00:00:00 2001
From: Gary King <gwking@metabang.com>
Date: Mon, 29 Sep 2008 08:18:01 -0400
Subject: [PATCH] Added subgraph-containing -- duh!

darcs-hash:20080929121801-3cc5d-d84dbd8439ccbdf68112853432c4906947d37781.gz
---
 dev/subgraph-containing.lisp |  137 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 137 insertions(+)
 create mode 100644 dev/subgraph-containing.lisp

diff --git a/dev/subgraph-containing.lisp b/dev/subgraph-containing.lisp
new file mode 100644
index 0000000..c4f33df
--- /dev/null
+++ b/dev/subgraph-containing.lisp
@@ -0,0 +1,137 @@
+;; 2008-09-23 - these are the only bits that depend on moptilities
+
+(in-package #:cl-graph)
+
+
+;;; ---------------------------------------------------------------------------
+;;; 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 (mopu: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 
+				 (mopu: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 (mopu: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))
+
+;;; ---------------------------------------------------------------------------
+;;; for completeness 
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-graph-from-vertexes ((vertex-list list))
+  (bind ((edges-to-keep nil)
+         (g (mopu:copy-template (graph (first vertex-list)))))
+        
+    (iterate-elements
+     vertex-list
+     (lambda (v)
+       (add-vertex g (element v))
+       (iterate-elements
+        (edges v)
+        (lambda (e)
+          (when (and (member (vertex-1 e) vertex-list)
+                     (member (vertex-2 e) vertex-list))
+            (pushnew e edges-to-keep :test #'eq))))))
+    
+    (iterate-elements
+     edges-to-keep
+     (lambda (e)
+       (bind ((v1 (source-vertex e))
+              (v2 (target-vertex e)))
+         ;;?? can we use copy here...
+         (add-edge-between-vertexes
+          g (element v1) (element v2)
+          :edge-type (if (directed-edge-p e)
+                       :directed
+                       :undirected)
+          :if-duplicate-do :force
+          :edge-class (type-of e)
+          :value (value e)
+          :edge-id (edge-id e)
+          :element (element e)
+          :tag (tag e)
+          :graph g
+          :color (color e)))))
+    g))
-- 
1.7.10.4