Communication with webworker

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 /script.it
parent: 20addbe8fd0ac4c79c8a69a4f888ec320a9ca4c3 (diff)
5 files changed, 400 insertions, 99 deletions
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 &ndash; 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&#8217;ardoise pour commencer à dessiner<span style="white-space:nowrap">&thinsp;</span>!
+
+  <footer class="info"> </footer>
+  </div>
+</article>
+
+    <footer>
+<p>&copy;  </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
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 /script.it
parent	20addbe8fd0ac4c79c8a69a4f888ec320a9ca4c3 (diff)