From 900a931f109598249ebc33bea50b65abf998ed0b Mon Sep 17 00:00:00 2001 From: Gary King Date: Fri, 28 Apr 2006 11:30:42 -0400 Subject: [PATCH] Setting a test suite at last darcs-hash:20060428153042-3cc5d-3d06a0a10e151e99f7774fa486a8a87ea7d72e8e.gz --- cl-graph-test.asd | 39 +++++++ dev/test-connected-components.lisp | 44 -------- dev/test-graph-algorithms.lisp | 121 --------------------- dev/test-graph-container.lisp | 77 ------------- dev/test-graph-metrics.lisp | 38 ------- dev/test-graph.lisp | 167 ----------------------------- unit-tests/test-connected-components.lisp | 44 ++++++++ unit-tests/test-graph-algorithms.lisp | 121 +++++++++++++++++++++ unit-tests/test-graph-container.lisp | 77 +++++++++++++ unit-tests/test-graph-metrics.lisp | 38 +++++++ unit-tests/test-graph.lisp | 167 +++++++++++++++++++++++++++++ 11 files changed, 486 insertions(+), 447 deletions(-) create mode 100644 cl-graph-test.asd delete mode 100644 dev/test-connected-components.lisp delete mode 100644 dev/test-graph-algorithms.lisp delete mode 100644 dev/test-graph-container.lisp delete mode 100644 dev/test-graph-metrics.lisp delete mode 100644 dev/test-graph.lisp create mode 100644 unit-tests/test-connected-components.lisp create mode 100644 unit-tests/test-graph-algorithms.lisp create mode 100644 unit-tests/test-graph-container.lisp create mode 100644 unit-tests/test-graph-metrics.lisp create mode 100644 unit-tests/test-graph.lisp diff --git a/cl-graph-test.asd b/cl-graph-test.asd new file mode 100644 index 0000000..1c58ada --- /dev/null +++ b/cl-graph-test.asd @@ -0,0 +1,39 @@ +;;; -*- Mode: Lisp; package: CL-USER; Syntax: Common-lisp; Base: 10 -*- + +#| + +|# + +(in-package :common-lisp-user) +(defpackage #:asdf-cl-graph-test (:use #:cl #:asdf)) +(in-package #:asdf-cl-graph-test) + +(defsystem cl-graph-test + :version "0.1" + :author "Gary Warren King " + :maintainer "Gary Warren King " + :licence "MIT Style License" + :description "Tests for CL-Graph" + + :components ((:module "unit-tests" + :components ((:file "package") + (:file "test*" :depends-on ("package")))) + + (:module "dev" + :components ((:static-file "notes.text")))) + + :in-order-to ((test-op (load-op moptilities-test))) + + :perform (test-op :after (op c) + (describe + (funcall + (intern (symbol-name '#:run-tests) '#:lift) + :suite (intern (symbol-name '#:cl-graph-test) '#:cl-graph-test)))) + :depends-on (cl-graph lift)) + +;;; --------------------------------------------------------------------------- + +(defmethod operation-done-p + ((o test-op) + (c (eql (find-system 'moptilities-test)))) + (values nil)) diff --git a/dev/test-connected-components.lisp b/dev/test-connected-components.lisp deleted file mode 100644 index 53b8fce..0000000 --- a/dev/test-connected-components.lisp +++ /dev/null @@ -1,44 +0,0 @@ -(in-package metabang.graph) - -(deftestsuite test-connected-component () - ()) - -;;; --------------------------------------------------------------------------- - -(defun make-connected-component-graph-1 () - (let ((g (make-container 'graph-container))) - (loop for label in '(wk-6-0 wp-5-1 wp-1-2 wp-2-3 wb-1-1 - wp-4-4 bp-5-6 bk-6-5 bb-5-7 bp-2-4 - bp-2-6 bp-1-5) do - (add-vertex g label)) - (loop for (source target) in '((wk-6-0 wp-5-1) - (wp-1-2 wp-2-3) - (wb-1-1 wp-4-4) - (bp-5-6 bk-6-5) - (bk-6-5 bb-5-7) - (bb-5-7 bp-2-4) - (bp-2-6 bp-1-5) - (bp-1-5 bp-2-4)) do - (add-edge-between-vertexes g source target :edge-type :directed - :value :defend)) - (loop for (source target) in '((bk-6-5 wp-4-4)) do - (add-edge-between-vertexes g source target :edge-type :directed - :value :attack)) - (loop for (source target) in '((wp-2-3 bp-2-4)) do - (add-edge-between-vertexes g source target :edge-type :undirected)) - g)) - -;;; --------------------------------------------------------------------------- - -(addtest (test-connected-component) - test-1 - (let ((g (make-connected-component-graph-1))) - (ensure-same - (mapcar #'size (find-connected-components g)) '(2 10) :test 'set-equal))) - -;;; --------------------------------------------------------------------------- - -(addtest (test-connected-component) - test-connected-component-count-1 - (let ((g (make-connected-component-graph-1))) - (ensure-same (connected-component-count g) 2 :test '=))) diff --git a/dev/test-graph-algorithms.lisp b/dev/test-graph-algorithms.lisp deleted file mode 100644 index f54b879..0000000 --- a/dev/test-graph-algorithms.lisp +++ /dev/null @@ -1,121 +0,0 @@ -(in-package cl-graph) - -(deftestsuite test-connected-components () - ()) - -(addtest (test-connected-components) - test-1 - (let ((g (make-container 'graph-container :default-edge-type :undirected))) - (loop for v in '(a b c d e f g h i j) do (add-vertex g v)) - (loop for (v1 v2) in '((a b) (a c) ( b c) (b d) (e f) (e g) (h i)) do - (add-edge-between-vertexes g v1 v2)) - - (let ((cc (connected-components g))) - (flet ((test (a b result) - (ensure-same (eq (representative-node cc (find-vertex g a)) - (representative-node cc (find-vertex g b))) - result))) - (loop for (v1 v2 result) in '((a b t) (a e nil) (f g t) - (j c nil) (b a t) (d c t)) do - (test v1 v2 result)))))) - -;;; --------------------------------------------------------------------------- - -(deftestsuite test-minimum-spanning-tree () - ()) - -(deftestsuite test-mst-kruskal (test-minimum-spanning-tree) - ()) - -(addtest (test-mst-kruskal) - test-1 - (let ((g (make-container 'graph-container - :default-edge-type :undirected - :undirected-edge-class 'weighted-edge)) - (m nil)) - (loop for (v1 v2 w) in '((a b 4) (a h 9) - (b c 8) (b h 11) - (c i 2) (c d 7) (c f 4) - (d e 9) (d f 14) - (e f 10) - (f g 2) - (g h 1) (g i 6) - (h i 7)) do - (add-edge-between-vertexes g v1 v2 :weight w)) - (setf m (minimum-spanning-tree-kruskal g)) - (ensure (set-equal - '(a b c d e f g h i) - (flatten (mapcar (lambda (e) - (list (element (vertex-1 e)) (element (vertex-2 e)))) - m)))) - (ensure-same (reduce #'+ m :key 'weight) 37 :test '=) - (ensure-same (size m) 8))) - -#+Test -(defclass* directed-weighted-edge (weighted-edge-mixin graph-container-directed-edge) - ()) - -#+Test -(let ((g (make-container 'graph-container - :default-edge-type :undirected - :undirected-edge-class 'weighted-edge - :directed-edge-class 'directed-weighted-edge))) - (loop for (v1 v2 w) in '((a b 4) (a h 9) - (b c 8) (b h 11) - (c i 2) (c d 7) (c f 4) - (d e 9) (d f 14) - (e f 10) - (f g 2) - (g h 1) (g i 6) - (h i 7) - - (a h 3)) do - (add-edge-between-vertexes g v1 v2 :weight w - :edge-type (if (random-boolean *random-generator* 0.3) - :directed :undirected))) - (minimum-spanning-tree-kruskal g)) - -#+Test -(graph->dot - (let ((g (make-container 'graph-container - :default-edge-type :undirected - :undirected-edge-class 'weighted-edge)) - (m nil)) - (loop for (v1 v2 w) in '((a b 10) (a b 1) (a d 3) - (b c 1) (b d 3) - (c d 1)) do - (add-edge-between-vertexes g v1 v2 :weight w :if-duplicate-do :force)) - (setf m (minimum-spanning-tree-kruskal g)) - g) - "p2dis:data;x.dot") - -#+Test -(let ((g (make-container 'graph-container - :default-edge-type :undirected - :undirected-edge-class 'weighted-edge)) - (m nil)) - (loop for (v1 v2 w) in '((a b 1) (a d 3) - (b c 5) (b d 2) - (c d 1)) do - (add-edge-between-vertexes g v1 v2 :weight w :if-duplicate-do :force)) - (setf m (minimum-spanning-tree-kruskal g)) - m) - -;;; --------------------------------------------------------------------------- - -#+test -(let ((graph (make-container 'graph-container))) - (loop for (a b) in '((r s) (r v) (s w) (t u) (t w) (t x) - (u y) (w x) (x y)) do - (add-edge-between-vertexes graph a b)) - - (breadth-first-search-graph graph 's)) - -;;; --------------------------------------------------------------------------- - -(let ((graph (make-container 'graph-container))) - (loop for (a b) in '((r s) (r v) (s w) (t u) (t w) (t x) - (u y) (w x) (x y)) do - (add-edge-between-vertexes graph a b)) - - (breadth-first-visitor graph 's #'print)) \ No newline at end of file diff --git a/dev/test-graph-container.lisp b/dev/test-graph-container.lisp deleted file mode 100644 index c2697da..0000000 --- a/dev/test-graph-container.lisp +++ /dev/null @@ -1,77 +0,0 @@ -(in-package metabang.graph) - -;;; --------------------------------------------------------------------------- -;;; utilities -;;; --------------------------------------------------------------------------- - -(defun make-simple-test-graph () - (let ((g (make-container 'graph-container))) - (loop for v in '(a b c d e) do - (add-vertex g v)) - (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do - (add-edge-between-vertexes g v1 v2)) - g)) - -;;; --------------------------------------------------------------------------- -;;; tests -;;; --------------------------------------------------------------------------- - -(deftestsuite test-graph-container () ()) - -;;; --------------------------------------------------------------------------- - -(addtest (test-graph-container) - test-simple-copying - (let ((g1 (make-simple-test-graph)) - (g2 nil)) - (setf g2 (copy-top-level g1)) - (ensure-same (size g1) (size g2)) - (iterate-vertexes - g1 (lambda (v) - (ensure (find-vertex g2 (value v))))) - (iterate-edges - g1 (lambda (e) - (ensure (find-edge-between-vertexes - g2 (value (source-vertex e)) - (value (target-vertex e)))))))) - -;;; --------------------------------------------------------------------------- - -;; fails because find-edge-between-vertexes for graph containers doesn't -;; care about the graph... -(addtest (test-graph-container) - test-find-edge-between-vertexes - (let ((g1 (make-simple-test-graph)) - (g2 nil)) - (setf g2 (copy-top-level 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 '=))) diff --git a/dev/test-graph-metrics.lisp b/dev/test-graph-metrics.lisp deleted file mode 100644 index 8071a08..0000000 --- a/dev/test-graph-metrics.lisp +++ /dev/null @@ -1,38 +0,0 @@ -(in-package metabang.graph) - -;;; --------------------------------------------------------------------------- - -(lift:deftestsuite test-vertex-triangle-count () - ((g (make-container 'graph-container)))) - -(lift:deftestsuite test-vertex-triangle-count-1 (test-vertex-triangle-count) - () - (:setup - (loop for v in '(a b c d e f g h) do (add-vertex g v)) - (loop for (s d) in '((a b) (b c) (a c) (b d) (d e) (d f) (d g) (e f) (f g) (g h)) do - (add-edge-between-vertexes g s d)))) - -(lift:addtest (test-vertex-triangle-count-1) - (lift:ensure-same (vertex-triangle-count (find-vertex g 'a)) 1 :test '=)) - - -(lift:addtest (test-vertex-triangle-count-1) - (lift:ensure-same (vertex-triangle-count (find-vertex g 'd)) 2 :test '=)) - -(lift:addtest (test-vertex-triangle-count-1) - (lift:ensure-same (vertex-triangle-count (find-vertex g 'h)) 0 :test '=)) - -(lift:deftestsuite test-vertex-triangle-count-2 (test-vertex-triangle-count) - () - (:setup - (loop for v in '(a b c d e) do (add-vertex g v)) - (loop for (s d) in '((a b) (b c) (a c) (c d) (c e)) do - (add-edge-between-vertexes g s d)))) - -(lift:addtest (test-vertex-triangle-count-2) - (lift:ensure-same (vertex-triangle-count (find-vertex g 'c)) 1 :test '=) - (lift:ensure-same (vertex-triangle-count (find-vertex g 'd)) 0 :test '=)) - -(lift:addtest (test-vertex-triangle-count-2) - (lift:ensure-same (average-local-clustering-coefficient g) - (float (/ 13 30)) :test 'samep)) \ No newline at end of file diff --git a/dev/test-graph.lisp b/dev/test-graph.lisp deleted file mode 100644 index a94dd28..0000000 --- a/dev/test-graph.lisp +++ /dev/null @@ -1,167 +0,0 @@ -(in-package metabang.graph) - -#| -(let ((g (make-container 'graph-container))) - (add-edge-between-vertexes g 'a 'b) - (let ((v-a (find-vertex g 'a)) - (v-b (find-vertex g 'b))) - (print (compute-applicable-methods #'(SETF ELEMENT) (list :NEW-A V-A))) - (setf (element v-a) :new-a) - (inspect g))) -|# - -(deftestsuite test-graph () ()) - - -(deftestsuite test-test-vertex () ()) - -(addtest (test-test-vertex) - test-1 - (bind ((x (float 2.1d0)) - (y (float 2.1d0)) - (g (make-container 'graph-container))) - (add-vertex g (+ x y)) - (add-vertex g (+ x y)) - - (ensure-same (size g) 2))) - -(addtest (test-test-vertex) - test-1 - (bind ((x (float 2.1d0)) - (y (float 2.1d0)) - (g (make-container 'graph-container :vertex-test #'=))) - (add-vertex g (+ x y)) - (add-vertex g (+ x y)) - - (ensure-same (size g) 1))) - - -;;; --------------------------------------------------------------------------- -;;; should do this for each _kind_ of graph -;;; --------------------------------------------------------------------------- - -(deftestsuite test-basic-graph-properties (test-graph) - ((graph-undirected (make-container 'graph-container :default-edge-type :undirected)) - (graph-directed (make-container 'graph-container :default-edge-type :directed))) - :setup ((loop for v in '(a b c d e) do - (add-vertex graph-undirected v) - (add-vertex graph-directed v)) - (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do - (add-edge-between-vertexes graph-undirected v1 v2) - (add-edge-between-vertexes graph-directed v1 v2)))) - -;;; --------------------------------------------------------------------------- - -(addtest (test-basic-graph-properties) - (ensure-same (size (graph-vertexes graph-directed)) 5 :test #'=) - (ensure-same (size (graph-edges graph-directed)) 4 :test #'=)) - -;;; --------------------------------------------------------------------------- - -(addtest (test-basic-graph-properties) - (delete-edge-between-vertexes graph-directed 'a 'b) - (ensure (null (find-edge-between-vertexes graph-directed 'a 'b - :error-if-not-found? nil)))) - -;;; --------------------------------------------------------------------------- - -(addtest (test-basic-graph-properties) - (delete-edge-between-vertexes graph-directed 'a 'b) - (ensure-same (size (graph-edges graph-directed)) 3)) - -;;; --------------------------------------------------------------------------- - -(deftestsuite test-graph-traversal (test-graph) - ((g (make-container 'graph-container))) - :setup (loop for (src dst) in '((a b) (a c) (a d) (b e) - (b f) (d g) (d h) (h i) - (h j)) do - (add-edge-between-vertexes g src dst :edge-type :directed))) - -;;; --------------------------------------------------------------------------- - -#| - -a - b - e - - f - - c - - d - g - - h - i - - j - -|# - -(addtest (test-graph-traversal) - (let ((result nil)) - (traverse-elements - g :depth (lambda (v) (push (element v) result))) - (ensure-same (reverse result) - '(e f b c g i j h d a) :test #'equal))) - -;;; --------------------------------------------------------------------------- - -(addtest (test-graph-traversal) - (let ((result nil)) - (traverse-elements - g :breadth (lambda (v) (push (element v) result))) - ;(print (reverse result)) - (ensure-same (reverse result) - '(a b c d e f g h i j) :test #'equal))) - - -;;; --------------------------------------------------------------------------- -;;; test-replace-vertex -;;; --------------------------------------------------------------------------- - -(deftestsuite test-replace-vertex (test-basic-graph-properties) ()) - -;;; --------------------------------------------------------------------------- - -(addtest (test-replace-vertex) - test-directed - (let ((b (find-vertex graph-directed 'b)) - (x (make-vertex-for-graph graph-directed :element 'x))) - (replace-vertex graph-directed b x) - (ensure (find-vertex graph-directed 'x)) - (ensure (not (find-vertex graph-directed 'b nil))) - (ensure-same (edge-count (find-vertex graph-directed 'x)) 2 :test =) - (ensure (find-edge-between-vertexes graph-directed 'a 'x)) - (ensure (find-edge-between-vertexes graph-directed 'x 'd)))) - -;;; --------------------------------------------------------------------------- - -(addtest (test-replace-vertex) - test-undirected - (let ((b (find-vertex graph-undirected 'b)) - (x (make-vertex-for-graph graph-undirected :element 'x))) - (replace-vertex graph-undirected b x) - (ensure (find-vertex graph-undirected 'x)) - (ensure (not (find-vertex graph-undirected 'b nil))) - (ensure-same (edge-count (find-vertex graph-undirected 'x)) 2 :test =) - (ensure (find-edge-between-vertexes graph-undirected 'a 'x)) - (ensure (find-edge-between-vertexes graph-undirected 'x 'd)))) - -;;; --------------------------------------------------------------------------- -;;; change vertex value -;;; --------------------------------------------------------------------------- - -(deftestsuite test-change-vertex-value (test-basic-graph-properties) ()) - -;;; --------------------------------------------------------------------------- - -(addtest (test-change-vertex-value) - test-undirected - (let ((b (find-vertex graph-undirected 'b))) - (setf (element b) 'x) - (ensure (find-vertex graph-undirected 'x)) - (ensure (not (find-vertex graph-undirected 'b nil))) - (ensure-same (edge-count (find-vertex graph-undirected 'x)) 2 :test =) - (ensure (find-edge-between-vertexes graph-undirected 'a 'x)) - (ensure (find-edge-between-vertexes graph-undirected 'x 'd)))) - - - -;;; --------------------------------------------------------------------------- -;;; test-replace-edge -;;; --------------------------------------------------------------------------- - diff --git a/unit-tests/test-connected-components.lisp b/unit-tests/test-connected-components.lisp new file mode 100644 index 0000000..53b8fce --- /dev/null +++ b/unit-tests/test-connected-components.lisp @@ -0,0 +1,44 @@ +(in-package metabang.graph) + +(deftestsuite test-connected-component () + ()) + +;;; --------------------------------------------------------------------------- + +(defun make-connected-component-graph-1 () + (let ((g (make-container 'graph-container))) + (loop for label in '(wk-6-0 wp-5-1 wp-1-2 wp-2-3 wb-1-1 + wp-4-4 bp-5-6 bk-6-5 bb-5-7 bp-2-4 + bp-2-6 bp-1-5) do + (add-vertex g label)) + (loop for (source target) in '((wk-6-0 wp-5-1) + (wp-1-2 wp-2-3) + (wb-1-1 wp-4-4) + (bp-5-6 bk-6-5) + (bk-6-5 bb-5-7) + (bb-5-7 bp-2-4) + (bp-2-6 bp-1-5) + (bp-1-5 bp-2-4)) do + (add-edge-between-vertexes g source target :edge-type :directed + :value :defend)) + (loop for (source target) in '((bk-6-5 wp-4-4)) do + (add-edge-between-vertexes g source target :edge-type :directed + :value :attack)) + (loop for (source target) in '((wp-2-3 bp-2-4)) do + (add-edge-between-vertexes g source target :edge-type :undirected)) + g)) + +;;; --------------------------------------------------------------------------- + +(addtest (test-connected-component) + test-1 + (let ((g (make-connected-component-graph-1))) + (ensure-same + (mapcar #'size (find-connected-components g)) '(2 10) :test 'set-equal))) + +;;; --------------------------------------------------------------------------- + +(addtest (test-connected-component) + test-connected-component-count-1 + (let ((g (make-connected-component-graph-1))) + (ensure-same (connected-component-count g) 2 :test '=))) diff --git a/unit-tests/test-graph-algorithms.lisp b/unit-tests/test-graph-algorithms.lisp new file mode 100644 index 0000000..f54b879 --- /dev/null +++ b/unit-tests/test-graph-algorithms.lisp @@ -0,0 +1,121 @@ +(in-package cl-graph) + +(deftestsuite test-connected-components () + ()) + +(addtest (test-connected-components) + test-1 + (let ((g (make-container 'graph-container :default-edge-type :undirected))) + (loop for v in '(a b c d e f g h i j) do (add-vertex g v)) + (loop for (v1 v2) in '((a b) (a c) ( b c) (b d) (e f) (e g) (h i)) do + (add-edge-between-vertexes g v1 v2)) + + (let ((cc (connected-components g))) + (flet ((test (a b result) + (ensure-same (eq (representative-node cc (find-vertex g a)) + (representative-node cc (find-vertex g b))) + result))) + (loop for (v1 v2 result) in '((a b t) (a e nil) (f g t) + (j c nil) (b a t) (d c t)) do + (test v1 v2 result)))))) + +;;; --------------------------------------------------------------------------- + +(deftestsuite test-minimum-spanning-tree () + ()) + +(deftestsuite test-mst-kruskal (test-minimum-spanning-tree) + ()) + +(addtest (test-mst-kruskal) + test-1 + (let ((g (make-container 'graph-container + :default-edge-type :undirected + :undirected-edge-class 'weighted-edge)) + (m nil)) + (loop for (v1 v2 w) in '((a b 4) (a h 9) + (b c 8) (b h 11) + (c i 2) (c d 7) (c f 4) + (d e 9) (d f 14) + (e f 10) + (f g 2) + (g h 1) (g i 6) + (h i 7)) do + (add-edge-between-vertexes g v1 v2 :weight w)) + (setf m (minimum-spanning-tree-kruskal g)) + (ensure (set-equal + '(a b c d e f g h i) + (flatten (mapcar (lambda (e) + (list (element (vertex-1 e)) (element (vertex-2 e)))) + m)))) + (ensure-same (reduce #'+ m :key 'weight) 37 :test '=) + (ensure-same (size m) 8))) + +#+Test +(defclass* directed-weighted-edge (weighted-edge-mixin graph-container-directed-edge) + ()) + +#+Test +(let ((g (make-container 'graph-container + :default-edge-type :undirected + :undirected-edge-class 'weighted-edge + :directed-edge-class 'directed-weighted-edge))) + (loop for (v1 v2 w) in '((a b 4) (a h 9) + (b c 8) (b h 11) + (c i 2) (c d 7) (c f 4) + (d e 9) (d f 14) + (e f 10) + (f g 2) + (g h 1) (g i 6) + (h i 7) + + (a h 3)) do + (add-edge-between-vertexes g v1 v2 :weight w + :edge-type (if (random-boolean *random-generator* 0.3) + :directed :undirected))) + (minimum-spanning-tree-kruskal g)) + +#+Test +(graph->dot + (let ((g (make-container 'graph-container + :default-edge-type :undirected + :undirected-edge-class 'weighted-edge)) + (m nil)) + (loop for (v1 v2 w) in '((a b 10) (a b 1) (a d 3) + (b c 1) (b d 3) + (c d 1)) do + (add-edge-between-vertexes g v1 v2 :weight w :if-duplicate-do :force)) + (setf m (minimum-spanning-tree-kruskal g)) + g) + "p2dis:data;x.dot") + +#+Test +(let ((g (make-container 'graph-container + :default-edge-type :undirected + :undirected-edge-class 'weighted-edge)) + (m nil)) + (loop for (v1 v2 w) in '((a b 1) (a d 3) + (b c 5) (b d 2) + (c d 1)) do + (add-edge-between-vertexes g v1 v2 :weight w :if-duplicate-do :force)) + (setf m (minimum-spanning-tree-kruskal g)) + m) + +;;; --------------------------------------------------------------------------- + +#+test +(let ((graph (make-container 'graph-container))) + (loop for (a b) in '((r s) (r v) (s w) (t u) (t w) (t x) + (u y) (w x) (x y)) do + (add-edge-between-vertexes graph a b)) + + (breadth-first-search-graph graph 's)) + +;;; --------------------------------------------------------------------------- + +(let ((graph (make-container 'graph-container))) + (loop for (a b) in '((r s) (r v) (s w) (t u) (t w) (t x) + (u y) (w x) (x y)) do + (add-edge-between-vertexes graph a b)) + + (breadth-first-visitor graph 's #'print)) \ No newline at end of file diff --git a/unit-tests/test-graph-container.lisp b/unit-tests/test-graph-container.lisp new file mode 100644 index 0000000..c2697da --- /dev/null +++ b/unit-tests/test-graph-container.lisp @@ -0,0 +1,77 @@ +(in-package metabang.graph) + +;;; --------------------------------------------------------------------------- +;;; utilities +;;; --------------------------------------------------------------------------- + +(defun make-simple-test-graph () + (let ((g (make-container 'graph-container))) + (loop for v in '(a b c d e) do + (add-vertex g v)) + (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do + (add-edge-between-vertexes g v1 v2)) + g)) + +;;; --------------------------------------------------------------------------- +;;; tests +;;; --------------------------------------------------------------------------- + +(deftestsuite test-graph-container () ()) + +;;; --------------------------------------------------------------------------- + +(addtest (test-graph-container) + test-simple-copying + (let ((g1 (make-simple-test-graph)) + (g2 nil)) + (setf g2 (copy-top-level g1)) + (ensure-same (size g1) (size g2)) + (iterate-vertexes + g1 (lambda (v) + (ensure (find-vertex g2 (value v))))) + (iterate-edges + g1 (lambda (e) + (ensure (find-edge-between-vertexes + g2 (value (source-vertex e)) + (value (target-vertex e)))))))) + +;;; --------------------------------------------------------------------------- + +;; fails because find-edge-between-vertexes for graph containers doesn't +;; care about the graph... +(addtest (test-graph-container) + test-find-edge-between-vertexes + (let ((g1 (make-simple-test-graph)) + (g2 nil)) + (setf g2 (copy-top-level 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 '=))) diff --git a/unit-tests/test-graph-metrics.lisp b/unit-tests/test-graph-metrics.lisp new file mode 100644 index 0000000..8071a08 --- /dev/null +++ b/unit-tests/test-graph-metrics.lisp @@ -0,0 +1,38 @@ +(in-package metabang.graph) + +;;; --------------------------------------------------------------------------- + +(lift:deftestsuite test-vertex-triangle-count () + ((g (make-container 'graph-container)))) + +(lift:deftestsuite test-vertex-triangle-count-1 (test-vertex-triangle-count) + () + (:setup + (loop for v in '(a b c d e f g h) do (add-vertex g v)) + (loop for (s d) in '((a b) (b c) (a c) (b d) (d e) (d f) (d g) (e f) (f g) (g h)) do + (add-edge-between-vertexes g s d)))) + +(lift:addtest (test-vertex-triangle-count-1) + (lift:ensure-same (vertex-triangle-count (find-vertex g 'a)) 1 :test '=)) + + +(lift:addtest (test-vertex-triangle-count-1) + (lift:ensure-same (vertex-triangle-count (find-vertex g 'd)) 2 :test '=)) + +(lift:addtest (test-vertex-triangle-count-1) + (lift:ensure-same (vertex-triangle-count (find-vertex g 'h)) 0 :test '=)) + +(lift:deftestsuite test-vertex-triangle-count-2 (test-vertex-triangle-count) + () + (:setup + (loop for v in '(a b c d e) do (add-vertex g v)) + (loop for (s d) in '((a b) (b c) (a c) (c d) (c e)) do + (add-edge-between-vertexes g s d)))) + +(lift:addtest (test-vertex-triangle-count-2) + (lift:ensure-same (vertex-triangle-count (find-vertex g 'c)) 1 :test '=) + (lift:ensure-same (vertex-triangle-count (find-vertex g 'd)) 0 :test '=)) + +(lift:addtest (test-vertex-triangle-count-2) + (lift:ensure-same (average-local-clustering-coefficient g) + (float (/ 13 30)) :test 'samep)) \ No newline at end of file diff --git a/unit-tests/test-graph.lisp b/unit-tests/test-graph.lisp new file mode 100644 index 0000000..a94dd28 --- /dev/null +++ b/unit-tests/test-graph.lisp @@ -0,0 +1,167 @@ +(in-package metabang.graph) + +#| +(let ((g (make-container 'graph-container))) + (add-edge-between-vertexes g 'a 'b) + (let ((v-a (find-vertex g 'a)) + (v-b (find-vertex g 'b))) + (print (compute-applicable-methods #'(SETF ELEMENT) (list :NEW-A V-A))) + (setf (element v-a) :new-a) + (inspect g))) +|# + +(deftestsuite test-graph () ()) + + +(deftestsuite test-test-vertex () ()) + +(addtest (test-test-vertex) + test-1 + (bind ((x (float 2.1d0)) + (y (float 2.1d0)) + (g (make-container 'graph-container))) + (add-vertex g (+ x y)) + (add-vertex g (+ x y)) + + (ensure-same (size g) 2))) + +(addtest (test-test-vertex) + test-1 + (bind ((x (float 2.1d0)) + (y (float 2.1d0)) + (g (make-container 'graph-container :vertex-test #'=))) + (add-vertex g (+ x y)) + (add-vertex g (+ x y)) + + (ensure-same (size g) 1))) + + +;;; --------------------------------------------------------------------------- +;;; should do this for each _kind_ of graph +;;; --------------------------------------------------------------------------- + +(deftestsuite test-basic-graph-properties (test-graph) + ((graph-undirected (make-container 'graph-container :default-edge-type :undirected)) + (graph-directed (make-container 'graph-container :default-edge-type :directed))) + :setup ((loop for v in '(a b c d e) do + (add-vertex graph-undirected v) + (add-vertex graph-directed v)) + (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do + (add-edge-between-vertexes graph-undirected v1 v2) + (add-edge-between-vertexes graph-directed v1 v2)))) + +;;; --------------------------------------------------------------------------- + +(addtest (test-basic-graph-properties) + (ensure-same (size (graph-vertexes graph-directed)) 5 :test #'=) + (ensure-same (size (graph-edges graph-directed)) 4 :test #'=)) + +;;; --------------------------------------------------------------------------- + +(addtest (test-basic-graph-properties) + (delete-edge-between-vertexes graph-directed 'a 'b) + (ensure (null (find-edge-between-vertexes graph-directed 'a 'b + :error-if-not-found? nil)))) + +;;; --------------------------------------------------------------------------- + +(addtest (test-basic-graph-properties) + (delete-edge-between-vertexes graph-directed 'a 'b) + (ensure-same (size (graph-edges graph-directed)) 3)) + +;;; --------------------------------------------------------------------------- + +(deftestsuite test-graph-traversal (test-graph) + ((g (make-container 'graph-container))) + :setup (loop for (src dst) in '((a b) (a c) (a d) (b e) + (b f) (d g) (d h) (h i) + (h j)) do + (add-edge-between-vertexes g src dst :edge-type :directed))) + +;;; --------------------------------------------------------------------------- + +#| + +a - b - e + - f + - c + - d - g + - h - i + - j + +|# + +(addtest (test-graph-traversal) + (let ((result nil)) + (traverse-elements + g :depth (lambda (v) (push (element v) result))) + (ensure-same (reverse result) + '(e f b c g i j h d a) :test #'equal))) + +;;; --------------------------------------------------------------------------- + +(addtest (test-graph-traversal) + (let ((result nil)) + (traverse-elements + g :breadth (lambda (v) (push (element v) result))) + ;(print (reverse result)) + (ensure-same (reverse result) + '(a b c d e f g h i j) :test #'equal))) + + +;;; --------------------------------------------------------------------------- +;;; test-replace-vertex +;;; --------------------------------------------------------------------------- + +(deftestsuite test-replace-vertex (test-basic-graph-properties) ()) + +;;; --------------------------------------------------------------------------- + +(addtest (test-replace-vertex) + test-directed + (let ((b (find-vertex graph-directed 'b)) + (x (make-vertex-for-graph graph-directed :element 'x))) + (replace-vertex graph-directed b x) + (ensure (find-vertex graph-directed 'x)) + (ensure (not (find-vertex graph-directed 'b nil))) + (ensure-same (edge-count (find-vertex graph-directed 'x)) 2 :test =) + (ensure (find-edge-between-vertexes graph-directed 'a 'x)) + (ensure (find-edge-between-vertexes graph-directed 'x 'd)))) + +;;; --------------------------------------------------------------------------- + +(addtest (test-replace-vertex) + test-undirected + (let ((b (find-vertex graph-undirected 'b)) + (x (make-vertex-for-graph graph-undirected :element 'x))) + (replace-vertex graph-undirected b x) + (ensure (find-vertex graph-undirected 'x)) + (ensure (not (find-vertex graph-undirected 'b nil))) + (ensure-same (edge-count (find-vertex graph-undirected 'x)) 2 :test =) + (ensure (find-edge-between-vertexes graph-undirected 'a 'x)) + (ensure (find-edge-between-vertexes graph-undirected 'x 'd)))) + +;;; --------------------------------------------------------------------------- +;;; change vertex value +;;; --------------------------------------------------------------------------- + +(deftestsuite test-change-vertex-value (test-basic-graph-properties) ()) + +;;; --------------------------------------------------------------------------- + +(addtest (test-change-vertex-value) + test-undirected + (let ((b (find-vertex graph-undirected 'b))) + (setf (element b) 'x) + (ensure (find-vertex graph-undirected 'x)) + (ensure (not (find-vertex graph-undirected 'b nil))) + (ensure-same (edge-count (find-vertex graph-undirected 'x)) 2 :test =) + (ensure (find-edge-between-vertexes graph-undirected 'a 'x)) + (ensure (find-edge-between-vertexes graph-undirected 'x 'd)))) + + + +;;; --------------------------------------------------------------------------- +;;; test-replace-edge +;;; --------------------------------------------------------------------------- + -- 1.7.10.4