Point suppression

6 files changed, 201 insertions, 58 deletions

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)