0. #lang typed/racket
1.  
2. (require typed/racket/gui)
3.  
4. (struct node ([ NE : Quadtree ]
5.               [ NW : Quadtree ]
6.               [ SW : Quadtree ]
7.               [ SE : Quadtree ]
8.               [ coords : coordinate]))
9.  
10. (define-type Quadtree (U Null node))
11.  
12. (struct coordinate ([x : Integer] [y : Integer]))
13.  
14. ; A null-checking wrapper for node-coords.
15. (: get-node-coords (-> Quadtree coordinate))
16. (define (get-node-coords quadtree)
17.   (cond [(null? quadtree) (raise "get-node-coords cannot be called on a null Quadtree.")]
18.         [else (node-coords quadtree)]))
19.  
20. ; A null-checking wrapper for node-<Direction>.
21. (: get-node-child (-> Quadtree (-> node Quadtree) Quadtree))
22. (define (get-node-child quadtree direction)
23.   (cond [(null? quadtree) (raise "get-node-child cannot be called on a null Quadtree.")]
24.         [else (direction quadtree)]))
25.  
26. (define-type Direction (U (-> node Quadtree) 'self))
27.  
28. (: in-range? (-> Integer Integer Integer Boolean))
29. (define (in-range? x y z)(and (<= x z) (>= y z)))
30.  
31.  
32. ; The comparison function discerns which quadrant below a node in which to categorize a set of coordinates.
33. ; The Finkel and Bentley paper uses a convention by which, for those points lying on cardinal directions,
34. ; Quadrants I and III are "open", while II and IV are "closed." It seems to me that this will inevitably
35. ; result in an unbalanced tree, so my implementation gives each quadrant a cardinal direction.
36. (: coordinate-compare (-> coordinate coordinate Direction))
37. (define (coordinate-compare a b)
38.   (let ([a-x : Integer (coordinate-x a)]
39.         [a-y : Integer (coordinate-y a)]
40.         [b-x : Integer (coordinate-x b)]
41.         [b-y : Integer (coordinate-y b)])
42.     (cond [(and (<= a-x b-x) (<  a-y b-y)) node-NE]
43.           [(and (>  a-x b-x) (<= a-y b-y)) node-NW]
44.           [(and (>= a-x b-x) (>  a-y b-y)) node-SW]
45.           [(and (<  a-x b-x) (>= a-y b-y)) node-SE]
46.           [(and (= a-x b-x) (= a-y b-y)) 'self]
47.           ; If you somehow raise this error, I did not account for something.
48.           ; I am confident the other options are exhaustive.
49.           [else (raise "coordinate-compare should never return this!")])))
50.  
51. (: quadtree-member? (-> Quadtree coordinate Boolean))
52. (define (quadtree-member? quadtree coords)
53.   (cond [(null? quadtree) #f]
54.         [else (let ([quadrant (coordinate-compare (node-coords quadtree) coords)])
55.                 (cond [(equal? quadrant 'self) #t]
56.                       [else (quadtree-member? (get-node-child quadtree quadrant) coords)]))]))
57.  
58. (: neighbor? (-> coordinate coordinate Boolean))
59. (define (neighbor? c1 c2)
60.   (let ([x1 : Integer (coordinate-x c1)]
61.         [y1 : Integer (coordinate-y c1)]
62.         [x2 : Integer (coordinate-x c2)]
63.         [y2 : Integer (coordinate-y c2)])
64.     (and
65.      (and (in-range? (- x1 1) (+ x1 1) x2)
66.           (in-range? (- y1 1) (+ y1 1) y2))
67.      (nand (equal? x1 x2) (equal? y1 y2)))))
68.  
69. (: overlapping-quadrants (-> coordinate coordinate (Listof (-> node Quadtree))))
70. (define (overlapping-quadrants c1 c2)
71.   (let* ([x1 : Integer (coordinate-x c1)]
72.          [y1 : Integer (coordinate-y c1)]
73.          [x2 : Integer (coordinate-x c2)]
74.          [y2 : Integer (coordinate-y c2)]
75.          [NE (if (and (>= (+ x2 1) x1) (>  (+ y2 1) y1)) node-NE null)]
76.          [NW (if (and (<  (- x2 1) x1) (>= (+ y2 1) y1)) node-NW null)]
77.          [SW (if (and (<= (- x2 1) x1) (<  (- y2 1) y1)) node-SW null)]
78.          [SE (if (and (>  (+ x2 1) x1) (<= (- y2 1) y1)) node-SE null)])
79.     ((inst filter (U Null (-> node Quadtree)) (-> node Quadtree)) procedure? (list NE NW SW SE))))
80.  
81. ; For now I'll just address the case I'll be using in Game of Life, and look for direct neighbors.
82. (: quadtree-neighbors (-> Quadtree coordinate (Listof coordinate)))
83. (define (quadtree-neighbors quadtree coords)
84.   (cond [(null? quadtree) null]
85.         [else
86.          (let ([quadrants (overlapping-quadrants (node-coords quadtree) coords)]
87.                [am-neighbor : (Listof coordinate) (if (neighbor? (node-coords quadtree) coords) (list (node-coords quadtree)) null)])
88.            ((inst append coordinate)
89.             ((inst append-map coordinate (-> node Quadtree))
90.              (λ ([direction : (-> node Quadtree)])
91.                (quadtree-neighbors (direction quadtree) coords)) quadrants) am-neighbor))]))
92.  
93. (: descendant-coordinates (-> Quadtree (Listof coordinate)))
94. (define (descendant-coordinates quadtree)
95.   (cond [(null? quadtree) null]
96.         [else (let ([coords (list (get-node-coords quadtree))])
97.                 (append coords
98.                         (append-map
99.                          (λ ([direction : (-> node Quadtree)])
100.                            (descendant-coordinates (direction quadtree)))
101.                          (list node-NE node-NW node-SW node-SE))))]))
102.  
103. (: quadtree-fold (-> Quadtree (Listof coordinate) Quadtree))
104. (define (quadtree-fold quadtree coord-list)
105.   (cond [(null? coord-list) quadtree]
106.         [else (quadtree-fold (quadtree-insert quadtree (first coord-list)) (rest coord-list))]))
107.  
108. (: quadtree-insert (-> Quadtree coordinate node))
109. (define (quadtree-insert quadtree coords)
110.   (cond [(null? quadtree) (node null null null null coords)]
111.         [(equal? 'self (coordinate-compare (get-node-coords quadtree) coords)) quadtree]
112.         [else
113.          (let* ([quadrant (coordinate-compare (get-node-coords quadtree) coords)]
114.                 [r (λ ([direction : (-> node Quadtree)])
115.                      (if (equal? quadrant direction)
116.                          (quadtree-insert (get-node-child quadtree direction) coords)
117.                          (get-node-child quadtree direction)))])
118.            (node
119.             (r node-NE)
120.             (r node-NW)
121.             (r node-SW)
122.             (r node-SE)
123.             (get-node-coords quadtree)))]))
124.  
125.  
126. ; Capes are constructs that let me hand up orphans as needed from the recursive part of the deletion mechanism.
127. (struct cape ([quadtree : Quadtree]
128.               [orphans : (Listof coordinate)]))
129.  
130. ; constants. never enough constants
131. (define cell-scale 5)
132. (define canvas-size 500)
133.  
134. (define living-cells
135.   (quadtree-fold null (map (lambda ([x : Integer]) (coordinate x  50)) (range 2 90))))
136.  
137. (define moment-zero (list living-cells))
138.  
139. ; Given a coordinate and a Quadtree, determine if it survives.
140. (: determine-cell-state (-> Quadtree coordinate Boolean))
141. (define (determine-cell-state population cell)
142.   (let ([living-neighbors (length (quadtree-neighbors population cell))]
143.         [orig-state (quadtree-member? population cell)])
144.     (if (< living-neighbors 2) #f                          ; if the cell has fewer than 2 neighbors, it dies.
145.         (if (equal? living-neighbors 3) #t                 ; if the cell has exactly 3 neighbors, it comes to life.
146.             (if (> living-neighbors 3) #f orig-state)))))  ; if the cell has more than 3 neighbors, it dies.
147.  
148. ; Advance time by one frame.
149. (: tick (-> Quadtree Quadtree))
150. (define (tick living-cells)
151.   (let ([cell-list (descendant-coordinates living-cells)])
152.     (quadtree-fold null
153.                    (append-map (λ ([cell : coordinate])
154.                                  (filter (curry determine-cell-state living-cells)
155.                                          (neighbor-coords cell)))
156.                                cell-list))))
157.  
158. ; I'd like to find a cleaner way to do this.
159. (: neighbor-coords (-> coordinate (Listof coordinate)))
160. (define (neighbor-coords coordinate)
161.   (let ([x : Integer (coordinate-x coordinate)]
162.         [y : Integer (coordinate-y coordinate)])
163.     (append-map (curry coordmap x) (range (- y 1) (+ y 2)))))
164.  
165. ; give all the ys for an x
166. (: coordmap (-> Integer Integer (Listof coordinate)))
167. (define (coordmap x y)
168.   (map (λ ([z : Integer]) (coordinate z y))
169.        (range (- x 1) (+ x 2))))
170.  
171. (define frame (new frame% [label "QTREEGOL"] [width canvas-size] [height canvas-size]))
172. (define canvas (new canvas% [parent frame]
173.                     [paint-callback
174.                      (λ (c dc)
175.                        (send dc set-pen "black" 1 'transparent)
176.                        (send dc set-brush "black" 'solid)
177.                        (send dc draw-rectangle 0 0 canvas-size canvas-size))]))
178. (send frame show #t)
179.  
180.  
181. ; draww
182. (: recursidraw (-> (Instance DC<%>) (Listof coordinate) (Instance DC<%>)))
183. (define (recursidraw dc cells)
184.   (cond
185.     [(empty? cells) dc]
186.     [else   (let ([cell : coordinate (first cells)])
187.               (send dc set-brush "green" 'solid)
188.               (send dc set-pen "green" 1 'solid)
189.               (send dc draw-rectangle
190.                     (* cell-scale (coordinate-y cell))
191.                     (* cell-scale (coordinate-x cell)) cell-scale cell-scale)
192.               (recursidraw dc (rest cells)))]))
193.  
194.  
195. (: evolve (-> Quadtree Void))
196. (define (evolve quadtree)
197.   (send canvas on-paint)
198.   (recursidraw (send canvas get-dc) (descendant-coordinates quadtree))
199.   (sleep/yield 0.03)
200.   (evolve (tick quadtree)))
201.  
202. (evolve living-cells)

=>