diff options
author | Sébastien Dailly <sebastien@chimrod.com> | 2021-01-03 05:42:35 +0100 |
---|---|---|
committer | Sébastien Dailly <sebastien@chimrod.com> | 2021-01-03 20:19:14 +0100 |
commit | a8f37f041dce3f16917b6659d3ca97492f178f4d (patch) | |
tree | 35223969024c9ebaed7309b5a6299f8de5f18d1f | |
parent | 20addbe8fd0ac4c79c8a69a4f888ec320a9ca4c3 (diff) |
Communication with webworker
-rwxr-xr-x | Makefile | 11 | ||||
-rwxr-xr-x | blog/hash_host/hash_localhost.ml | 2 | ||||
-rwxr-xr-x | elements/timer.ml | 1 | ||||
-rwxr-xr-x | layer/dune | 2 | ||||
-rwxr-xr-x | layer/fillPrinter.ml (renamed from path/fillPrinter.ml) | 5 | ||||
-rwxr-xr-x | layer/linePrinter.ml | 69 | ||||
-rwxr-xr-x | layer/paths.ml | 107 | ||||
-rwxr-xr-x | layer/wireFramePrinter.ml (renamed from path/wireFramePrinter.ml) | 4 | ||||
-rwxr-xr-x | layer/wireFramePrinter.mli | 27 | ||||
-rwxr-xr-x | path/dune | 2 | ||||
-rwxr-xr-x | path/fixed.ml | 8 | ||||
-rwxr-xr-x | path/fixed.mli | 15 | ||||
-rwxr-xr-x | path/linePrinter.ml | 54 | ||||
-rwxr-xr-x | path/path.ml | 107 | ||||
-rwxr-xr-x | path/point.ml | 7 | ||||
-rwxr-xr-x | path/point.mli | 4 | ||||
-rwxr-xr-x | path/wireFramePrinter.mli | 27 | ||||
-rwxr-xr-x | script.it/drawer.html | 135 | ||||
-rwxr-xr-x | script.it/dune | 35 | ||||
-rwxr-xr-x | script.it/script.ml | 196 | ||||
-rwxr-xr-x | script.it/state.ml | 69 | ||||
-rwxr-xr-x | script.it/worker.ml | 64 | ||||
-rwxr-xr-x | shapes/bezier.ml | 25 | ||||
-rwxr-xr-x | worker/dune | 9 | ||||
-rwxr-xr-x | worker/worker.ml | 5 |
25 files changed, 680 insertions, 310 deletions
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 @@ -3,6 +3,6 @@ (libraries gg brr - shapes + path ) ) diff --git a/path/fillPrinter.ml b/layer/fillPrinter.ml index 76056c7..2297d15 100755 --- a/path/fillPrinter.ml +++ b/layer/fillPrinter.ml @@ -1,4 +1,5 @@ -module Make(Repr: Layer.Repr.PRINTER) = struct +module Point = Path.Point +module Make(Repr: Repr.PRINTER) = struct type t = Point.t @@ -16,7 +17,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct (* Start a new path. *) let start - : Point.t -> repr -> repr + : Path.Point.t -> repr -> repr = fun t {close ; path } -> let path = Repr.move_to (Point.get_coord t) path in { close 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/path/wireFramePrinter.ml b/layer/wireFramePrinter.ml index 796bbd9..81ab271 100755 --- a/path/wireFramePrinter.ml +++ b/layer/wireFramePrinter.ml @@ -1,4 +1,6 @@ -module Make(Repr: Layer.Repr.PRINTER) = struct +module Point = Path.Point + +module Make(Repr: Repr.PRINTER) = struct type t = Point.t type repr = 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 @@ -2,8 +2,6 @@ (name path) (libraries gg - brr - layer shapes ) ) 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.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 @@ + +<!DOCTYPE html> +<html lang="fr_fr"> +<head> + <meta charset="utf-8" /> + <meta http-equiv="X-UA-Compatible" content="IE=edge" /> + <meta name="HandheldFriendly" content="True" /> + <meta name="viewport" content="width=device-width, initial-scale=1.0" /> + <meta name="robots" content="noindex, nofollow" /> + + <link href="https://fonts.googleapis.com/css2?family=Source+Code+Pro:ital,wght@0,400;0,700;1,400&family=Source+Sans+Pro:ital,wght@0,300;0,400;0,700;1,400&display=swap" rel="stylesheet"> + + <link rel="stylesheet" type="text/css" href="/theme/stylesheet/style.min.css"> + + + <link id="pygments-light-theme" rel="stylesheet" type="text/css" + href="//localhost:8000/theme/pygments/monokai.min.css"> + + + <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/fontawesome.css"> + <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/brands.css"> + <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/solid.css"> + + <link href="//localhost:8000/custom.css" rel="stylesheet"> + + <link href="//localhost:8000/feeds/all.atom.xml" type="application/atom+xml" rel="alternate" title="Chimrod Atom"> + + + + + + <meta name="author" content="Chimrod" /> + <meta name="description" content="" /> +<meta property="og:site_name" content="Chimrod"/> +<meta property="og:type" content="blog"/> +<meta property="og:title" content="Chimrod"/> +<meta property="og:description" content=""/> +<meta property="og:locale" content="en_US"/> +<meta property="og:url" content="//localhost:8000"/> +<meta property="og:image" content="/images/profile.png"> + + + + <title>Chimrod – Drawer</title> + +</head> +<body class="light-theme"> + <aside> + <div> + <a href="//localhost:8000"> + <img src="/profile.png" alt="Chimrod" title="Chimrod"> + </a> + + <h1> + <a href="//localhost:8000">Chimrod</a> + </h1> + + + + <nav> + <ul class="list"> + + + + <li> + <a target="_self" href="http://git.chimrod.com" >git</a> + </li> + </ul> + </nav> + + <ul class="social"> + </ul> + </div> + + </aside> + <main> + + <nav> + <a href="//localhost:8000">Accueil</a> + + + <a href="//localhost:8000/feeds/all.atom.xml">Atom</a> + + </nav> + +<article class="single"> + <header> + + <h1 id="drawer">Drawer</h1> + </header> + <div> + + <noscript>Sorry, you need to enable JavaScript to see this page.</noscript> + <script id="drawer_js" type="text/javascript" defer="defer" src="script.js"></script> + <script> + var script = document.getElementById('drawer_js'); + script.addEventListener('load', function() { + var app = document.getElementById('slate'); + drawer.run(app); + }); + </script> + <section class="todoapp" id="app"> + <canvas id="slate" class="drawing-zone" width="800" height="800"> + </section> + + Cliquez dans l’ardoise pour commencer à dessiner<span style="white-space:nowrap"> </span>! + + <footer class="info"> </footer> + </div> +</article> + + <footer> +<p>© </p> +<p> +Construit avec <a href="http://getpelican.com" target="_blank">Pelican</a> utilisant le thème <a href="http://bit.ly/flex-pelican" target="_blank">Flex</a> +</p> </footer> + </main> + + + + +<script type="application/ld+json"> +{ + "@context" : "http://schema.org", + "@type" : "Blog", + "name": " Chimrod ", + "url" : "//localhost:8000", + "image": "./profile.png", + "description": "" +} +</script> + + +</body> +</html> 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 |