1 (in-package metabang.graph)
4 (let ((g (make-container 'graph-container)))
5 (add-edge-between-vertexes g 'a 'b)
6 (let ((v-a (find-vertex g 'a))
7 (v-b (find-vertex g 'b)))
8 (print (compute-applicable-methods #'(SETF ELEMENT) (list :NEW-A V-A)))
9 (setf (element v-a) :new-a)
13 (deftestsuite test-graph () ())
16 (deftestsuite test-test-vertex () ())
18 (addtest (test-test-vertex)
20 (bind ((x (float 2.1d0))
22 (g (make-container 'graph-container)))
23 (add-vertex g (+ x y))
24 (add-vertex g (+ x y))
26 (ensure-same (size g) 2)))
28 (addtest (test-test-vertex)
30 (bind ((x (float 2.1d0))
32 (g (make-container 'graph-container :vertex-test #'=)))
33 (add-vertex g (+ x y))
34 (add-vertex g (+ x y))
36 (ensure-same (size g) 1)))
39 ;;; ---------------------------------------------------------------------------
40 ;;; should do this for each _kind_ of graph
41 ;;; ---------------------------------------------------------------------------
43 (deftestsuite test-basic-graph-properties (test-graph)
44 ((graph-undirected (make-container 'graph-container :default-edge-type :undirected))
45 (graph-directed (make-container 'graph-container :default-edge-type :directed)))
46 :setup ((loop for v in '(a b c d e) do
47 (add-vertex graph-undirected v)
48 (add-vertex graph-directed v))
49 (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do
50 (add-edge-between-vertexes graph-undirected v1 v2)
51 (add-edge-between-vertexes graph-directed v1 v2))))
53 ;;; ---------------------------------------------------------------------------
55 (addtest (test-basic-graph-properties)
56 (ensure-same (size (graph-vertexes graph-directed)) 5 :test #'=)
57 (ensure-same (size (graph-edges graph-directed)) 4 :test #'=))
59 ;;; ---------------------------------------------------------------------------
61 (addtest (test-basic-graph-properties)
62 (delete-edge-between-vertexes graph-directed 'a 'b)
63 (ensure (null (find-edge-between-vertexes graph-directed 'a 'b
64 :error-if-not-found? nil))))
66 ;;; ---------------------------------------------------------------------------
68 (addtest (test-basic-graph-properties)
69 (delete-edge-between-vertexes graph-directed 'a 'b)
70 (ensure-same (size (graph-edges graph-directed)) 3))
72 ;;; ---------------------------------------------------------------------------
74 (deftestsuite test-graph-traversal (test-graph)
75 ((g (make-container 'graph-container)))
76 :setup (loop for (src dst) in '((a b) (a c) (a d) (b e)
77 (b f) (d g) (d h) (h i)
79 (add-edge-between-vertexes g src dst :edge-type :directed)))
81 ;;; ---------------------------------------------------------------------------
94 (addtest (test-graph-traversal)
97 g :depth (lambda (v) (push (element v) result)))
98 (ensure-same (reverse result)
99 '(e f b c g i j h d a) :test #'equal)))
101 ;;; ---------------------------------------------------------------------------
103 (addtest (test-graph-traversal)
106 g :breadth (lambda (v) (push (element v) result)))
107 ;(print (reverse result))
108 (ensure-same (reverse result)
109 '(a b c d e f g h i j) :test #'equal)))
112 ;;; ---------------------------------------------------------------------------
113 ;;; test-replace-vertex
114 ;;; ---------------------------------------------------------------------------
116 (deftestsuite test-replace-vertex (test-basic-graph-properties) ())
118 ;;; ---------------------------------------------------------------------------
120 (addtest (test-replace-vertex)
122 (let ((b (find-vertex graph-directed 'b))
123 (x (make-vertex-for-graph graph-directed :element 'x)))
124 (replace-vertex graph-directed b x)
125 (ensure (find-vertex graph-directed 'x))
126 (ensure (not (find-vertex graph-directed 'b nil)))
127 (ensure-same (edge-count (find-vertex graph-directed 'x)) 2 :test =)
128 (ensure (find-edge-between-vertexes graph-directed 'a 'x))
129 (ensure (find-edge-between-vertexes graph-directed 'x 'd))))
131 ;;; ---------------------------------------------------------------------------
133 (addtest (test-replace-vertex)
135 (let ((b (find-vertex graph-undirected 'b))
136 (x (make-vertex-for-graph graph-undirected :element 'x)))
137 (replace-vertex graph-undirected b x)
138 (ensure (find-vertex graph-undirected 'x))
139 (ensure (not (find-vertex graph-undirected 'b nil)))
140 (ensure-same (edge-count (find-vertex graph-undirected 'x)) 2 :test =)
141 (ensure (find-edge-between-vertexes graph-undirected 'a 'x))
142 (ensure (find-edge-between-vertexes graph-undirected 'x 'd))))
144 ;;; ---------------------------------------------------------------------------
145 ;;; change vertex value
146 ;;; ---------------------------------------------------------------------------
148 (deftestsuite test-change-vertex-value (test-basic-graph-properties) ())
150 ;;; ---------------------------------------------------------------------------
152 (addtest (test-change-vertex-value)
154 (let ((b (find-vertex graph-undirected 'b)))
155 (setf (element b) 'x)
156 (ensure (find-vertex graph-undirected 'x))
157 (ensure (not (find-vertex graph-undirected 'b nil)))
158 (ensure-same (edge-count (find-vertex graph-undirected 'x)) 2 :test =)
159 (ensure (find-edge-between-vertexes graph-undirected 'a 'x))
160 (ensure (find-edge-between-vertexes graph-undirected 'x 'd))))
164 ;;; ---------------------------------------------------------------------------
165 ;;; test-replace-edge
166 ;;; ---------------------------------------------------------------------------