git.fiddlerwoaroof.com
Browse code

Adding various other implementations

fiddlerwoaroof authored on 23/05/2016 21:13:29
Showing 5 changed files
bisorter.lisp
History View file @ 3bf1c97
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,61 @@
1 
+(defpackage :3dr.bisorter
2 
+  (:use :alexandria :serapeum :cl))
3 
+
4 
+(in-package :3dr.bisorter)
5 
+
6 
+(defun make-adj-arr (&optional (size 25))
7 
+  (make-array size :adjustable t :fill-pointer 0))
8 
+
9 
+(defclass bilayer ()
10 
+  ((fg :initarg :fg :accessor fg :initform (make-adj-arr))
11 
+   (bg :initarg :bg :accessor bg :initform (make-adj-arr))
12 
+   (dimension :initarg :dimension :accessor dimension)
13 
+   (center :initarg :center :accessor center)))
14 
+
15 
+(defun split-points (points bilayer)
16 
+  (with-slots (fg bg dimension center) bilayer
17 
+    (map nil
18 
+         (lambda (point)
19 
+           (if (< (elt center dimension) (elt point dimension))
20 
+             (vector-push-extend point fg)
21 
+             (vector-push-extend point bg)))
22 
+         points)
23 
+    bilayer))
24 
+
25 
+(defmethod print-object ((object bilayer) s)
26 
+  (print-unreadable-object (object s :type t :identity t)
27 
+    (with-slots (fg bg dimension center) object
28 
+      (format s "center: ~s div on: ~s (~d fg, ~d bg)"
29 
+              center dimension
30 
+              (length fg)
31 
+              (length bg)))))
32 
+
33 
+(defun split-bilayer (bilayer)
34 
+  (with-slots (fg bg dimension center) bilayer
35 
+    (let* ((new-dimension (mod (1+ dimension)
36 
+                               (length center)))
37 
+           (new-fg-bilayer (make-instance 'bilayer
38 
+                                       :dimension new-dimension
39 
+                                       :center center))
40 
+           (new-bg-bilayer (make-instance 'bilayer
41 
+                                       :dimension new-dimension
42 
+                                       :center center)))
43 
+      (list (split-points fg new-fg-bilayer)
44 
+            (split-points bg new-bg-bilayer)))))
45 
+
46 
+(defvar *bis*)
47 
+(defvar *points*)
48 
+
49 
+(defun main ()
50 
+  (setf *bis* (make-instance 'bilayer
51 
+                             :dimension 0
52 
+                             :center (vector 0 0 0)))
53 
+
54 
+  (flet ((100- (x) (- 100 x)))
55 
+    (setf *points*
56 
+          (loop repeat 1000
57 
+                collect (vector (random 200)
58 
+                                (100- (random 200))
59 
+                                (100- (random 200))))))
60 
+
61 
+  (split-points *points* *bis*))
octcone.lisp
History View file @ 3bf1c97
... ... 
@@ -16,16 +16,17 @@
16 16
17 17 
 (defun bucket-point (point octcone)
18 18 
   (with-slots (nw-bucket ne-bucket sw-bucket se-bucket center) octcone
19 
-    (with-accessors ((center-y 3dr::point-y) (center-z 3dr::point-z)) center
19 
+    (with-accessors ((center-y 3dr::point-y) (center-z 3dr::point-z)) center
20 20 
       (with-accessors ((point-y 3dr::point-y) (point-z 3dr::point-z)) point
21 
-        (vector-push-extend point
22 
-                            (if (< point-y center-y)
23 
-                                (if (< point-z center-z)
24 
-                                    sw-bucket
25 
-                                  nw-bucket)
26 
-                              (if (< point-z center-z)
27 
-                                  se-bucket
28 
-                                ne-bucket)))))))
21 
+        (vector-push-extend
22 
+          point
23 
+          (if (< point-y center-y)
24 
+            (if (< point-z center-z)
25 
+              sw-bucket
26 
+              nw-bucket)
27 
+            (if (< point-z center-z)
28 
+              se-bucket
29 
+              ne-bucket)))))))
29 30
30 31 
 (defun normalize-bucket (octcone bucket)
31 32 
   (let ((the-bucket (slot-value octcone bucket)))
... ... 
@@ -37,39 +38,67 @@
37 38 
         collect (normalize-bucket octcone bucket)))
38 39
39 40 
 (defun half-power-two (low high)
40 
-  (expt 2
41 
-        (floor
42 
-         (log
43 
-          (abs
44 
-           (+ low
45 
-              (floor (- high low)
46 
-                     2)))
47 
-          2))))
41 
+  (* (signum low)
42 
+     (expt 2
43 
+           (floor (log (abs (+ low
44 
+                               (floor (- high low)
45 
+                                      2)))
46 
+                       2)))))
48 47
49 48 
 (defun subdivide-bucket (octcone bucket)
49 
+  (declare (optimize (debug 3)))
50 50 
   (let ((the-bucket (slot-value octcone bucket)))
51 
-    (when (< 0 (length the-bucket))
51 
+    (check-type the-bucket vector)
52 
+    (if (< 1 (length the-bucket))
52 53 
       (let* ((max-y (reduce #'max the-bucket :key #'3dr::point-y))
53 54 
              (min-y (reduce #'min the-bucket :key #'3dr::point-y))
54 
-
55 
+
55 56 
              (max-z (reduce #'max the-bucket :key #'3dr::point-z))
56 57 
              (min-z (reduce #'min the-bucket :key #'3dr::point-z))
57 
-
58 
+
58 59 
              (new-octc (make-instance 'octcone
59 60 
                                       :center (vector 0
60 61 
                                                       (half-power-two min-y max-y)
61 62 
                                                       (half-power-two min-z max-z)))))
62 
-
63 
+
63 64 
         (values (prog1 new-octc
64 
-                  (map nil
65 
-                       (lambda (point) (bucket-point point new-octc))
66 
-                       the-bucket))
65 
+                  (when (or (= min-y max-y) (= min-z max-z))
66 
+                    (setf (slot-value octcone bucket)
67 
+                          new-octc)
68 
+                    (map nil
69 
+                         (lambda (point)
70 
+                           (bucket-point point new-octc))
71 
+                         the-bucket)))
67 72 
                 (vector min-y max-y)
68 
-                (vector min-z max-z))))))
73 
+                (vector min-z max-z)))
74 
+      nil)))
75 
+
76 
+(defmethod bucket-length (bucket)
77 
+  (declare (optimize (debug 3)))
78 
+  (typecase bucket
79 
+    (vector (length bucket))
80 
+    (octcone
81 
+      (with-slots (nw-bucket ne-bucket sw-bucket se-bucket overflow-bucket) bucket
82 
+        (+ (bucket-length nw-bucket)
83 
+           (bucket-length ne-bucket)
84 
+           (bucket-length se-bucket)
85 
+           (bucket-length sw-bucket)
86 
+           (bucket-length overflow-bucket))))))
87 
+
88 
+(defmethod print-object ((object octcone) s)
89 
+  (print-unreadable-object (object s :type t :identity t)
90 
+    (with-slots (nw-bucket ne-bucket sw-bucket se-bucket overflow-bucket center) object
91 
+      (format s "center: (~{~a~^,~}) sizes: nw ~d, ne ~d, se ~d, sw ~d, overflow ~d"
92 
+              (coerce center 'list)
93 
+              (bucket-length nw-bucket)
94 
+              (bucket-length ne-bucket)
95 
+              (bucket-length se-bucket)
96 
+              (bucket-length sw-bucket)
97 
+              (bucket-length overflow-bucket)))))
69 98
70 99 
 (defun subdivide-buckets (octcone)
71 
-  (loop for bucket in '(nw-bucket ne-bucket se-bucket sw-bucket)
72 
-        collect (subdivide-bucket octcone bucket)))
100 
+  (let ((result (loop for bucket in '(nw-bucket ne-bucket se-bucket sw-bucket)
101 
+                      collect (subdivide-bucket octcone bucket))))))
73 102
74 103 
 (defun show-bucket-sizes (octcone)
75 104 
   (loop for bucket in '(nw-bucket ne-bucket se-bucket sw-bucket)
... ... 
@@ -90,4 +119,44 @@
90 119 
             (bucket-point x *octc*))
91 120 
           *points*))
92 121
93 
-
122 
+(defun make-graph-conns (conns)
123 
+  (format nil "~:{~4t~(\"~a\" -> \"~a\"~%~)~}" conns))
124 
+
125 
+(defun make-graph (conns)
126 
+  (format nil "digraph {~%~a~%}~%" (make-graph-conns conns)))
127 
+
128 
+(defun bucket-to-pair (bucket parent)
129 
+  (declare (optimize (debug 3)))
130 
+  (flet ((bucket-to-string (center bucket title)
131 
+           (format nil "\"(~a: <~{~d~^, ~}> ~d)\""
132 
+                   (sxhash bucket)
133 
+                   (coerce center 'list)
134 
+                   (bucket-length bucket))))
135 
+    (with-slots (center) bucket
136 
+      (with-slots ((parent-center center)) parent
137 
+        (list (bucket-to-string parent-center parent)
138 
+              (bucket-to-string center bucket))))))
139 
+
140 
+(defun octcone-to-graph-pairs (octcone)
141 
+  (declare (optimize (debug 3)))
142 
+  (with-slots (nw-bucket ne-bucket se-bucket sw-bucket center) octcone
143 
+    (list
144 
+      (typecase nw-bucket
145 
+        (octcone (bucket-to-pair nw-bucket octcone)))
146 
+      (typecase ne-bucket
147 
+        (octcone (bucket-to-pair ne-bucket octcone)))
148 
+      (typecase se-bucket
149 
+        (octcone (bucket-to-pair se-bucket octcone)))
150 
+      (typecase sw-bucket
151 
+        (octcone (bucket-to-pair sw-bucket octcone))))))
152 
+
153 
+(defun bucket-to-graph-list (bucket)
154 
+  (declare (optimize (debug 3)))
155 
+  (typecase bucket
156 
+    (octcone
157 
+      (with-slots (nw-bucket ne-bucket se-bucket sw-bucket center) bucket
158 
+        (append (octcone-to-graph-pairs bucket)
159 
+                (bucket-to-graph-list nw-bucket)
160 
+                (bucket-to-graph-list ne-bucket)
161 
+                (bucket-to-graph-list sw-bucket)
162 
+                (bucket-to-graph-list se-bucket))))))
octcone2.lisp
History View file @ 3bf1c97
94 163 
new file mode 100644
... ... 
@@ -0,0 +1,201 @@
1 
+(in-package #:3dr.octcone2)
2 
+
3 
+(defun make-adj-arr (&optional (size 25))
4 
+  (make-array size :adjustable t :fill-pointer 0))
5 
+
6 
+(defclass quadtree ()
7 
+  ((nw-bucket :initarg :nw-bucket :accessor nw-bucket :initform nil)
8 
+   (ne-bucket :initarg :ne-bucket :accessor ne-bucket :initform nil)
9 
+   (sw-bucket :initarg :sw-bucket :accessor sw-bucket :initform nil)
10 
+   (se-bucket :initarg :se-bucket :accessor se-bucket :initform nil)
11 
+
12 
+   (nw-bucket-bg :initarg :nw-bucket-bg :accessor nw-bucket-bg :initform nil)
13 
+   (ne-bucket-bg :initarg :ne-bucket-bg :accessor ne-bucket-bg :initform nil)
14 
+   (sw-bucket-bg :initarg :sw-bucket-bg :accessor sw-bucket-bg :initform nil)
15 
+   (se-bucket-bg :initarg :se-bucket-bg :accessor se-bucket-bg :initform nil)
16 
+
17 
+   (duplicates :initarg :duplicates :accessor duplicates :initform (make-adj-arr))
18 
+   (center :initarg :center :accessor center)))
19 
+
20 
+(defgeneric insert-in-quadtree (quadtree point))
21 
+
22 
+(defstruct (point (:type vector)) x y z)
23 
+
24 
+(defun maybe-replace-bucket (quadtree bucket point)
25 
+  (declare (optimize (debug 3)))
26 
+  (let ((bucket-val (slot-value quadtree bucket)))
27 
+    (if (not bucket-val)
28 
+      (setf (slot-value quadtree bucket) point)
29 
+      (etypecase bucket-val
30 
+        (vector (setf (slot-value quadtree bucket)
31 
+                      (insert-in-quadtree (make-instance 'quadtree
32 
+                                                         :center bucket-val)
33 
+                                          point)))
34 
+        (quadtree (if (< (c-distance (center quadtree) point)
35 
+                         (c-distance (center quadtree) (center bucket-val)))
36 
+                    (let ((new-quadtree (make-instance 'quadtree :center point)))
37 
+                      (setf (slot-value quadtree bucket) new-quadtree)
38 
+                      (insert-in-quadtree new-quadtree bucket-val))
39 
+                    (insert-in-quadtree bucket-val point)))))))
40 
+
41 
+(defun c-distance (p1 p2)
42 
+  (declare (optimize (speed 3) (debug 0))
43 
+           (inline c-distance))
44 
+  (sqrt (loop for c1 across p1
45 
+              for c2 across p2
46 
+              sum (expt (- c2 c1) 2))))
47 
+
48 
+(defmethod insert-in-quadtree ((quadtree quadtree) (child quadtree))
49 
+  (with-slots ((parent-center center) duplicates) quadtree
50 
+    (with-slots ((child-center center)) child
51 
+      (with-accessors ((point-x point-x) (point-y point-y) (point-z point-z)) child-center
52 
+        (with-accessors ((center-x point-x) (center-y point-y) (center-z point-z)) parent-center
53 
+          (if (equalp parent-center child-center)
54 
+            (vector-push-extend child-center duplicates)
55 
+            (maybe-replace-bucket quadtree
56 
+                                  (if (< point-x center-x)
57 
+                                    (if (< point-y center-y)
58 
+                                      (if (< point-z center-z) 'sw-bucket-bg 'sw-bucket)
59 
+                                      (if (< point-z center-z) 'nw-bucket-bg 'nw-bucket))
60 
+                                    (if (< point-y center-y)
61 
+                                      (if (< point-z center-z) 'se-bucket-bg 'se-bucket)
62 
+                                      (if (< point-z center-z) 'ne-bucket-bg 'ne-bucket)))
63 
+                                  child)))))))
64 
+
65 
+(defmethod insert-in-quadtree ((quadtree quadtree) (point vector))
66 
+  (declare (optimize (debug 3)))
67 
+  (prog1 quadtree
68 
+    (with-slots (duplicates center) quadtree
69 
+      (with-accessors ((point-x point-x) (point-y point-y) (point-z point-z)) point
70 
+        (with-accessors ((center-x point-x) (center-y point-y) (center-z point-z)) center
71 
+          (if (equalp point center)
72 
+            (vector-push-extend point duplicates)
73 
+            (maybe-replace-bucket quadtree
74 
+                                  (if (< point-x center-x)
75 
+                                    (if (< point-y center-y)
76 
+                                      (if (< point-z center-z) 'sw-bucket-bg 'sw-bucket)
77 
+                                      (if (< point-z center-z) 'nw-bucket-bg 'nw-bucket))
78 
+                                    (if (< point-y center-y)
79 
+                                      (if (< point-z center-z) 'se-bucket-bg 'se-bucket)
80 
+                                      (if (< point-z center-z) 'ne-bucket-bg 'ne-bucket)))
81 
+                                  point)))))))
82 
+
83 
+(defmethod print-object ((object quadtree) s)
84 
+  (declare (optimize (debug 3)))
85 
+  (print-unreadable-object (object s :type t :identity t)
86 
+    (with-slots (center nw-bucket nw-bucket-bg ne-bucket ne-bucket-bg
87 
+                        se-bucket se-bucket-bg sw-bucket sw-bucket-bg
88 
+                        duplicates) object
89 
+      (format s "~s x~d: ~@{~a~^ ~}"
90 
+              center
91 
+              (length duplicates)
92 
+              (not (null nw-bucket))
93 
+              (not (null nw-bucket-bg))
94 
+              (not (null ne-bucket))
95 
+              (not (null ne-bucket-bg))
96 
+              (not (null sw-bucket))
97 
+              (not (null sw-bucket-bg))
98 
+              (not (null se-bucket))
99 
+              (not (null se-bucket-bg))))))
100 
+
101 
+(defun make-graph-conns (conns)
102 
+  (format nil "~:{~4t~(\"~a\" -> \"~a\"~%~)~}" conns))
103 
+
104 
+(defun make-graph (conns)
105 
+  (format nil "digraph {splines=ortho;~%node [shape=box];~%~a~%}~%" (make-graph-conns conns)))
106 
+
107 
+(defun quadtree-to-graph (quadtree &optional parent)
108 
+  (declare (optimize (debug 3)))
109 
+  (flet ((graph-bucket (bucket)
110 
+           (typecase quadtree
111 
+             (quadtree (quadtree-to-graph (slot-value quadtree bucket)
112 
+                                          quadtree)))))
113 
+    (when quadtree
114 
+      (with-slots (center) quadtree
115 
+        (with-slots ((parent-center center)) parent
116 
+          (append (when parent
117 
+                    (list (list parent-center
118 
+                                (typecase quadtree
119 
+                                  (quadtree center)
120 
+                                  (vector quadtree)))))
121 
+                  (graph-bucket 'nw-bucket-bg)
122 
+                  (graph-bucket 'ne-bucket-bg)
123 
+                  (graph-bucket 'sw-bucket-bg)
124 
+                  (graph-bucket 'se-bucket-bg)
125 
+                  (graph-bucket 'nw-bucket)
126 
+                  (graph-bucket 'ne-bucket)
127 
+                  (graph-bucket 'sw-bucket)
128 
+                  (graph-bucket 'se-bucket)))))))
129 
+
130 
+(defun draw-line (buffer p1 p2)
131 
+  (with-accessors ((x1 point-x) (y1 point-y)) p1
132 
+    (let ((x1 (+ 64 x1))
133 
+          (y1 (+ 64 y1)))
134 
+      (with-accessors ((x2 point-x) (y2 point-y)) p2
135 
+        (let ((x2 (+ 64 x2))
136 
+              (y2 (+ 64 y2)))
137 
+          (let* ((dist-x (abs (- x1 x2)))
138 
+                 (dist-y (abs (- y1 y2)))
139 
+                 (steep (> dist-y dist-x)))
140 
+            (when steep
141 
+              (psetf x1 y1 y1 x1
142 
+                     x2 y2 y2 x2))
143 
+            (when (> x1 x2)
144 
+              (psetf x1 x2 x2 x1
145 
+                     y1 y2 y2 y1))
146 
+            (let* ((delta-x (- x2 x1))
147 
+                   (delta-y (abs (- y1 y2)))
148 
+                   (error (floor delta-x 2))
149 
+                   (y-step (if (< y1 y2) 1 -1))
150 
+                   (y y1))
151 
+              (loop
152 
+                :for x :upfrom x1 :to x2
153 
+                :do (if steep
154 
+                      (setf (aref buffer x y) 1)
155 
+                      (setf (aref buffer y x) 1))
156 
+                (setf error (- error delta-y))
157 
+                (when (< error 0)
158 
+                  (incf y y-step)
159 
+                  (incf error delta-x))))
160 
+            buffer))))))
161 
+
162 
+(defun one-layer-of-octree (quadtree)
163 
+  (flet ((bucket-as-point (b)
164 
+           (etypecase b
165 
+             (null nil)
166 
+             (vector b)
167 
+             (quadtree (center b)))))
168 
+    (with-slots (nw-bucket nw-bucket-bg ne-bucket ne-bucket-bg se-bucket se-bucket-bg sw-bucket sw-bucket-bg) quadtree
169 
+      (list
170 
+        (mapcar #'bucket-as-point (list quadtree
171 
+                                        nw-bucket nw-bucket-bg
172 
+                                        ne-bucket ne-bucket-bg
173 
+                                        se-bucket se-bucket-bg
174 
+                                        sw-bucket sw-bucket-bg))))))
175 
+
176 
+(defun octree-to-list (octree)
177 
+  (typecase octree
178 
+    (vector (list (list octree nil nil nil nil nil nil nil nil)))
179 
+    (quadtree (with-slots (nw-bucket nw-bucket-bg ne-bucket ne-bucket-bg se-bucket se-bucket-bg sw-bucket sw-bucket-bg) octree
180 
+                (append (one-layer-of-octree octree)
181 
+                        (when nw-bucket        (octree-to-list nw-bucket))
182 
+                        (when nw-bucket-bg  (octree-to-list nw-bucket-bg))
183 
+                        (when ne-bucket        (octree-to-list ne-bucket))
184 
+                        (when ne-bucket-bg  (octree-to-list ne-bucket-bg))
185 
+                        (when se-bucket        (octree-to-list se-bucket))
186 
+                        (when se-bucket-bg  (octree-to-list se-bucket-bg))
187 
+                        (when sw-bucket        (octree-to-list sw-bucket))
188 
+                        (when sw-bucket-bg  (octree-to-list sw-bucket-bg)))))))
189 
+
190 
+(defun main ()
191 
+  (declare (optimize (debug 3)))
192 
+  (labels ((50- (x) (- x 50))
193 
+           (random-point (&optional (limit 100))
194 
+             (make-point :x (50- (random limit))
195 
+                         :y (50- (random limit))
196 
+                         :z 0 #|(50- (random limit))|#)))
197 
+    (let ((quadtree (make-instance 'quadtree :center #(0 0 0)))
198 
+          (points (loop repeat 100 collect (random-point))))
199 
+      (map nil (lambda (point) (insert-in-quadtree quadtree point))
200 
+        points)
201 
+      (values quadtree points))))
octree3.lisp
History View file @ 3bf1c97
0 202 
new file mode 100644
... ... 
@@ -0,0 +1,193 @@
1 
+(defpackage #:3dr.octcone3
2 
+  (:use #:cl #:alexandria #:fw.lu))
3 
+
4 
+(in-package #:3dr.octcone3)
5 
+
6 
+(defun make-adj-arr (&optional (size 25))
7 
+  (make-array size :adjustable t :fill-pointer 0))
8 
+
9 
+(defstruct (point (:type vector)) x y z)
10 
+
11 
+(defclass bintree ()
12 
+  ((left :initarg :left :accessor left :initform nil)
13 
+   (right :initarg :right :accessor right :initform nil)
14 
+   (duplicates :initarg :duplicates :accessor duplicates :initform (make-adj-arr))
15 
+   (center :initarg :center :accessor center)))
16 
+
17 
+(defclass quadtree ()
18 
+  ((nw :initarg :nw :accessor nw :initform nil)
19 
+   (ne :initarg :ne :accessor ne :initform nil)
20 
+   (se :initarg :se :accessor se :initform nil)
21 
+   (sw :initarg :sw :accessor sw :initform nil)
22 
+   (duplicates :initarg :duplicates :accessor duplicates :initform (make-adj-arr))
23 
+   (center :initarg :center :accessor center)))
24 
+
25 
+(defgeneric insert-in-tree (bintree child))
26 
+(defmethod insert-in-tree ((bintree bintree) (child real))
27 
+  (with-slots (left right duplicates center) bintree
28 
+    (if (= child center)
29 
+      (vector-push-extend center duplicates)
30 
+      (if (< child center)
31 
+        (etypecase left
32 
+          (bintree (insert-in-tree left child))
33 
+          (real (setf left (make-instance 'bintree :center left))
34 
+                (insert-in-tree left child))
35 
+          (null (setf left child)))
36 
+
37 
+        (etypecase right
38 
+          (bintree (insert-in-tree right child))
39 
+          (real (setf right (make-instance 'bintree :center right))
40 
+                (insert-in-tree right child))
41 
+          (null (setf right child)))))))
42 
+
43 
+(defmethod insert-in-tree ((quadtree quadtree) (child vector))
44 
+  (labels ((vector-value (child)
45 
+             (etypecase child
46 
+               (quadtree (center child))
47 
+               (vector child)))
48 
+           (dist-to-child (child)
49 
+             (c-distance (center quadtree) (vector-value child)))
50 
+           (replace-bucket (name)
51 
+             (etypecase (slot-value quadtree name)
52 
+               (quadtree (insert-in-tree (slot-value quadtree name) child))
53 
+               (vector (let ((old-bucket (slot-value quadtree name)))
54 
+                         (if (<= (dist-to-child child) (dist-to-child old-bucket))
55 
+                           (let ((new-bucket (make-instance 'quadtree :center child)))
56 
+                             (setf (slot-value quadtree name) new-bucket)
57 
+                             (with-accessors ((old-bucket-x point-x) (old-bucket-y point-y)) (vector-value old-bucket)
58 
+                               (with-accessors ((new-bucket-x point-x) (new-bucket-y point-y)) (vector-value new-bucket)
59 
+                                 (if (< old-bucket-x new-bucket-x)
60 
+                                   (if (>= old-bucket-y new-bucket-y)
61 
+                                     (setf (nw new-bucket) old-bucket)
62 
+                                     (setf (sw new-bucket) old-bucket))
63 
+                                   (if (>= old-bucket-y new-bucket-y)
64 
+                                     (setf (ne new-bucket) old-bucket)
65 
+                                     (setf (se new-bucket) old-bucket))))))
66 
+                           (setf (slot-value quadtree name)
67 
+                                 (make-instance 'quadtree :center old-bucket))))
68 
+                       (insert-in-tree (slot-value quadtree name) child))
69 
+               (null (setf (slot-value quadtree name) child)))))
70 
+
71 
+    (with-slots (nw ne se sw duplicates center) quadtree
72 
+      (if (equalp child center)
73 
+        (vector-push-extend center duplicates)
74 
+        (with-accessors ((center-x point-x) (center-y point-y)) center
75 
+          (with-accessors ((child-x point-x) (child-y point-y)) child
76 
+            (if (< child-x center-x)
77 
+              (if (>= child-y center-y)
78 
+                (replace-bucket 'nw)
79 
+                (replace-bucket 'sw))
80 
+              (if (>= child-y center-y)
81 
+                (replace-bucket 'ne)
82 
+                (replace-bucket 'se)))))))))
83 
+
84 
+(defun one-layer-of-octree (quadtree)
85 
+  (flet ((bucket-as-point (b)
86 
+           (etypecase b
87 
+             (null nil)
88 
+             (vector b)
89 
+             (quadtree (center b)))))
90 
+    (with-slots (nw-bucket nw-bucket-bg ne-bucket ne-bucket-bg se-bucket se-bucket-bg sw-bucket sw-bucket-bg) quadtree
91 
+      (list
92 
+        (mapcar #'bucket-as-point (list quadtree
93 
+                                        nw-bucket nw-bucket-bg
94 
+                                        ne-bucket ne-bucket-bg
95 
+                                        se-bucket se-bucket-bg
96 
+                                        sw-bucket sw-bucket-bg))))))
97 
+
98 
+(defun one-layer-of-bintree (bintree)
99 
+  (flet ((bintree-as-point (b)
100 
+           (etypecase b
101 
+             (null nil)
102 
+             (real b)
103 
+             (bintree (center b)))))
104 
+    (with-slots (left right) bintree
105 
+      (list (mapcar #'bintree-as-point (list bintree left right))))))
106 
+
107 
+(defun one-layer-of-quadtree (quadtree)
108 
+  (flet ((quadtree-as-point (b)
109 
+           (etypecase b
110 
+             (null nil)
111 
+             (vector b)
112 
+             (quadtree (center b)))))
113 
+    (with-slots (nw ne se sw) quadtree
114 
+      (list (mapcar #'quadtree-as-point (list quadtree nw ne se sw))))))
115 
+
116 
+(defun bintree-to-list (bintree)
117 
+  (typecase bintree
118 
+    (vector (list (list bintree nil nil)))
119 
+    (bintree (with-slots (left right) bintree
120 
+               (append (one-layer-of-bintree bintree)
121 
+                       (when left (bintree-to-list left))
122 
+                       (when right (bintree-to-list right)))))))
123 
+
124 
+(defun quadtree-to-list (quadtree)
125 
+  (typecase quadtree
126 
+    (real (list (list quadtree nil nil)))
127 
+    (quadtree (with-slots (nw ne se sw) quadtree
128 
+               (append (one-layer-of-quadtree quadtree)
129 
+                       (when nw (quadtree-to-list nw))
130 
+                       (when ne (quadtree-to-list ne))
131 
+                       (when se (quadtree-to-list se))
132 
+                       (when sw (quadtree-to-list sw)))))))
133 
+
134 
+
135 
+(defun bintreelist-to-graph (bintreelist)
136 
+  (loop for list in bintreelist
137 
+        append (loop with head = (car list)
138 
+                     for tail in (cdr list)
139 
+                     when tail collect (list head tail))))
140 
+
141 
+(defmethod print-object ((object quadtree) s)
142 
+  (declare (optimize (debug 3)))
143 
+  (print-unreadable-object (object s :type t :identity t)
144 
+    (with-slots (center nw ne se sw duplicates) object
145 
+      (format s "~s x~d: ~@{~a~^ ~}"
146 
+              center
147 
+              (length duplicates)
148 
+              (not (null nw))
149 
+              (not (null ne))
150 
+              (not (null sw))
151 
+              (not (null se))))))
152 
+
153 
+(defun draw-line (buffer p1 p2)
154 
+  (with-accessors ((x1 point-x) (y1 point-y)) p1
155 
+    (with-accessors ((x2 point-x) (y2 point-y)) p2
156 
+      (let* ((dist-x (abs (- x1 x2)))
157 
+             (dist-y (abs (- y1 y2)))
158 
+             (steep (> dist-y dist-x)))
159 
+        (when steep
160 
+          (psetf x1 y1 y1 x1
161 
+                 x2 y2 y2 x2))
162 
+        (when (> x1 x2)
163 
+          (psetf x1 x2 x2 x1
164 
+                 y1 y2 y2 y1))
165 
+        (let* ((delta-x (- x2 x1))
166 
+               (delta-y (abs (- y1 y2)))
167 
+               (error (floor delta-x 2))
168 
+               (y-step (if (< y1 y2) 1 -1))
169 
+               (y y1))
170 
+          (loop
171 
+            :for x :upfrom x1 :to x2
172 
+            :do (if steep
173 
+                  (incf (aref buffer x y) 1)
174 
+                  (incf (aref buffer y x) 1))
175 
+            (setf error (- error delta-y))
176 
+            (when (< error 0)
177 
+              (incf y y-step)
178 
+              (incf error delta-x))))
179 
+        buffer))))
180 
+
181 
+(defun c-distance (p1 p2)
182 
+  (declare (optimize (debug 3))
183 
+           (inline c-distance))
184 
+  (sqrt (loop for c1 across p1
185 
+              for c2 across p2
186 
+              sum (expt (- c2 c1) 2))))
187 
+
188 
+
189 
+(defun main ()
190 
+  (let ((res (make-instance 'quadtree :center #(50 50))))
191 
+    (loop repeat 400
192 
+          do (insert-in-tree res (vector (random 100) (random 100)))
193 
+          finally (return-from main res))))
package.lisp
History View file @ 3bf1c97
... ... 
@@ -1,5 +1,8 @@
1 1 
 ;;;; package.lisp
2 2
3 
+(defpackage #:3dr.octcone2
4 
+  (:use #:cl #:alexandria #:fw.lu))
5 
+
3 6 
 (defpackage #:3dr.octcone
4 7 
   (:use #:cl #:alexandria #:fw.lu))
5 8