0. #lang typed/racket
1.  
2. ; a naive hack at quadtrees
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. ; Mutually recursive with the Quadtree type. The node structure means that
6. ; every node has coordinates embedded, and four children, which may be nodes or nulls.
7. (struct node ([ NE : Quadtree ]
8.               [ NW : Quadtree ]
9.               [ SW : Quadtree ]
10.               [ SE : Quadtree ]
11.               [ coords : coordinate]))
12.  
13. ; get-node-coords and get-node-child are null-gated wrappers for node accessors.
14. ; I don't know if this is the accepted way, but it makes the type checker happy.
15. ; My functions were already nullchecking, but I guess this is more explicit.
16. (: get-node-coords (-> Quadtree coordinate))
17. (define (get-node-coords quadtree)
18.   (cond [(null? quadtree) (raise "Don't be calling get-node-coords on nulls!")]
19.         [else (node-coords quadtree)]))
20.  
21. (: get-node-child (-> Quadtree (-> node Quadtree) Quadtree))
22. (define (get-node-child quadtree direction)
23.   (cond [(null? quadtree) (raise "Don't be calling get-node-child on nulls!")]
24.         [else (direction quadtree)]))
25.  
26.  
27. ; A union type: a Quadtree will be null or a node.
28. (define-type Quadtree (U Null node))
29.  
30. ; I don't know if this will help the compiler optimize, but I figure we don't actually
31. ; need this to be an integer, so I'm limiting Quadenum to these five Symbol literals.
32. (define-type Quadenum (U 'NE 'NW 'SW 'SE 'self))
33.  
34. ; X and Y coordinates, since Quadtrees' composite keys are two-dimensional constructs.
35. (struct coordinate ([x : Integer] [y : Integer]))
36.  
37. ; The comparison function, it seems to me, is the beating heart at the center of quadtrees.
38. ; You just gotta discern which quadrant below a node to categorize a set of coordinates in.
39. ; Also, exact match/collisions.
40. (: coordinate-compare (-> coordinate coordinate Quadenum))
41. (define (coordinate-compare a b)
42.   (cond [(and (equal? (coordinate-x a) (coordinate-x b))
43.               (equal? (coordinate-y a) (coordinate-y b))) 'self]
44.         [(and (<= (coordinate-x a) (coordinate-x b))                 ; Why are some of these -or-equals?
45.               (< (coordinate-y a) (coordinate-y b))) 'NE]            ; To keep the tree perfectly balanced, as all things should be.
46.         [(and (> (coordinate-x a) (coordinate-x b))                  ; Otherwise, two quadrants would get all the luck.
47.               (<= (coordinate-y a) (coordinate-y b))) 'NW]           ; Any bias adds up and unbalances the tree.
48.         [(and (>= (coordinate-x a) (coordinate-x b))                 ; Therefore, each quadrant owns a cardinal direction of its own.
49.               (> (coordinate-y a) (coordinate-y b))) 'SW]
50.         [(and (< (coordinate-x a) (coordinate-x b))
51.               (>= (coordinate-y a) (coordinate-y b))) 'SE]
52.         [else (raise "How did you get here that is not how integers work")])) ; I am confident the other options are exhaustive.
53.  
54. ; Determine if a particular coordinate pair is a member of a quadtree.
55. (: quadtree-member? (-> Quadtree coordinate Boolean))
56. (define (quadtree-member? quadtree coords)
57.   (cond [(null? quadtree) #f] ; Nulls have no children.
58.         [else
59.          (let ([quadrant (coordinate-compare (node-coords quadtree) coords)])
60.            (cond [(equal? quadrant 'self) #t]
61.                  [else (quadtree-member? (map-directions quadtree quadrant) coords)]))]))
62.  
63. ; A mapping of struct accessor functions to the non-self enumerators returned by coordinate-compare.
64. (: map-directions (-> node Quadenum Quadtree))
65. (define (map-directions node quadenum)
66.   (cond [(equal? quadenum 'NE) (get-node-child node node-NE)]
67.         [(equal? quadenum 'NW) (get-node-child node node-NW)]
68.         [(equal? quadenum 'SW) (get-node-child node node-SW)]
69.         [(equal? quadenum 'SE) (get-node-child node node-SE)]
70.         [else (raise "Don't call this on yourself!!")])) ; Self should never get mapped to.
71.  
72. ; Insertion
73. ; Given a null Quadtree, return a new Quadtree with null children, containing the coordinates.
74. ; Given a Quadtree whose coordinates equal those supplied, return the original Quadtree.
75. ; Given a non-null, non-matching node, recursively traverse to a null child and return a new tree with the coordinates at that location.
76. (: quadtree-insert (-> Quadtree coordinate node))
77. (define (quadtree-insert quadtree coords)
78.   (cond [(null? quadtree) (node null null null null coords)]                                  ; You've landed: returning a new leaf on the tree.
79.         [(equal? 'self (coordinate-compare (get-node-coords quadtree) coords)) quadtree]      ; This quadtree contains the requested coordinates. Return original quadtree.
80.         [else
81.          (let* ([quadrant (coordinate-compare (get-node-coords quadtree) coords)]             ; The quadrant these coordinates belong to on quadtree.
82.                 [recurse (quadtree-insert (map-directions quadtree quadrant) coords)]         ; Reach down `quadrant' and hand up what's down there.
83.                 [NE (if (equal? quadrant 'NE) recurse (get-node-child quadtree node-NE))]     ; Ensure correct arity when assembling this node's representation to hand up
84.                 [NW (if (equal? quadrant 'NW) recurse (get-node-child quadtree node-NW))]     ; the stack. Only one of these will call 'recurse', and that one will
85.                 [SW (if (equal? quadrant 'SW) recurse (get-node-child quadtree node-SW))]     ; be inserted into the final product in the correct field
86.                 [SE (if (equal? quadrant 'SE) recurse (get-node-child quadtree node-SE))])
87.            (node NE NW SW SE (get-node-coords quadtree)))])) ; Here, we package up everything we know about the current Quadtree from this point down and send it up the recursion stack.

=>