diff options
Diffstat (limited to 'script.it/layer/paths.ml')
| -rwxr-xr-x | script.it/layer/paths.ml | 352 |
1 files changed, 182 insertions, 170 deletions
diff --git a/script.it/layer/paths.ml b/script.it/layer/paths.ml index d3baf02..1c4251f 100755 --- a/script.it/layer/paths.ml +++ b/script.it/layer/paths.ml @@ -1,95 +1,82 @@ -open StdLabels (** Common module for ensuring that the function is evaluated only once *) +open StdLabels + +module Path = Script_path (** This represent a single path, which can be transformed throug a [repr] function. *) module type PATH = sig type t + val repr : + t + -> (module Path.Repr.M with type point = Path.Point.t and type t = 's) + -> 's + -> 's (** 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 ] - + | `Ductus + ] module type P = sig include Path.Repr.M type repr - val create_path - : (repr -> repr) -> t + val create_path : (repr -> repr) -> t - val get - : t -> repr + 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 - +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 get : t -> repr = M.get - let create_path - : (repr -> repr) -> t - = M.create_path + 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 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 -> + 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 - 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 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 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) + | Move of point | Line_to of (point * point) | Quadratic of (point * Gg.v2 * Gg.v2 * point) @@ -98,42 +85,35 @@ module ReprSingle = struct type point = Path.Point.t - let start t actions = - (Move t)::actions + let start t actions = Move t :: actions - let line_to p0 p1 actions = - Line_to (p0, p1)::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 quadratic_to : point * Gg.v2 * Gg.v2 * point -> t -> t = + fun q actions -> Quadratic q :: actions - let stop - : t -> t - = fun v -> v + 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 + 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) +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) - +module FillSVG = FillEngine.Make (Svg) +module DuctusSVG = DuctusEngine.Make (Svg) (** Draw a path to a canva.contents @@ -141,104 +121,136 @@ module DuctusSVG = DuctusEngine.Make(Svg) 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 - +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 +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 |