diff options
| -rwxr-xr-x | layer/ductusPrinter.ml | 69 | ||||
| -rwxr-xr-x | layer/linePrinter.ml | 48 | ||||
| -rwxr-xr-x | layer/paths.ml | 23 | ||||
| -rwxr-xr-x | path/fixed.ml | 102 | ||||
| -rwxr-xr-x | path/fixed.mli | 6 | ||||
| -rwxr-xr-x | script.it/dune | 2 | ||||
| -rwxr-xr-x | script.it/script.ml | 42 | ||||
| -rwxr-xr-x | script.it/selection.ml | 72 | ||||
| -rwxr-xr-x | script.it/selection.mli | 21 | ||||
| -rwxr-xr-x | script.it/state.ml | 79 | ||||
| -rwxr-xr-x | script.it/worker.ml | 43 |
11 files changed, 382 insertions, 125 deletions
diff --git a/layer/ductusPrinter.ml b/layer/ductusPrinter.ml new file mode 100755 index 0000000..3ed1c3c --- /dev/null +++ b/layer/ductusPrinter.ml @@ -0,0 +1,69 @@ +module Make(Repr: Repr.PRINTER) = struct + + type t = Path.Point.t + + type repr = + { path: (Repr.t) + } + + let create_path + : 'b -> repr + = fun _ -> + { path = Repr.create () + } + + (* Start a new path. *) + let start + : Path.Point.t -> repr -> repr + = fun t {path} -> + let path = Repr.move_to (Path.Point.get_coord t) path in + let path = Repr.line_to (Path.Point.get_coord' t) path in + { path + } + + let line_to + : Path.Point.t -> Path.Point.t -> repr -> repr + = fun _ t {path} -> + let path = Repr.move_to (Path.Point.get_coord t) path in + let path = Repr.line_to (Path.Point.get_coord' t) path in + { path + } + + let quadratic_to + : Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr + = fun p0 ctrl0 ctrl1 p1 { path } -> + + let path = ref path in + + let bezier = + { Shapes.Bezier.p0 = Path.Point.get_coord p0 + ; ctrl0 + ; ctrl1 + ; p1 = Path.Point.get_coord p1 + } in + + (* Mark each point on the bezier curve. The first point is the most + recent point *) + let delay = + ((Path.Point.get_stamp p0) -. (Path.Point.get_stamp p1)) + *. 100. /. 3. + in + for i = 0 to (Int.of_float delay) do + let bezier', _ = Shapes.Bezier.slice (0.1 *. (Float.of_int i)) bezier in + let point = Path.Point.copy p1 bezier'.Shapes.Bezier.p1 in + path := Repr.move_to (Path.Point.get_coord point) !path; + path := Repr.line_to (Path.Point.get_coord' point) !path; + done; + + { path = !path } + + let stop + : repr -> repr + = fun path -> path + + + let get + : repr -> Repr.t + = fun {path; _} -> + path +end diff --git a/layer/linePrinter.ml b/layer/linePrinter.ml index 3ed1c3c..c15bcc9 100755 --- a/layer/linePrinter.ml +++ b/layer/linePrinter.ml @@ -2,6 +2,21 @@ module Make(Repr: Repr.PRINTER) = struct type t = Path.Point.t + let mark point path = + let open Gg.V2 in + let point = Path.Point.get_coord point in + + let dist = 5. + and dist' = -5. in + + let path = Repr.move_to (point - (of_tuple (dist, dist))) path + |> Repr.line_to ( point + (of_tuple (dist, dist))) + |> Repr.move_to (point + (of_tuple (dist', dist))) + |> Repr.line_to ( point + (of_tuple (dist, dist'))) + in + path + + type repr = { path: (Repr.t) } @@ -16,16 +31,15 @@ module Make(Repr: Repr.PRINTER) = struct let start : Path.Point.t -> repr -> repr = fun t {path} -> - let path = Repr.move_to (Path.Point.get_coord t) path in - let path = Repr.line_to (Path.Point.get_coord' t) path in + let path = mark t path in { path } let line_to : Path.Point.t -> Path.Point.t -> repr -> repr = fun _ t {path} -> - let path = Repr.move_to (Path.Point.get_coord t) path in - let path = Repr.line_to (Path.Point.get_coord' t) path in + let path = Repr.line_to (Path.Point.get_coord t) path + |> mark t in { path } @@ -33,29 +47,11 @@ module Make(Repr: Repr.PRINTER) = struct : Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr = fun p0 ctrl0 ctrl1 p1 { path } -> - let path = ref path in - - let bezier = - { Shapes.Bezier.p0 = Path.Point.get_coord p0 - ; ctrl0 - ; ctrl1 - ; p1 = Path.Point.get_coord p1 - } in - - (* Mark each point on the bezier curve. The first point is the most - recent point *) - let delay = - ((Path.Point.get_stamp p0) -. (Path.Point.get_stamp p1)) - *. 100. /. 3. - in - for i = 0 to (Int.of_float delay) do - let bezier', _ = Shapes.Bezier.slice (0.1 *. (Float.of_int i)) bezier in - let point = Path.Point.copy p1 bezier'.Shapes.Bezier.p1 in - path := Repr.move_to (Path.Point.get_coord point) !path; - path := Repr.line_to (Path.Point.get_coord' point) !path; - done; + let path = Repr.move_to (Path.Point.get_coord p0) path + |> Repr.quadratic_to ctrl0 ctrl1 (Path.Point.get_coord p1) + |> mark p1 in - { path = !path } + { path = path } let stop : repr -> repr diff --git a/layer/paths.ml b/layer/paths.ml index 3cedd6d..59215df 100755 --- a/layer/paths.ml +++ b/layer/paths.ml @@ -11,13 +11,14 @@ end (* Canva representation *) module FillCanvaRepr = FillPrinter.Make(CanvaPrinter) +module DuctusCanvaRepr = DuctusPrinter.Make(CanvaPrinter) module LineCanvaRepr = LinePrinter.Make(CanvaPrinter) module WireCanvaRepr = WireFramePrinter.Make(CanvaPrinter) (* SVG representation *) module FillSVGRepr = FillPrinter.Make(Svg) -module LineSVGRepr = LinePrinter.Make(Svg) +module DuctusSVGRepr = DuctusPrinter.Make(Svg) module WireSVGRepr = WireFramePrinter.Make(Svg) @@ -47,9 +48,9 @@ let to_canva | `Ductus -> R.repr path - (module WireCanvaRepr) - (WireCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - |> WireCanvaRepr.get + (module DuctusCanvaRepr) + (DuctusCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) + |> DuctusCanvaRepr.get |> Brr_canvas.C2d.stroke ctx @@ -81,18 +82,6 @@ let to_svg ; v (Jstr.v "stroke") color] !paths - | `Line -> - let svg_path = R.repr - path - (module LineSVGRepr) - (LineSVGRepr.create_path (fun _ -> ())) - |> LineSVGRepr.get in - Svg.path - ~at:Brr.At.[ - v (Jstr.v "fill") color - ; v (Jstr.v "stroke") color - ; v (Jstr.v "d") svg_path ] - [] | `Ductus -> let svg_path = R.repr path @@ -105,3 +94,5 @@ let to_svg ; v (Jstr.v "stroke") color ; v (Jstr.v "d") svg_path ] [] + | `Line -> + raise Not_found diff --git a/path/fixed.ml b/path/fixed.ml index 7ee0705..95a42d5 100755 --- a/path/fixed.ml +++ b/path/fixed.ml @@ -129,15 +129,6 @@ module Make(Point:P) = struct ) in Repr.stop repr - let box - : bezier -> Gg.box2 - = fun bezier -> - Gg.Box2.of_pts - (Point.get_coord bezier.p0) - (Point.get_coord bezier.p1) - |> (fun b -> Gg.Box2.add_pt b bezier.ctrl0) - |> (fun b -> Gg.Box2.add_pt b bezier.ctrl1) - (** Return the distance between a given point and the curve. May return None if the point is out of the curve *) let distance @@ -157,23 +148,20 @@ module Make(Point:P) = struct res end | Curve bezier -> - begin match Gg.Box2.mem point (box bezier) with - | false -> res - | true -> - let bezier' = Shapes.Bezier.( - - { p0 = Point.get_coord bezier.p0 - ; p1 = Point.get_coord bezier.p1 - ; ctrl0 = bezier.ctrl0 - ; ctrl1 = bezier.ctrl1 } - ) in - let _, point' = Shapes.Bezier.get_closest_point point bezier' in - let distance = Gg.V2.( norm (point - point') ) in - match res with - | None -> Some (point', distance, bezier.p0, bezier.p1) - | Some (_, d, _, _) -> if d < distance then res else (Some (point', distance, bezier.p0, bezier.p1)) - end + let bezier' = Shapes.Bezier.( + + { p0 = Point.get_coord bezier.p0 + ; p1 = Point.get_coord bezier.p1 + ; ctrl0 = bezier.ctrl0 + ; ctrl1 = bezier.ctrl1 } + ) in + let _, point' = Shapes.Bezier.get_closest_point point bezier' in + let distance = Gg.V2.( norm (point - point') ) in + match res with + | None -> Some (point', distance, bezier.p0, bezier.p1) + | Some (_, d, _, _) when d < distance -> res + | _ -> (Some (point', distance, bezier.p0, bezier.p1)) ) let map_point @@ -187,6 +175,70 @@ module Make(Point:P) = struct ) in {id; path} + let iter + : t -> f:(Point.t -> unit) -> unit + = fun {path; _} ~f -> + Array.iter path + ~f:(function + | Empty -> () + | Line (p1, p2) -> f p1; f p2 + | Curve bezier -> f bezier.p0 ; f bezier.p1 + ) + + + let remove_point + : t -> Point.t -> t + = fun {id; path} point -> + + (* First search the element to remove *) + let idx = ref None + and counter = ref 0 in + + let _ = Array.exists + path + ~f:(fun element -> + + let res = match element with + | Empty -> false + | Line (p0, p1) + | Curve {p0;p1;_} -> + if p0 = point then ( + idx := Some (!counter) ; + true + ) else if p1 = point then ( + idx := Some (!counter +1) ; + true + ) else + false + in + incr counter; + res) in + + match !idx with + | None -> {id; path} + | Some 0 -> + (* Remove the first point *) + let path' = Array.init + ((Array.length path) -1) + ~f:( fun i -> Array.get path (i + 1)) in + {id; path=path'} + | Some n when n = (Array.length path) -> + (* Remove the last point *) + let path' = Array.init + ((Array.length path) -1) + ~f:( fun i -> Array.get path i) in + {id; path=path'} + | Some n -> + let path' = Array.init + ((Array.length path) -1) + ~f:(fun i -> + if i < (n -1) then + Array.get path (i) + else + Array.get path (i +1) + ) in + {id; path=path'} + let update : t -> path array -> t = fun {id; _} path -> {id; path} diff --git a/path/fixed.mli b/path/fixed.mli index c6af84d..32f6012 100755 --- a/path/fixed.mli +++ b/path/fixed.mli @@ -40,9 +40,15 @@ module Make(Point:P) : sig val distance : Gg.v2 -> t -> (Gg.v2 * float * Point.t * Point.t) option + val iter + : t -> f:(Point.t -> unit) -> unit + val map_point : t -> (Point.t -> Point.t) -> t + val remove_point + : t -> Point.t -> t + type bezier = { p0:Point.t (* The starting point *) ; p1:Point.t (* The end point *) 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) |