diff options
Diffstat (limited to 'layer')
| -rwxr-xr-x | layer/paths.ml | 161 |
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 - |