From a63662059215a26db627c4b76147a3c9338f5b74 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Wed, 6 Jan 2021 22:09:53 +0100 Subject: Point suppression --- script.it/dune | 2 +- script.it/script.ml | 42 ++++++++++++++++++++++++-- script.it/selection.ml | 72 ++++++++++++++++++++++++++++++++++++++++++++ script.it/selection.mli | 21 +++++++++++++ script.it/state.ml | 79 +++++++++++++++++++++++++++---------------------- script.it/worker.ml | 43 ++++++++++++++++----------- 6 files changed, 201 insertions(+), 58 deletions(-) create mode 100755 script.it/selection.ml create mode 100755 script.it/selection.mli (limited to 'script.it') diff --git a/script.it/dune b/script.it/dune index e7ca0dc..84b91f6 100755 --- a/script.it/dune +++ b/script.it/dune @@ -9,7 +9,7 @@ layer ) (modes js) - (modules script state) + (modules script state selection) (preprocess (pps ppx_hash js_of_ocaml-ppx)) (link_flags (:standard -no-check-prims)) ) diff --git a/script.it/script.ml b/script.it/script.ml index 95272fb..e91dc92 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -144,7 +144,7 @@ let set_sidebar El.select [ El.option ~at:At.[value (Jstr.v "1")] [ txt' "Fill"] - ; El.option ~at:At.[value (Jstr.v "2")] + ; El.option ~at:At.[value (Jstr.v "3")] [ txt' "Ductus"] ] in @@ -212,7 +212,6 @@ let on_change canva mouse_position timer state = Cd2d.set_stroke_style context (Cd2d.color white); Cd2d.set_fill_style context (Cd2d.color white); - (* If we are in edit mode, we add a point under the cursor. Otherwise, we would only display the previous registered point, which can @@ -236,7 +235,8 @@ let on_change canva mouse_position timer state = ~f:(fun path -> let () = match state.mode with - | Selection id -> + | Selection (Path id) + | Selection (Point (id, _)) -> begin match id = (Path.Fixed.id path) with | true -> (* If the element is the selected one, change the color *) @@ -251,6 +251,42 @@ let on_change canva mouse_position timer state = Layer.Paths.to_canva (module Path.Fixed) path context state.rendering ); + + let () = match state.mode with + | Selection (Path id) -> + Cd2d.set_stroke_style context (Cd2d.color white); + List.iter + state.paths + ~f:(fun path -> + if id = Path.Fixed.id path then + Layer.Paths.to_canva (module Path.Fixed) path context `Line + ) + | Selection (Point (id, point)) -> + (* As before, mark the selected path *) + Cd2d.set_stroke_style context (Cd2d.color white); + List.iter + state.paths + ~f:(fun path -> + if id = Path.Fixed.id path then + Layer.Paths.to_canva (module Path.Fixed) path context `Line + ); + + (* Now draw the selected point *) + + let x, y = Gg.V2.to_tuple @@ Path.Point.get_coord point in + Cd2d.stroke_rect + ~x:(x -. 5.) + ~y:(y -. 5.) + ~w:10. + ~h:10. + context; + + + + | _ -> () + in + + () let spawn_worker () = diff --git a/script.it/selection.ml b/script.it/selection.ml new file mode 100755 index 0000000..e05839b --- /dev/null +++ b/script.it/selection.ml @@ -0,0 +1,72 @@ +open StdLabels + +type t = + | Path of int + | Point of (int * Path.Point.t) + +let threshold = 20. + +let get_from_paths + : (float * float) -> Path.Fixed.t list -> float * (Gg.v2 * Path.Fixed.t * Path.Point.t * Path.Point.t) option + = fun position paths -> + let point = Gg.V2.of_tuple position in + (* If the user click on a curve, select it *) + List.fold_left paths + ~init:(threshold, None) + ~f:(fun (dist, selection) path -> + match Path.Fixed.distance point path with + | Some (point', p, p0, p1) when p < dist -> + dist, Some (point', path, p0, p1) + | _ -> dist, selection + ) + +let select_path + : Path.Fixed.t -> t + = fun path -> Path (Path.Fixed.id path) + +let select_point + : Path.Fixed.t -> Gg.v2 -> t + = fun path v2_point -> + + let point' = ref None in + + Path.Fixed.iter + path + ~f:(fun p -> + let open Gg.V2 in + match (norm ((Path.Point.get_coord p) - v2_point) < threshold) with + | false -> () + | true -> point' := Some p + ); + + match !point' with + | Some point -> + Point (Path.Fixed.id path, point) + | None -> + (* If the point does not exists, find the exact point on the curve *) + let coord = Gg.V2.to_tuple v2_point in + begin match get_from_paths coord [path] with + | _, None -> Path (Path.Fixed.id path) + | f, Some (point, path, p0, p1) -> + + let angle0 = Path.Point.get_angle p0 + and angle1 = Path.Point.get_angle p1 + and width0 = Path.Point.get_width p0 + and width1 = Path.Point.get_width p1 + and stamp0 = Path.Point.get_stamp p0 + and stamp1 = Path.Point.get_stamp p1 in + let angle = angle0 +. f *. ( angle1 -. angle0 ) in + let width = width0 +. f *. ( width1 -. width0 ) in + let stamp = stamp0 +. f *. ( stamp1 -. stamp0 ) in + + let x, y = Gg.V2.to_tuple point in + + let point' = Path.Point.create + ~angle + ~width + ~stamp + ~x + ~y + in + Point (Path.Fixed.id path, point') + end diff --git a/script.it/selection.mli b/script.it/selection.mli new file mode 100755 index 0000000..01f12dc --- /dev/null +++ b/script.it/selection.mli @@ -0,0 +1,21 @@ +type t = + | Path of int + | Point of (int * Path.Point.t) + +(** Return the closest path from the list to a given point. + + The path is returned with all thoses informations : + - The point in the path + - The path itself + - The starting point from the path + - The end point in the path + +*) +val get_from_paths + : (float * float) -> Path.Fixed.t list -> float * (Gg.v2 * Path.Fixed.t * Path.Point.t * Path.Point.t) option + +val select_path + : Path.Fixed.t -> t + +val select_point + : Path.Fixed.t -> Gg.v2 -> t diff --git a/script.it/state.ml b/script.it/state.ml index 53cc861..f08c3a1 100755 --- a/script.it/state.ml +++ b/script.it/state.ml @@ -5,7 +5,7 @@ let backgroundColor = Blog.Nord.nord0 type mode = | Edit - | Selection of int + | Selection of Selection.t | Out (** Events *) @@ -76,21 +76,6 @@ let insert_or_replace state ((x, y) as p) stamp path = let threshold = 20. -let check_selection - : (float * float) -> Path.Fixed.t list -> (Gg.v2 * Path.Fixed.t * Path.Point.t * Path.Point.t) option - = fun position paths -> - let point = Gg.V2.of_tuple position in - (* If the user click on a curve, select it *) - let _, res = List.fold_left paths - ~init:(threshold, None) - ~f:(fun (dist, selection) path -> - match Path.Fixed.distance point path with - | Some (point', p, p0, p1) when p < dist -> - dist, Some (point', path, p0, p1) - | _ -> dist, selection - ) in - res - (** Update the path in the selection with the given function applied to every point *) let update_selection id state f = @@ -105,18 +90,17 @@ let update_selection id state f = { state with paths } -let select_segment point (p, selected, p0, p1) state = +(** Select the given segment, and modify angle and width accordingly *) +let select_segment _ (_, selected, p0, p1) state dist = let angle0 = Path.Point.get_angle p0 and angle1 = Path.Point.get_angle p1 in let width0 = Path.Point.get_width p0 and width1 = Path.Point.get_width p1 in - let dist = Gg.V2.(norm ( p - (Gg.V2.of_tuple point))) in - let angle = angle0 +. dist *. ( angle1 -. angle0 ) in let width = width0 +. dist *. ( width1 -. width0 ) in - let id = Path.Fixed.id selected in + let id = Selection.select_path selected in { state with mode = (Selection id) ; angle @@ -144,11 +128,11 @@ let do_action let stamp = 0. in let point = - match check_selection p state.paths with - | None -> + match Selection.get_from_paths p state.paths with + | _, None -> (* Start a new path with the point clicked *) Path.Point.create ~x ~y ~angle ~width ~stamp - | Some (p, _, _, _) -> + | _, Some (p, _, _, _) -> (* If the point is close to an existing path, we use the closest point in the path instead *) let x, y = Gg.V2.to_tuple p in @@ -162,13 +146,20 @@ let do_action (* Click anywhere while in selection mode, we either select another path, or switch to Out mode*) - | `Click position, (Selection _) -> - begin match check_selection position state.paths with - | None -> + | `Click position, (Selection (Path id)) + | `Click position, (Selection (Point (id, _))) -> + begin match Selection.get_from_paths position state.paths with + | _, None -> { state with mode = Out } - | Some selection -> - select_segment position selection state + | dist, Some selection -> + let _, path, _, _ = selection in + if Path.Fixed.id path != id then + select_segment position selection state dist + else + (* On the same segment, check for a point *) + let selection = Selection.select_point path (Gg.V2.of_tuple position) in + {state with mode= Selection selection} end | `Out point, Edit -> @@ -200,21 +191,37 @@ let do_action (* Else, check if there is a curve under the cursor, and remove it *) | None -> let current = Path.Path_Builder.empty in - begin match check_selection point state.paths with - | None -> + begin match Selection.get_from_paths point state.paths with + | _, None -> { state with mode = Out ; current } - | Some selection -> - select_segment point selection { state with current } + | dist, Some selection -> + select_segment point selection { state with current } dist end end - | `Delete, Selection id -> - let paths = List.filter state.paths ~f:(fun p -> Path.Fixed.id p != id) in + | `Delete, Selection (Path id) -> + let paths = List.filter + state.paths + ~f:(fun p -> + Path.Fixed.id p != id + ) in { state with paths ; mode = Out} + | `Delete, Selection (Point (id, point)) -> + List.iter + state.paths + ~f:(fun p -> + let id' = Path.Fixed.id p in + match id' = id with + | false -> () + | true -> + (* Send the job to the worker *) + Brr_webworkers.Worker.post worker (`DeletePoint (id, point, p)) + ); + state | `Export, _ -> @@ -253,10 +260,10 @@ let do_action state (* Change the select curve with the appropriate setting *) - | `Angle angle, Selection s -> + | `Angle angle, Selection (Path s) -> let state = { state with angle } in update_selection s state (fun p -> Path.Point.set_angle p angle) - | `Width width, Selection s -> + | `Width width, Selection (Path s) -> let state = { state with width } in update_selection s state (fun p -> Path.Point.set_width p width) diff --git a/script.it/worker.ml b/script.it/worker.ml index 3150869..e2408b7 100755 --- a/script.it/worker.ml +++ b/script.it/worker.ml @@ -3,6 +3,7 @@ open Js_of_ocaml type message = [ | `Complete of (int * (Path.Fixed.path array)) + | `DeletePoint of (int * Path.Point.t * Path.Fixed.t) ] exception Empty_Element @@ -36,27 +37,33 @@ let assoc_point ; Path.Fixed.ctrl1 = bezier.Shapes.Bezier.ctrl1 } -let execute (command: [> message]) = - match command with - | `Complete (id, paths) -> - (* Convert all the points in list *) - let points = List.init - ~len:((Array.length paths) ) - ~f:(fun i -> get_point (Array.get paths i)) in - let p0 = first_point (Array.get paths 0)in +let rebuild (id, paths) = + (* Convert all the points in list *) + let points = List.init + ~len:((Array.length paths) ) + ~f:(fun i -> get_point (Array.get paths i)) in + let p0 = first_point (Array.get paths 0)in + + let points = p0::points 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 -> () + | Ok beziers -> - (* We process the whole curve in a single block *) - begin match Shapes.Bspline.to_bezier points with - | Error `InvalidPath -> () - | Ok beziers -> + (* Now for each point, reassociate the same point information, + We should have as many points as before *) + let rebuilded = Array.map2 beziers paths ~f:assoc_point in + Worker.post_message (`Complete (id, rebuilded)) + end - (* Now for each point, reassociate the same point information, - We should have as many points as before *) - let rebuilded = Array.map2 beziers paths ~f:assoc_point in - Worker.post_message (`Complete (id, rebuilded)) - end +let execute (command: [> message]) = + match command with + | `Complete (id, paths) -> + rebuild (id, paths) + | `DeletePoint (id, point, path) -> + let path = Path.Fixed.remove_point path point in + rebuild (id, Path.Fixed.path path) | any -> Worker.post_message (`Other any) -- cgit v1.2.3