Interior curve evaluation

9 files changed, 172 insertions, 126 deletions

diff --git a/layer/paths.ml b/layer/paths.ml
index 3a8bfe8..d3baf02 100755
--- a/layer/paths.ml
+++ b/layer/paths.ml
@@ -84,19 +84,19 @@ module MakePrinter(M:Repr.ENGINE) : P
 end
 
 (** Transform the two path, into a single one. *)
-module ReprSingle(T:PATH) = struct
+module ReprSingle = struct
 
-  type t = T.t * T.t
+  type point = Path.Point.t
 
-  module R = struct
-    type point = Path.Point.t
+  type repr =
+    | Move of (point)
+    | Line_to of (point * point)
+    | Quadratic of (point * Gg.v2 * Gg.v2 * point)
 
-    type repr' =
-      | Move of (point)
-      | Line_to of (point * point)
-      | Quadratic of (point * Gg.v2 * Gg.v2 * point)
+  module R = struct
+    type t = repr list
 
-    type t = repr' list
+    type point = Path.Point.t
 
     let start t actions =
       (Move t)::actions
@@ -111,92 +111,109 @@ module ReprSingle(T:PATH) = struct
 
     let stop
       : t -> t
-      = fun v -> List.rev v
+      = fun v -> v
 
   end
 
   let repr
-    : t -> (module Path.Repr.M with type point = Path.Point.t and type t = 's) -> 's -> 's
-    = fun (type s) (path, _) (module Repr:Path.Repr.M with type point = Path.Point.t and type t = s) state ->
-      let elems = T.repr path (module R) [] in
-
-      let state = List.fold_left elems
-          ~init:state
-          ~f:(fun state -> function
-              | R.Move pt -> Repr.start pt state
-              | R.Line_to (p0, p1) -> Repr.line_to p0 p1 state
-              | R.Quadratic t -> Repr.quadratic_to t state
-            )
-      in Repr.stop state
+    : (module PATH with type t = 't) -> 't -> 't -> repr list * repr list
+    = fun (type t) (module P:PATH with type t = t) path back ->
+      let path = P.repr path (module R) []
+      and back = P.repr back (module R) [] in
+      path, back
 end
 
-module ReprFixed = ReprSingle(Path.Fixed)
-module ReprBuild = ReprSingle(Path.Path_Builder)
-
 (* Canva representation *)
 
 module FillCanva = FillEngine.Make(CanvaPrinter)
 module LineCanva = LineEngine.Make(CanvaPrinter)
-module DuctusCanva = FillEngine.Make(CanvaPrinter)
-
-module FillCanvaRepr = MakePrinter(FillCanva)
-module DuctusCanvaRepr = MakePrinter(DuctusCanva)
-module LineCanvaRepr = MakePrinter(LineCanva)
+module DuctusCanva = DuctusEngine.Make(CanvaPrinter)
 
 (* SVG representation *)
 
-module FillSVGRepr = MakePrinter(FillEngine.Make(Svg))
-module DuctusSVGRepr = MakePrinter(DuctusEngine.Make(Svg))
+module FillSVG = FillEngine.Make(Svg)
+module DuctusSVG = DuctusEngine.Make(Svg)
+
 
+(** Draw a path to a canva.contents
 
-(** Draw a path to a canva *)
+    The code may seems scary, but is very repetitive. Firt, all points (from the
+    main stroke, and the interior one) are evaluated. Then, they are both rendered
+    using the selected engine.
+*)
 let to_canva
-  : (module PATH with type t = 's)  -> 's -> Brr_canvas.C2d.t -> printer -> unit
-  = fun (type s) (module R:PATH with type t = s) path ctx -> function
+  : (module PATH with type t = 's) -> 's * 's -> Brr_canvas.C2d.t -> printer -> unit
+  = fun (type s) (module R:PATH with type t = s) (path, back) ctx engine ->
+    let f, b = ReprSingle.repr (module R) path back in
+    match engine with
     | `Fill ->
-      R.repr
-        path
-        (module FillCanvaRepr)
-        (FillCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
-      |> FillCanvaRepr.get
+      let t = List.fold_left2 f b
+          ~init:(FillCanva.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
+          ~f:(fun ctx f b ->
+              match (f, b) with
+              | ReprSingle.Move p0, ReprSingle.Move p0' -> FillCanva.start p0 p0' ctx
+              | ReprSingle.Line_to l, ReprSingle.Line_to l' -> FillCanva.line_to l l' ctx
+              | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> FillCanva.quadratic_to q q' ctx
+              | _ -> ctx
+            ) in
+      FillCanva.get t
       |> Brr_canvas.C2d.stroke ctx
     | `Line ->
-      R.repr
-        path
-        (module LineCanvaRepr)
-        (LineCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
-      |> LineCanvaRepr.get
+      let t = List.fold_left2 f b
+          ~init:(LineCanva.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
+          ~f:(fun ctx f b ->
+              match (f, b) with
+              | ReprSingle.Move p0, ReprSingle.Move p0' -> LineCanva.start p0 p0' ctx
+              | ReprSingle.Line_to l, ReprSingle.Line_to l' -> LineCanva.line_to l l' ctx
+              | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> LineCanva.quadratic_to q q' ctx
+              | _ -> ctx
+            ) in
+      LineCanva.get t
       |> Brr_canvas.C2d.stroke ctx
     | `Ductus ->
-      R.repr
-        path
-        (module DuctusCanvaRepr)
-        (DuctusCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
-      |> DuctusCanvaRepr.get
+      let t = List.fold_left2 f b
+          ~init:(DuctusCanva.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
+          ~f:(fun ctx f b ->
+              match (f, b) with
+              | ReprSingle.Move p0, ReprSingle.Move p0' -> DuctusCanva.start p0 p0' ctx
+              | ReprSingle.Line_to l, ReprSingle.Line_to l' -> DuctusCanva.line_to l l' ctx
+              | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> DuctusCanva.quadratic_to q q' ctx
+              | _ -> ctx
+            ) in
+      DuctusCanva.get t
       |> Brr_canvas.C2d.stroke ctx
 
 
+
 (** Draw a path and represent it as SVG *)
 let to_svg
-  : (module PATH with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t
-  = fun (type s) (module R:PATH with type t = s) ~color path -> function
+  : (module PATH with type t = 's) -> color:Jstr.t -> 's * 's -> printer -> Brr.El.t
+  = fun (type s) (module R:PATH with type t = s) ~color (path, back) engine ->
+    let f, b = ReprSingle.repr (module R) path back in
+    match engine with
     | `Fill ->
 
       (* In order to deal with over crossing path, I cut the path in as
          many segment as there is curve, and fill them all. Then, all of theme
          are grouped inside a single element *)
       let paths = ref [] in
-      let _ = 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
+      let init = (FillSVG.create_path
+                    (fun p ->
+                       let repr = Svg.path
+                           ~at:Brr.At.[ v (Jstr.v "d") p ]
+                           [] in
+
+                       paths := repr::!paths;
+                       Jstr.empty)) in
+      let _ = List.fold_left2 f b
+          ~init
+          ~f:(fun ctx f b ->
+              match (f, b) with
+              | ReprSingle.Move p0, ReprSingle.Move p0' -> FillSVG.start p0 p0' ctx
+              | ReprSingle.Line_to l, ReprSingle.Line_to l' -> FillSVG.line_to l l' ctx
+              | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> FillSVG.quadratic_to q q' ctx
+              | _ -> ctx
+            ) in
 
       Brr.El.v (Jstr.v "g")
         ~at:Brr.At.[
@@ -205,11 +222,18 @@ let to_svg
         !paths
 
     | `Ductus ->
-      let svg_path = R.repr
-          path
-          (module DuctusSVGRepr)
-          (DuctusSVGRepr.create_path (fun _ -> Jstr.empty))
-                     |> DuctusSVGRepr.get in
+      let init = DuctusSVG.create_path (fun _ -> Jstr.empty) in
+      let svg_path = List.fold_left2 f b
+          ~init
+          ~f:(fun ctx f b ->
+              match (f, b) with
+              | ReprSingle.Move p0, ReprSingle.Move p0' -> DuctusSVG.start p0 p0' ctx
+              | ReprSingle.Line_to l, ReprSingle.Line_to l' -> DuctusSVG.line_to l l' ctx
+              | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> DuctusSVG.quadratic_to q q' ctx
+              | _ -> ctx
+            )
+                     |> DuctusSVG.get in
+
       Svg.path
         ~at:Brr.At.[
             v (Jstr.v "fill")  color
@@ -218,4 +242,3 @@ let to_svg
         []
     | `Line ->
       raise Not_found
-
diff --git a/path/builder.ml b/path/builder.ml
index 166c073..4403599 100755
--- a/path/builder.ml
+++ b/path/builder.ml
@@ -203,4 +203,22 @@ module Make(Point:P) = struct
               path
           )
 
+  let map
+    : t -> (Point.t -> Point.t) -> t
+    = fun (points, beziers) f ->
+      let points = List.map
+          points
+          ~f
+      and beziers = List.map
+          beziers
+          ~f:(fun bezier ->
+
+              { p0 = f bezier.p0
+              ; p1 = f bezier.p1
+              ; ctrl0 = Point.(get_coord (f ( copy bezier.p0 bezier.ctrl0)))
+              ; ctrl1 = Point.(get_coord (f ( copy bezier.p1 bezier.ctrl1)))
+              }
+            ) in
+      points, beziers
+
 end
diff --git a/path/builder.mli b/path/builder.mli
index ff66bcb..2afbd4b 100755
--- a/path/builder.mli
+++ b/path/builder.mli
@@ -37,4 +37,7 @@ module Make(Point:P) : sig
   val repr
     : t -> (module Repr.M with type point = Point.t and type t = 's) -> 's -> 's
 
+  val map 
+    : t -> (Point.t -> Point.t) -> t
+
 end
diff --git a/path/fixed.ml b/path/fixed.ml
index d61bb0a..1362ad3 100755
--- a/path/fixed.ml
+++ b/path/fixed.ml
@@ -179,7 +179,12 @@ module Make(Point:P) = struct
             | Curve bezier ->
               let point = f step.point in
               { point
-              ; move = Curve {bezier with p1 = f bezier.p1} }
+              ; move = Curve
+                    { p1 = f bezier.p1
+                    ; ctrl0 = Point.get_coord (f (Point.copy step.point bezier.ctrl0))
+                    ; ctrl1 = Point.get_coord (f (Point.copy bezier.p1 bezier.ctrl1))
+                    }
+              }
           )
 
   let iter
diff --git a/script.it/outline.ml b/script.it/outline.ml
index 4962d8e..0dbecd0 100755
--- a/script.it/outline.ml
+++ b/script.it/outline.ml
@@ -6,7 +6,7 @@ type t =
   ; back: Path.Fixed.t
   }
 
-let get_id =
+let get_id () =
   let id = !internal_path_id in
   incr internal_path_id;
   id
diff --git a/script.it/script.ml b/script.it/script.ml
index 9ef15fe..3859cc9 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -225,7 +225,10 @@ let on_change canva mouse_position timer state =
   in
 
 
-  Layer.Paths.to_canva (module Layer.Paths.ReprBuild) (current, current) context state.rendering;
+  let back = Path.Path_Builder.map
+      current
+      (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
+  Layer.Paths.to_canva (module Path.Path_Builder) (current, back) context state.rendering;
 
   List.iter state.paths
     ~f:(fun path ->
@@ -246,7 +249,7 @@ let on_change canva mouse_position timer state =
         in
 
         let p = path.Outline.path in
-        Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (p, p) context state.rendering
+        Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context state.rendering
       );
 
   let () = match state.mode with
@@ -257,7 +260,7 @@ let on_change canva mouse_position timer state =
         ~f:(fun path ->
             if id = path.Outline.id then
               let p = path.Outline.path in
-              Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (p, p) context `Line
+              Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context `Line
           )
     | Selection (Point (id, point)) ->
       (* As before, mark the selected path *)
@@ -265,22 +268,22 @@ let on_change canva mouse_position timer state =
 
       List.iter
         state.paths
-        ~f:(fun path ->
-            if id = path.Outline.id then
+        ~f:(fun outline ->
+            if id = outline.Outline.id then
               let path = begin match pos with
                 | Some pos ->
 
                   let pos_v2 = Gg.V2.of_tuple pos in
                   if Elements.Timer.delay timer < 0.3 then
-                    path.Outline.path
+                    outline.Outline.path
                   else
                     let point' = Path.Point.copy point pos_v2 in
-                    begin match Path.Fixed.replace_point path.Outline.path point' with
-                      | None -> path.Outline.path
+                    begin match Path.Fixed.replace_point outline.Outline.path point' with
+                      | None -> outline.Outline.path
                       | Some p -> p
                     end
-                | None -> path.Outline.path end in
-              Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (path, path) context `Line
+                | None -> outline.Outline.path end in
+              Layer.Paths.to_canva (module Path.Fixed) (path, outline.Outline.back) context `Line
           );
 
       (* Now draw the selected point *)
diff --git a/script.it/state.ml b/script.it/state.ml
index 403efbe..fd35554 100755
--- a/script.it/state.ml
+++ b/script.it/state.ml
@@ -21,10 +21,7 @@ type render_event =
     `Rendering of Layer.Paths.printer
   ]
 
-type worker_event =
-  [ `Basic of Jv.t
-  | `Complete of Outline.t
-  ]
+type worker_event = Worker_messages.from_worker
 
 type events =
   [ canva_events
@@ -280,31 +277,31 @@ let do_action
         | Some _ ->
 
           let current = insert_or_replace state point stamp state.current in
-          let paths =
-
-            let path = Path.Fixed.to_fixed
-                (module Path.Path_Builder)
-                current in
-
-            (* Create a copy from the path with all the interior points *)
-            let back = Path.Fixed.map
-                path
-                (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
-
-            let last =
-              { Outline.path = path
-              ; Outline.back = back
-              ; Outline.id = Outline.get_id
-              }
-            in
-
-            let () = post worker (`Complete last) in
-            last::state.paths
-          and current = Path.Path_Builder.empty in
-
-          { state with
-            mode = Out
-          ; paths; current }
+          let path = Path.Fixed.to_fixed
+              (module Path.Path_Builder)
+              current in
+
+          (* Create a copy from the path with all the interior points *)
+          let back = Path.Fixed.map
+              path
+              (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
+
+          let last =
+            { Outline.path = path
+            ; Outline.back = back
+            ; Outline.id = Outline.get_id ()
+            }
+          in
+
+          (* Send to the worker for a full review *)
+          let () = post worker (`Complete last) in
+
+          let state =
+            { state with
+              mode = Out
+            ; paths = last::state.paths
+            ; current = Path.Path_Builder.empty } in
+          state
 
         (* Else, check if there is a curve under the cursor, and remove it *)
         | None ->
@@ -357,8 +354,8 @@ let do_action
 
                    Layer.Paths.to_svg
                      ~color:Blog.Nord.nord0
-                     (module Layer.Paths.ReprFixed)
-                     (path.Outline.path, path.Outline.path)
+                     (module Path.Fixed)
+                     (path.Outline.path, path.Outline.back)
                      state.rendering
 
                  )) in
@@ -388,20 +385,17 @@ let do_action
     | `Rendering rendering, _ ->
       { state with rendering}
 
-
-    | `Basic t, _ ->
+    | `Other t, _ ->
       Console.(log [t]);
       state
 
-    | `Complete path, _ ->
-      let id = path.Outline.id in
-      let paths = List.map state.paths
+    | `Complete newPath, _ ->
+      let paths = List.map
+          state.paths
           ~f:(fun line ->
-              let id' = line.Outline.id in
-              match id = id' with
-              | false -> line
-              | true -> path
-            ) in
+              match newPath.Outline.id = line.Outline.id with
+              | true -> newPath
+              | false -> line) in
       { state with paths }
 
 
diff --git a/script.it/worker.ml b/script.it/worker.ml
index 898df39..51fe49c 100755
--- a/script.it/worker.ml
+++ b/script.it/worker.ml
@@ -19,7 +19,7 @@ let execute (command: [> Worker_messages.to_worker]) =
         path
         (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
     let=? back = Path.Fixed.rebuild back in
-    Worker.post_message (`Complete {outline with path; back})
+    post_message (`Complete {outline with path; back})
 
   (* Remove the point from the main line, and reevaluate the whole path *)
   | `DeletePoint (point, outline) ->
@@ -28,7 +28,7 @@ let execute (command: [> Worker_messages.to_worker]) =
         path
         (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
     let=? back = Path.Fixed.rebuild back in
-    Worker.post_message (`Complete {outline with path; back})
+    post_message (`Complete {outline with path; back})
 
   (* Only evaluate the interior *)
   | `Back outline ->
@@ -36,7 +36,7 @@ let execute (command: [> Worker_messages.to_worker]) =
         outline.Outline.path
         (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
     let=? back = Path.Fixed.rebuild back in
-    Worker.post_message (`Complete {outline with back})
+    post_message (`Complete {outline with back})
 
   | _ ->
     post_message (`Other (Js.string "Unknown message received"))
diff --git a/script.it/worker_messages/worker_messages.ml b/script.it/worker_messages/worker_messages.ml
index a4d05c8..b33bb23 100755
--- a/script.it/worker_messages/worker_messages.ml
+++ b/script.it/worker_messages/worker_messages.ml
@@ -7,6 +7,6 @@ type to_worker = [
 ]
 
 type from_worker = [
-  | `Complete of Path.Fixed.t
+  | `Complete of Outline.t
   | `Other of Js.js_string Js.t
 ]