Added vertex-pair->edge map to graph-containers

darcs-hash:20060428160543-3cc5d-3239cfb2bee57a9e6cd2d02e9616275ddc92a95f.gz

diff --git a/dev/graph-container.lisp b/dev/graph-container.lisp
index f7f09ad..b5305d9 100644 (file)
--- a/dev/graph-container.lisp
+++ b/dev/graph-container.lisp
@@ -20,7 +20,8 @@ DISCUSSION
                             initial-contents-mixin
                             basic-graph
                             container-uses-nodes-mixin)
-  ((vertex-pair->edge (make-container 'simple-associative-container) r))
+  ((vertex-pair->edge (make-container 'simple-associative-container
+                                      :test #'equal) r))
   (:default-initargs
     :vertex-class 'graph-container-vertex
     :directed-edge-class 'graph-container-directed-edge
@@ -155,7 +156,8 @@ DISCUSSION
            (add-edge-to-vertex edge vertex-1))
           (t
            (add-edge-to-vertex edge vertex-1)
-           (add-edge-to-vertex edge vertex-2))))
+           (add-edge-to-vertex edge vertex-2)))
+    (push edge (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))))
   edge)
 
 ;;; ---------------------------------------------------------------------------
@@ -175,10 +177,14 @@ DISCUSSION
                                        (vertex-1 graph-container-vertex) 
                                        (vertex-2 graph-container-vertex)
                                        &key error-if-not-found?)
-  (declare (ignore error-if-not-found?))
-  (search-for-match (vertex-edges vertex-1)
-                    (lambda (edge)
-                      (eq vertex-2 (other-vertex edge vertex-1)))))
+  (multiple-value-bind (value found?)
+                       (item-at-1 (vertex-pair->edge graph) 
+                                  (cons vertex-1 vertex-2))
+    (when (and error-if-not-found?
+               (not found?))
+      (error 'graph-edge-not-found-error 
+             :vertex-1 vertex-1 :vertex-2 vertex-1))
+    (first value)))
 
 ;;; ---------------------------------------------------------------------------
 
@@ -217,12 +223,26 @@ DISCUSSION
 ;;; ---------------------------------------------------------------------------
 
 (defmethod delete-edge ((graph graph-container) (edge graph-container-edge))
-  (delete-item (vertex-edges (vertex-1 edge)) edge)
-  (delete-item (vertex-edges (vertex-2 edge)) edge)
+  (let ((vertex-1 (vertex-1 edge))
+        (vertex-2 (vertex-2 edge)))
+    (delete-item (vertex-edges vertex-1) edge)
+    (delete-item (vertex-edges vertex-2) edge)
+    (setf (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))
+          (delete (cons vertex-1 vertex-2) 
+                  (item-at-1 (vertex-pair->edge graph) (cons vertex-1 vertex-2))
+                  :test #'equal)))
   edge)
 
 ;;; ---------------------------------------------------------------------------
 
+(defmethod empty! :after ((graph graph-container))
+  (empty! (vertex-pair->edge graph)))
+
+
+;;; ---------------------------------------------------------------------------
+;;; iteration
+;;; ---------------------------------------------------------------------------
+
 (defmethod iterate-edges ((graph graph-container) fn)
   (iterate-elements (graph-edges graph) fn))
 

diff --git a/dev/notes.text b/dev/notes.text
index 997c35a..140ae52 100644 (file)
--- a/dev/notes.text
+++ b/dev/notes.text
@@ -1,3 +1,10 @@
+optimize : find-edge-between-vertexes-if
+
+Should have delete-item-at-1
+
+delete-edge : equal or eql
+
+
 #|
 (in-package cl-graph)
 

diff --git a/unit-tests/test-graph-container.lisp b/unit-tests/test-graph-container.lisp
index 87d943a..95ba3c0 100644 (file)
--- a/unit-tests/test-graph-container.lisp
+++ b/unit-tests/test-graph-container.lisp
@@ -16,62 +16,69 @@
 ;;; tests
 ;;; --------------------------------------------------------------------------- 
 
-(deftestsuite test-graph-container () ())
+(deftestsuite graph-container-test (cl-graph-test) ())
 
 ;;; ---------------------------------------------------------------------------
 
-(addtest (test-graph-container)
+(addtest (graph-container-test)
+  test-empty!
+  (let ((g1 (make-simple-test-graph)))
+    (empty! g1)
+    (ensure-same (size g1) 0)))
+
+;;; ---------------------------------------------------------------------------
+;;; vertex test 
+;;; ---------------------------------------------------------------------------
+
+;;?? should be in test-graph and work for every graph container type
+
+(addtest (graph-container-test)
+  no-vertex-test
+  (let ((g (make-container 'graph-container)))
+    (loop for (src dst) in '((a b) (a c) (c d) (a d) (d e) (e f) (b f)) do
+          (add-edge-between-vertexes g (list src) (list dst)))
+    (ensure-same (size g) 14 :test '=)))
+
+(addtest (graph-container-test)
+  vertex-test
+  (let ((g (make-container 'graph-container :vertex-test #'equal)))
+    (loop for (src dst) in '((a b) (a c) (c d) (a d) (d e) (e f) (b f)) do
+          (add-edge-between-vertexes g (list src) (list dst)))
+    (ensure-same (size g) 6 :test '=)))
+
+
+;;; ---------------------------------------------------------------------------
+;;; copying
+;;; ---------------------------------------------------------------------------
+
+(addtest (graph-container-test)
   test-simple-copying
   (let ((g1 (make-simple-test-graph))
         (g2 nil))
-    (setf g2 (copy-top-level g1))
+    (setf g2 (copy-thing g1))
     (ensure-same (size g1) (size g2))
     (iterate-vertexes
      g1 (lambda (v)
-          (ensure (find-vertex g2 (value v)))))
+          (ensure (find-vertex g2 (element v)))))
     (iterate-edges 
      g1 (lambda (e)
           (ensure (find-edge-between-vertexes 
-                   g2 (value (source-vertex e))
-                   (value (target-vertex e))))))))
+                   g2 (element (source-vertex e))
+                   (element (target-vertex e))))))))
 
 ;;; ---------------------------------------------------------------------------
 
 ;; fails because find-edge-between-vertexes for graph containers doesn't
 ;; care about the graph...
-(addtest (test-graph-container)
+(addtest (graph-container-test)
   test-find-edge-between-vertexes
   (let ((g1 (make-simple-test-graph))
         (g2 nil))
-    (setf g2 (copy-top-level g1))
+    (setf g2 (copy-thing g1))
     
     (ensure (not 
              (find-edge-between-vertexes g2 (find-vertex g1 'a) (find-vertex g1 'b))))))
 
 ;;; ---------------------------------------------------------------------------
 
-(addtest (test-graph-container)
-  test-empty!
-  (let ((g1 (make-simple-test-graph)))
-    (empty! g1)
-    (ensure-same (size g1) 0)))
-
-;;; ---------------------------------------------------------------------------
-;;; vertex test 
-;;; ---------------------------------------------------------------------------
-
-;;?? should be in test-graph and work for every graph container type
-
-(addtest (test-graph-container)
-  no-vertex-test
-  (let ((g (make-container 'graph-container)))
-    (loop for (src dst) in '((a b) (a c) (c d) (a d) (d e) (e f) (b f)) do
-          (add-edge-between-vertexes g (list src) (list dst)))
-    (ensure-same (size g) 14 :test '=)))
 
-(addtest (test-graph-container)
-  vertex-test
-  (let ((g (make-container 'graph-container :vertex-test #'equal)))
-    (loop for (src dst) in '((a b) (a c) (c d) (a d) (d e) (e f) (b f)) do
-          (add-edge-between-vertexes g (list src) (list dst)))
-    (ensure-same (size g) 6 :test '=)))