0. #lang typed/racket
1.  
2. ; a naive hack at quadtrees by rob@robertlavery.com
3. ; https://www.researchgate.net/profile/Raphael_Finkel/publication/220197855_Quad_Trees_A_Data_Structure_for_Retrieval_on_Composite_Keys/links/0c9605273bba2ece7b000000/Quad-Trees-A-Data-Structure-for-Retrieval-on-Composite-Keys.pdf
4.  
5.  
6.  
7. (provide node                          ; Type: A struct, recursive with Quadtree, representing a non-null record with four children.
8.          Quadtree                      ; Type: Union type, either a null record or a node.
9.          get-node-coords               ; Function: A null-gated function to provide the coordinates associated with a node.
10.          get-node-child                ; Function: A null-gated function to provide a child under a node in a particular Direction.
11.          Direction                     ; Type: A union type -- either a function that returns a child node, or the symbol 'self.
12.          coordinate                    ; Type: A struct of X Y cartesian coordinates.
13.          coordinate-x                  ; Function: Struct accessor for coordinates.
14.          coordinate-y                  ; Function: Struct accessor for coordinates.
15.          coordinate-compare            ; Function: Return a Direction when given two points.
16.          quadtree-member?              ; Function: A predicate that returns #t iff given Quadtree contains given coordinate.
17.          in-range?                     ; Function: A predicate that given x y z returns #t iff x <= z <= y.
18.          neighbor?                     ; Function: A predicate that returns #t iff two coordinates are neighbors.
19.          overlapping-quadrants         ; Function: Returns a list of Directions overlapping neighbor points to a given coordinate.
20.          quadtree-neighbors            ; Function: Returns a list of coordinates from the Quadtree neighboring a given coordinate.
21.          descendant-coordinates        ; Function: Return coordinates of a node and all its descendants.
22.          quadtree-fold                 ; Function: Given a Quadtree and a list of coordinates, recursively insert coordinates and return resultant quadtree.
23.          quadtree-insert               ; Function: Given a Quadtree and a coordinate, return a Quadtree with the new coordinate inserted.
24.          quadtree-delete               ; Function: Given a Quadtree and a coordinate, return a Quadtree with the coordinate deleted. Nonrecursive wrapper for cps.
25.          cape                          ; Type: A struct containing a Quadtree and a list of orphaned coordinates.
26.          cps                           ; Function: Recursively delete a coordinate from a Quadtree, returning a cape containing the new Quadtree and a list of any orphaned coordinates.
27.          print-all-coords)             ; Convenience function to print all the coordinates from a list of coordinates.
28.  
29.  
30. (struct node ([ NE : Quadtree ]
31.               [ NW : Quadtree ]
32.               [ SW : Quadtree ]
33.               [ SE : Quadtree ]
34.               [ coords : coordinate]))
35.  
36. (define-type Quadtree (U Null node))
37.  
38. (struct coordinate ([x : Integer] [y : Integer]))
39.  
40. ; A null-checking wrapper for node-coords.
41. (: get-node-coords (-> Quadtree coordinate))
42. (define (get-node-coords quadtree)
43.   (cond [(null? quadtree) (raise "get-node-coords cannot be called on a null Quadtree.")]
44.         [else (node-coords quadtree)]))
45.  
46. ; A null-checking wrapper for node-<Direction>.
47. (: get-node-child (-> Quadtree (-> node Quadtree) Quadtree))
48. (define (get-node-child quadtree direction)
49.   (cond [(null? quadtree) (raise "get-node-child cannot be called on a null Quadtree.")]
50.         [else (direction quadtree)]))
51.  
52. (define-type Direction (U (-> node Quadtree) 'self))
53.  
54. (: in-range? (-> Integer Integer Integer Boolean))
55. (define (in-range? x y z)(and (<= x z) (>= y z)))
56.  
57.  
58. ; The comparison function discerns which quadrant below a node in which to categorize a set of coordinates.
59. ; The Finkel and Bentley paper uses a convention by which, for those points lying on cardinal directions,
60. ; Quadrants I and III are "open", while II and IV are "closed." It seems to me that this will inevitably
61. ; result in an unbalanced tree, so my implementation gives each quadrant a cardinal direction.
62. (: coordinate-compare (-> coordinate coordinate Direction))
63. (define (coordinate-compare a b)
64.   (cond [(and (equal? (coordinate-x a) (coordinate-x b))
65.               (equal? (coordinate-y a) (coordinate-y b))) 'self]
66.         [(and (<= (coordinate-x a) (coordinate-x b))
67.               (<  (coordinate-y a) (coordinate-y b))) node-NE]
68.         [(and (>  (coordinate-x a) (coordinate-x b))
69.               (<= (coordinate-y a) (coordinate-y b))) node-NW]
70.         [(and (>= (coordinate-x a) (coordinate-x b))
71.               (>  (coordinate-y a) (coordinate-y b))) node-SW]
72.         [(and (<  (coordinate-x a) (coordinate-x b))
73.               (>= (coordinate-y a) (coordinate-y b))) node-SE]
74.         ; If you somehow raise this error, I did not account for something.
75.         ; I am confident the other options are exhaustive.
76.         [else (raise "coordinate-compare should never return this!")]))
77.  
78. (: quadtree-member? (-> Quadtree coordinate Boolean))
79. (define (quadtree-member? quadtree coords)
80.   (cond [(null? quadtree) #f]
81.         [else (let ([quadrant (coordinate-compare (node-coords quadtree) coords)])
82.                 (cond [(equal? quadrant 'self) #t]
83.                       [else (quadtree-member? (get-node-child quadtree quadrant) coords)]))]))
84.  
85. (: neighbor? (-> coordinate coordinate Boolean))
86. (define (neighbor? c1 c2)
87.   (let ([x1 : Integer (coordinate-x c1)]
88.         [y1 : Integer (coordinate-y c1)]
89.         [x2 : Integer (coordinate-x c2)]
90.         [y2 : Integer (coordinate-y c2)])
91.     (and
92.      (and (in-range? (- x1 1) (+ x1 1) x2)
93.           (in-range? (- y1 1) (+ y1 1) y2))
94.      (nand (equal? x1 x2) (equal? y1 y2)))))
95.  
96. (: overlapping-quadrants (-> coordinate coordinate (Listof (-> node Quadtree))))
97. (define (overlapping-quadrants c1 c2)
98.   (let* ([x1 : Integer (coordinate-x c1)]
99.          [y1 : Integer (coordinate-y c1)]
100.          [x2 : Integer (coordinate-x c2)]
101.          [y2 : Integer (coordinate-y c2)]
102.          [NE (if (and (>= (+ x2 1) x1) (>  (+ y2 1) y1)) node-NE null)]
103.          [NW (if (and (<  (- x2 1) x1) (>= (+ y2 1) y1)) node-NW null)]
104.          [SW (if (and (<= (- x2 1) x1) (<  (- y2 1) y1)) node-SW null)]
105.          [SE (if (and (>  (+ x2 1) x1) (<= (- y2 1) y1)) node-SE null)])
106.     ((inst filter (U Null (-> node Quadtree)) (-> node Quadtree)) procedure? (list NE NW SW SE))))
107.  
108. ; For now I'll just address the case I'll be using in Game of Life, and look for direct neighbors.
109. (: quadtree-neighbors (-> Quadtree coordinate (Listof coordinate)))
110. (define (quadtree-neighbors quadtree coords)
111.   (cond [(null? quadtree) null]
112.         [else
113.          (let ([quadrants (overlapping-quadrants (node-coords quadtree) coords)]
114.                [am-neighbor : (Listof coordinate) (if (neighbor? (node-coords quadtree) coords) (list (node-coords quadtree)) null)])
115.            ((inst append coordinate)
116.             ((inst append-map coordinate (-> node Quadtree))
117.              (λ ([direction : (-> node Quadtree)])
118.                (quadtree-neighbors (direction quadtree) coords)) quadrants) am-neighbor))]))
119.  
120. (: descendant-coordinates (-> Quadtree (Listof coordinate)))
121. (define (descendant-coordinates quadtree)
122.   (cond [(null? quadtree) null]
123.         [else (let ([coords (list (get-node-coords quadtree))])
124.                 (append coords
125.                         (append-map
126.                          (λ ([direction : (-> node Quadtree)])
127.                            (descendant-coordinates (direction quadtree)))
128.                          (list node-NE node-NW node-SW node-SE))))]))
129.  
130. (: quadtree-fold (-> Quadtree (Listof coordinate) Quadtree))
131. (define (quadtree-fold quadtree coord-list)
132.   (cond [(null? coord-list) quadtree]
133.         [else (quadtree-fold (quadtree-insert quadtree (first coord-list)) (rest coord-list))]))
134.  
135. (: quadtree-insert (-> Quadtree coordinate node))
136. (define (quadtree-insert quadtree coords)
137.   (cond [(null? quadtree) (node null null null null coords)]
138.         [(equal? 'self (coordinate-compare (get-node-coords quadtree) coords)) quadtree]
139.         [else
140.          (let* ([quadrant (coordinate-compare (get-node-coords quadtree) coords)]
141.                 [r (λ ([direction : (-> node Quadtree)])
142.                      (if (equal? quadrant direction)
143.                          (quadtree-insert (get-node-child quadtree direction) coords)
144.                          (get-node-child quadtree direction)))])
145.            (node
146.             (r node-NE)
147.             (r node-NW)
148.             (r node-SW)
149.             (r node-SE)
150.             (get-node-coords quadtree)))]))
151.  
152.  
153. ; Capes are constructs that let me hand up orphans as needed from the recursive part of the deletion mechanism.
154. (struct cape ([quadtree : Quadtree]
155.               [orphans : (Listof coordinate)]))
156.  
157. ; Deletion
158. ; Given a null Quadtree, return it unchanged (it's already gone.)
159. ; At the top of the recursion stack, take any remaining orphans and insert them into the new Quadtree.
160. ; Quadtree-delete is a wrapper function whose job is to keep the orphans an internal matter.
161. ; It calls the recursive cps function, which performs the deletion and hands up a 'cape' struct
162. ; containing a list of orphaned nodes that need to be reinserted to the quadtree.
163. (: quadtree-delete (-> Quadtree coordinate Quadtree))
164. (define (quadtree-delete quadtree coords)
165.   (let* ([crime-scene-and-orphans (cps quadtree coords)]
166.          [crime-scene (cape-quadtree crime-scene-and-orphans)]
167.          [orphans (cape-orphans crime-scene-and-orphans)])
168.     (quadtree-fold crime-scene orphans)))
169.  
170. ; The best part is that after I implemented all this I realized I don't need deletion for Game of Life lol
171. (: cps (-> Quadtree coordinate cape))
172. (define (cps quadtree coords)
173.   (cond [(null? quadtree) (cape null null)] ; Stop, he's already dead
174.         [(equal? 'self (coordinate-compare (get-node-coords quadtree) coords)) ; Do the deed,
175.          (cape null (rest (descendant-coordinates quadtree)))]                 ; but rescue the orphans.
176.         [else
177.          (let* ([quadrant (coordinate-compare (get-node-coords quadtree) coords)]
178.                 [r (λ ([direction : (-> node Quadtree)]) (if (equal? quadrant direction)
179.                                                              (cps (get-node-child quadtree direction) coords)
180.                                                              (cape (get-node-child quadtree direction) null)))]
181.                 [NE (r node-NE)] [NW (r node-NW)] [SW (r node-SW)] [SE (r node-SE)]
182.                 [gather-orphans (λ ([cape-list : (Listof cape)]) (append-map cape-orphans cape-list))]
183.                 [orphans (gather-orphans (list NE NW SW SE))])
184.            (cape (node
185.                   (cape-quadtree NE)
186.                   (cape-quadtree NW)
187.                   (cape-quadtree SW)
188.                   (cape-quadtree SE)
189.                   (get-node-coords quadtree)) orphans))]))
190.  
191. (: print-all-coords (-> (Listof coordinate) Void))
192. (define (print-all-coords coord-list)
193.   ((inst for-each coordinate)
194.    (λ (coord) (fprintf (current-output-port)
195.                        "X: ~s Y: ~s\n"
196.                        (coordinate-x coord)
197.                        (coordinate-y coord))) coord-list))
198.  
199. ; I started learning Racket about a week ago and the first thing I did was three separate implementations of Conway's Game of Life,
200. ; each longer and less performant than the last. I decided that the problem was the data structures I was using, so I decided to implement
201. ; my own toy Quadtree. Others have done it, but this one is mine, and I've had a lot of fun putting it together.

=>