root/trunk/projects/bos/test/web/quad-tree.lisp

Revision 3656, 7.8 kB (checked in by ksprotte, 5 months ago)

whitespace cleanup

Line 
1 (in-package :bos.test)
2 (in-suite :bos.test.web.quad-tree)
3
4 (eval-when (:compile-toplevel :load-toplevel :execute)
5   (import '(bos.web::quad-node
6             bos.web::*m2-geo-box*
7             bos.web::ensure-child
8             bos.web::geo-box-intersect-p
9             bos.web::geo-box-encloses-p
10             bos.web::make-geo-box
11             bos.web::geo-box
12             bos.web::geo-box-west
13             bos.web::geo-box-east
14             bos.web::geo-box-north
15             bos.web::geo-box-south
16             bos.web::child
17             bos.web::node-extension
18             bos.web::extensions
19             bos.web::map-nodes
20             bos.web::ensure-node-with-path
21             bos.web::node-path
22             bos.web::geo-point-in-box-p
23             bos.web::node-has-children-p
24             bos.web::any-child
25             bos.web::child-index
26             bos.web::find-node-with-path
27             bos.web::ensure-node-with-path
28             )))
29
30 (test geo-box-intersect-p.1
31       (let ((tree (make-instance 'quad-node :geo-box *m2-geo-box*)))
32         (ensure-child tree 0)
33         (ensure-child tree 1)
34         (ensure-child tree 2)
35         (ensure-child tree 3)
36         (loop for (a b) in '((2 3) (1 3) (1 2) (0 3) (0 2) (0 1))
37            do (is-false (geo-box-intersect-p (geo-box (child tree a))
38                                              (geo-box (child tree b)))))
39         (loop for (a b) in '((0 0) (1 1) (2 2) (3 3))
40            do (is-true (geo-box-intersect-p (geo-box (child tree a))
41                                             (geo-box (child tree b)))))
42         (loop for a in '(0 1 2 3)
43            do (is-true (geo-box-intersect-p (geo-box (child tree a))
44                                             (geo-box tree))))))
45
46 (test geo-box-encloses-p.1
47       (let ((tree (make-instance 'quad-node :geo-box *m2-geo-box*)))
48         (ensure-child tree 0)
49         (ensure-child tree 1)
50         (ensure-child tree 2)
51         (ensure-child tree 3)
52         (loop for (a b) in '((2 3) (1 3) (1 2) (0 3) (0 2) (0 1))
53            do (progn
54                 (is-false (geo-box-encloses-p (geo-box (child tree a))
55                                               (geo-box (child tree b))))
56                 (is-false (geo-box-encloses-p (geo-box (child tree b))
57                                               (geo-box (child tree a))))))
58         (loop for (a b) in '((0 0) (1 1) (2 2) (3 3))
59            do (is-true (geo-box-encloses-p (geo-box (child tree a))
60                                            (geo-box (child tree b)))))
61         (loop for a in '(0 1 2 3)
62            do (progn
63                 (is-true (geo-box-encloses-p (geo-box tree)
64                                              (geo-box (child tree a))))
65                 (is-false (geo-box-encloses-p (geo-box (child tree a))
66                                               (geo-box tree)))))
67         (let ((a *m2-geo-box*)
68               ;; slightly moved
69               (b (make-geo-box (+ (geo-box-west *m2-geo-box*) 0.01d0)
70                                (- (geo-box-north *m2-geo-box*) 0.01d0)
71                                (+ (geo-box-east *m2-geo-box*) 0.01d0)
72                                (- (geo-box-south *m2-geo-box*) 0.01d0))))
73           (assert (geo-box-intersect-p a b))
74           (is-false (geo-box-encloses-p a b))
75           (is-false (geo-box-encloses-p b a)))))
76
77 (test geo-point-in-box-p
78       (let* ((tree (make-instance 'quad-node :geo-box *m2-geo-box*))
79              (box (geo-box tree)))
80         (is-true (geo-point-in-box-p box (list (geo-box-west box) (geo-box-north box))))
81         (is-false (geo-point-in-box-p box (list (geo-box-east box) (geo-box-north box))))
82         (is-false (geo-point-in-box-p box (list (geo-box-west box) (geo-box-south box))))
83         (is-false (geo-point-in-box-p box (list (geo-box-east box) (geo-box-south box))))
84         ;;
85         (is-true (geo-point-in-box-p box (list (+ 0.01d0 (geo-box-west box))
86                                                (- (geo-box-north box) 0.01d0))))))
87
88 (test quad-node.make-instance
89       ;; quad-node
90       (signals error (make-instance 'quad-node))
91       (signals error (make-instance 'quad-node :geo-box 123))
92       (finishes (make-instance 'quad-node :geo-box *m2-geo-box*))
93       ;; node-extension
94       (signals error (make-instance 'node-extension))
95       (let ((base-node (make-instance 'quad-node :geo-box *m2-geo-box*)))
96         (signals error (make-instance 'node-extension :base-node base-node))
97         (let ((ext (make-instance 'node-extension :base-node base-node :name :ext)))
98           (is (member ext (extensions base-node)))))
99       (let ((base-node (make-instance 'quad-node :geo-box *m2-geo-box*)))
100         (make-instance 'node-extension :base-node base-node :name :ext)
101         (finishes (make-instance 'node-extension :base-node base-node :name :ext2))
102         (signals error (make-instance 'node-extension :base-node base-node :name :ext))))
103
104 (test quad-node.children
105       (let* ((q (make-instance 'quad-node :geo-box *m2-geo-box*))
106              (e (make-instance 'node-extension :base-node q :name :ext)))
107         (is (null (child q 0)))
108         (is (null (child e 0)))
109         (is (null (node-has-children-p q)))
110         (is (null (node-has-children-p e)))
111         (ensure-child q 0)
112         (is (child q 0))
113         (is (null (child e 0)))
114         (ensure-child e 0)
115         (is (child q 0))
116         (is (child e 0))
117         (is (node-has-children-p q))
118         (is (node-has-children-p e))
119         (is (any-child q))
120         (is (any-child e))
121         (is (= 0 (child-index q (child q 0))))
122         (is (= 0 (child-index e (child e 0))))
123         (is (eql (child q 0)
124                  (find-node-with-path q '(0))))
125         (is (eql (child e 0)
126                  (find-node-with-path e '(0))))
127         (is (eql (ensure-node-with-path q '(0 0))
128                  (child (child q 0) 0)))
129         (is (eql (ensure-node-with-path e '(0 0))
130                  (child (child e 0) 0)))))
131
132 (test map-nodes.1
133       (labels ((count-nodes (tree)
134                  (let ((count 0))
135                    (map-nodes (lambda (node) (declare (ignore node)) (incf count)) tree)
136                    count)))
137         (let ((tree (make-instance 'quad-node :geo-box *m2-geo-box*)))
138           (is (= 1 (count-nodes tree)))
139           (ensure-node-with-path tree '(0))
140           (is (= 2 (count-nodes tree)))
141           (ensure-node-with-path tree '(1))
142           (is (= 3 (count-nodes tree)))
143           (ensure-node-with-path tree '(2))
144           (is (= 4 (count-nodes tree)))
145           (ensure-node-with-path tree '(3))
146           (is (= 5 (count-nodes tree)))
147           (ensure-node-with-path tree '(0 0))
148           (is (= 6 (count-nodes tree)))
149           (ensure-node-with-path tree '(0 1))
150           (is (= 7 (count-nodes tree))))))
151
152 (test map-nodes.2
153       (labels ((count-nodes (tree)
154                  (let ((count 0))
155                    (map-nodes (lambda (node)
156                                 (is (eql :ext (bos.web::name node)))
157                                 (incf count)) tree)
158                    count)))
159         (let* ((q (make-instance 'quad-node :geo-box *m2-geo-box*))
160                (tree (make-instance 'node-extension :base-node q :name :ext)))
161           (is (= 1 (count-nodes tree)))
162           (ensure-node-with-path tree '(0))
163           (is (= 2 (count-nodes tree)))
164           (ensure-node-with-path tree '(1))
165           (is (= 3 (count-nodes tree)))
166           (ensure-node-with-path tree '(2))
167           (is (= 4 (count-nodes tree)))
168           (ensure-node-with-path tree '(3))
169           (is (= 5 (count-nodes tree)))
170           (ensure-node-with-path tree '(0 0))
171           (is (= 6 (count-nodes tree)))
172           (ensure-node-with-path tree '(0 1))
173           (is (= 7 (count-nodes tree))))))
174
175 (test node-path.1
176       (let ((bos.web::*quad-tree* (make-instance 'quad-node :geo-box *m2-geo-box*)))
177         (for-all ((path (gen-list :elements (gen-integer :min 0 :max 3))))
178                  (is (equal path (node-path (ensure-node-with-path bos.web::*quad-tree* path)))))))
Note: See TracBrowser for help on using the browser.