refactoring for clustering behavior + fmt

examples/complex.ml

@@ -26,8 +26,7 @@ let () =
   let complex_shape =
     complex
       (List.map
-         (fun (x, y) ->
-           circle ~c:(point (x *. radius) (y *. radius)) radius)
+         (fun (x, y) -> circle ~c:(point (x *. radius) (y *. radius)) radius)
          coords)
   in
   (* translating that complex shape by radius / 2 *)

examples/dune

@@ -82,13 +82,13 @@
  (name star)
  (modules star)
  (libraries joy))
- 
-(executable 
+
+(executable
  (name repeat)
  (modules repeat)
  (libraries joy))
 
-(executable 
+(executable
  (name quadtree)
  (modules quadtree)
- (libraries joy))
+ (libraries joy))

examples/quadtree.ml

@@ -1,107 +1,124 @@
 open Joy
 
+type point = Joy.point
+
 (* Constants *)
 let size = 800.
 let half_size = size /. 2.
-let max_leaf_points = 3
-let num_points = 900
+let max_leaf_points = 4
+let clusters = 32
 
 (* Init rng *)
 let _ = Random.self_init ()
 
 (* Point utils *)
-let pmap2 f ({x = x1; y = y1}: point) ({ x = x2; y = y2}: point): point = { x = f x1 x2; y = f y1 y2}
-let ( /! ) ({ x; y}: point) scalar: point = { x = x /. scalar; y = y /. scalar }
+let splat n = point n n
+
+let pmap2 f ({ x = x1; y = y1 } : point) ({ x = x2; y = y2 } : point) =
+  point (f x1 x2) (f y1 y2)
+
+let ( +~ ) (p1 : point) (p2 : point) : point =
+  point (p1.x +. p2.x) (p1.y +. p2.y)
+
+let ( /! ) ({ x; y } : point) scalar : point =
+  { x = x /. scalar; y = y /. scalar }
 
-let rand_point _: point = { x = (Random.float size) -. half_size; y = (Random.float size) -. half_size}
+(* Random utils for creating random clustered points *)
+let rand_point () =
+  point (Random.float size -. half_size) (Random.float size -. half_size)
+
+let centered_point (center : point) _ : point =
+  let offset () = Random.float 100. -. 50. in
+  center +~ { x = offset (); y = offset () }
+
+let cluster _ =
+  let center = rand_point () in
+  List.init (8 + Random.int 24) (centered_point center)
 
 (* Box and utils *)
-type box = { min : point; max: point }
-let box (minx, miny) (maxx, maxy) = 
-  { min = { x = minx; y = miny }; max = { x = maxx; y = maxy }}
-
-let midpoint { min; max } = 
-  (pmap2 (+.) min max) /! 2.
-
-let quarters (mid: point) box =
-  let lu = { min = { x = box.min.x; y = mid.y }; max = { x = mid.x; y = box.max.y } } in 
-  let ru = { min = { x = mid.x; y = mid.y }; max = { x = box.max.x; y = box.max.y } } in 
-  let rd = { min = { x = mid.x; y = box.min.y }; max = { x = box.max.x; y = mid.y } } in 
-  let ld = { min = box.min; max = mid } in
-  (lu, ru, rd, ld)
+type box = { min : point; max : point }
+(** Axis aligned bounding box *)
 
-(* let (|=) box ({x; y}: point) = 
-  { min = { x = min box.min.x x; y = min box.min.y y }; max = { x = max box.max.x x; y = max box.max.y y }}
+let box min max = { min; max }
 
-let bound_points = List.fold_left (fun acc p -> acc |= p) *)
+(** Returns the middle point of the box *)
+let midpoint { min; max } = pmap2 ( +. ) min max /! 2.
 
-let contains box ({ x;y }: point) = 
-  x > box.min.x && x < box.max.x && y > box.min.y && y < box.max.y
+(** Subdivides a box into four even axis-aligned boxes *)
+let quarters ({ min; max } as box) =
+  let mid = midpoint box in
+  let lu = { min = { x = min.x; y = mid.y }; max = { x = mid.x; y = max.y } } in
+  let ru = { min = { x = mid.x; y = mid.y }; max = { x = max.x; y = max.y } } in
+  let rd = { min = { x = mid.x; y = min.y }; max = { x = max.x; y = mid.y } } in
+  let ld = { min; max = mid } in
+  (lu, ru, rd, ld)
+
+(** checks whether point is within bounds of box *)
+let contains { min; max } ({ x; y } : point) =
+  x > min.x && x < max.x && y > min.y && y < max.y
 
 (* Quadtree and utils *)
 type 'a leaf = box * 'a list
-type 'a tree = Empty | Leaf of 'a leaf | Node of { aabb : box; children : 'a tree list }
-
-let split_root box points = 
-  let partition (lu, ru, rd, ld) es = 
-    let belong box = List.filter (contains box) in
-    (
-      (lu, (belong lu es)), 
-      (ru, (belong ru es)),
-      (rd, (belong rd es)), 
-      (ld, (belong ld es))
-    )
+(** Leaf is 2-tuple of bounding box * 'a list of elts whose position is within that box *)
+
+type 'a tree = Leaf of 'a leaf | Node of 'a tree list
+(* Node potentially doesn't need to hold aabb? *)
+
+(** Constructs tree from root *)
+let split_root box points =
+  (* Groups points with the boxes that contain them *)
+  let partition (lu, ru, rd, ld) es =
+    let belongs box = List.filter (contains box) in
+    ( (lu, belongs lu es),
+      (ru, belongs ru es),
+      (rd, belongs rd es),
+      (ld, belongs ld es) )
+  in
+  (* Splits and converts to Node if leaf has too many points,
+      otherwise returns leaf *)
+  let rec split (box, es) =
+    if List.length es > max_leaf_points then
+      let quarters' = quarters box in
+      let lu, ru, rd, ld = partition quarters' points in
+      Node (List.map split [ lu; ru; rd; ld ])
+    else Leaf (box, es)
   in
-  let rec split (box, es) = 
-     if List.length es > max_leaf_points then 
-        let mid = midpoint box in
-        let quarters' = quarters mid box in 
-        let (lu, ru, rd,ld) = partition quarters' points in
-        Node { aabb = box; children = List.map split [lu; ru; rd; ld]}
-      else 
-        Leaf (box, es)  
-  in 
   split (box, points)
 
-
-let build () = 
-  let _ = Empty in
-  let root = box ((-.half_size), (-. half_size)) (half_size, half_size) in 
-  let points = List.init num_points rand_point in 
+let build () =
+  let root = box (splat (-.half_size)) (splat half_size) in
+  let points = List.flatten (List.init clusters cluster) in
   split_root root points
 
-let to_flat_shapes tree: shape list =
-  let rect_of_bb bb = rectangle ~c:(midpoint bb) (bb.max.x -. bb.min.x) (bb.max.y -. bb.min.y) in
-  let circle_of_point pt = 
-    circle ~c:pt 1. 
+let to_flat_shapes tree =
+  let rect_of_bb bb =
+    rectangle ~c:(midpoint bb) (bb.max.x -. bb.min.x) (bb.max.y -. bb.min.y)
   in
-  let rec convert xs = function 
-    | Node { aabb; children } -> 
-      let b = rect_of_bb aabb in
-      List.flatten (List.map (convert (b :: xs)) children) 
-    | Leaf (aabb, es) -> 
-      let b = rect_of_bb aabb in
-      ((List.map circle_of_point es) @ (b :: xs) )
-    | Empty -> 
-      [] 
+  let circle_of_point pt = circle ~c:pt 1. in
+  let rec convert xs = function
+    | Node children -> List.flatten (List.map (convert xs) children)
+    | Leaf (aabb, es) ->
+        let b = rect_of_bb aabb in
+        List.map circle_of_point es @ (b :: xs)
   in
   convert [] tree
 
+(* With color handling system this function won't be necessary as color can be
+   decided at construction *)
 let render_color shape =
-  match shape with  
-    | Shape.Circle _ -> 
+  match shape with
+  | Shape.Circle _ ->
       set_color (1., 1. /. 255., 1. /. 255.);
       render shape
-    | _ ->
+  | _ ->
       set_color (0., 0., 0.);
-      render shape 
+      render shape
 
-let () = 
+let () =
   init ();
   background (1., 1., 1., 1.);
-  let tree = build () in 
-  let to_shapes = to_flat_shapes tree in 
+  let tree = build () in
+  let to_shapes = to_flat_shapes tree in
   set_color (0., 0., 0.);
   List.iter render_color to_shapes;
   write ~filename:"quadtree.png" ()
-

examples/repeat.ml

@@ -12,7 +12,7 @@ let () =
   init ();
   background (1., 1., 1., 1.);
   let circle = circle ~c:(point (-100.) 0.) 50. in
-  let shapes = repeat 10 (translate 10. 0.) circle in 
+  let shapes = repeat 10 (translate 10. 0.) circle in
   set_color (0., 0., 0.);
   render shapes;
   write ~filename:"repeat.png" ()

lib/shape.ml

@@ -19,13 +19,10 @@ let ( /~ ) p1 p2 = { x = p1.x /. p2.x; y = p1.x /. p2.x }
 (* point -> scalar arithmetic *)
 let ( -! ) { x; y } scalar = { x = x -. scalar; y = y -. scalar }
 let ( /! ) { x; y } scalar = { x = x /. scalar; y = y /. scalar }
-let ( *! ) {x; y} scalar = {x = x *. scalar; y = y *. scalar}
+let ( *! ) { x; y } scalar = { x = x *. scalar; y = y *. scalar }
 let point x y = { x; y }
-
-let center = {x= 0.; y = 0.}
-
-let circle ?(c = center) r =
-  Circle { c; radius = r }
+let center = { x = 0.; y = 0. }
+let circle ?(c = center) r = Circle { c; radius = r }
 
 let rectangle ?(c = center) width height =
   let { x; y } = c -! ((width +. height) /. 4.) in
@@ -36,14 +33,9 @@ let rectangle ?(c = center) width height =
       { x = x +. width; y = y +. height };
       { x = x +. width; y };
     ]
-
-
-let ellipse ?(c = center) rx ry =
-  Ellipse { c; rx; ry }
-
-let line ?(a = center) b =
-  Line { a; b }
 
+let ellipse ?(c = center) rx ry = Ellipse { c; rx; ry }
+let line ?(a = center) b = Line { a; b }
 let polygon lst_points = Polygon lst_points
 
 let complex shapes =

lib/shape.mli

@@ -24,4 +24,3 @@ val ellipse : ?c:point -> float -> float -> shape
 val complex : shape list -> shape
 val line : ?a:point -> point -> shape
 val polygon : point list -> shape
-

lib/transform.ml

@@ -22,11 +22,15 @@ let rec scale factor s =
   let scale_point fact pt = pt *! sqrt fact in
   match s with
   | Circle circle' ->
-      Circle { c = scale_point factor circle'.c; radius = scale_length factor circle'.radius  }
+      Circle
+        {
+          c = scale_point factor circle'.c;
+          radius = scale_length factor circle'.radius;
+        }
   | Ellipse ellipse' ->
       Ellipse
         {
-          c = scale_point factor ellipse'.c; 
+          c = scale_point factor ellipse'.c;
           rx = scale_length factor ellipse'.rx;
           ry = scale_length factor ellipse'.ry;
         }
@@ -42,29 +46,29 @@ let to_radians degrees = float_of_int degrees *. Stdlib.Float.pi /. 180.
 
 let to_polar point =
   let { x; y } = point in
-    ( sqrt ((x *. x) +. (y *. y)),
-      atan2 y x )
+  (sqrt ((x *. x) +. (y *. y)), atan2 y x)
 
 let from_polar polar_point =
-  let (r, theta) = polar_point in
+  let r, theta = polar_point in
   { x = r *. cos theta; y = r *. sin theta }
 
 let rotate_point degrees point =
   let radians = to_radians degrees in
-  let (r, theta) = to_polar point in
+  let r, theta = to_polar point in
   from_polar (r, theta +. radians)
 
 let rec rotate degrees shape =
   match shape with
   | Circle circle' -> Circle { circle' with c = rotate_point degrees circle'.c }
-  | Ellipse ellipse' -> Ellipse { ellipse' with c = rotate_point degrees ellipse'.c }
+  | Ellipse ellipse' ->
+      Ellipse { ellipse' with c = rotate_point degrees ellipse'.c }
   | Line _line -> failwith "Not Implemented"
   | Polygon polygon' -> polygon (List.map (rotate_point degrees) polygon')
   | Complex shapes -> Complex (List.map (rotate degrees) shapes)
 
 let compose f g x = g (f x)
-
 let range n = List.init n Fun.id
+
 let repeat n op shape =
   let match_list l =
     match l with [] -> [ op shape ] | last :: _ -> op last :: l

lib/transform.mli

@@ -1,5 +1,11 @@
 val translate : float -> float -> Shape.shape -> Shape.shape
 val scale : float -> Shape.shape -> Shape.shape
 val rotate : int -> Shape.shape -> Shape.shape
-val compose : (Shape.shape -> Shape.shape) -> (Shape.shape -> Shape.shape) -> Shape.shape -> Shape.shape
-val repeat : int -> (Shape.shape -> Shape.shape) -> Shape.shape -> Shape.shape
+
+val compose :
+  (Shape.shape -> Shape.shape) ->
+  (Shape.shape -> Shape.shape) ->
+  Shape.shape ->
+  Shape.shape
+
+val repeat : int -> (Shape.shape -> Shape.shape) -> Shape.shape -> Shape.shape