X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=dev%2Fgraph.lisp;h=3af3c47e52e703c9c21c1f2be2a9fea4759a06c9;hb=704d2802c057c57704629dcd228ead6c5d3c4258;hp=7143e6c8fd35009d71afc12c2375b04c1f2a9808;hpb=3e6caf777362fbe61b76b305e9b4aa1e80a60bc4;p=cl-graph.git

diff --git a/dev/graph.lisp b/dev/graph.lisp
index 7143e6c..3af3c47 100644
--- a/dev/graph.lisp
+++ b/dev/graph.lisp
@@ -14,7 +14,7 @@ something is putting something on the vertexes plist's
 |#
 
 
-(in-package metabang.graph)
+(in-package #:metabang.graph)
 
 ;;; ---------------------------------------------------------------------------
 ;;; classes
@@ -481,6 +481,11 @@ something is putting something on the vertexes plist's
   (delete-item (graph-edges graph) edge)
   edge)
 
+
+(defmethod delete-all-edges :after ((graph basic-graph))
+  (empty! (graph-edges graph))
+  graph)
+
 ;;; ---------------------------------------------------------------------------
 
 (defmethod delete-vertex ((graph basic-graph) value-or-vertex)
@@ -617,7 +622,14 @@ something is putting something on the vertexes plist's
        (when error-if-not-found?
          (error 'graph-vertex-not-found-error :vertex value :graph graph))))
 
-;;; ---------------------------------------------------------------------------
+(defmethod find-vertex ((graph basic-graph) (vertex basic-vertex)
+                        &optional (error-if-not-found? t))
+  (cond ((eq graph (graph vertex))
+	 vertex)
+	(t
+	 (when error-if-not-found?
+	   (error 'graph-vertex-not-found-error 
+		  :vertex vertex :graph graph)))))
 
 (defmethod find-vertex ((edge basic-edge) (value t)
                         &optional (error-if-not-found? t))
@@ -630,18 +642,6 @@ something is putting something on the vertexes plist's
   (when error-if-not-found?
     (error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge)))
 
-;;; ---------------------------------------------------------------------------
-
-(defmethod search-for-vertex ((graph basic-graph) (value t) 
-                              &key (key (vertex-key graph)) (test 'equal)
-                              (error-if-not-found? t))
-  (aif (search-for-node graph value :test test :key key)
-       it
-       (when error-if-not-found?
-         (error "~S not found in ~A using key ~S and test ~S" value graph key 
-                test))))
-
-;;; ---------------------------------------------------------------------------
 
 (defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex)
                               &key (key (vertex-key graph)) (test 'equal)
@@ -651,8 +651,6 @@ something is putting something on the vertexes plist's
        (when error-if-not-found?
          (error "~A not found in ~A" vertex graph))))
 
-;;; ---------------------------------------------------------------------------
-;; TODO !!! dispatch is the same as the second method above
 (defmethod search-for-vertex ((graph basic-graph) (vertex t)
                               &key (key (vertex-key graph)) (test 'equal)
                               (error-if-not-found? t))
@@ -661,8 +659,6 @@ something is putting something on the vertexes plist's
        (when error-if-not-found?
          (error "~A not found in ~A" vertex graph))))
 
-;;; ---------------------------------------------------------------------------
-
 (defmethod iterate-elements ((graph basic-graph) fn)
    (iterate-elements (graph-vertexes graph) 
                      (lambda (vertex) (funcall fn (element vertex)))))
@@ -1001,43 +997,43 @@ nil gathers the entire closure(s)."
 
 (defmethod make-filtered-graph ((old-graph basic-graph)
                                 test-fn
-                                &optional
+                                &key
                                 (graph-completion-method nil)
-                                (depth nil))
-  (let ((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
+                                (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))
+  new-graph)
 
 ;;; ---------------------------------------------------------------------------
 
 (defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
-                                &optional (depth nil))
-  (make-filtered-graph graph
-                       #'(lambda (v)
-                           (equal v vertex))
-                       :complete-closure-with-links
-                       depth))
+                                &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))
 
 ;;; ---------------------------------------------------------------------------