aboutsummaryrefslogtreecommitdiff
path: root/path/fixed.ml
diff options
context:
space:
mode:
authorSébastien Dailly <sebastien@chimrod.com>2021-02-05 09:08:39 +0100
committerSébastien Dailly <sebastien@dailly.me>2022-02-07 14:39:30 +0100
commit561d0f0155f4906d90eb7e73a3ff9cb28909126f (patch)
tree9a606c2d7832272ea33d7052512a5fa59805d582 /path/fixed.ml
parent86ec559f913c389e8dc055b494630f21a45e039b (diff)
Update project structure
Diffstat (limited to 'path/fixed.ml')
-rwxr-xr-xpath/fixed.ml487
1 files changed, 0 insertions, 487 deletions
diff --git a/path/fixed.ml b/path/fixed.ml
deleted file mode 100755
index 1362ad3..0000000
--- a/path/fixed.ml
+++ /dev/null
@@ -1,487 +0,0 @@
-open StdLabels
-
-(** Signature for points *)
-module type P = sig
- type t
-
- val get_coord : t -> Gg.v2
-
- val id : t -> int
-
- val copy : t -> Gg.v2 -> t
-
-end
-
-module Make(Point:P) = struct
-
- type bezier =
- { ctrl0:Gg.v2 (* The control point *)
- ; ctrl1:Gg.v2 (* The control point *)
- ; p1:Point.t (* The end point *)
- }
-
- module type BUILDER = sig
- type t
-
- val repr
- : t -> (module Repr.M with type point = Point.t and type t = 's) -> 's -> 's
- end
-
- type path =
- | Line of Point.t
- | Curve of bezier
-
-
- type step =
- { point : Point.t
- ; move : path
- }
-
- type t = step array
-
- module ToFixed = struct
- type point = Point.t
-
- type t = int * step list
-
- let create_path () = 0, []
-
- (* Start a new path. *)
- let start point t =
- let _ = point in
- t
-
- let line_to
- : point -> point -> t -> t
- = fun p1 p2 (i, t) ->
- ( i + 1
- , { point = p1
- ; move = Line p2
- }:: t )
-
- let quadratic_to
- : (point * Gg.v2 * Gg.v2 * point) -> t -> t
- = fun (p0, ctrl0, ctrl1, p1) (i, t) ->
- let curve = Curve
- { ctrl0
- ; ctrl1
- ; p1} in
- ( i + 1
- , { point = p0
- ; move = curve
- } ::t)
-
- let stop t = t
-
- let get
- : int * step list -> step array
- = fun (n, t) ->
-
- (* The array is initialized with a magic number, and just after
- filled with the values from the list in reverse. All the elements are set.
- *)
- let res = Obj.magic (Array.make n 0) in
- List.iteri t
- ~f:(fun i elem -> Array.set res (n - i - 1) elem );
- res
- end
-
- let to_fixed
- : (module BUILDER with type t = 'a) -> 'a -> t
- = fun (type s) (module Builder: BUILDER with type t = s) t ->
- Builder.repr t (module ToFixed) (ToFixed.create_path ())
- |> ToFixed.get
-
- let repr
- : t -> (module Repr.M with type point = Point.t and type t = 's) -> 's -> 's
- = fun (type s) t (module Repr : Repr.M with type point = Point.t and type t = s) repr ->
- let repr_bezier p p0 bezier =
- Repr.quadratic_to
- ( p0
- , bezier.ctrl0
- , bezier.ctrl1
- , bezier.p1 )
- p in
-
- let _, repr = Array.fold_left t
- ~init:(true, repr)
- ~f:(fun (first, path) element ->
- let path = if first then
- Repr.start element.point path
- else path in
- match element.move with
- | Line p1 ->
- ( false
- , Repr.line_to element.point p1 path )
- | Curve bezier ->
- ( false
- , repr_bezier path element.point bezier )
- ) in
- Repr.stop repr
-
-
- type approx =
- { distance : float
- ; closest_point : Gg.v2
- ; ratio : float
- ; p0 : Point.t
- ; p1 : Point.t }
-
- (** Return the distance between a given point and the curve. May return
- None if the point is out of the curve *)
- let distance
- : Gg.v2 -> t -> approx option
- = fun point t ->
-
- Array.fold_left t
- ~init:None
- ~f:(fun res step ->
- match step.move with
- | Line p1 ->
- let box = Gg.Box2.of_pts (Point.get_coord step.point) (Point.get_coord p1) in
- begin match Gg.Box2.mem point box with
- | false -> res
- | true ->
- (* TODO Evaluate the normal *)
- res
- end
- | Curve bezier ->
-
- let bezier' = Shapes.Bezier.(
-
- { p0 = Point.get_coord step.point
- ; p1 = Point.get_coord bezier.p1
- ; ctrl0 = bezier.ctrl0
- ; ctrl1 = bezier.ctrl1 }
- ) in
- let ratio, point' = Shapes.Bezier.get_closest_point point bezier' in
- let distance' = Gg.V2.( norm (point - point') ) in
- match res with
- | Some {distance; _} when distance < distance' -> res
- | _ -> Some
- { closest_point = point'
- ; distance = distance'
- ; p0 = step.point
- ; p1 = bezier.p1
- ; ratio }
- )
-
- let map
- : t -> (Point.t -> Point.t) -> t
- = fun t f ->
- Array.map t
- ~f:(fun step ->
- match step.move with
- | Line p2 ->
- { point = f step.point
- ; move = Line (f p2)
- }
- | Curve bezier ->
- let point = f step.point in
- { point
- ; move = Curve
- { p1 = f bezier.p1
- ; ctrl0 = Point.get_coord (f (Point.copy step.point bezier.ctrl0))
- ; ctrl1 = Point.get_coord (f (Point.copy bezier.p1 bezier.ctrl1))
- }
- }
- )
-
- let iter
- : t -> f:(Point.t -> unit) -> unit
- = fun t ~f ->
- Array.iter t
- ~f:(fun step ->
- match step.move with
- | Line p2 -> f step.point; f p2
- | Curve bezier -> f step.point ; f bezier.p1
- )
-
- let get_point'
- : step -> Point.t
- = fun { move ; _} ->
- match move with
- | Line p1 -> p1
- | Curve bezier -> bezier.p1
-
- (** Associate the return from the bezier point to an existing path *)
- let assoc_point
- : Shapes.Bezier.t -> step -> step
- = fun bezier step ->
- match step.move with
- | Line p1
- | Curve {p1; _} ->
- let p0' = Point.copy step.point bezier.Shapes.Bezier.p0
- and p1' = Point.copy p1 bezier.Shapes.Bezier.p1 in
- { point = p0'
- ; move = Curve
- { p1 = p1'
- ; ctrl0 = bezier.Shapes.Bezier.ctrl0
- ; ctrl1 = bezier.Shapes.Bezier.ctrl1
- }
- }
-
-
- let build_from_three_points p0 p1 p2 =
- let bezier =
- Shapes.Bezier.quadratic_to_cubic
- @@ Shapes.Bezier.three_points_quadratic
- (Point.get_coord p0)
- (Point.get_coord p1)
- (Point.get_coord p2) in
-
- (* The middle point is not exactly at the middle anymore (it can have been
- moved), we have the reevaluate it's position *)
- let ratio, _ = Shapes.Bezier.get_closest_point
- (Point.get_coord p1)
- bezier in
-
- let b0, b1 = Shapes.Bezier.slice ratio bezier in
- let p0' = Point.copy p0 b0.Shapes.Bezier.p0
- and p1' = Point.copy p1 b0.Shapes.Bezier.p1
- and p2' = Point.copy p2 b1.Shapes.Bezier.p1 in
-
- [| { point = p0'
- ; move =
- Curve { ctrl0 = b0.Shapes.Bezier.ctrl0
- ; ctrl1 = b0.Shapes.Bezier.ctrl1
- ; p1 = p1'
- } }
- ; { point = p1'
- ; move = Curve { ctrl0 = b1.Shapes.Bezier.ctrl0
- ; ctrl1 = b1.Shapes.Bezier.ctrl1
- ; p1 = p2' }
- } |]
-
- (** Rebuild the whole curve by evaluating all the points *)
- let rebuild
- : t -> t option
- = fun t ->
-
- match Array.length t with
- | 0 -> None
- | 1 ->
- let step = Array.get t 0 in
- begin match step.move with
- | Curve {p1; _}
- | Line p1 ->
- Some
- [|
- { point = step.point
- ; move = Line p1 } |]
- end
- | 2 ->
- let p0 = (Array.get t 0).point
- and p1 = (Array.get t 1).point
- and p2 = get_point' @@ Array.get t 1 in
- Some (build_from_three_points p0 p1 p2)
-
- | _ ->
-
- (* Convert all the points in list *)
- let points = List.init
- ~len:((Array.length t) )
- ~f:(fun i -> Point.get_coord @@ get_point' (Array.get t i)) in
- let p0 = Point.get_coord @@ (Array.get t 0).point in
-
- let points = p0::points in
-
- (* We process the whole curve in a single block *)
- begin match Shapes.Bspline.to_bezier points with
- | Error `InvalidPath -> None
- | Ok beziers ->
-
- (* Now for each point, reassociate the same point information,
- We should have as many points as before *)
- let rebuilded = Array.map2 beziers t ~f:assoc_point in
- Some rebuilded
- end
-
- let find_pt_index
- : Point.t -> step array -> int option
- = fun point path ->
- (* First search the element to remove. The counter mark the position of
- the point to remove, not the segment itself. *)
- let idx = ref None
- and counter = ref 0 in
-
- let _ = Array.exists
- path
- ~f:(fun element ->
- let res =
- if (Point.id element.point) = (Point.id point) then (
- idx := Some (!counter) ;
- true
- ) else match element.move with
- | Line p1
- | Curve {p1;_} when (Point.id p1) = (Point.id point) ->
- idx := Some (!counter+1) ;
- true
- | _ ->
- false
- in
- incr counter;
- res) in
- !idx
-
- let remove_point
- : t -> Point.t -> t option
- = fun t point ->
-
- match Array.length t with
- | 0
- | 1 -> None
- | 2 ->
- (* Two segment, we get the points and transform this into a single line *)
- let p0 = (Array.get t 0).point
- and p1 = (Array.get t 1).point
- and p2 = get_point' @@ Array.get t 1 in
- let elms = List.filter [p0; p1; p2]
- ~f:(fun pt -> Point.id pt != Point.id point) in
- begin match elms with
- | p0::p1::[] ->
- Some
- [| { point = p0
- ; move = Line p1 }|]
- | _ -> None
- end
- | l ->
- match find_pt_index point t with
- | None -> Some t
- | Some 0 ->
- (* Remove the first point *)
- let path = Array.init (l-1)
- ~f:( fun i -> Array.get t (i+1)) in
- Some path
- | Some n when n = (Array.length t) ->
- (* Remove the last point *)
- let path = Array.init (l-1)
- ~f:( fun i -> Array.get t i) in
- Some path
- | Some n ->
- let path' = Array.init (l-1)
- ~f:(fun i ->
- if i < (n-1) then
- Array.get t (i)
- else if i = (n-1) then
- (* We know that the point is not the first nor the last one.
- So it is safe to call n-1 or n + 1 point
-
- We have to rebuild the point and set that
- point_(-1).id = point_(+1).id
- *)
- let p0 = (Array.get t i).point in
-
- match (Array.get t (i+1)).move with
- | Line p1 ->
- { point = p0
- ; move = Line p1 }
- | Curve c ->
- { point = p0
- ; move = Curve c }
-
- else
- Array.get t (i+1)
- ) in
- rebuild path'
-
- let first_point
- : step -> Point.t
- = fun {point; _} -> point
-
- let replace_point
- : t -> Point.t -> t option
- = fun t p ->
-
- let add_path paths idx f points =
- if 0 <= idx && idx < Array.length paths then
- let path = Array.get t idx in
- Point.get_coord (f path)
- :: points
- else points in
-
- match Array.length t with
- | 0 -> None
- | 1 -> (* Only one point, easy ? *)
- let step = Array.get t 0 in
- begin match step.move with
- | Curve {p1; _}
- | Line p1 ->
- let p0 = if (Point.id step.point = Point.id p) then p else step.point
- and p1 = if (Point.id p1 = Point.id p) then p else p1 in
- Some [|
- { point = p0
- ; move = Line p1 }
- |]
- end
-
- | 2 ->
- let p0 = (Array.get t 0).point
- and p1 = (Array.get t 1).point
- and p2 = get_point' @@ Array.get t 1 in
-
- let p0 = if (Point.id p0 = Point.id p) then p else p0
- and p1 = if (Point.id p1 = Point.id p) then p else p1
- and p2 = if (Point.id p2 = Point.id p) then p else p2 in
- Some (build_from_three_points p0 p1 p2)
-
- (* More than two segmend, it is ok for a partial reevaluation *)
- | _ ->
- match find_pt_index p t with
- | None -> None
- | Some n ->
- let path = Array.copy t in
-
- let p0, p1 =
-
- if n < Array.length path then
- p, get_point' (Array.get path n)
- else
- (Array.get path (n -1)).point, p
- in
-
- let min_idx = max (n-3) 0 in
-
- let points =
- add_path path (n-3) first_point
- @@ add_path path (n-2) first_point
- @@ add_path path (n-1) first_point
- @@ (fun tl -> (Point.get_coord p)::tl)
- @@ add_path path n get_point'
- @@ add_path path (n+1) get_point'
- @@ add_path path (n+2) get_point'
- @@ [] in
-
- (* It is impressive how fast it is to evaluate the curve ! Maybe is the
- worker not required at all…
- *)
- let bezier_opt = Shapes.Bspline.to_bezier points in
- begin match bezier_opt with
- | Ok paths ->
- Array.iteri paths
- ~f:(fun i bezier ->
- (* Only take two points before, and two after *)
- let idx = min_idx + i in
- if (n-2 < idx) && (idx < n +2) && idx < Array.length path then
- Array.set path idx (assoc_point bezier (Array.get path idx))
- );
- Some path
- | Error _ ->
- let bezier', _ = Shapes.Bezier.three_points_quadratic
- (Point.get_coord p)
- (Point.get_coord @@ get_point' (Array.get path 0))
- (Point.get_coord @@ get_point' (Array.get path 1))
- |> Shapes.Bezier.quadratic_to_cubic
- |> Shapes.Bezier.slice 0.5
- in
- Array.set path 0
- { point = p0
- ; move = (Curve
- { ctrl0 = bezier'.Shapes.Bezier.ctrl0
- ; ctrl1 = bezier'.Shapes.Bezier.ctrl1
- ; p1
- })
- };
- Some path
- end
-end