aboutsummaryrefslogtreecommitdiff
path: root/layer/paths.ml
diff options
context:
space:
mode:
Diffstat (limited to 'layer/paths.ml')
-rwxr-xr-xlayer/paths.ml244
1 files changed, 0 insertions, 244 deletions
diff --git a/layer/paths.ml b/layer/paths.ml
deleted file mode 100755
index d3baf02..0000000
--- a/layer/paths.ml
+++ /dev/null
@@ -1,244 +0,0 @@
-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
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-03 11:42:26 +0000