Interior curve evaluation

1 files changed, 92 insertions, 69 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
-