From 89dbb39c3fcd188ef7acf092061d756046b2c5d4 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Tue, 22 Feb 2022 14:14:04 +0100 Subject: Reformating --- script.it/dune | 2 +- script.it/layer/ductusEngine.ml | 127 +++-- script.it/layer/dune | 2 +- script.it/layer/fillEngine.ml | 133 +++--- script.it/layer/lineEngine.ml | 73 ++- script.it/layer/paths.ml | 352 +++++++------- script.it/layer/repr.ml | 37 +- script.it/layer/wireFramePrinter.ml | 127 +++-- script.it/layer/wireFramePrinter.mli | 26 +- script.it/outline/dune | 2 +- script.it/outline/outline.ml | 14 +- script.it/path/dune | 2 +- script.it/path/path.ml | 7 - script.it/path/script_path.ml | 7 + script.it/script.ml | 678 +++++++++++++-------------- script.it/script_event/click.ml | 106 ++--- script.it/script_event/export.ml | 34 +- script.it/script_event/mouse_down.ml | 142 +++--- script.it/script_event/property.ml | 76 +-- script.it/state/dune | 2 +- script.it/state/selection.ml | 85 ++-- script.it/state/selection.mli | 18 +- script.it/state/state.ml | 41 +- script.it/worker.ml | 85 ++-- script.it/worker_messages/dune | 2 +- script.it/worker_messages/worker_messages.ml | 28 +- 26 files changed, 1040 insertions(+), 1168 deletions(-) delete mode 100755 script.it/path/path.ml create mode 100755 script.it/path/script_path.ml diff --git a/script.it/dune b/script.it/dune index 2b1d446..c9a28d5 100755 --- a/script.it/dune +++ b/script.it/dune @@ -22,7 +22,7 @@ (libraries js_of_ocaml shapes - path + script_path worker_messages outline ) diff --git a/script.it/layer/ductusEngine.ml b/script.it/layer/ductusEngine.ml index b943467..95cf502 100755 --- a/script.it/layer/ductusEngine.ml +++ b/script.it/layer/ductusEngine.ml @@ -1,82 +1,67 @@ -module Make(Layer: Repr.PRINTER) = struct +module Path = Script_path +module Make (Layer : Repr.PRINTER) = struct type point = Path.Point.t - type t = - { path: (Layer.t) - } + type t = { path : Layer.t } type repr = Layer.t - let create_path - : 'b -> t - = fun _ -> - { path = Layer.create () - } + let create_path : 'b -> t = fun _ -> { path = Layer.create () } + + let start : point -> point -> t -> t = + fun p1 p2 { path } -> + let path = + Layer.move_to (Path.Point.get_coord p1) path + |> Layer.line_to (Path.Point.get_coord p2) + in + { path } - let start - : point -> point -> t -> t - = fun p1 p2 { path } -> - let path = - Layer.move_to (Path.Point.get_coord p1) path - |> Layer.line_to (Path.Point.get_coord p2) in - { path - } - let line_to - : (point * point) -> (point * point) -> t -> t - = fun (_, p1) (_, p1') {path} -> - let path = Layer.move_to (Path.Point.get_coord p1) path in - let path = Layer.line_to (Path.Point.get_coord p1') path in - { path + let line_to : point * point -> point * point -> t -> t = + fun (_, p1) (_, p1') { path } -> + let path = Layer.move_to (Path.Point.get_coord p1) path in + let path = Layer.line_to (Path.Point.get_coord p1') path in + { path } + + + let quadratic_to : + point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t = + fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') { path } -> + let bezier = + { Shapes.Bezier.p0 = Path.Point.get_coord p0 + ; ctrl0 + ; ctrl1 + ; p1 = Path.Point.get_coord p1 + } + and bezier' = + { Shapes.Bezier.p0 = Path.Point.get_coord p0' + ; ctrl0 = ctrl0' + ; ctrl1 = 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) *. 30. in + let path = ref path in + for i = 0 to Int.of_float delay do + let ratio = Float.of_int i /. delay in + let bezier, _ = Shapes.Bezier.slice ratio bezier + and bezier', _ = Shapes.Bezier.slice ratio bezier' in + + let point = Path.Point.mix ratio bezier.Shapes.Bezier.p1 p0 p1 + and point' = Path.Point.mix ratio bezier'.Shapes.Bezier.p1 p0' p1' in + + path := Layer.move_to (Path.Point.get_coord point) !path; + path := Layer.line_to (Path.Point.get_coord point') !path + done; + + { path = !path } + + + let stop : t -> t = fun path -> path - let quadratic_to - : (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t - = fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') {path} -> - - let bezier = - { Shapes.Bezier.p0 = Path.Point.get_coord p0 - ; ctrl0 - ; ctrl1 - ; p1 = Path.Point.get_coord p1 - } - - and bezier' = - { Shapes.Bezier.p0 = Path.Point.get_coord p0' - ; ctrl0 = ctrl0' - ; ctrl1 = 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)) - *. 30. - in - let path = ref path in - for i = 0 to ((Int.of_float delay) ) do - let ratio = (Float.of_int i) /. delay in - let bezier, _ = Shapes.Bezier.slice ratio bezier - and bezier', _ = Shapes.Bezier.slice ratio bezier' in - - let point = Path.Point.mix ratio bezier.Shapes.Bezier.p1 p0 p1 - and point' = Path.Point.mix ratio bezier'.Shapes.Bezier.p1 p0' p1' in - - path := Layer.move_to (Path.Point.get_coord point) !path; - path := Layer.line_to (Path.Point.get_coord point') !path; - done; - - { path = !path } - - let stop - : t -> t - = fun path -> path - - - let get - : t -> Layer.t - = fun {path; _} -> - path + let get : t -> Layer.t = fun { path; _ } -> path end diff --git a/script.it/layer/dune b/script.it/layer/dune index 3c617ad..2459d2b 100755 --- a/script.it/layer/dune +++ b/script.it/layer/dune @@ -3,6 +3,6 @@ (libraries gg brr - path + script_path ) ) diff --git a/script.it/layer/fillEngine.ml b/script.it/layer/fillEngine.ml index 9a3fe7e..92f94c7 100755 --- a/script.it/layer/fillEngine.ml +++ b/script.it/layer/fillEngine.ml @@ -1,89 +1,70 @@ -module Make(Layer: Repr.PRINTER) = struct +module Path = Script_path +module Make (Layer : Repr.PRINTER) = struct type point = Path.Point.t type repr = Layer.t type t = - { path: Layer.t + { path : Layer.t ; close : Layer.t -> Layer.t } - let create_path - : (Layer.t -> Layer.t) -> t - = fun f -> - { close = f - ; path = Layer.create () - } + let create_path : (Layer.t -> Layer.t) -> t = + fun f -> { close = f; path = Layer.create () } + (* Start a new path. *) - let start - : point -> point -> t -> t - = fun p1 _ {close ; path } -> - let path = Layer.move_to (Path.Point.get_coord p1) path in - { close - ; path - } - - let line_to - : (point * point) -> (point * point) -> t -> t - = fun (p0, p1) (p0', p1') t -> - - let p0 = Path.Point.get_coord p0 - and p1 = Path.Point.get_coord p1 - and p0' = Path.Point.get_coord p0' - and p1' = Path.Point.get_coord p1' in - - let path = - Layer.move_to p1 t.path - |> Layer.line_to p1' - |> Layer.line_to p0' - |> Layer.line_to p0 - |> Layer.line_to p1 - |> Layer.close in - let path = t.close path in - { t with path} - - let quadratic_to - : (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t - = fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') t -> - - let p0 = Path.Point.get_coord p0 - and p1 = Path.Point.get_coord p1 - and p0' = Path.Point.get_coord p0' - and p1' = Path.Point.get_coord p1' - in - - let path = - Layer.move_to p1 t.path - |> Layer.line_to p1' - - (* Backward *) - |> Layer.quadratic_to - ctrl1' - ctrl0' - p0' - |> Layer.line_to p0 - - (* Forward *) - |> Layer.quadratic_to - ctrl0 - ctrl1 - p1 - |> Layer.close - |> t.close in - - - { t with path } - - let stop - : t -> t - = fun t -> - t - - let get - : t -> Layer.t - = fun t -> - t.path + let start : point -> point -> t -> t = + fun p1 _ { close; path } -> + let path = Layer.move_to (Path.Point.get_coord p1) path in + { close; path } + + + let line_to : point * point -> point * point -> t -> t = + fun (p0, p1) (p0', p1') t -> + let p0 = Path.Point.get_coord p0 + and p1 = Path.Point.get_coord p1 + and p0' = Path.Point.get_coord p0' + and p1' = Path.Point.get_coord p1' in + + let path = + Layer.move_to p1 t.path + |> Layer.line_to p1' + |> Layer.line_to p0' + |> Layer.line_to p0 + |> Layer.line_to p1 + |> Layer.close + in + let path = t.close path in + { t with path } + + + let quadratic_to : + point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t = + fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') t -> + let p0 = Path.Point.get_coord p0 + and p1 = Path.Point.get_coord p1 + and p0' = Path.Point.get_coord p0' + and p1' = Path.Point.get_coord p1' in + + let path = + Layer.move_to p1 t.path + |> Layer.line_to p1' + (* Backward *) + |> Layer.quadratic_to ctrl1' ctrl0' p0' + |> Layer.line_to p0 + (* Forward *) + |> Layer.quadratic_to ctrl0 ctrl1 p1 + |> Layer.close + |> t.close + in + + { t with path } + + + let stop : t -> t = fun t -> t + + let get : t -> Layer.t = fun t -> t.path end diff --git a/script.it/layer/lineEngine.ml b/script.it/layer/lineEngine.ml index 3d15d9c..c10017a 100755 --- a/script.it/layer/lineEngine.ml +++ b/script.it/layer/lineEngine.ml @@ -1,5 +1,6 @@ -module Make(Layer: Repr.PRINTER) = struct +module Path = Script_path +module Make (Layer : Repr.PRINTER) = struct type point = Path.Point.t let mark point path = @@ -9,60 +10,50 @@ module Make(Layer: Repr.PRINTER) = struct let dist = 5. and dist' = -5. in - let path = Layer.move_to (point - (of_tuple (dist, dist))) path - |> Layer.line_to ( point + (of_tuple (dist, dist))) - |> Layer.move_to (point + (of_tuple (dist', dist))) - |> Layer.line_to ( point + (of_tuple (dist, dist'))) + let path = + Layer.move_to (point - of_tuple (dist, dist)) path + |> Layer.line_to (point + of_tuple (dist, dist)) + |> Layer.move_to (point + of_tuple (dist', dist)) + |> Layer.line_to (point + of_tuple (dist, dist')) in path - type t = - { path: (Layer.t) - } + type t = { path : Layer.t } type repr = Layer.t - let create_path - : 'b -> t - = fun _ -> - { path = Layer.create () - } + let create_path : 'b -> t = fun _ -> { path = Layer.create () } - let start - : point -> point -> t -> t - = fun p1 _ { path } -> - let path = mark p1 path in - { path - } + let start : point -> point -> t -> t = + fun p1 _ { path } -> + let path = mark p1 path in + { path } - let line_to - : (point * point) -> (point * point) -> t -> t - = fun (p0, p1) _ {path} -> - let path = Layer.move_to (Path.Point.get_coord p0) path - |> Layer.line_to (Path.Point.get_coord p1) - |> mark p1 in - { path - } - let quadratic_to - : (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t - = fun (p0, ctrl0, ctrl1, p1) _ {path} -> + let line_to : point * point -> point * point -> t -> t = + fun (p0, p1) _ { path } -> + let path = + Layer.move_to (Path.Point.get_coord p0) path + |> Layer.line_to (Path.Point.get_coord p1) + |> mark p1 + in + { path } - let path = Layer.move_to (Path.Point.get_coord p0) path - |> Layer.quadratic_to ctrl0 ctrl1 (Path.Point.get_coord p1) - |> mark p1 in - { path = path } + let quadratic_to : + point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t = + fun (p0, ctrl0, ctrl1, p1) _ { path } -> + let path = + Layer.move_to (Path.Point.get_coord p0) path + |> Layer.quadratic_to ctrl0 ctrl1 (Path.Point.get_coord p1) + |> mark p1 + in - let stop - : t -> t - = fun path -> path + { path } - let get - : t -> Layer.t - = fun {path; _} -> - path + let stop : t -> t = fun path -> path + let get : t -> Layer.t = fun { path; _ } -> path end diff --git a/script.it/layer/paths.ml b/script.it/layer/paths.ml index d3baf02..1c4251f 100755 --- a/script.it/layer/paths.ml +++ b/script.it/layer/paths.ml @@ -1,95 +1,82 @@ -open StdLabels (** Common module for ensuring that the function is evaluated only once *) +open StdLabels + +module Path = Script_path (** This represent a single path, which can be transformed throug a [repr] function. *) module type PATH = sig type t + val repr : + t + -> (module Path.Repr.M with type point = Path.Point.t and type t = 's) + -> 's + -> 's (** Represent the path *) - val repr - : t -> (module Path.Repr.M - with type point = Path.Point.t - and type t = 's) -> 's -> 's end type printer = [ `Fill | `Line - | `Ductus ] - + | `Ductus + ] module type P = sig include Path.Repr.M type repr - val create_path - : (repr -> repr) -> t + val create_path : (repr -> repr) -> t - val get - : t -> repr + val get : t -> repr end - -module MakePrinter(M:Repr.ENGINE) : P - with type point = M.point - and type t = M.t - and type repr = M.repr = struct - +module MakePrinter (M : Repr.ENGINE) : + P with type point = M.point and type t = M.t and type repr = M.repr = struct type t = M.t type point = M.point type repr = M.repr - let get - : t -> repr - = M.get + let get : t -> repr = M.get - let create_path - : (repr -> repr) -> t - = M.create_path + let create_path : (repr -> repr) -> t = M.create_path - let start - : Path.Point.t -> t -> t - = fun pt t -> - M.start pt pt t + let start : Path.Point.t -> t -> t = fun pt t -> M.start pt pt t - let line_to - : Path.Point.t -> Path.Point.t -> t -> t - = fun p0 p1 t -> + let line_to : Path.Point.t -> Path.Point.t -> t -> t = + fun p0 p1 t -> + M.line_to + (p0, p1) + ( Path.Point.copy p0 @@ Path.Point.get_coord' p0 + , Path.Point.copy p1 @@ Path.Point.get_coord' p1 ) + t - M.line_to - ( p0 - , p1 ) - ( Path.Point.copy p0 @@ Path.Point.get_coord' p0 - , Path.Point.copy p1 @@ Path.Point.get_coord' p1 ) - t - let quadratic_to - : (Path.Point.t * Gg.v2 * Gg.v2 * Path.Point.t) -> t -> t - = fun (p0, ctrl0, ctrl1, p1) t -> + let quadratic_to : Path.Point.t * Gg.v2 * Gg.v2 * Path.Point.t -> t -> t = + fun (p0, ctrl0, ctrl1, p1) t -> + let ctrl0' = Path.Point.get_coord' @@ Path.Point.copy p0 ctrl0 + and ctrl1' = Path.Point.get_coord' @@ Path.Point.copy p1 ctrl1 in + M.quadratic_to + (p0, ctrl0, ctrl1, p1) + ( Path.Point.copy p0 @@ Path.Point.get_coord' p0 + , ctrl0' + , ctrl1' + , Path.Point.copy p1 @@ Path.Point.get_coord' p1 ) + t - let ctrl0' = Path.Point.get_coord' @@ Path.Point.copy p0 ctrl0 - and ctrl1' = Path.Point.get_coord' @@ Path.Point.copy p1 ctrl1 in - M.quadratic_to - (p0, ctrl0, ctrl1, p1) - (Path.Point.copy p0 @@ Path.Point.get_coord' p0, ctrl0', ctrl1', Path.Point.copy p1 @@ Path.Point.get_coord' p1) - - t - let stop = M.stop end (** Transform the two path, into a single one. *) module ReprSingle = struct - type point = Path.Point.t type repr = - | Move of (point) + | Move of point | Line_to of (point * point) | Quadratic of (point * Gg.v2 * Gg.v2 * point) @@ -98,42 +85,35 @@ module ReprSingle = struct type point = Path.Point.t - let start t actions = - (Move t)::actions + let start t actions = Move t :: actions - let line_to p0 p1 actions = - Line_to (p0, p1)::actions + let line_to p0 p1 actions = Line_to (p0, p1) :: actions - let quadratic_to - : (point * Gg.v2 * Gg.v2 * point) -> t -> t - = fun q actions -> - (Quadratic q)::actions + let quadratic_to : point * Gg.v2 * Gg.v2 * point -> t -> t = + fun q actions -> Quadratic q :: actions - let stop - : t -> t - = fun v -> v + let stop : t -> t = fun v -> v end - let repr - : (module PATH with type t = 't) -> 't -> 't -> repr list * repr list - = fun (type t) (module P:PATH with type t = t) path back -> - let path = P.repr path (module R) [] - and back = P.repr back (module R) [] in - path, back + let repr : (module PATH with type t = 't) -> 't -> 't -> repr list * repr list + = + fun (type t) (module P : PATH with type t = t) path back -> + let path = P.repr path (module R) [] + and back = P.repr back (module R) [] in + (path, back) end (* Canva representation *) -module FillCanva = FillEngine.Make(CanvaPrinter) -module LineCanva = LineEngine.Make(CanvaPrinter) -module DuctusCanva = DuctusEngine.Make(CanvaPrinter) +module FillCanva = FillEngine.Make (CanvaPrinter) +module LineCanva = LineEngine.Make (CanvaPrinter) +module DuctusCanva = DuctusEngine.Make (CanvaPrinter) (* SVG representation *) -module FillSVG = FillEngine.Make(Svg) -module DuctusSVG = DuctusEngine.Make(Svg) - +module FillSVG = FillEngine.Make (Svg) +module DuctusSVG = DuctusEngine.Make (Svg) (** Draw a path to a canva.contents @@ -141,104 +121,136 @@ module DuctusSVG = DuctusEngine.Make(Svg) main stroke, and the interior one) are evaluated. Then, they are both rendered using the selected engine. *) -let to_canva - : (module PATH with type t = 's) -> 's * 's -> Brr_canvas.C2d.t -> printer -> unit - = fun (type s) (module R:PATH with type t = s) (path, back) ctx engine -> - let f, b = ReprSingle.repr (module R) path back in - match engine with - | `Fill -> - let t = List.fold_left2 f b - ~init:(FillCanva.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - ~f:(fun ctx f b -> - match (f, b) with - | ReprSingle.Move p0, ReprSingle.Move p0' -> FillCanva.start p0 p0' ctx - | ReprSingle.Line_to l, ReprSingle.Line_to l' -> FillCanva.line_to l l' ctx - | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> FillCanva.quadratic_to q q' ctx - | _ -> ctx - ) in - FillCanva.get t - |> Brr_canvas.C2d.stroke ctx - | `Line -> - let t = List.fold_left2 f b - ~init:(LineCanva.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - ~f:(fun ctx f b -> - match (f, b) with - | ReprSingle.Move p0, ReprSingle.Move p0' -> LineCanva.start p0 p0' ctx - | ReprSingle.Line_to l, ReprSingle.Line_to l' -> LineCanva.line_to l l' ctx - | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> LineCanva.quadratic_to q q' ctx - | _ -> ctx - ) in - LineCanva.get t - |> Brr_canvas.C2d.stroke ctx - | `Ductus -> - let t = List.fold_left2 f b - ~init:(DuctusCanva.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - ~f:(fun ctx f b -> - match (f, b) with - | ReprSingle.Move p0, ReprSingle.Move p0' -> DuctusCanva.start p0 p0' ctx - | ReprSingle.Line_to l, ReprSingle.Line_to l' -> DuctusCanva.line_to l l' ctx - | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> DuctusCanva.quadratic_to q q' ctx - | _ -> ctx - ) in - DuctusCanva.get t - |> Brr_canvas.C2d.stroke ctx - +let to_canva : + (module PATH with type t = 's) + -> 's * 's + -> Brr_canvas.C2d.t + -> printer + -> unit = + fun (type s) (module R : PATH with type t = s) (path, back) ctx engine -> + let f, b = ReprSingle.repr (module R) path back in + match engine with + | `Fill -> + let t = + List.fold_left2 + f + b + ~init: + (FillCanva.create_path (fun p -> + Brr_canvas.C2d.fill ctx p; + p ) ) + ~f:(fun ctx f b -> + match (f, b) with + | ReprSingle.Move p0, ReprSingle.Move p0' -> + FillCanva.start p0 p0' ctx + | ReprSingle.Line_to l, ReprSingle.Line_to l' -> + FillCanva.line_to l l' ctx + | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> + FillCanva.quadratic_to q q' ctx + | _ -> ctx ) + in + FillCanva.get t |> Brr_canvas.C2d.stroke ctx + | `Line -> + let t = + List.fold_left2 + f + b + ~init: + (LineCanva.create_path (fun p -> + Brr_canvas.C2d.fill ctx p; + p ) ) + ~f:(fun ctx f b -> + match (f, b) with + | ReprSingle.Move p0, ReprSingle.Move p0' -> + LineCanva.start p0 p0' ctx + | ReprSingle.Line_to l, ReprSingle.Line_to l' -> + LineCanva.line_to l l' ctx + | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> + LineCanva.quadratic_to q q' ctx + | _ -> ctx ) + in + LineCanva.get t |> Brr_canvas.C2d.stroke ctx + | `Ductus -> + let t = + List.fold_left2 + f + b + ~init: + (DuctusCanva.create_path (fun p -> + Brr_canvas.C2d.fill ctx p; + p ) ) + ~f:(fun ctx f b -> + match (f, b) with + | ReprSingle.Move p0, ReprSingle.Move p0' -> + DuctusCanva.start p0 p0' ctx + | ReprSingle.Line_to l, ReprSingle.Line_to l' -> + DuctusCanva.line_to l l' ctx + | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> + DuctusCanva.quadratic_to q q' ctx + | _ -> ctx ) + in + DuctusCanva.get t |> Brr_canvas.C2d.stroke ctx (** Draw a path and represent it as SVG *) -let to_svg - : (module PATH with type t = 's) -> color:Jstr.t -> 's * 's -> printer -> Brr.El.t - = fun (type s) (module R:PATH with type t = s) ~color (path, back) engine -> - let f, b = ReprSingle.repr (module R) path back in - match engine with - | `Fill -> - - (* In order to deal with over crossing path, I cut the path in as - many segment as there is curve, and fill them all. Then, all of theme - are grouped inside a single element *) - let paths = ref [] in - let init = (FillSVG.create_path - (fun p -> - let repr = Svg.path - ~at:Brr.At.[ v (Jstr.v "d") p ] - [] in - - paths := repr::!paths; - Jstr.empty)) in - let _ = List.fold_left2 f b - ~init - ~f:(fun ctx f b -> - match (f, b) with - | ReprSingle.Move p0, ReprSingle.Move p0' -> FillSVG.start p0 p0' ctx - | ReprSingle.Line_to l, ReprSingle.Line_to l' -> FillSVG.line_to l l' ctx - | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> FillSVG.quadratic_to q q' ctx - | _ -> ctx - ) in - - Brr.El.v (Jstr.v "g") - ~at:Brr.At.[ - v (Jstr.v "fill") color - ; v (Jstr.v "stroke") color] - !paths - - | `Ductus -> - let init = DuctusSVG.create_path (fun _ -> Jstr.empty) in - let svg_path = List.fold_left2 f b - ~init - ~f:(fun ctx f b -> - match (f, b) with - | ReprSingle.Move p0, ReprSingle.Move p0' -> DuctusSVG.start p0 p0' ctx - | ReprSingle.Line_to l, ReprSingle.Line_to l' -> DuctusSVG.line_to l l' ctx - | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> DuctusSVG.quadratic_to q q' ctx - | _ -> ctx - ) - |> DuctusSVG.get in - - Svg.path - ~at:Brr.At.[ - v (Jstr.v "fill") color - ; v (Jstr.v "stroke") color - ; v (Jstr.v "d") svg_path ] - [] - | `Line -> - raise Not_found +let to_svg : + (module PATH with type t = 's) + -> color:Jstr.t + -> 's * 's + -> printer + -> Brr.El.t = + fun (type s) (module R : PATH with type t = s) ~color (path, back) engine -> + let f, b = ReprSingle.repr (module R) path back in + match engine with + | `Fill -> + (* In order to deal with over crossing path, I cut the path in as + many segment as there is curve, and fill them all. Then, all of theme + are grouped inside a single element *) + let paths = ref [] in + let init = + FillSVG.create_path (fun p -> + let repr = Svg.path ~at:Brr.At.[ v (Jstr.v "d") p ] [] in + + paths := repr :: !paths; + Jstr.empty ) + in + let _ = + List.fold_left2 f b ~init ~f:(fun ctx f b -> + match (f, b) with + | ReprSingle.Move p0, ReprSingle.Move p0' -> + FillSVG.start p0 p0' ctx + | ReprSingle.Line_to l, ReprSingle.Line_to l' -> + FillSVG.line_to l l' ctx + | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> + FillSVG.quadratic_to q q' ctx + | _ -> ctx ) + in + + Brr.El.v + (Jstr.v "g") + ~at:Brr.At.[ v (Jstr.v "fill") color; v (Jstr.v "stroke") color ] + !paths + | `Ductus -> + let init = DuctusSVG.create_path (fun _ -> Jstr.empty) in + let svg_path = + List.fold_left2 f b ~init ~f:(fun ctx f b -> + match (f, b) with + | ReprSingle.Move p0, ReprSingle.Move p0' -> + DuctusSVG.start p0 p0' ctx + | ReprSingle.Line_to l, ReprSingle.Line_to l' -> + DuctusSVG.line_to l l' ctx + | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> + DuctusSVG.quadratic_to q q' ctx + | _ -> ctx ) + |> DuctusSVG.get + in + + Svg.path + ~at: + Brr.At. + [ v (Jstr.v "fill") color + ; v (Jstr.v "stroke") color + ; v (Jstr.v "d") svg_path + ] + [] + | `Line -> raise Not_found diff --git a/script.it/layer/repr.ml b/script.it/layer/repr.ml index 552e2b7..4bc5520 100755 --- a/script.it/layer/repr.ml +++ b/script.it/layer/repr.ml @@ -1,21 +1,21 @@ -module type PRINTER = sig +module Path = Script_path +module type PRINTER = sig type t - val create: unit -> t + val create : unit -> t (* Start a new path. *) - val move_to: Gg.v2 -> t -> t + val move_to : Gg.v2 -> t -> t - val line_to: Gg.v2 -> t -> t + val line_to : Gg.v2 -> t -> t + val quadratic_to : Gg.v2 -> Gg.v2 -> Gg.v2 -> t -> t (** [quadratic_to ctrl0 ctrl1 p1] create a quadratic curve from the current point to [p1], with control points [ctrl0] and [ctrl1] *) - val quadratic_to: Gg.v2 -> Gg.v2 -> Gg.v2 -> t -> t + val close : t -> t (** Request for the path to be closed *) - val close: t -> t - end module type ENGINE = sig @@ -25,25 +25,16 @@ module type ENGINE = sig type repr - val get - : t -> repr - - val create_path - : (repr -> repr) -> t + val get : t -> repr - val start - : point -> point -> t -> t + val create_path : (repr -> repr) -> t - val line_to - : (point * point) -> (point * point) -> t -> t + val start : point -> point -> t -> t - val quadratic_to - : (point * Gg.v2 * Gg.v2 * point) - -> (point * Gg.v2 * Gg.v2 * point) - -> t - -> t + val line_to : point * point -> point * point -> t -> t - val stop - : t -> t + val quadratic_to : + point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t + val stop : t -> t end diff --git a/script.it/layer/wireFramePrinter.ml b/script.it/layer/wireFramePrinter.ml index 81ab271..e61bd7c 100755 --- a/script.it/layer/wireFramePrinter.ml +++ b/script.it/layer/wireFramePrinter.ml @@ -1,80 +1,69 @@ +module Path = Script_path module Point = Path.Point -module Make(Repr: Repr.PRINTER) = struct +module Make (Repr : Repr.PRINTER) = struct type t = Point.t type repr = - { back: (Repr.t -> Repr.t) - ; path: (Repr.t) + { back : Repr.t -> Repr.t + ; path : Repr.t ; last_point : Point.t option } - let create_path - : 'b -> repr - = fun _ -> - { back = Repr.close - ; path = Repr.create () - ; last_point = None - } + let create_path : 'b -> repr = + fun _ -> { back = Repr.close; path = Repr.create (); last_point = None } + (* Start a new path. *) - let start - : Point.t -> repr -> repr - = fun t {back; path; _} -> - let path = Repr.move_to (Point.get_coord t) path in - let line' = Repr.line_to (Point.get_coord' t) in - { back = (fun p -> back @@ line' p) - ; path - ; last_point = Some t - } - - let line_to - : Point.t -> Point.t -> repr -> repr - = fun _ t {back; path; _} -> - let line' = Repr.line_to (Point.get_coord' t) in - { back = (fun t -> back @@ line' t) - ; path = Repr.line_to (Point.get_coord t) path - ; last_point = Some t - } - - let quadratic_to - : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr - = fun p0 ctrl0 ctrl1 p1 t -> - - let ctrl0' = Point.copy p1 ctrl0 - and ctrl1' = Point.copy p1 ctrl1 in - - let line' path = - Repr.quadratic_to - (Point.get_coord' @@ ctrl1') - (Point.get_coord' ctrl0') - (Point.get_coord' p0) path in - - let path = Repr.quadratic_to - (Point.get_coord ctrl0') - (Point.get_coord ctrl1') - (Point.get_coord p1) - t.path in - { back = (fun p -> t.back @@ line' p) - ; path - ; last_point = Some p1 - } - - let stop - : repr -> repr - = fun {back; path; last_point} -> - - let path = - match last_point with - | Some point -> Repr.line_to (Point.get_coord' point) path - | None -> path in - - { back = (fun x -> x) - ; path = back path - ; last_point = None } - - let get - : repr -> Repr.t - = fun {back; path; _} -> - back path + let start : Point.t -> repr -> repr = + fun t { back; path; _ } -> + let path = Repr.move_to (Point.get_coord t) path in + let line' = Repr.line_to (Point.get_coord' t) in + { back = (fun p -> back @@ line' p); path; last_point = Some t } + + + let line_to : Point.t -> Point.t -> repr -> repr = + fun _ t { back; path; _ } -> + let line' = Repr.line_to (Point.get_coord' t) in + { back = (fun t -> back @@ line' t) + ; path = Repr.line_to (Point.get_coord t) path + ; last_point = Some t + } + + + let quadratic_to : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr = + fun p0 ctrl0 ctrl1 p1 t -> + let ctrl0' = Point.copy p1 ctrl0 + and ctrl1' = Point.copy p1 ctrl1 in + + let line' path = + Repr.quadratic_to + (Point.get_coord' @@ ctrl1') + (Point.get_coord' ctrl0') + (Point.get_coord' p0) + path + in + + let path = + Repr.quadratic_to + (Point.get_coord ctrl0') + (Point.get_coord ctrl1') + (Point.get_coord p1) + t.path + in + { back = (fun p -> t.back @@ line' p); path; last_point = Some p1 } + + + let stop : repr -> repr = + fun { back; path; last_point } -> + let path = + match last_point with + | Some point -> Repr.line_to (Point.get_coord' point) path + | None -> path + in + + { back = (fun x -> x); path = back path; last_point = None } + + + let get : repr -> Repr.t = fun { back; path; _ } -> back path end diff --git a/script.it/layer/wireFramePrinter.mli b/script.it/layer/wireFramePrinter.mli index b198d58..3b18814 100755 --- a/script.it/layer/wireFramePrinter.mli +++ b/script.it/layer/wireFramePrinter.mli @@ -1,27 +1,21 @@ -module Make(Repr:Repr.PRINTER): sig +module Path = Script_path - type repr +module Make (Repr : Repr.PRINTER) : sig + type repr type t = Path.Point.t - val create_path - : 'b -> repr + val create_path : 'b -> repr (* Start a new path. *) - val start - : Path.Point.t -> repr -> repr + val start : Path.Point.t -> repr -> repr - val line_to - : Path.Point.t -> Path.Point.t -> repr -> repr + val line_to : Path.Point.t -> Path.Point.t -> repr -> repr - val quadratic_to - : Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr + val quadratic_to : + Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr - val stop - : repr -> repr - - - val get - : repr -> Repr.t + val stop : repr -> repr + val get : repr -> Repr.t end diff --git a/script.it/outline/dune b/script.it/outline/dune index 73b7998..16a475c 100755 --- a/script.it/outline/dune +++ b/script.it/outline/dune @@ -1,7 +1,7 @@ (library (name outline) (libraries - path) + script_path) (modules outline) (preprocess (pps ppx_hash js_of_ocaml-ppx)) ) diff --git a/script.it/outline/outline.ml b/script.it/outline/outline.ml index 1df7588..588084e 100755 --- a/script.it/outline/outline.ml +++ b/script.it/outline/outline.ml @@ -1,11 +1,12 @@ open StdLabels +module Path = Script_path let internal_path_id = ref 0 type t = { id : int - ; path: Path.Fixed.t - ; back: Path.Fixed.t + ; path : Path.Fixed.t + ; back : Path.Fixed.t } let get_id () = @@ -13,9 +14,6 @@ let get_id () = incr internal_path_id; id -let find - : t list -> int -> t option - = fun ts id -> - List.find_opt - ts - ~f:(fun p -> p.id = id) + +let find : t list -> int -> t option = + fun ts id -> List.find_opt ts ~f:(fun p -> p.id = id) diff --git a/script.it/path/dune b/script.it/path/dune index 863c768..699f7fe 100755 --- a/script.it/path/dune +++ b/script.it/path/dune @@ -1,5 +1,5 @@ (library - (name path) + (name script_path) (libraries gg shapes diff --git a/script.it/path/path.ml b/script.it/path/path.ml deleted file mode 100755 index ea90de4..0000000 --- a/script.it/path/path.ml +++ /dev/null @@ -1,7 +0,0 @@ -(** Common module for ensuring that the function is evaluated only once *) - -module Point = Point -module Repr = Repr -module Path_Builder = Builder.Make(Point) -module Fixed = Fixed.Make(Point) - diff --git a/script.it/path/script_path.ml b/script.it/path/script_path.ml new file mode 100755 index 0000000..ea90de4 --- /dev/null +++ b/script.it/path/script_path.ml @@ -0,0 +1,7 @@ +(** Common module for ensuring that the function is evaluated only once *) + +module Point = Point +module Repr = Repr +module Path_Builder = Builder.Make(Point) +module Fixed = Fixed.Make(Point) + diff --git a/script.it/script.ml b/script.it/script.ml index eb12458..e4cec67 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -2,13 +2,13 @@ open StdLabels open Note open Brr open Brr_note - module State = Script_state.State module Selection = Script_state.Selection +module Path = Script_path + +let post : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit = + Brr_webworkers.Worker.post -let post - : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit - = Brr_webworkers.Worker.post type canva_events = [ `MouseDown of float * float @@ -16,71 +16,54 @@ type canva_events = ] (** Create the element in the page, and the event handler *) -let canva - : Brr.El.t -> canva_events Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t - = fun element -> - - (* Adapt the width to the window *) - El.set_inline_style - El.Style.width - (Jstr.v "100%") - element; - - (* See https://stackoverflow.com/a/14855870/13882826 *) - El.set_inline_style - El.Style.height - (Jstr.v "100%") - element; - - El.set_prop - El.Prop.width - (El.prop Elements.Prop.offsetWidth element) - element; - - El.set_prop - El.Prop.height - (El.prop Elements.Prop.offsetHeight element) - element; - - El.set_inline_style - El.Style.width - (Jstr.v "") - element; - - let module C = Brr_canvas.Canvas in - let c = C.of_el element in - - (* Mouse events *) - let mouse = Brr_note_kit.Mouse.on_el - ~normalize:false - (fun x y -> (x, y)) element in - - let click = - Brr_note_kit.Mouse.left_down mouse - |> E.map (fun c -> `MouseDown c) in - - let up = - Brr_note_kit.Mouse.left_up mouse - |> E.map (fun c -> `Out c) in - - let position = Brr_note_kit.Mouse.pos mouse in - - let pos = S.l2 - (fun b pos -> - if b then - Some pos - else - None ) - (Brr_note_kit.Mouse.left mouse) - position in - - E.select [click; up], pos, c - -let click_event el = - Evr.on_el - Ev.click - Evr.unit - el +let canva : + Brr.El.t + -> canva_events Note.E.t + * (float * float) option Note.S.t + * Brr_canvas.Canvas.t = + fun element -> + (* Adapt the width to the window *) + El.set_inline_style El.Style.width (Jstr.v "100%") element; + + (* See https://stackoverflow.com/a/14855870/13882826 *) + El.set_inline_style El.Style.height (Jstr.v "100%") element; + + El.set_prop El.Prop.width (El.prop Elements.Prop.offsetWidth element) element; + + El.set_prop + El.Prop.height + (El.prop Elements.Prop.offsetHeight element) + element; + + El.set_inline_style El.Style.width (Jstr.v "") element; + + let module C = Brr_canvas.Canvas in + let c = C.of_el element in + + (* Mouse events *) + let mouse = + Brr_note_kit.Mouse.on_el ~normalize:false (fun x y -> (x, y)) element + in + + let click = + Brr_note_kit.Mouse.left_down mouse |> E.map (fun c -> `MouseDown c) + in + + let up = Brr_note_kit.Mouse.left_up mouse |> E.map (fun c -> `Out c) in + + let position = Brr_note_kit.Mouse.pos mouse in + + let pos = + S.l2 + (fun b pos -> if b then Some pos else None) + (Brr_note_kit.Mouse.left mouse) + position + in + + (E.select [ click; up ], pos, c) + + +let click_event el = Evr.on_el Ev.click Evr.unit el type 'a param_events = { width : float S.t @@ -92,129 +75,124 @@ type 'a param_events = type slider = { input : El.t - ; legend : El.t } - -let set_sidebar - : El.t -> State.state -> _ param_events * slider * slider - = fun element state -> - - let delete = - El.button - [ El.i - ~at:At.[ class' (Jstr.v "fas") - ; class' (Jstr.v "fa-times-circle") ] - [] - ; El.txt' "Delete "] in - - let delete_event = click_event delete in - - let export = - El.button - [ El.i - ~at:At.[ class' (Jstr.v "fas") - ; class' (Jstr.v "fa-download") ] - [] - ; El.txt' "Download"] in - let export_event = click_event export in - - let nib_size, nib_size_event = - Elements.Input.slider - ~at:At.[ type' (Jstr.v "range") - ; v (Jstr.v "min") (Jstr.v "1") - ; v (Jstr.v "max") (Jstr.v "50") - ; At.value (Jstr.of_float state.width) - ] in - - let width = El.div [] in - let width_slider = - { input = nib_size - ; legend = width } in - - let input_angle, angle_event = - Elements.Input.slider - ~at:At.[ type' (Jstr.v "range") - ; v (Jstr.v "min") (Jstr.v "0") - ; v (Jstr.v "max") (Jstr.v "90") - ; At.value (Jstr.of_float state.angle) - ] in - - let angle = El.div [] in - let angle_slider = - { input = input_angle - ; legend = angle } in - - let render = - El.select - [ El.option ~at:At.[value (Jstr.v "1")] - [ El.txt' "Fill"] - ; El.option ~at:At.[value (Jstr.v "3")] - [ El.txt' "Ductus"] - ] in - - let rendering' = El.div - [ El.txt' "Rendering : " - ; render ] in - - let render_event = - Evr.on_el - Ev.change (fun _ -> - let raw_value = El.prop El.Prop.value render - |> Jstr.to_int in - let render_type = match raw_value with - | Some 1 -> `Fill - | Some 2 -> `Line - | Some 3 -> `Ductus - | _ -> `Fill in - - let module M = struct - type t = Layer.Paths.printer - let process t state = { state with State.rendering = t } - end - in - State.dispatch (module M) render_type + ; legend : El.t + } - ) rendering' in +let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = + fun element state -> + let delete = + El.button + [ El.i + ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-times-circle") ] + [] + ; El.txt' "Delete " + ] + in - let () = - El.append_children element - [ El.hr () - ; delete - ; export + let delete_event = click_event delete in - ; rendering' + let export = + El.button + [ El.i ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-download") ] [] + ; El.txt' "Download" + ] + in + let export_event = click_event export in + + let nib_size, nib_size_event = + Elements.Input.slider + ~at: + At. + [ type' (Jstr.v "range") + ; v (Jstr.v "min") (Jstr.v "1") + ; v (Jstr.v "max") (Jstr.v "50") + ; At.value (Jstr.of_float state.width) + ] + in - ; El.hr () + let width = El.div [] in + let width_slider = { input = nib_size; legend = width } in + + let input_angle, angle_event = + Elements.Input.slider + ~at: + At. + [ type' (Jstr.v "range") + ; v (Jstr.v "min") (Jstr.v "0") + ; v (Jstr.v "max") (Jstr.v "90") + ; At.value (Jstr.of_float state.angle) + ] + in + + let angle = El.div [] in + let angle_slider = { input = input_angle; legend = angle } in - ; width - ; nib_size + let render = + El.select + [ El.option ~at:At.[ value (Jstr.v "1") ] [ El.txt' "Fill" ] + ; El.option ~at:At.[ value (Jstr.v "3") ] [ El.txt' "Ductus" ] + ] + in - ; angle - ; input_angle + let rendering' = El.div [ El.txt' "Rendering : "; render ] in + + let render_event = + Evr.on_el + Ev.change + (fun _ -> + let raw_value = El.prop El.Prop.value render |> Jstr.to_int in + let render_type = + match raw_value with + | Some 1 -> `Fill + | Some 2 -> `Line + | Some 3 -> `Ductus + | _ -> `Fill + in + + let module M = struct + type t = Layer.Paths.printer + + let process t state = { state with State.rendering = t } + end in + State.dispatch (module M) render_type ) + rendering' + in + + let () = + El.append_children + element + [ El.hr () + ; delete + ; export + ; rendering' + ; El.hr () + ; width + ; nib_size + ; angle + ; input_angle + ] + in + ( { delete = delete_event + ; angle = angle_event + ; width = nib_size_event + ; export = export_event + ; rendering = render_event + } + , angle_slider + , width_slider ) - ] - in - ( { delete = delete_event - ; angle = angle_event - ; width = nib_size_event - ; export = export_event - ; rendering = render_event } - , angle_slider - , width_slider - ) let backgroundColor = Blog.Nord.nord0 + let white = Jstr.v "#eceff4" + let green = Jstr.v "#a3be8c" let draw_point point context = let module Cd2d = Brr_canvas.C2d in 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 + Cd2d.stroke_rect ~x:(x -. 5.) ~y:(y -. 5.) ~w:10. ~h:10. context + (** Redraw the canva on update *) let on_change canva mouse_position timer state = @@ -222,17 +200,14 @@ let on_change canva mouse_position timer state = let pos_v2 = Option.map Gg.V2.of_tuple pos in let module Cd2d = Brr_canvas.C2d in - - let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in + let w, h = + Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) + in let context = Cd2d.create canva in Cd2d.set_fill_style context (Cd2d.color backgroundColor); - Cd2d.fill_rect context - ~x:0.0 - ~y:0.0 - ~w - ~h; + Cd2d.fill_rect context ~x:0.0 ~y:0.0 ~w ~h; Cd2d.set_stroke_style context (Cd2d.color white); Cd2d.set_fill_style context (Cd2d.color white); @@ -240,177 +215,170 @@ let on_change canva mouse_position timer state = Otherwise, we would only display the previous registered point, which can be far away in the past, and would give to the user a sensation of lag. - *) let current = - begin match state.State.mode, pos with - | Edit, Some point -> + match (state.State.mode, pos) with + | Edit, Some point -> let stamp = Elements.Timer.delay timer in State.insert_or_replace state point stamp state.current - | _ -> - state.current - end + | _ -> state.current in - - let back = Path.Path_Builder.map - current - (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in - Layer.Paths.to_canva (module Path.Path_Builder) (current, back) context state.rendering; - - List.iter state.paths - ~f:(fun path -> - - let () = match state.mode with - | Selection (Path id) - | Selection (Point (id, _)) -> - begin match id = path.Outline.id with - | true -> - (* If the element is the selected one, change the color *) - Cd2d.set_fill_style context (Cd2d.color Blog.Nord.nord8); - Cd2d.set_stroke_style context (Cd2d.color Blog.Nord.nord8) - | false -> - Cd2d.set_stroke_style context (Cd2d.color white); - Cd2d.set_fill_style context (Cd2d.color white); - end - | _ -> () - in - - let p = path.Outline.path in - Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context state.rendering - ); + let back = + Path.Path_Builder.map current (fun pt -> + Path.Point.copy pt @@ Path.Point.get_coord' pt ) + in + Layer.Paths.to_canva + (module Path.Path_Builder) + (current, back) + context + state.rendering; + + List.iter state.paths ~f:(fun path -> + let () = + match state.mode with + | Selection (Path id) | Selection (Point (id, _)) -> + ( match id = path.Outline.id with + | true -> + (* If the element is the selected one, change the color *) + Cd2d.set_fill_style context (Cd2d.color Blog.Nord.nord8); + Cd2d.set_stroke_style context (Cd2d.color Blog.Nord.nord8) + | false -> + Cd2d.set_stroke_style context (Cd2d.color white); + Cd2d.set_fill_style context (Cd2d.color white) ) + | _ -> () + in + + let p = path.Outline.path in + Layer.Paths.to_canva + (module Path.Fixed) + (p, path.Outline.back) + context + state.rendering ); (* Draw the selected path, and operate the modifications directly as a preview *) - let () = match state.mode with + let () = + match state.mode with | Selection t -> - Cd2d.set_stroke_style context (Cd2d.color white); - begin match pos_v2, Selection.find_selection t state.paths with + Cd2d.set_stroke_style context (Cd2d.color white); + ( match (pos_v2, Selection.find_selection t state.paths) with (* The selected element does not exist, just do nothing *) | _, None -> () - (* There is no click on the canva, print the line *) | None, Some (Path outline) -> - Layer.Paths.to_canva - (module Path.Fixed) - (outline.path, outline.back) - context - `Line; - - (* The user is modifiying the path *) + Layer.Paths.to_canva + (module Path.Fixed) + (outline.path, outline.back) + context + `Line + (* The user is modifiying the path *) | Some pos_v2, Some (Path outline) -> - (* Translate the path *) - let delta = Gg.V2.(pos_v2 - state.State.mouse_down_position) in - let path = Path.Fixed.map - outline.Outline.path - (fun pt -> Path.Point.get_coord pt - |> Gg.V2.add delta - |> Path.Point.copy pt) in - Layer.Paths.to_canva - (module Path.Fixed) - (path, path) - context - `Line; - - (* The user is modifiying the point *) - | Some pos_v2, Some (Point (outline, point)) when Elements.Timer.delay timer > 0.3 -> - let point' = Path.Point.copy point pos_v2 in - let path = begin match Path.Fixed.replace_point outline.Outline.path point' with - | None -> outline.Outline.path - | Some p -> p - end in - - Layer.Paths.to_canva - (module Path.Fixed) - (path, path) - context - `Line; - draw_point point context + (* Translate the path *) + let delta = Gg.V2.(pos_v2 - state.State.mouse_down_position) in + let path = + Path.Fixed.map outline.Outline.path (fun pt -> + Path.Point.get_coord pt + |> Gg.V2.add delta + |> Path.Point.copy pt ) + in + Layer.Paths.to_canva (module Path.Fixed) (path, path) context `Line + (* The user is modifiying the point *) + | Some pos_v2, Some (Point (outline, point)) + when Elements.Timer.delay timer > 0.3 -> + let point' = Path.Point.copy point pos_v2 in + let path = + match Path.Fixed.replace_point outline.Outline.path point' with + | None -> outline.Outline.path + | Some p -> p + in + Layer.Paths.to_canva (module Path.Fixed) (path, path) context `Line; + draw_point point context | _, Some (Point (outline, point)) -> - Layer.Paths.to_canva - (module Path.Fixed) - (outline.path, outline.back) - context - `Line; - draw_point point context - - end + Layer.Paths.to_canva + (module Path.Fixed) + (outline.path, outline.back) + context + `Line; + draw_point point context ) | _ -> () in () + let spawn_worker () = - try Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js")) - with Jv.Error e -> Error e + try Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js")) with + | Jv.Error e -> Error e -let page_main id = +let page_main id = let timer, tick = Elements.Timer.create () in let parameters, angle_element, width_slider = - begin match Blog.Sidebar.get () with - | None -> - Jv.throw (Jstr.v "No sidebar") - | Some el -> - + match Blog.Sidebar.get () with + | None -> Jv.throw (Jstr.v "No sidebar") + | Some el -> Blog.Sidebar.clean el; set_sidebar el State.init - end in - - begin match (Jv.is_none id) with - | true -> Console.(error [str "No element with id '%s' found"; id]) - | false -> - - match spawn_worker () with - | Error e -> El.set_children (Jv.Id.of_jv id) - [ El.p El.[txt (Jv.Error.message e)]] - - | Ok worker -> + in + match Jv.is_none id with + | true -> Console.(error [ str "No element with id '%s' found"; id ]) + | false -> + ( match spawn_worker () with + | Error e -> + El.set_children + (Jv.Id.of_jv id) + [ El.p El.[ txt (Jv.Error.message e) ] ] + | Ok worker -> let worker_event, worker_send = E.create () in - let delete_event = E.map + let delete_event = + E.map (fun () -> - let module Delete = Script_event.Delete in - State.dispatch (module Delete) Delete.{ worker }) + let module Delete = Script_event.Delete in + State.dispatch (module Delete) Delete.{ worker } ) parameters.delete - and export_event = - E.map (fun () -> + E.map + (fun () -> let module Export = Script_event.Export in - State.dispatch (module Export ) ()) + State.dispatch (module Export) () ) parameters.export - and angle_event = S.changes parameters.angle - |> E.map (fun value -> - let module Property = Script_event.Property in - State.dispatch (module Property) (Property.{ value ; worker ; prop = `Angle})) - - and width_event = S.changes parameters.width - |> E.map (fun value -> - let module Property = Script_event.Property in - State.dispatch (module Property) (Property.{ value ; worker ; prop = `Width })) - and worker_event = Note.E.filter_map + and angle_event = + S.changes parameters.angle + |> E.map (fun value -> + let module Property = Script_event.Property in + State.dispatch + (module Property) + Property.{ value; worker; prop = `Angle } ) + and width_event = + S.changes parameters.width + |> E.map (fun value -> + let module Property = Script_event.Property in + State.dispatch + (module Property) + Property.{ value; worker; prop = `Width } ) + and worker_event = + Note.E.filter_map (function | `Other t -> - Console.(log [t]); - None + Console.(log [ t ]); + None | `Complete outline -> - let module Complete_path = Script_event.Complete_path in - Some ( - State.dispatch (module Complete_path) outline)) - + let module Complete_path = Script_event.Complete_path in + Some (State.dispatch (module Complete_path) outline) ) worker_event in let my_host = Uri.host @@ Window.location @@ G.window in - if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then ( + ( if Hashtbl.hash my_host = Blog.Hash_host.expected_host + then let target = Brr_webworkers.Worker.as_target worker in - Ev.listen Brr_io.Message.Ev.message - (fun t -> - Ev.as_type t - |> Brr_io.Message.Ev.data - |> worker_send) - target); + Ev.listen + Brr_io.Message.Ev.message + (fun t -> Ev.as_type t |> Brr_io.Message.Ev.data |> worker_send) + target ); (* Add the events to the canva : @@ -420,25 +388,27 @@ let page_main id = - Get also the click event for starting to draw *) let canva_events, mouse_position, canva = canva (Jv.Id.of_jv id) in - let canva_events = Note.E.map + let canva_events = + Note.E.map (function | `MouseDown c -> - let module MouseDown = Script_event.Mouse_down in - State.dispatch (module MouseDown) MouseDown.{ position = c ; timer } - + let module MouseDown = Script_event.Mouse_down in + State.dispatch + (module MouseDown) + MouseDown.{ position = c; timer } | `Out c -> - let module Click = Script_event.Click in - State.dispatch (module Click) Click.{ point = c ; worker ; timer } - ) canva_events in + let module Click = Script_event.Click in + State.dispatch + (module Click) + Click.{ point = c; worker; timer } ) + canva_events + in let tick_event = - S.sample_filter mouse_position - ~on:tick - (fun pos f -> - let module Tick = Script_event.Tick in - Option.map (fun p -> - State.dispatch (module Tick) (f, p)) - pos ) in + S.sample_filter mouse_position ~on:tick (fun pos f -> + let module Tick = Script_event.Tick in + Option.map (fun p -> State.dispatch (module Tick) (f, p)) pos ) + in (* The first evaluation is the state. Which is the result of all the successives events to the initial state *) @@ -453,69 +423,55 @@ let page_main id = ; width_event ; delete_event ; export_event - ; parameters.rendering ]) + ; parameters.rendering + ] ) in (* The seconde evaluation is the canva refresh, which only occurs when - the mouse is updated, or on delete events *) + the mouse is updated, or on delete events *) let _ = E.select [ E.map (fun _ -> ()) (S.changes mouse_position) ; E.map (fun _ -> ()) parameters.rendering ; E.map (fun _ -> ()) worker_event - ; parameters.delete ] - |> fun ev -> E.log ev (fun _ -> + ; parameters.delete + ] + |> fun ev -> + E.log ev (fun _ -> on_change canva mouse_position timer (S.value state) ) - |> Option.iter Logr.hold in - + |> Option.iter Logr.hold + in (* Ajust the angle slide according to the state *) let angle_signal = S.map (fun s -> Jstr.of_float s.State.angle) state in let _ = - Elr.def_prop - Elements.Prop.value - angle_signal - angle_element.input - - and _ = Elr.def_children + Elr.def_prop Elements.Prop.value angle_signal angle_element.input + and _ = + Elr.def_children angle_element.legend (S.map - (fun v -> - [ El.txt' "Angle : " - ; El.txt v - ; El.txt' "°" ] ) - angle_signal) in + (fun v -> [ El.txt' "Angle : "; El.txt v; El.txt' "°" ]) + angle_signal ) + in let width_signal = S.map (fun s -> Jstr.of_float s.State.width) state in - let _ = - Elr.def_prop - Elements.Prop.value - width_signal - width_slider.input - - and _ = Elr.def_children + let _ = Elr.def_prop Elements.Prop.value width_signal width_slider.input + and _ = + Elr.def_children width_slider.legend - (S.map (fun v -> - [ El.txt' "Width : " - ; El.txt v ] - ) - width_signal - ) in + (S.map (fun v -> [ El.txt' "Width : "; El.txt v ]) width_signal) + in (* Draw the canva for first time *) on_change canva mouse_position timer State.init; (* Hold the state *) let _ = Logr.hold (S.log state (fun _ -> ())) in - () + () ) - end let () = - let open Jv in - let drawer = obj - [| "run", (repr page_main) - |] in + let drawer = obj [| ("run", repr page_main) |] in set global "drawer" drawer diff --git a/script.it/script_event/click.ml b/script.it/script_event/click.ml index b7ffcb6..d1fd2e2 100755 --- a/script.it/script_event/click.ml +++ b/script.it/script_event/click.ml @@ -1,12 +1,14 @@ module State = Script_state.State module Selection = Script_state.Selection +module Path = Script_path (** Handle a click outside of the selection *) -type t = { point : float * float - ; timer : Elements.Timer.t - ; worker : Brr_webworkers.Worker.t - } +type t = + { point : float * float + ; timer : Elements.Timer.t + ; worker : Brr_webworkers.Worker.t + } (** The drag function is incorrectly named, as we dont't care if we are selecting an element or not. @@ -14,78 +16,62 @@ type t = { point : float * float But, in the case we are (point, path…), we effectively move the element with the mouse. *) let drag mouse_coord state worker = function | State.Selection t -> - let mouse_v2 = Gg.V2.of_tuple mouse_coord in - begin match Selection.find_selection t state.State.paths with + let mouse_v2 = Gg.V2.of_tuple mouse_coord in + ( match Selection.find_selection t state.State.paths with | None -> state | Some (Point (path, point)) -> - let point' = Path.Point.copy point mouse_v2 in - State.post worker (`TranslatePoint (point', path)); - (* Just replace the position of the selected point *) - { state with mode = Selection (Point (path.id, point')) } + let point' = Path.Point.copy point mouse_v2 in + State.post worker (`TranslatePoint (point', path)); + (* Just replace the position of the selected point *) + { state with mode = Selection (Point (path.id, point')) } | Some (Path path) -> - let delta = Gg.V2.(mouse_v2 - state.State.mouse_down_position) in - State.post worker (`TranslatePath (path, delta)); - state - end + let delta = Gg.V2.(mouse_v2 - state.State.mouse_down_position) in + State.post worker (`TranslatePath (path, delta)); + state ) (* TODO Long click in out mode should translate the whole slate *) | _ -> state -let process {point; timer ; worker} state = - match state.State.mode with +let process { point; timer; worker } state = + match state.State.mode with | Edit -> - let stamp = Elements.Timer.delay timer in - Elements.Timer.stop timer; - begin match Path.Path_Builder.peek2 state.current with + let stamp = Elements.Timer.delay timer in + Elements.Timer.stop timer; + ( match Path.Path_Builder.peek2 state.current with (* If there is at last two points selected, handle this as a curve creation. And we add the new point in the current path *) | Some _ -> + let current = + State.insert_or_replace state point stamp state.current + in + let path = Path.Fixed.to_fixed (module Path.Path_Builder) current in - let current = State.insert_or_replace state point stamp state.current in - let path = Path.Fixed.to_fixed - (module Path.Path_Builder) - current in - - (* Create a copy from the path with all the interior points *) - let back = Path.Fixed.map - path - (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in + (* Create a copy from the path with all the interior points *) + let back = + Path.Fixed.map path (fun pt -> + Path.Point.copy pt @@ Path.Point.get_coord' pt ) + in - let last = - Outline.{ path - ; back - ; id = Outline.get_id () - } - in + let last = Outline.{ path; back; id = Outline.get_id () } in - (* Send to the worker for a full review *) - let () = State.post worker (`Complete last) in + (* Send to the worker for a full review *) + let () = State.post worker (`Complete last) in - let state = - { state with - mode = Out - ; paths = last::state.paths - ; current = Path.Path_Builder.empty } in - state - - (* Else, check if there is a curve under the cursor, and remove it *) - | None -> - let current = Path.Path_Builder.empty in - begin match Selection.get_from_paths point state.paths with - | _, None -> + let state = { state with mode = Out - ; current + ; paths = last :: state.paths + ; current = Path.Path_Builder.empty } + in + state + (* Else, check if there is a curve under the cursor, and remove it *) + | None -> + let current = Path.Path_Builder.empty in + ( match Selection.get_from_paths point state.paths with + | _, None -> { state with mode = Out; current } | dist, Some selection -> - State.select_segment point selection { state with current } dist - - end - end - - | _ when Elements.Timer.delay timer < 0.3 -> - state - - | _ -> - drag point state worker state.mode - + State.select_segment point selection { state with current } dist + ) ) + | _ when Elements.Timer.delay timer < 0.3 -> state + | _ -> drag point state worker state.mode diff --git a/script.it/script_event/export.ml b/script.it/script_event/export.ml index 10dd937..db2f89c 100755 --- a/script.it/script_event/export.ml +++ b/script.it/script_event/export.ml @@ -1,30 +1,32 @@ open StdLabels open Brr module State = Script_state.State +module Path = Script_path type t = unit let process () state = let my_host = Uri.host @@ Window.location @@ G.window in - if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then ( + ( if Hashtbl.hash my_host = Blog.Hash_host.expected_host + then (* Convert the path into an sVG element *) - let svg = Layer.Svg.svg - ~at:Brr.At.[ - v (Jstr.v "xmlns") (Jstr.v "http://www.w3.org/2000/svg") - ; v (Jstr.v "xmlns:xlink") (Jstr.v "http://www.w3.org/1999/xlink") ] - (List.map state.State.paths - ~f:(fun path -> - - Layer.Paths.to_svg - ~color:Blog.Nord.nord0 - (module Path.Fixed) - Outline.(path.path, path.back) - state.State.rendering - - )) in + let svg = + Layer.Svg.svg + ~at: + Brr.At. + [ v (Jstr.v "xmlns") (Jstr.v "http://www.w3.org/2000/svg") + ; v (Jstr.v "xmlns:xlink") (Jstr.v "http://www.w3.org/1999/xlink") + ] + (List.map state.State.paths ~f:(fun path -> + Layer.Paths.to_svg + ~color:Blog.Nord.nord0 + (module Path.Fixed) + Outline.(path.path, path.back) + state.State.rendering ) ) + in let content = El.prop Elements.Prop.outerHTML svg in Elements.Transfert.send ~mime_type:(Jstr.v "image/svg+xml") ~filename:(Jstr.v "out.svg") - content); + content ); state diff --git a/script.it/script_event/mouse_down.ml b/script.it/script_event/mouse_down.ml index 1c25a7d..88fefb4 100755 --- a/script.it/script_event/mouse_down.ml +++ b/script.it/script_event/mouse_down.ml @@ -1,84 +1,90 @@ module State = Script_state.State module Selection = Script_state.Selection +module Path = Script_path -type t = { position : float * float - ; timer : Elements.Timer.t } +type t = + { position : float * float + ; timer : Elements.Timer.t + } let process { position; timer } state = match state.State.mode with - | Out -> - let x, y = position in - Elements.Timer.start timer 0.3; - - let width = state.width - and angle = state.angle in + let x, y = position in + Elements.Timer.start timer 0.3; - let stamp = 0. in - let point = - match Selection.get_from_paths position state.paths with - | _, None -> - (* Start a new path with the point clicked *) - Path.Point.create ~x ~y ~angle ~width ~stamp - | _, 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 - Path.Point.create ~x ~y ~angle ~width ~stamp - in + let width = state.width + and angle = state.angle in - let current = Path.Path_Builder.add_point - point - state.current in - { state with - current - ; mode = Edit - ; mouse_down_position = Gg.V2.of_tuple (x, y)} - - | (Selection (Path id)) - | (Selection (Point (id, _))) -> + let stamp = 0. in + let point = + match Selection.get_from_paths position state.paths with + | _, None -> + (* Start a new path with the point clicked *) + Path.Point.create ~x ~y ~angle ~width ~stamp + | _, 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 + Path.Point.create ~x ~y ~angle ~width ~stamp + in - let get_any () = - begin match Selection.get_from_paths position state.paths with + let current = Path.Path_Builder.add_point point state.current in + { state with + current + ; mode = Edit + ; mouse_down_position = Gg.V2.of_tuple (x, y) + } + | Selection (Path id) | Selection (Point (id, _)) -> + let get_any () = + match Selection.get_from_paths position state.paths with | _, None -> - { state with - mode = Out - ; mouse_down_position = Gg.V2.of_tuple position } + { state with + mode = Out + ; mouse_down_position = Gg.V2.of_tuple position + } | dist, Some selection -> - let _, outline, _, _ = selection in - if outline.Outline.id != id then ( - let mouse_down_position = Gg.V2.of_tuple position in - State.select_segment position selection { state with mouse_down_position } dist - ) else - (* On the same segment, check for a point *) - let selection = Selection.select_point outline (Gg.V2.of_tuple position) in - match selection with - | Path _ -> - { state with - mode = Selection selection - ; mouse_down_position = Gg.V2.of_tuple position } - | Point (_, pt) -> - (* In order to handle the point move, start the timer *) - Elements.Timer.start timer 0.3; - { state with - mode = Selection selection - ; angle = Path.Point.get_angle pt - ; width = Path.Point.get_width pt - ; mouse_down_position = Gg.V2.of_tuple position } - end - in - (* First, check for a point in the selected path. If any of them in - found, check anything to select in all the elements *) - begin match Outline.find state.paths id with + let _, outline, _, _ = selection in + if outline.Outline.id != id + then + let mouse_down_position = Gg.V2.of_tuple position in + State.select_segment + position + selection + { state with mouse_down_position } + dist + else + (* On the same segment, check for a point *) + let selection = + Selection.select_point outline (Gg.V2.of_tuple position) + in + ( match selection with + | Path _ -> + { state with + mode = Selection selection + ; mouse_down_position = Gg.V2.of_tuple position + } + | Point (_, pt) -> + (* In order to handle the point move, start the timer *) + Elements.Timer.start timer 0.3; + { state with + mode = Selection selection + ; angle = Path.Point.get_angle pt + ; width = Path.Point.get_width pt + ; mouse_down_position = Gg.V2.of_tuple position + } ) + in + (* First, check for a point in the selected path. If any of them in + found, check anything to select in all the elements *) + ( match Outline.find state.paths id with | None -> get_any () | Some outline -> - begin match Selection.select_point outline (Gg.V2.of_tuple position) with - | Path _ -> get_any () - | other -> + ( match Selection.select_point outline (Gg.V2.of_tuple position) with + | Path _ -> get_any () + | other -> Elements.Timer.start timer 0.3; - {state with - mode = Selection other - ; mouse_down_position = Gg.V2.of_tuple position } - end - end + { state with + mode = Selection other + ; mouse_down_position = Gg.V2.of_tuple position + } ) ) | Edit -> state diff --git a/script.it/script_event/property.ml b/script.it/script_event/property.ml index dbdc1de..b41d3f8 100755 --- a/script.it/script_event/property.ml +++ b/script.it/script_event/property.ml @@ -1,52 +1,52 @@ module State = Script_state.State module Selection = Script_state.Selection +module Path = Script_path let update_property worker state value f = function | None -> state | Some (Selection.Path outline) -> - (* Change width for the whole path *) - let outline = { outline with - Outline.path = Path.Fixed.map outline.Outline.path (fun p -> - f p value) - } in - State.post worker (`Back outline); - state + (* Change width for the whole path *) + let outline = + { outline with + Outline.path = + Path.Fixed.map outline.Outline.path (fun p -> f p value) + } + in + State.post worker (`Back outline); + state | Some (Point (outline, point)) -> - let path = Path.Fixed.map - outline.path - (fun pt -> - match Path.Point.id pt = Path.Point.id point with - | false -> pt - | true -> f pt value) - in - let outline = {outline with path} in - State.post worker (`Back outline); - state + let path = + Path.Fixed.map outline.path (fun pt -> + match Path.Point.id pt = Path.Point.id point with + | false -> pt + | true -> f pt value ) + in + let outline = { outline with path } in + State.post worker (`Back outline); + state -type t = { prop : [`Angle | `Width ] - ; value : float - ; worker : Brr_webworkers.Worker.t - } -let process { prop; value ; worker } state = +type t = + { prop : [ `Angle | `Width ] + ; value : float + ; worker : Brr_webworkers.Worker.t + } + +let process { prop; value; worker } state = match prop with | `Angle -> - let angle = value in - begin match state.State.mode with - + let angle = value in + ( match state.State.mode with | Selection t -> - let state = { state with angle } in - Selection.find_selection t state.paths - |> update_property worker state angle Path.Point.set_angle - | _ -> { state with angle } - end + let state = { state with angle } in + Selection.find_selection t state.paths + |> update_property worker state angle Path.Point.set_angle + | _ -> { state with angle } ) | `Width -> - let width = value in - begin match state.State.mode with - + let width = value in + ( match state.State.mode with | Selection t -> - let state = { state with width } in - Selection.find_selection t state.paths - |> update_property worker state width Path.Point.set_width - | _ -> { state with width } - end + let state = { state with width } in + Selection.find_selection t state.paths + |> update_property worker state width Path.Point.set_width + | _ -> { state with width } ) diff --git a/script.it/state/dune b/script.it/state/dune index 7d4ef3f..d838c04 100755 --- a/script.it/state/dune +++ b/script.it/state/dune @@ -8,6 +8,6 @@ worker_messages outline layer - path + script_path ) ) diff --git a/script.it/state/selection.ml b/script.it/state/selection.ml index f5f135a..3590a98 100755 --- a/script.it/state/selection.ml +++ b/script.it/state/selection.ml @@ -1,4 +1,5 @@ open StdLabels +module Path = Script_path type 'a selection = | Path of 'a @@ -6,59 +7,55 @@ type 'a selection = type t = int selection -let find_selection - : int selection -> Outline.t list -> Outline.t selection option - = fun selection paths -> - match selection with - | Path id -> Option.map (fun p -> Path p) (Outline.find paths id) - | Point (id, pt) -> Option.map (fun p -> Point (p, pt)) (Outline.find paths id) +let find_selection : + int selection -> Outline.t list -> Outline.t selection option = + fun selection paths -> + match selection with + | Path id -> Option.map (fun p -> Path p) (Outline.find paths id) + | Point (id, pt) -> + Option.map (fun p -> Point (p, pt)) (Outline.find paths id) + let threshold = 20. -let get_from_paths - : (float * float) -> Outline.t list -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option - = fun position outlines -> - let point = Gg.V2.of_tuple position in - (* If the user click on a curve, select it *) - List.fold_left outlines - ~init:(threshold, None) - ~f:(fun (dist, selection) outline -> - match Path.Fixed.distance point outline.Outline.path with - | Some { closest_point ; distance; p0; p1 ; ratio} when distance < dist -> - ratio, Some (closest_point, outline, p0, p1) - | _ -> dist, selection - ) +let get_from_paths : + float * float + -> Outline.t list + -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option = + fun position outlines -> + let point = Gg.V2.of_tuple position in + (* If the user click on a curve, select it *) + List.fold_left + outlines + ~init:(threshold, None) + ~f:(fun (dist, selection) outline -> + match Path.Fixed.distance point outline.Outline.path with + | Some { closest_point; distance; p0; p1; ratio } when distance < dist -> + (ratio, Some (closest_point, outline, p0, p1)) + | _ -> (dist, selection) ) -let select_path - : Outline.t -> t - = fun outline -> Path outline.Outline.id -let select_point - : Outline.t -> Gg.v2 -> t - = fun outline v2_point -> +let select_path : Outline.t -> t = fun outline -> Path outline.Outline.id - let point' = ref None in - let dist = ref threshold in +let select_point : Outline.t -> Gg.v2 -> t = + fun outline v2_point -> + let point' = ref None in + let dist = ref threshold in - Path.Fixed.iter - outline.Outline.path - ~f:(fun p -> - let open Gg.V2 in - let new_dist = norm ((Path.Point.get_coord p) - v2_point) in - match (new_dist < !dist) with - | false -> () - | true -> - dist:= new_dist; - point' := Some p - ); + Path.Fixed.iter outline.Outline.path ~f:(fun p -> + let open Gg.V2 in + let new_dist = norm (Path.Point.get_coord p - v2_point) in + match new_dist < !dist with + | false -> () + | true -> + dist := new_dist; + point' := Some p ); - match !point' with - | Some point -> - Point (outline.Outline.id, point) - | None -> - Path (outline.Outline.id) + match !point' with + | Some point -> Point (outline.Outline.id, point) + | None -> Path outline.Outline.id - (* +(* (* 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 diff --git a/script.it/state/selection.mli b/script.it/state/selection.mli index 9792a2d..2020dab 100755 --- a/script.it/state/selection.mli +++ b/script.it/state/selection.mli @@ -1,3 +1,5 @@ +module Path = Script_path + type 'a selection = | Path of 'a | Point of ('a * Path.Point.t) @@ -6,6 +8,10 @@ type t = int selection val threshold : float +val get_from_paths : + float * float + -> Outline.t list + -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option (** Return the closest path from the list to a given point. The path is returned with all thoses informations : @@ -15,19 +21,15 @@ val threshold : float - The end point in the path *) -val get_from_paths - : (float * float) -> Outline.t list -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option -val select_path - : Outline.t -> t +val select_path : Outline.t -> t +val select_point : Outline.t -> Gg.v2 -> t (** Check for selecting a point on the given outline. If no point is available, select the path. *) -val select_point - : Outline.t -> Gg.v2 -> t -val find_selection - : int selection -> Outline.t list -> Outline.t selection option +val find_selection : + int selection -> Outline.t list -> Outline.t selection option diff --git a/script.it/state/state.ml b/script.it/state/state.ml index f3be91d..6c48979 100755 --- a/script.it/state/state.ml +++ b/script.it/state/state.ml @@ -1,3 +1,5 @@ +module Path = Script_path + type mode = | Edit | Selection of Selection.t @@ -19,48 +21,37 @@ type state = ; mouse_down_position : Gg.v2 } -include Application.Make(struct type t = state end) +include Application.Make (struct + type t = state +end) + +let post : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit = + Brr_webworkers.Worker.post -let post - : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit - = Brr_webworkers.Worker.post let insert_or_replace state ((x, y) as p) stamp path = let width = state.width and angle = state.angle in let point = Path.Point.create ~x ~y ~angle ~width ~stamp in match Path.Path_Builder.peek path with - | None -> - Path.Path_Builder.add_point - point - path + | None -> Path.Path_Builder.add_point point path | Some p1 -> - let open Gg.V2 in + let open Gg.V2 in + let p1' = Path.Point.get_coord p1 in - let p1' = Path.Point.get_coord p1 in + let dist = norm (p1' - of_tuple p) in + if dist < 5. then path else Path.Path_Builder.add_point point path - let dist = (norm (p1' - (of_tuple p))) in - if dist < 5. then ( - path - ) else ( - Path.Path_Builder.add_point - point - path - ) (** Select the given segment, and modify angle and width accordingly *) let select_segment _ (_, selected, p0, p1) state dist = - let point' = Path.Point.mix dist (Path.Point.get_coord p0) p0 p1 in - let angle = (Float.round @@ 10. *. Path.Point.get_angle point') /. 10. - and width = (Float.round @@ 10. *. Path.Point.get_width point') /. 10. in + let angle = (Float.round @@ (10. *. Path.Point.get_angle point')) /. 10. + and width = (Float.round @@ (10. *. Path.Point.get_width point')) /. 10. in let id = Selection.select_path selected in - { state with - mode = (Selection id) - ; angle - ; width } + { state with mode = Selection id; angle; width } let init = diff --git a/script.it/worker.ml b/script.it/worker.ml index 62104ec..9455765 100755 --- a/script.it/worker.ml +++ b/script.it/worker.ml @@ -1,67 +1,60 @@ open Js_of_ocaml +module Path = Script_path -let (let=?) : 'a option -> ('a -> unit) -> unit - = fun f opt -> Option.iter opt f +let ( let=? ) : 'a option -> ('a -> unit) -> unit = + fun f opt -> Option.iter opt f -let post_message - : Worker_messages.from_worker -> unit - = Worker.post_message +let post_message : Worker_messages.from_worker -> unit = Worker.post_message let rebuild outline = let path = outline.Outline.path in let=? path = Path.Fixed.rebuild path in - let back = Path.Fixed.map - path - (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in + let back = + Path.Fixed.map path (fun pt -> + Path.Point.copy pt @@ Path.Point.get_coord' pt ) + in let=? back = Path.Fixed.rebuild back in - post_message (`Complete {outline with path; back}) + post_message (`Complete { outline with path; back }) -let execute (command: Worker_messages.to_worker) = - match command with +let execute (command : Worker_messages.to_worker) = + match command with (* Full rebuild, evaluate the whole path *) - | `Complete outline -> - rebuild outline - + | `Complete outline -> rebuild outline (* Remove the point from the main line, and reevaluate the whole path *) | `DeletePoint (point, outline) -> - let=? path = Path.Fixed.remove_point outline.Outline.path point in - rebuild { outline with path } - + let=? path = Path.Fixed.remove_point outline.Outline.path point in + rebuild { outline with path } (* Only evaluate the interior *) | `Back outline -> - let back = Path.Fixed.map - outline.Outline.path - (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in - let=? back = Path.Fixed.rebuild back in - post_message (`Complete {outline with back}) - + let back = + Path.Fixed.map outline.Outline.path (fun pt -> + Path.Point.copy pt @@ Path.Point.get_coord' pt ) + in + let=? back = Path.Fixed.rebuild back in + post_message (`Complete { outline with back }) | `TranslatePath (outline, delta) -> - let path = Path.Fixed.map - outline.path - (fun pt -> Path.Point.get_coord pt - |> Gg.V2.add delta - |> Path.Point.copy pt) - and back = Path.Fixed.map - outline.back - (fun pt -> Path.Point.get_coord pt - |> Gg.V2.add delta - |> Path.Point.copy pt) in - post_message (`Complete {outline with path; back}) - + let path = + Path.Fixed.map outline.path (fun pt -> + Path.Point.get_coord pt |> Gg.V2.add delta |> Path.Point.copy pt ) + and back = + Path.Fixed.map outline.back (fun pt -> + Path.Point.get_coord pt |> Gg.V2.add delta |> Path.Point.copy pt ) + in + post_message (`Complete { outline with path; back }) | `TranslatePoint (point, outline) -> - (* I do not use the function Path.Fixed.replace_point here, I just - replace the point position and run a full rebuild *) - let path = Path.Fixed.map outline.path - (fun pt -> - match Path.Point.id pt = Path.Point.id point with - | true -> point - | false -> pt - ) in + (* I do not use the function Path.Fixed.replace_point here, I just + replace the point position and run a full rebuild *) + let path = + Path.Fixed.map outline.path (fun pt -> + match Path.Point.id pt = Path.Point.id point with + | true -> point + | false -> pt ) + in + + rebuild { outline with path } - rebuild { outline with path } -let () = - Worker.set_onmessage execute +let () = Worker.set_onmessage execute diff --git a/script.it/worker_messages/dune b/script.it/worker_messages/dune index b4e1c2b..5b80cd3 100755 --- a/script.it/worker_messages/dune +++ b/script.it/worker_messages/dune @@ -3,5 +3,5 @@ (libraries js_of_ocaml outline - path) + script_path) ) diff --git a/script.it/worker_messages/worker_messages.ml b/script.it/worker_messages/worker_messages.ml index 7efd3d3..2d07895 100755 --- a/script.it/worker_messages/worker_messages.ml +++ b/script.it/worker_messages/worker_messages.ml @@ -1,19 +1,17 @@ open Js_of_ocaml +module Path = Script_path -type to_worker = [ - | `Complete of Outline.t - | `DeletePoint of (Path.Point.t * Outline.t) +type to_worker = + [ `Complete of Outline.t + | `DeletePoint of Path.Point.t * Outline.t + | (* Update the interior path *) + `Back of Outline.t + | (* Translate a path *) + `TranslatePath of Outline.t * Gg.v2 + | `TranslatePoint of Path.Point.t * Outline.t + ] - (* Update the interior path *) - | `Back of Outline.t - - (* Translate a path *) - | `TranslatePath of (Outline.t * Gg.v2) - - | `TranslatePoint of (Path.Point.t * Outline.t) -] - -type from_worker = [ - | `Complete of Outline.t +type from_worker = + [ `Complete of Outline.t | `Other of Js.js_string Js.t -] + ] -- cgit v1.2.3