diff options
Diffstat (limited to 'script.it/layer/paths.ml')
| -rwxr-xr-x | script.it/layer/paths.ml | 244 |
1 files changed, 244 insertions, 0 deletions
diff --git a/script.it/layer/paths.ml b/script.it/layer/paths.ml new file mode 100755 index 0000000..d3baf02 --- /dev/null +++ b/script.it/layer/paths.ml @@ -0,0 +1,244 @@ +open StdLabels +(** Common module for ensuring that the function is evaluated only once *) + +(** This represent a single path, which can be transformed throug a [repr] + function. *) +module type PATH = sig + type t + + (** Represent the path *) + val repr + : t -> (module Path.Repr.M + with type point = Path.Point.t + and type t = 's) -> 's -> 's +end + +type printer = + [ `Fill + | `Line + | `Ductus ] + + +module type P = sig + include Path.Repr.M + + type repr + + val create_path + : (repr -> repr) -> t + + val get + : t -> repr +end + + +module MakePrinter(M:Repr.ENGINE) : P + with type point = M.point + and type t = M.t + and type repr = M.repr = struct + + type t = M.t + + type point = M.point + + type repr = M.repr + + let get + : t -> repr + = M.get + + let create_path + : (repr -> repr) -> t + = M.create_path + + let start + : Path.Point.t -> t -> t + = fun pt t -> + M.start pt pt t + + let line_to + : Path.Point.t -> Path.Point.t -> t -> t + = fun p0 p1 t -> + + M.line_to + ( p0 + , p1 ) + ( Path.Point.copy p0 @@ Path.Point.get_coord' p0 + , Path.Point.copy p1 @@ Path.Point.get_coord' p1 ) + t + + let quadratic_to + : (Path.Point.t * Gg.v2 * Gg.v2 * Path.Point.t) -> t -> t + = fun (p0, ctrl0, ctrl1, p1) t -> + + + let ctrl0' = Path.Point.get_coord' @@ Path.Point.copy p0 ctrl0 + and ctrl1' = Path.Point.get_coord' @@ Path.Point.copy p1 ctrl1 in + M.quadratic_to + (p0, ctrl0, ctrl1, p1) + (Path.Point.copy p0 @@ Path.Point.get_coord' p0, ctrl0', ctrl1', Path.Point.copy p1 @@ Path.Point.get_coord' p1) + + t + + let stop = M.stop +end + +(** Transform the two path, into a single one. *) +module ReprSingle = struct + + type point = Path.Point.t + + 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 point = Path.Point.t + + let start t actions = + (Move t)::actions + + let line_to p0 p1 actions = + Line_to (p0, p1)::actions + + let quadratic_to + : (point * Gg.v2 * Gg.v2 * point) -> t -> t + = fun q actions -> + (Quadratic q)::actions + + let stop + : t -> t + = fun v -> v + + end + + let repr + : (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 + +(* Canva representation *) + +module FillCanva = FillEngine.Make(CanvaPrinter) +module LineCanva = LineEngine.Make(CanvaPrinter) +module DuctusCanva = DuctusEngine.Make(CanvaPrinter) + +(* SVG representation *) + +module FillSVG = FillEngine.Make(Svg) +module DuctusSVG = DuctusEngine.Make(Svg) + + +(** Draw a path to a canva.contents + + 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 * '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 -> + 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 -> + 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 -> + 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 * '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 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.[ + v (Jstr.v "fill") color + ; v (Jstr.v "stroke") color] + !paths + + | `Ductus -> + 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 + ; v (Jstr.v "stroke") color + ; v (Jstr.v "d") svg_path ] + [] + | `Line -> + raise Not_found |