From 00f077bf4c429dc7d8dddc3cd83256ba80c936be Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Sun, 21 Jan 2024 18:58:23 -0500 Subject: [PATCH] refactoring for clustering behavior + fmt --- examples/complex.ml | 3 +- examples/dune | 8 +-- examples/quadtree.ml | 155 ++++++++++++++++++++++++------------------- examples/repeat.ml | 2 +- lib/shape.ml | 18 ++--- lib/shape.mli | 1 - lib/transform.ml | 20 +++--- lib/transform.mli | 10 ++- 8 files changed, 117 insertions(+), 100 deletions(-) diff --git a/examples/complex.ml b/examples/complex.ml index 0caa916..7fb0359 100644 --- a/examples/complex.ml +++ b/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 *) diff --git a/examples/dune b/examples/dune index 3b46d79..d6883b0 100644 --- a/examples/dune +++ b/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)) \ No newline at end of file + (libraries joy)) diff --git a/examples/quadtree.ml b/examples/quadtree.ml index b8c4a3d..6656cb3 100644 --- a/examples/quadtree.ml +++ b/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" () - diff --git a/examples/repeat.ml b/examples/repeat.ml index 92749b9..c762ca0 100644 --- a/examples/repeat.ml +++ b/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" () diff --git a/lib/shape.ml b/lib/shape.ml index b74900f..771a4a1 100644 --- a/lib/shape.ml +++ b/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 = diff --git a/lib/shape.mli b/lib/shape.mli index a854dee..52bcc0c 100644 --- a/lib/shape.mli +++ b/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 - diff --git a/lib/transform.ml b/lib/transform.ml index efcf10a..5b74edb 100644 --- a/lib/transform.ml +++ b/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 diff --git a/lib/transform.mli b/lib/transform.mli index 712f823..e3be1ed 100644 --- a/lib/transform.mli +++ b/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 \ No newline at end of file + +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