Update script.it project

9 files changed, 202 insertions, 170 deletions

diff --git a/script.it/script.ml b/script.it/script.ml
index a21afa9..29bf2c9 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -87,7 +87,7 @@ type 'a param_events =
   ; angle : float S.t
   ; export : unit E.t
   ; delete : unit E.t
-  ; rendering : ([> State.render_event] as 'a) E.t
+  ; rendering : State.events E.t
   }
 
 type slider =
@@ -160,11 +160,22 @@ let set_sidebar
         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
+            let render_type = match raw_value with
+              | Some 1 -> `Fill
+              | Some 2 -> `Line
+              | Some 3 -> `Ductus
+              | _ -> `Fill in
+
+            let module M = struct
+              type t = Layer.Paths.printer
+              let update t state = { state with State.rendering = t }
+            end
+            in
+
+            State.E
+              ( render_type
+              ,  (module M: State.Handler with type t = Layer.Paths.printer ))
+
           )  rendering' in
 
     let () =
@@ -358,22 +369,52 @@ let page_main id =
                      [ El.p El.[txt (Jv.Error.message e)]]
 
       | Ok worker ->
+
+        let worker_event, worker_send = E.create () in
+
         let delete_event = E.map
-            (fun () -> `Generic (
-                 let module Delete = Script_event.Delete in
-                 State.E ( Delete.{ worker }
-                         , (module Delete: State.Handler with type t = Delete.t)
-                         )))
+            (fun () ->
+               let module Delete = Script_event.Delete in
+               State.E
+                 ( Delete.{ worker }
+                 , (module Delete: State.Handler with type t = Delete.t )))
             parameters.delete
 
-        and export_event = E.map (fun () -> `Export) parameters.export
+        and export_event =
+          E.map (fun () ->
+              let module Export = Script_event.Export in
+              State.E
+                ( ()
+                , (module Export: State.Handler with type t = Export.t )))
+            parameters.export
         and angle_event = S.changes parameters.angle
-                          |> E.map (fun value -> `Angle value)
+                          |> E.map (fun value ->
+                              let module Property = Script_event.Property in
+                              State.E
+                                ( Property.{ value ; worker ; prop = `Angle }
+                                , (module Property: State.Handler with type t = Property.t )))
+
         and width_event = S.changes parameters.width
-                          |> E.map (fun value -> `Width value)
+                          |> E.map (fun value ->
+                              let module Property = Script_event.Property in
+                              State.E
+                                ( Property.{ value ; worker ; prop = `Width }
+                                , (module Property: State.Handler with type t = Property.t )))
+        and worker_event = Note.E.filter_map
+            (function
+              | `Other t ->
+                Console.(log [t]);
+                None
+              | `Complete outline ->
+                let module Complete_path = Script_event.Complete_path in
+                Some (
+                  State.E
+                    ( outline
+                    , (module Complete_path: State.Handler with type t = Complete_path.t ))))
+
+            worker_event
         in
 
-        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
@@ -396,35 +437,33 @@ let page_main id =
             (function
               | `MouseDown c ->
                 let module MouseDown = Script_event.Mouse_down in
-                `Generic (
-                  State.E
-                    ( MouseDown.{ position = c
-                                ; timer
-                                }
-                    , (module MouseDown: State.Handler with type t = MouseDown.t)))
+                State.E
+                  ( MouseDown.{ position = c ; timer }
+                  , (module MouseDown: State.Handler with type t = MouseDown.t ))
 
               | `Out c ->
-                let module Out = Script_event.Out in
-                `Generic (
-                  State.E
-                    ( Out.{ point = c
-                          ; worker
-                          ; timer
-                          }
-                    , (module Out: State.Handler with type t = Out.t)))
-
+                let module Click = Script_event.Click in
+                State.E
+                  ( Click.{ point = c ; worker; timer }
+                  , (module Click: State.Handler with type t = Click.t ))
             ) canva_events in
 
         let tick_event =
           S.sample_filter mouse_position
             ~on:tick
-            (fun pos f -> Option.map (fun p -> `Point (f, p)) pos ) in
+            (fun pos f ->
+               let module Tick = Script_event.Tick in
+               Option.map (fun p ->
+                   State.E
+                     ( (f, p)
+                     , (module Tick: State.Handler with type t = Tick.t )))
+                 pos ) in
 
         (* The first evaluation is the state. Which is the result of all the
            successives events to the initial state *)
         let state =
           Application.run
-            (State.do_action worker)
+            State.do_action
             State.init
             (E.select
                [ worker_event
diff --git a/script.it/script_event/out.ml b/script.it/script_event/click.ml
index b8b8599..591887b 100755
--- a/script.it/script_event/out.ml
+++ b/script.it/script_event/click.ml
@@ -8,8 +8,11 @@ type t = { point  : float * float
          ; worker : Brr_webworkers.Worker.t
          }
 
-(** Long click, move the selected element if any *)
-let longClick mouse_coord state worker = function
+(** The drag function is incorrectly named, as we dont't care if we are
+    selecting an element or not.
+
+    But, in the case we are (point, path…), we effectively move the element with the mouse. *)
+let drag mouse_coord state worker = function
   | State.Selection t ->
     let mouse_v2 = Gg.V2.of_tuple mouse_coord in
     begin match Selection.find_selection t state.State.paths with
@@ -24,10 +27,10 @@ let longClick mouse_coord state worker = function
         State.post worker (`TranslatePath (path, delta));
         state
     end
-  (*  TODO Long click in out mode should translate the slate *)
+  (*  TODO Long click in out mode should translate the whole slate *)
   | _ -> state
 
-let apply {point; timer ; worker} state =
+let update {point; timer ; worker} state =
   match state.State.mode with
 
   | Edit ->
@@ -84,5 +87,5 @@ let apply {point; timer ; worker} state =
     state
 
   | _ ->
-    longClick point state worker state.mode
+    drag point state worker state.mode
 
diff --git a/script.it/script_event/complete_path.ml b/script.it/script_event/complete_path.ml
new file mode 100755
index 0000000..99dd6ae
--- /dev/null
+++ b/script.it/script_event/complete_path.ml
@@ -0,0 +1,14 @@
+open StdLabels
+module State = Script_state.State
+
+type t = Outline.t
+
+let update newPath state =
+  let paths = List.map
+      state.State.paths
+      ~f:(fun line ->
+          match Outline.(newPath.id = line.id) with
+          | true -> newPath
+          | false -> line) in
+  { state with paths }
+
diff --git a/script.it/script_event/delete.ml b/script.it/script_event/delete.ml
index edd5d23..6aac5d2 100755
--- a/script.it/script_event/delete.ml
+++ b/script.it/script_event/delete.ml
@@ -7,7 +7,7 @@ module Selection = Script_state.Selection
 type t = { worker : Brr_webworkers.Worker.t }
 
 (* Click anywhere while in Out mode, we switch in edition *)
-let apply { worker } state =
+let update { worker } state =
   match state.State.mode with
   | Selection (Path id) ->
     let paths = List.filter
diff --git a/script.it/script_event/export.ml b/script.it/script_event/export.ml
new file mode 100755
index 0000000..9e900c7
--- /dev/null
+++ b/script.it/script_event/export.ml
@@ -0,0 +1,30 @@
+open StdLabels
+open Brr
+module State = Script_state.State
+
+type t = unit
+
+let update () state =
+  let my_host = Uri.host @@ Window.location @@ G.window in
+  if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
+    (* Convert the path into an sVG element *)
+    let svg = Layer.Svg.svg
+        ~at:Brr.At.[
+            v (Jstr.v "xmlns") (Jstr.v "http://www.w3.org/2000/svg")
+          ; v (Jstr.v "xmlns:xlink") (Jstr.v "http://www.w3.org/1999/xlink") ]
+        (List.map state.State.paths
+           ~f:(fun path ->
+
+               Layer.Paths.to_svg
+                 ~color:Blog.Nord.nord0
+                 (module Path.Fixed)
+                 Outline.(path.path, path.back)
+                 state.State.rendering
+
+             )) in
+    let content = El.prop Elements.Prop.outerHTML svg in
+    Elements.Transfert.send
+      ~mime_type:(Jstr.v "image/svg+xml")
+      ~filename:(Jstr.v "out.svg")
+      content);
+  state
diff --git a/script.it/script_event/mouse_down.ml b/script.it/script_event/mouse_down.ml
index 04ea2fd..98e866a 100755
--- a/script.it/script_event/mouse_down.ml
+++ b/script.it/script_event/mouse_down.ml
@@ -4,7 +4,7 @@ module Selection = Script_state.Selection
 type t = { position : float * float
          ; timer  : Elements.Timer.t }
 
-let apply { position; timer } state =
+let update { position; timer } state =
   match state.State.mode with
 
   | Out ->
diff --git a/script.it/script_event/property.ml b/script.it/script_event/property.ml
new file mode 100755
index 0000000..e637ab7
--- /dev/null
+++ b/script.it/script_event/property.ml
@@ -0,0 +1,52 @@
+module State = Script_state.State
+module Selection = Script_state.Selection
+
+let update_property worker state value f = function
+  | None -> state
+  | Some (Selection.Path outline) ->
+    (* Change width for the whole path *)
+    let outline = { outline with
+                    Outline.path = Path.Fixed.map outline.Outline.path (fun p ->
+                        f p value)
+                  } in
+    State.post worker (`Back outline);
+    state
+  | Some (Point (outline, point)) ->
+    let path = Path.Fixed.map
+        outline.path
+        (fun pt ->
+           match Path.Point.id pt = Path.Point.id point with
+           | false -> pt
+           | true -> f pt value)
+    in
+    let outline = {outline with path} in
+    State.post worker (`Back outline);
+    state
+
+type t = { prop : [`Angle | `Width ]
+         ; value : float
+         ; worker : Brr_webworkers.Worker.t
+         }
+
+let update { prop; value ; worker } state =
+  match prop with
+  | `Angle ->
+    let angle = value in
+    begin match state.State.mode with
+
+      | Selection t ->
+        let state = { state with angle } in
+        Selection.find_selection t state.paths
+        |> update_property worker state angle Path.Point.set_angle
+      | _ -> { state with angle }
+    end
+  | `Width ->
+    let width = value in
+    begin match state.State.mode with
+
+      | Selection t ->
+        let state = { state with width } in
+        Selection.find_selection t state.paths
+        |> update_property worker state width Path.Point.set_width
+      | _ -> { state with width }
+    end
diff --git a/script.it/script_event/tick.ml b/script.it/script_event/tick.ml
new file mode 100755
index 0000000..c927a2a
--- /dev/null
+++ b/script.it/script_event/tick.ml
@@ -0,0 +1,20 @@
+module State = Script_state.State
+
+type t = float * (float * float)
+
+(** Tick event
+
+    Tick only occurs when drawing a new path
+
+*)
+let update (delay, point) state =
+  match state.State.mode with
+  | Edit ->
+    (* Add the point in the list *)
+    let current = State.insert_or_replace
+        state
+        point
+        delay
+        state.current in
+    { state with current }
+  | _ -> state
diff --git a/script.it/state/state.ml b/script.it/state/state.ml
index 4cf6992..e8cd87e 100755
--- a/script.it/state/state.ml
+++ b/script.it/state/state.ml
@@ -1,17 +1,8 @@
-open StdLabels
-open Brr
-
 type mode =
   | Edit
   | Selection of Selection.t
   | Out
 
-(** Events *)
-type render_event =
-  [
-    `Rendering of Layer.Paths.printer
-  ]
-
 type worker_event = Worker_messages.from_worker
 
 (*
@@ -32,21 +23,13 @@ module type Handler = sig
 
   type t
 
-  val apply: t -> state -> state
+  val update: t -> state -> state
 
 end
 
 type t = E : 'a * (module Handler with type t = 'a) -> t
 
-type events =
-  [ `Export
-  | render_event
-  | worker_event
-  | `Point of float * (float * float)
-  | `Width of float
-  | `Angle of float
-  | `Generic of t
-  ]
+type events = t
 
 let post
   : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit
@@ -89,120 +72,11 @@ let select_segment _ (_, selected, p0, p1) state dist =
   ; angle
   ; width }
 
-(** Tick event
-
-    Tick only occurs when drawing a new path
-
-*)
-let tick (delay, point) state =
-  match state.mode with
-  | Edit ->
-    (* Add the point in the list *)
-    let current = insert_or_replace
-        state
-        point
-        delay
-        state.current in
-    { state with current }
-  | _ -> state
-
-let update_property worker state value f = function
-  | None -> state
-  | Some (Selection.Path outline) ->
-    (* Change width for the whole path *)
-    let outline = { outline with
-                    Outline.path = Path.Fixed.map outline.Outline.path (fun p ->
-                        f p value)
-                  } in
-    post worker (`Back outline);
-    state
-  | Some (Point (outline, point)) ->
-    let path = Path.Fixed.map
-        outline.path
-        (fun pt ->
-           match Path.Point.id pt = Path.Point.id point with
-           | false -> pt
-           | true -> f pt value)
-    in
-    let outline = {outline with path} in
-    post worker (`Back outline);
-    state
-
-let width worker width state =
-  match state.mode with
-
-  | Selection t ->
-    let state = { state with width } in
-    Selection.find_selection t state.paths
-    |> update_property worker state width Path.Point.set_width
-  | _ -> { state with width }
-
-let angle worker angle state =
-  match state.mode with
-
-  | Selection t ->
-    let state = { state with angle } in
-    Selection.find_selection t state.paths
-    |> update_property worker state angle Path.Point.set_angle
-  | _ -> { state with angle }
-
 
 let do_action
-  : Brr_webworkers.Worker.t -> (events, state) Application.t
-  = fun worker event state ->
-    match event, state.mode with
-    | `Generic (E (t, (module Handler))), _ ->
-      Handler.apply t state
-    | `Point (delay, point), _ ->
-      tick (delay, point) state
-
-
-    | `Export, _ ->
-      let my_host = Uri.host @@ Window.location @@ G.window in
-      if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
-        (* Convert the path into an sVG element *)
-        let svg = Layer.Svg.svg
-            ~at:Brr.At.[
-                v (Jstr.v "xmlns") (Jstr.v "http://www.w3.org/2000/svg")
-              ; v (Jstr.v "xmlns:xlink") (Jstr.v "http://www.w3.org/1999/xlink") ]
-            (List.map state.paths
-               ~f:(fun path ->
-
-                   Layer.Paths.to_svg
-                     ~color:Blog.Nord.nord0
-                     (module Path.Fixed)
-                     Outline.(path.path, path.back)
-                     state.rendering
-
-                 )) in
-        let content = El.prop Elements.Prop.outerHTML svg in
-        Elements.Transfert.send
-          ~mime_type:(Jstr.v "image/svg+xml")
-          ~filename:(Jstr.v "out.svg")
-          content);
-      state
-
-    | `Angle value , _ ->
-      angle worker value state
-    | `Width value, _ ->
-      width worker value state
-
-
-    | `Rendering rendering, _ ->
-      { state with rendering}
-
-    | `Other t, _ ->
-      Console.(log [t]);
-      state
-
-    | `Complete newPath, _ ->
-      let paths = List.map
-          state.paths
-          ~f:(fun line ->
-              match Outline.(newPath.id = line.id) with
-              | true -> newPath
-              | false -> line) in
-      { state with paths }
+  : (events, state) Application.t
+  = fun (E (t, (module Handler))) state ->
+    Handler.update t state
 
 
 let init =