From fbbd5f255d84d9f24a47907cc68d048b18907a5c Mon Sep 17 00:00:00 2001 From: Gary King Date: Fri, 28 Apr 2006 12:05:43 -0400 Subject: [PATCH] Added vertex-pair->edge map to graph-containers darcs-hash:20060428160543-3cc5d-3239cfb2bee57a9e6cd2d02e9616275ddc92a95f.gz --- dev/graph-container.lisp | 36 +++++++++++++---- dev/notes.text | 7 ++++ unit-tests/test-graph-container.lisp | 71 +++++++++++++++++++--------------- 3 files changed, 74 insertions(+), 40 deletions(-) diff --git a/dev/graph-container.lisp b/dev/graph-container.lisp index f7f09ad..b5305d9 100644 --- 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 --- 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 --- 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 '=))) -- 1.7.10.4