From a8f37f041dce3f16917b6659d3ca97492f178f4d Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Sun, 3 Jan 2021 05:42:35 +0100 Subject: Communication with webworker --- Makefile | 11 +++ blog/hash_host/hash_localhost.ml | 2 +- elements/timer.ml | 1 - layer/dune | 2 +- layer/fillPrinter.ml | 73 +++++++++++++++ layer/linePrinter.ml | 69 ++++++++++++++ layer/paths.ml | 107 +++++++++++++++++++++ layer/wireFramePrinter.ml | 80 ++++++++++++++++ layer/wireFramePrinter.mli | 27 ++++++ path/dune | 2 - path/fillPrinter.ml | 72 -------------- path/fixed.ml | 8 ++ path/fixed.mli | 15 +++ path/linePrinter.ml | 54 ----------- path/path.ml | 107 +-------------------- path/point.ml | 7 +- path/point.mli | 4 +- path/wireFramePrinter.ml | 78 ---------------- path/wireFramePrinter.mli | 27 ------ script.it/drawer.html | 135 +++++++++++++++++++++++++++ script.it/dune | 35 ++++--- script.it/script.ml | 196 +++++++++++++++++++++++++-------------- script.it/state.ml | 69 ++++++++++---- script.it/worker.ml | 64 +++++++++++++ shapes/bezier.ml | 25 +++++ worker/dune | 9 -- worker/worker.ml | 5 - 27 files changed, 827 insertions(+), 457 deletions(-) create mode 100755 Makefile create mode 100755 layer/fillPrinter.ml create mode 100755 layer/linePrinter.ml create mode 100755 layer/paths.ml create mode 100755 layer/wireFramePrinter.ml create mode 100755 layer/wireFramePrinter.mli delete mode 100755 path/fillPrinter.ml delete mode 100755 path/linePrinter.ml delete mode 100755 path/wireFramePrinter.ml delete mode 100755 path/wireFramePrinter.mli create mode 100755 script.it/drawer.html create mode 100755 script.it/worker.ml delete mode 100755 worker/dune delete mode 100755 worker/worker.ml diff --git a/Makefile b/Makefile new file mode 100755 index 0000000..849544b --- /dev/null +++ b/Makefile @@ -0,0 +1,11 @@ +all: + dune build + +release: + dune build --profile=release + +serve: + cd _build/default && python3 -m http.server 5000 + +clean: + dune clean diff --git a/blog/hash_host/hash_localhost.ml b/blog/hash_host/hash_localhost.ml index c652b6a..a41022e 100755 --- a/blog/hash_host/hash_localhost.ml +++ b/blog/hash_host/hash_localhost.ml @@ -1 +1 @@ -let expected_host = [%static_hash ""] +let expected_host = [%static_hash "localhost"] diff --git a/elements/timer.ml b/elements/timer.ml index bd676fd..28516fc 100755 --- a/elements/timer.ml +++ b/elements/timer.ml @@ -30,7 +30,6 @@ let start (fun () -> let span = Time.counter_value t.counter in - t.counter <- Time.counter (); send span) in t.id <- timer_id diff --git a/layer/dune b/layer/dune index f0b1b13..3c617ad 100755 --- a/layer/dune +++ b/layer/dune @@ -3,6 +3,6 @@ (libraries gg brr - shapes + path ) ) diff --git a/layer/fillPrinter.ml b/layer/fillPrinter.ml new file mode 100755 index 0000000..2297d15 --- /dev/null +++ b/layer/fillPrinter.ml @@ -0,0 +1,73 @@ +module Point = Path.Point +module Make(Repr: Repr.PRINTER) = struct + + type t = Point.t + + type repr = + { path: Repr.t + ; close : Repr.t -> Repr.t + } + + let create_path + : (Repr.t -> Repr.t) -> repr + = fun f -> + { close = f + ; path = Repr.create () + } + + (* Start a new path. *) + let start + : Path.Point.t -> repr -> repr + = fun t {close ; path } -> + let path = Repr.move_to (Point.get_coord t) path in + { close + ; path + } + + let line_to + : Point.t -> Point.t -> repr -> repr + = fun p0 p1 t -> + let path = + Repr.move_to (Point.get_coord p1) t.path + |> Repr.line_to (Point.get_coord' p1) + |> Repr.line_to (Point.get_coord' p0) + |> Repr.line_to (Point.get_coord p0) + |> Repr.line_to (Point.get_coord p1) + |> Repr.close in + let path = t.close path in + { t with path} + + 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 path = + Repr.move_to (Point.get_coord p1) t.path + |> Repr.line_to (Point.get_coord' p1) + |> Repr.quadratic_to + (Point.get_coord' ctrl1') + (Point.get_coord' ctrl0') + (Point.get_coord' p0) + |> Repr.line_to (Point.get_coord p0) + |> Repr.quadratic_to + (Point.get_coord ctrl0') + (Point.get_coord ctrl1') + (Point.get_coord p1) + |> Repr.close in + let path = t.close path in + { t with path} + + + let stop + : repr -> repr + = fun t -> + t + + let get + : repr -> Repr.t + = fun t -> + t.path +end diff --git a/layer/linePrinter.ml b/layer/linePrinter.ml new file mode 100755 index 0000000..3ed1c3c --- /dev/null +++ b/layer/linePrinter.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/paths.ml b/layer/paths.ml new file mode 100755 index 0000000..3cedd6d --- /dev/null +++ b/layer/paths.ml @@ -0,0 +1,107 @@ +(** Common module for ensuring that the function is evaluated only once *) + +module type REPRESENTABLE = sig + type t + + (** Represent the path *) + val repr + : t -> (module Path.Repr.M with type t = Path.Point.t and type repr = 's) -> 's -> 's +end + +(* Canva representation *) + +module FillCanvaRepr = FillPrinter.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 WireSVGRepr = WireFramePrinter.Make(Svg) + + +type printer = + [ `Fill + | `Line + | `Ductus ] + +(** Draw a path to a canva *) +let to_canva + : (module REPRESENTABLE with type t = 's) -> 's -> Brr_canvas.C2d.t -> printer -> unit + = fun (type s) (module R:REPRESENTABLE with type t = s) path ctx -> function + | `Fill -> + R.repr + path + (module FillCanvaRepr) + (FillCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) + |> FillCanvaRepr.get + |> Brr_canvas.C2d.stroke ctx + | `Line -> + R.repr + path + (module LineCanvaRepr) + (LineCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) + |> LineCanvaRepr.get + |> Brr_canvas.C2d.stroke ctx + | `Ductus -> + R.repr + path + (module WireCanvaRepr) + (WireCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) + |> WireCanvaRepr.get + |> Brr_canvas.C2d.stroke ctx + + +(** Draw a path and represent it as SVG *) +let to_svg + : (module REPRESENTABLE with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t + = fun (type s) (module R:REPRESENTABLE with type t = s) ~color path -> function + | `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 _ = R.repr + path + (module FillSVGRepr) + (FillSVGRepr.create_path + (fun p -> + let repr = Svg.path + ~at:Brr.At.[ v (Jstr.v "d") p ] + [] in + + paths := repr::!paths; + Jstr.empty)) in + + Brr.El.v (Jstr.v "g") + ~at:Brr.At.[ + v (Jstr.v "fill") color + ; 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 + (module WireSVGRepr) + (WireSVGRepr.create_path (fun _ -> ())) + |> WireSVGRepr.get in + Svg.path + ~at:Brr.At.[ + v (Jstr.v "fill") color + ; v (Jstr.v "stroke") color + ; v (Jstr.v "d") svg_path ] + [] diff --git a/layer/wireFramePrinter.ml b/layer/wireFramePrinter.ml new file mode 100755 index 0000000..81ab271 --- /dev/null +++ b/layer/wireFramePrinter.ml @@ -0,0 +1,80 @@ +module Point = Path.Point + +module Make(Repr: Repr.PRINTER) = struct + type t = Point.t + + type repr = + { 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 + } + + (* 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 +end diff --git a/layer/wireFramePrinter.mli b/layer/wireFramePrinter.mli new file mode 100755 index 0000000..b198d58 --- /dev/null +++ b/layer/wireFramePrinter.mli @@ -0,0 +1,27 @@ +module Make(Repr:Repr.PRINTER): sig + + type repr + + type t = Path.Point.t + + val create_path + : 'b -> repr + + (* Start a new path. *) + val start + : 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 stop + : repr -> repr + + + val get + : repr -> Repr.t + +end diff --git a/path/dune b/path/dune index 42965db..863c768 100755 --- a/path/dune +++ b/path/dune @@ -2,8 +2,6 @@ (name path) (libraries gg - brr - layer shapes ) ) diff --git a/path/fillPrinter.ml b/path/fillPrinter.ml deleted file mode 100755 index 76056c7..0000000 --- a/path/fillPrinter.ml +++ /dev/null @@ -1,72 +0,0 @@ -module Make(Repr: Layer.Repr.PRINTER) = struct - - type t = Point.t - - type repr = - { path: Repr.t - ; close : Repr.t -> Repr.t - } - - let create_path - : (Repr.t -> Repr.t) -> repr - = fun f -> - { close = f - ; path = Repr.create () - } - - (* Start a new path. *) - let start - : Point.t -> repr -> repr - = fun t {close ; path } -> - let path = Repr.move_to (Point.get_coord t) path in - { close - ; path - } - - let line_to - : Point.t -> Point.t -> repr -> repr - = fun p0 p1 t -> - let path = - Repr.move_to (Point.get_coord p1) t.path - |> Repr.line_to (Point.get_coord' p1) - |> Repr.line_to (Point.get_coord' p0) - |> Repr.line_to (Point.get_coord p0) - |> Repr.line_to (Point.get_coord p1) - |> Repr.close in - let path = t.close path in - { t with path} - - 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 path = - Repr.move_to (Point.get_coord p1) t.path - |> Repr.line_to (Point.get_coord' p1) - |> Repr.quadratic_to - (Point.get_coord' ctrl1') - (Point.get_coord' ctrl0') - (Point.get_coord' p0) - |> Repr.line_to (Point.get_coord p0) - |> Repr.quadratic_to - (Point.get_coord ctrl0') - (Point.get_coord ctrl1') - (Point.get_coord p1) - |> Repr.close in - let path = t.close path in - { t with path} - - - let stop - : repr -> repr - = fun t -> - t - - let get - : repr -> Repr.t - = fun t -> - t.path -end diff --git a/path/fixed.ml b/path/fixed.ml index 0ff4aad..d20c897 100755 --- a/path/fixed.ml +++ b/path/fixed.ml @@ -41,6 +41,10 @@ module Make(Point:P) = struct : t -> int = fun {id; _} -> id + let path + : t -> path array + = fun {path; _} -> path + module ToFixed = struct type t = Point.t @@ -183,4 +187,8 @@ module Make(Point:P) = struct ) in {id; path} + let update + : t -> path array -> t + = fun {id; _} path -> {id; path} + end diff --git a/path/fixed.mli b/path/fixed.mli index 1f02aed..c84b51d 100755 --- a/path/fixed.mli +++ b/path/fixed.mli @@ -43,4 +43,19 @@ module Make(Point:P) : sig val map_point : t -> (Point.t -> Point.t) -> t + type bezier = + { p0:Point.t (* The starting point *) + ; p1:Point.t (* The end point *) + ; ctrl0:Gg.v2 (* The control point *) + ; ctrl1:Gg.v2 } (* The control point *) + + type path = + | Empty + | Line of Point.t * Point.t + | Curve of bezier + + val path : t -> path array + + val update : t -> path array -> t + end diff --git a/path/linePrinter.ml b/path/linePrinter.ml deleted file mode 100755 index c0a7d58..0000000 --- a/path/linePrinter.ml +++ /dev/null @@ -1,54 +0,0 @@ -module Make(Repr: Layer.Repr.PRINTER) = struct - - type t = Point.t - - type repr = - { path: (Repr.t) - } - - let create_path - : 'b -> repr - = fun _ -> - { path = Repr.create () - } - - (* Start a new path. *) - let start - : Point.t -> repr -> repr - = fun t {path} -> - let path = Repr.move_to (Point.get_coord t) path in - let path = Repr.line_to (Point.get_coord' t) path in - { path - } - - let line_to - : Point.t -> Point.t -> repr -> repr - = fun _ t {path} -> - let path = Repr.move_to (Point.get_coord t) path in - let path = Repr.line_to (Point.get_coord' t) path in - { path - } - - let quadratic_to - : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr - = fun _p0 _ctrl0 _ctrl1 p1 {path} -> - - let path = Repr.move_to (Point.get_coord p1) path in - let path = Repr.line_to (Point.get_coord' p1) path in - - { path - } - - let stop - : repr -> repr - = fun {path} -> - - - { path - } - - let get - : repr -> Repr.t - = fun {path; _} -> - path -end diff --git a/path/path.ml b/path/path.ml index 9b6b9c4..ea90de4 100755 --- a/path/path.ml +++ b/path/path.ml @@ -1,112 +1,7 @@ (** Common module for ensuring that the function is evaluated only once *) module Point = Point - -module type REPRESENTABLE = sig - type t - - (** Represent the path *) - val repr - : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's -end - +module Repr = Repr module Path_Builder = Builder.Make(Point) module Fixed = Fixed.Make(Point) -(* Canva representation *) - -module FillCanvaRepr = FillPrinter.Make(Layer.CanvaPrinter) -module LineCanvaRepr = LinePrinter.Make(Layer.CanvaPrinter) -module WireCanvaRepr = WireFramePrinter.Make(Layer.CanvaPrinter) - -(* SVG representation *) - -module FillSVGRepr = FillPrinter.Make(Layer.Svg) -module LineSVGRepr = LinePrinter.Make(Layer.Svg) -module WireSVGRepr = WireFramePrinter.Make(Layer.Svg) - - -type printer = - [ `Fill - | `Line - | `Wire ] - -(** Draw a path to a canva *) -let to_canva - : (module REPRESENTABLE with type t = 's) -> 's -> Brr_canvas.C2d.t -> printer -> unit - = fun (type s) (module R:REPRESENTABLE with type t = s) path ctx -> function - | `Fill -> - R.repr - path - (module FillCanvaRepr) - (FillCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - |> FillCanvaRepr.get - |> Brr_canvas.C2d.stroke ctx - | `Line -> - R.repr - path - (module LineCanvaRepr) - (LineCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - |> LineCanvaRepr.get - |> Brr_canvas.C2d.stroke ctx - | `Wire -> - R.repr - path - (module WireCanvaRepr) - (WireCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - |> WireCanvaRepr.get - |> Brr_canvas.C2d.stroke ctx - - -(** Draw a path and represent it as SVG *) -let to_svg - : (module REPRESENTABLE with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t - = fun (type s) (module R:REPRESENTABLE with type t = s) ~color path -> function - | `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 _ = R.repr - path - (module FillSVGRepr) - (FillSVGRepr.create_path - (fun p -> - let repr = Layer.Svg.path - ~at:Brr.At.[ v (Jstr.v "d") p ] - [] in - - paths := repr::!paths; - Jstr.empty)) in - - Brr.El.v (Jstr.v "g") - ~at:Brr.At.[ - v (Jstr.v "fill") color - ; v (Jstr.v "stroke") color] - !paths - - | `Line -> - let svg_path = R.repr - path - (module LineSVGRepr) - (LineSVGRepr.create_path (fun _ -> ())) - |> LineSVGRepr.get in - Layer.Svg.path - ~at:Brr.At.[ - v (Jstr.v "fill") color - ; v (Jstr.v "stroke") color - ; v (Jstr.v "d") svg_path ] - [] - | `Wire -> - let svg_path = R.repr - path - (module WireSVGRepr) - (WireSVGRepr.create_path (fun _ -> ())) - |> WireSVGRepr.get in - Layer.Svg.path - ~at:Brr.At.[ - v (Jstr.v "fill") color - ; v (Jstr.v "stroke") color - ; v (Jstr.v "d") svg_path ] - [] diff --git a/path/point.ml b/path/point.ml index 06eb635..031e1e0 100755 --- a/path/point.ml +++ b/path/point.ml @@ -2,18 +2,21 @@ type t = { p: Gg.v2 ; size : float ; angle: float + ; stamp : float } let empty = { p = Gg.V2.of_tuple (0., 0.) ; size = 0. ; angle = 0. + ; stamp = 0. } -let create ~angle ~width ~x ~y = +let create ~angle ~width ~stamp ~x ~y = { p = Gg.V2.v x y ; size = width ; angle = Gg.Float.rad_of_deg (180. -. angle ) + ; stamp } let copy point p = @@ -30,6 +33,8 @@ let (+) p1 p2 = let get_coord { p; _ } = p +let get_stamp { stamp; _} = stamp + let get_coord' : t -> Gg.v2 = fun t -> diff --git a/path/point.mli b/path/point.mli index 649a3be..db87a71 100755 --- a/path/point.mli +++ b/path/point.mli @@ -6,7 +6,9 @@ val (+): t -> Gg.v2 -> t val get_coord : t -> Gg.v2 -val create: angle:float -> width:float -> x:float -> y:float -> t +val get_stamp : t -> float + +val create: angle:float -> width:float -> stamp:float -> x:float -> y:float -> t val copy : t -> Gg.v2 -> t diff --git a/path/wireFramePrinter.ml b/path/wireFramePrinter.ml deleted file mode 100755 index 796bbd9..0000000 --- a/path/wireFramePrinter.ml +++ /dev/null @@ -1,78 +0,0 @@ -module Make(Repr: Layer.Repr.PRINTER) = struct - type t = Point.t - - type repr = - { 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 - } - - (* 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 -end diff --git a/path/wireFramePrinter.mli b/path/wireFramePrinter.mli deleted file mode 100755 index fa8a5a8..0000000 --- a/path/wireFramePrinter.mli +++ /dev/null @@ -1,27 +0,0 @@ -module Make(Repr:Layer.Repr.PRINTER): sig - - type repr - - type t = Point.t - - val create_path - : 'b -> repr - - (* Start a new path. *) - val start - : Point.t -> repr -> repr - - val line_to - : Point.t -> Point.t -> repr -> repr - - val quadratic_to - : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr - - val stop - : repr -> repr - - - val get - : repr -> Repr.t - -end diff --git a/script.it/drawer.html b/script.it/drawer.html new file mode 100755 index 0000000..c55a849 --- /dev/null +++ b/script.it/drawer.html @@ -0,0 +1,135 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Chimrod – Drawer + + + + +
+ + + +
+
+ +

Drawer

+
+
+ + + + +
+ +
+ + Cliquez dans l’ardoise pour commencer à dessiner ! + +
+
+
+ +
+

©

+

+Construit avec Pelican utilisant le thème Flex +

+
+ + + + + + + + + diff --git a/script.it/dune b/script.it/dune index 1536f2b..e7ca0dc 100755 --- a/script.it/dune +++ b/script.it/dune @@ -1,26 +1,39 @@ -(executables - (names script) +(executable + (name script) (libraries - js_of_ocaml brr brr.note - vg - vg.htmlc - messages - messages_json - worker shapes - tools elements blog - path + layer ) (modes js) - (preprocess (pps ppx_hash)) + (modules script state) + (preprocess (pps ppx_hash js_of_ocaml-ppx)) (link_flags (:standard -no-check-prims)) ) + (rule (targets script.js) (deps script.bc.js) (action (run cp %{deps} %{targets}))) + +(executable + (name worker) + (modules worker) + (libraries + js_of_ocaml + shapes + path + ) + (modes js) + (preprocess (pps ppx_hash js_of_ocaml-ppx)) + (link_flags (:standard -no-check-prims)) + ) + +(rule + (targets worker.js) + (deps worker.bc.js) + (action (run cp %{deps} %{targets}))) diff --git a/script.it/script.ml b/script.it/script.ml index 3e52f5c..131ea39 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -80,8 +80,16 @@ let click_event el = let show_value input = El.txt (Jstr.of_float input) +type 'a param_events = + { width : float S.t + ; angle : float S.t + ; export : unit E.t + ; delete : unit E.t + ; rendering : ([> State.render_event] as 'a) E.t + } + let set_sidebar - : El.t -> State.state -> unit E.t * float S.t * float S.t *unit E.t + : El.t -> State.state -> _ param_events = fun element state -> let open El in @@ -130,6 +138,7 @@ let set_sidebar ; v (Jstr.v "max") (Jstr.v "90") ; At.value (Jstr.of_float state.angle) ] in + let angle = El.div [] in Elr.def_children angle @@ -143,17 +152,32 @@ let set_sidebar let render = El.select - [ El.option ~at:At.[value (Jstr.v "Fill")] + [ El.option ~at:At.[value (Jstr.v "1")] [ txt' "Fill"] - ; El.option ~at:At.[value (Jstr.v "Wireframe")] - [ txt' "Wireframe"] - ; El.option ~at:At.[value (Jstr.v "Ductus")] + ; El.option ~at:At.[value (Jstr.v "2")] [ txt' "Ductus"] +(* + ; El.option ~at:At.[value (Jstr.v "3")] + [ txt' "Line"] +*) ] in + let rendering' = El.div [ 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 + match raw_value with + | Some 1 -> `Rendering `Fill + | Some 2 -> `Rendering `Line + | Some 3 -> `Rendering `Ductus + | _ -> `Rendering `Fill + ) rendering' in + let () = El.append_children element [ hr () @@ -172,14 +196,19 @@ let set_sidebar ] in - delete_event, angle_event, nib_size_event, export_event + { delete = delete_event + ; angle = angle_event + ; width = nib_size_event + ; export = export_event + ; rendering = render_event + } let backgroundColor = Blog.Nord.nord0 let white = Jstr.v "#eceff4" let green = Jstr.v "#a3be8c" (** Redraw the canva on update *) -let on_change canva mouse_position state = +let on_change canva mouse_position timer state = let module Cd2d = Brr_canvas.C2d in let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in @@ -206,15 +235,14 @@ let on_change canva mouse_position state = let current = begin match state.State.mode, pos with | Edit, Some point -> - State.insert_or_replace state point state.current + let stamp = Elements.Timer.delay timer in + State.insert_or_replace state point stamp state.current | _ -> state.current end in - let repr = `Fill in - - Path.to_canva (module Path.Path_Builder) current context repr; + Layer.Paths.to_canva (module Path.Path_Builder) current context state.rendering; List.iter state.paths ~f:(fun path -> @@ -233,14 +261,21 @@ let on_change canva mouse_position state = | _ -> () in - Path.to_canva (module Path.Fixed) path context repr + Layer.Paths.to_canva (module Path.Fixed) path context state.rendering ); () +let spawn_worker () = + try + Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js")) + with + | Jv.Error e -> Error e let page_main id = - let delete_event', angle_signal', width_signal', export_event' = + let timer, tick = Elements.Timer.create () in + + let parameters = begin match Blog.Sidebar.get () with | None -> Jv.throw (Jstr.v "No sidebar") @@ -249,11 +284,11 @@ let page_main id = Blog.Sidebar.clean el; set_sidebar el State.init end in - let delete_event = E.map (fun () -> `Delete) delete_event' - and export_event = E.map (fun () -> `Export) export_event' - and angle_event = S.changes angle_signal' + let delete_event = E.map (fun () -> `Delete) parameters.delete + and export_event = E.map (fun () -> `Export) parameters.export + and angle_event = S.changes parameters.angle |> E.map (fun value -> `Angle value) - and width_event = S.changes width_signal' + and width_event = S.changes parameters.width |> E.map (fun value -> `Width value) in @@ -263,64 +298,81 @@ let page_main id = | true -> Console.(error [str "No element with id '%s' found"; id]) | false -> - (* Add the events to the canva : - - - The mouse position is a signal used for both the update and the - canva refresh - - - Get also the click event for starting to draw - *) - - let canva_events, mouse_position, canva = canva (Jv.Id.of_jv id) in - - let tick_event = - S.sample_filter mouse_position - ~on:State.tick - (fun pos f -> Option.map (fun p -> `Point (f, p)) pos ) in - - (* The first evaluation is the state. Which is the result of all the - successives events to the initial state *) - let state = - E.select - [ canva_events - ; tick_event - ; angle_event - ; width_event - ; delete_event - ; export_event ] - |> E.map State.do_action - |> Note.S.accum State.init in - - (* The seconde evaluation is the canva refresh, which only occurs when - the mouse is updated, or on delete events *) - let _ = - E.select - [ E.map (fun _ -> ()) (S.changes mouse_position) - ; E.map (fun _ -> ()) (S.changes angle_signal') - ; E.map (fun _ -> ()) (S.changes width_signal') - ; delete_event' ] - |> fun ev -> E.log ev (fun _ -> on_change canva mouse_position (S.value state) ) - |> Option.iter Logr.hold in - - - (* Draw the canva for first time *) - on_change canva mouse_position State.init; - - (* Hold the state *) - let _ = Logr.hold (S.log state (fun _ -> ())) in - () + 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 my_host = Uri.host @@ Window.location @@ G.window in + 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); + + (* Add the events to the canva : + + - The mouse position is a signal used for both the update and the + canva refresh + + - Get also the click event for starting to draw + *) + + let canva_events, mouse_position, canva = canva (Jv.Id.of_jv id) in + + let tick_event = + S.sample_filter mouse_position + ~on:tick + (fun pos f -> Option.map (fun p -> `Point (f, p)) pos ) in + + (* The first evaluation is the state. Which is the result of all the + successives events to the initial state *) + let state = + E.select + [ worker_event + ; canva_events + ; tick_event + ; angle_event + ; width_event + ; delete_event + ; export_event + ; parameters.rendering + ] + |> E.map (State.do_action worker timer) + |> Note.S.accum State.init in + + (* The seconde evaluation is the canva refresh, which only occurs when + the mouse is updated, or on delete events *) + let _ = + E.select + [ E.map (fun _ -> ()) (S.changes mouse_position) + ; E.map (fun _ -> ()) (S.changes parameters.angle) + ; E.map (fun _ -> ()) (S.changes parameters.width) + ; E.map (fun _ -> ()) parameters.rendering + ; E.map (fun _ -> ()) worker_event + ; parameters.delete ] + |> fun ev -> E.log ev (fun _ -> on_change canva mouse_position timer (S.value state) ) + |> Option.iter Logr.hold 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 () = - if Brr_webworkers.Worker.ami () then - () - else ( - let open Jv in - let drawer = obj - [| "run", (repr page_main) - |] in + let open Jv in + let drawer = obj + [| "run", (repr page_main) + |] in - set global "drawer" drawer - ) + set global "drawer" drawer diff --git a/script.it/state.ml b/script.it/state.ml index 5a1ef8f..cfde0b0 100755 --- a/script.it/state.ml +++ b/script.it/state.ml @@ -1,12 +1,8 @@ open StdLabels open Brr -let expected_host = Blog.Hash_host.expected_host - let backgroundColor = Blog.Nord.nord0 -let timer, tick = Elements.Timer.create () - type mode = | Edit | Selection of int @@ -22,10 +18,21 @@ type button_events = [ `Delete | `Export ] +type render_event = + [ + `Rendering of Layer.Paths.printer + ] + +type worker_event = + [ `Basic of Jv.t + | `Complete of (int * (Path.Fixed.path array)) + ] type events = [ canva_events | button_events + | render_event + | worker_event | `Point of float * (float * float) | `Width of float | `Angle of float @@ -41,12 +48,13 @@ type state = ; current : Path.Path_Builder.t ; width : float ; angle : float + ; rendering : Layer.Paths.printer } -let insert_or_replace state ((x, y) as p) path = +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 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 @@ -97,14 +105,15 @@ let update_selection id state f = { state with paths } let do_action - : events -> state -> state - = fun event state -> + : Brr_webworkers.Worker.t -> Elements.Timer.t -> events -> state -> state + = fun worker timer event state -> match event, state.mode with - | `Point (_delay, point), Edit -> + | `Point (delay, point), Edit -> (* Add the point in the list *) let current = insert_or_replace state point + delay state.current in { state with current } @@ -115,16 +124,17 @@ let do_action let width = state.width and angle = state.angle in + let stamp = 0. in let point = match check_selection p state.paths with | None -> (* Start a new path with the point clicked *) - Path.Point.create ~x ~y ~angle ~width + 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 + Path.Point.create ~x ~y ~angle ~width ~stamp in let current = Path.Path_Builder.add_point @@ -150,6 +160,7 @@ let do_action end | `Out point, Edit -> + let stamp = Elements.Timer.delay timer in Elements.Timer.stop timer; begin match Path.Path_Builder.peek2 state.current with (* If there is at last two points selected, handle this as a curve @@ -162,14 +173,20 @@ let do_action | Some (p, _) -> Gg.V2.to_tuple p in *) - let current = insert_or_replace state point state.current in + let current = insert_or_replace state point stamp state.current in let paths = let last = Path.Fixed.to_fixed (module Path.Path_Builder) current in + + let id = Path.Fixed.id last + and path = Path.Fixed.path last in + let () = Brr_webworkers.Worker.post worker (`Complete (id, path)) in last::state.paths and current = Path.Path_Builder.empty in + + { state with mode = Out ; paths; current } @@ -198,8 +215,7 @@ let do_action | `Export, _ -> let my_host = Uri.host @@ Window.location @@ G.window in - - if (Hashtbl.hash my_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.[ @@ -208,11 +224,11 @@ let do_action (List.map state.paths ~f:(fun path -> - Path.to_svg + Layer.Paths.to_svg ~color:backgroundColor (module Path.Fixed) path - `Fill + state.rendering )) in let content = El.prop Elements.Prop.outerHTML svg in @@ -248,6 +264,26 @@ let do_action | `Delete, Out -> state + | `Rendering rendering, _ -> + { state with rendering} + + + | `Basic t, _ -> + Console.(log [t]); + state + + | `Complete (id, paths), _ -> + let paths = List.map state.paths + ~f:(fun path -> + let id' = Path.Fixed.id path in + match id = id' with + | false -> path + | true -> + Path.Fixed.update path paths + ) in + { state with paths } + + (* Some non possible cases *) | `Out _, Out | `Point _, Out @@ -263,4 +299,5 @@ let init = ; mode = Out ; angle = 30. ; width = 10. + ; rendering = `Fill } diff --git a/script.it/worker.ml b/script.it/worker.ml new file mode 100755 index 0000000..3150869 --- /dev/null +++ b/script.it/worker.ml @@ -0,0 +1,64 @@ +open StdLabels +open Js_of_ocaml + +type message = [ + | `Complete of (int * (Path.Fixed.path array)) +] + +exception Empty_Element + +let get_point + : Path.Fixed.path -> Gg.v2 + = function + | Empty -> raise Empty_Element + | Line (_, p1) -> Path.Point.get_coord p1 + | Curve bezier -> Path.Point.get_coord bezier.Path.Fixed.p1 + +let first_point + : Path.Fixed.path -> Gg.v2 + = function + | Empty -> raise Empty_Element + | Line (p0, _) -> Path.Point.get_coord p0 + | Curve bezier -> Path.Point.get_coord bezier.Path.Fixed.p0 + +let assoc_point + : Shapes.Bezier.t -> Path.Fixed.path -> Path.Fixed.path + = fun bezier -> function + | Empty -> raise Empty_Element + | Line (p0, p1) + | Curve {p0; p1; _} -> + let p0' = Path.Point.copy p0 bezier.Shapes.Bezier.p0 + and p1' = Path.Point.copy p1 bezier.Shapes.Bezier.p1 in + Curve + { Path.Fixed.p0 = p0' + ; Path.Fixed.p1 = p1' + ; Path.Fixed.ctrl0 = bezier.Shapes.Bezier.ctrl0 + ; 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 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 -> + + (* 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 + | any -> + Worker.post_message (`Other any) + +let () = + Worker.set_onmessage execute diff --git a/shapes/bezier.ml b/shapes/bezier.ml index bf7aaaa..f5f288c 100755 --- a/shapes/bezier.ml +++ b/shapes/bezier.ml @@ -201,3 +201,28 @@ let reverse ; p1 = bezier.p0 ; ctrl0 = bezier.ctrl1 ; ctrl1 = bezier.ctrl0 } + +(** + + see https://github.com/Pomax/BezierInfo-2/blob/master/docs/js/graphics-element/lib/bezierjs/bezier.js#L504 + + let root + : t -> 'a + = fun bezier -> + + let accept + : float -> bool + = fun t -> + 0. <= t && t <= 1. in + + let cuberoot v = + if v < 0. then + Float.pow (Float.neg v) ( 1. /. 3.) + |> Float.neg + else Float.pow v (1. /. 3.) in + + + + + failwith "Non implemented" +*) diff --git a/worker/dune b/worker/dune deleted file mode 100755 index 508055e..0000000 --- a/worker/dune +++ /dev/null @@ -1,9 +0,0 @@ -(library - (name worker) - (libraries - gg - brr - note - shapes - ) - ) diff --git a/worker/worker.ml b/worker/worker.ml deleted file mode 100755 index 7a8d09a..0000000 --- a/worker/worker.ml +++ /dev/null @@ -1,5 +0,0 @@ -open Brr_webworkers - -let spawn_worker name = - try Ok (Worker.create name) with - | Jv.Error e -> Error e -- cgit v1.2.3