aboutsummaryrefslogtreecommitdiff
path: root/script.it/layer
diff options
context:
space:
mode:
Diffstat (limited to 'script.it/layer')
-rwxr-xr-xscript.it/layer/ductusEngine.ml127
-rwxr-xr-xscript.it/layer/dune2
-rwxr-xr-xscript.it/layer/fillEngine.ml133
-rwxr-xr-xscript.it/layer/lineEngine.ml73
-rwxr-xr-xscript.it/layer/paths.ml352
-rwxr-xr-xscript.it/layer/repr.ml37
-rwxr-xr-xscript.it/layer/wireFramePrinter.ml127
-rwxr-xr-xscript.it/layer/wireFramePrinter.mli26
8 files changed, 410 insertions, 467 deletions
diff --git a/script.it/layer/ductusEngine.ml b/script.it/layer/ductusEngine.ml
index b943467..95cf502 100755
--- a/script.it/layer/ductusEngine.ml
+++ b/script.it/layer/ductusEngine.ml
@@ -1,82 +1,67 @@
-module Make(Layer: Repr.PRINTER) = struct
+module Path = Script_path
+module Make (Layer : Repr.PRINTER) = struct
type point = Path.Point.t
- type t =
- { path: (Layer.t)
- }
+ type t = { path : Layer.t }
type repr = Layer.t
- let create_path
- : 'b -> t
- = fun _ ->
- { path = Layer.create ()
- }
+ let create_path : 'b -> t = fun _ -> { path = Layer.create () }
+
+ let start : point -> point -> t -> t =
+ fun p1 p2 { path } ->
+ let path =
+ Layer.move_to (Path.Point.get_coord p1) path
+ |> Layer.line_to (Path.Point.get_coord p2)
+ in
+ { path }
- let start
- : point -> point -> t -> t
- = fun p1 p2 { path } ->
- let path =
- Layer.move_to (Path.Point.get_coord p1) path
- |> Layer.line_to (Path.Point.get_coord p2) in
- { path
- }
- let line_to
- : (point * point) -> (point * point) -> t -> t
- = fun (_, p1) (_, p1') {path} ->
- let path = Layer.move_to (Path.Point.get_coord p1) path in
- let path = Layer.line_to (Path.Point.get_coord p1') path in
- { path
+ let line_to : point * point -> point * point -> t -> t =
+ fun (_, p1) (_, p1') { path } ->
+ let path = Layer.move_to (Path.Point.get_coord p1) path in
+ let path = Layer.line_to (Path.Point.get_coord p1') path in
+ { path }
+
+
+ let quadratic_to :
+ point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t =
+ fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') { path } ->
+ let bezier =
+ { Shapes.Bezier.p0 = Path.Point.get_coord p0
+ ; ctrl0
+ ; ctrl1
+ ; p1 = Path.Point.get_coord p1
+ }
+ and bezier' =
+ { Shapes.Bezier.p0 = Path.Point.get_coord p0'
+ ; ctrl0 = ctrl0'
+ ; ctrl1 = ctrl1'
+ ; p1 = Path.Point.get_coord p1'
}
+ in
+
+ (* Mark each point on the bezier curve. The first point is the most
+ recent point *)
+ let delay = (Path.Point.get_stamp p0 -. Path.Point.get_stamp p1) *. 30. in
+ let path = ref path in
+ for i = 0 to Int.of_float delay do
+ let ratio = Float.of_int i /. delay in
+ let bezier, _ = Shapes.Bezier.slice ratio bezier
+ and bezier', _ = Shapes.Bezier.slice ratio bezier' in
+
+ let point = Path.Point.mix ratio bezier.Shapes.Bezier.p1 p0 p1
+ and point' = Path.Point.mix ratio bezier'.Shapes.Bezier.p1 p0' p1' in
+
+ path := Layer.move_to (Path.Point.get_coord point) !path;
+ path := Layer.line_to (Path.Point.get_coord point') !path
+ done;
+
+ { path = !path }
+
+
+ let stop : t -> t = fun path -> path
- let quadratic_to
- : (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t
- = fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') {path} ->
-
- let bezier =
- { Shapes.Bezier.p0 = Path.Point.get_coord p0
- ; ctrl0
- ; ctrl1
- ; p1 = Path.Point.get_coord p1
- }
-
- and bezier' =
- { Shapes.Bezier.p0 = Path.Point.get_coord p0'
- ; ctrl0 = ctrl0'
- ; ctrl1 = ctrl1'
- ; p1 = Path.Point.get_coord p1'
- } in
-
- (* Mark each point on the bezier curve. The first point is the most
- recent point *)
- let delay =
- ((Path.Point.get_stamp p0) -. (Path.Point.get_stamp p1))
- *. 30.
- in
- let path = ref path in
- for i = 0 to ((Int.of_float delay) ) do
- let ratio = (Float.of_int i) /. delay in
- let bezier, _ = Shapes.Bezier.slice ratio bezier
- and bezier', _ = Shapes.Bezier.slice ratio bezier' in
-
- let point = Path.Point.mix ratio bezier.Shapes.Bezier.p1 p0 p1
- and point' = Path.Point.mix ratio bezier'.Shapes.Bezier.p1 p0' p1' in
-
- path := Layer.move_to (Path.Point.get_coord point) !path;
- path := Layer.line_to (Path.Point.get_coord point') !path;
- done;
-
- { path = !path }
-
- let stop
- : t -> t
- = fun path -> path
-
-
- let get
- : t -> Layer.t
- = fun {path; _} ->
- path
+ let get : t -> Layer.t = fun { path; _ } -> path
end
diff --git a/script.it/layer/dune b/script.it/layer/dune
index 3c617ad..2459d2b 100755
--- a/script.it/layer/dune
+++ b/script.it/layer/dune
@@ -3,6 +3,6 @@
(libraries
gg
brr
- path
+ script_path
)
)
diff --git a/script.it/layer/fillEngine.ml b/script.it/layer/fillEngine.ml
index 9a3fe7e..92f94c7 100755
--- a/script.it/layer/fillEngine.ml
+++ b/script.it/layer/fillEngine.ml
@@ -1,89 +1,70 @@
-module Make(Layer: Repr.PRINTER) = struct
+module Path = Script_path
+module Make (Layer : Repr.PRINTER) = struct
type point = Path.Point.t
type repr = Layer.t
type t =
- { path: Layer.t
+ { path : Layer.t
; close : Layer.t -> Layer.t
}
- let create_path
- : (Layer.t -> Layer.t) -> t
- = fun f ->
- { close = f
- ; path = Layer.create ()
- }
+ let create_path : (Layer.t -> Layer.t) -> t =
+ fun f -> { close = f; path = Layer.create () }
+
(* Start a new path. *)
- let start
- : point -> point -> t -> t
- = fun p1 _ {close ; path } ->
- let path = Layer.move_to (Path.Point.get_coord p1) path in
- { close
- ; path
- }
-
- let line_to
- : (point * point) -> (point * point) -> t -> t
- = fun (p0, p1) (p0', p1') t ->
-
- let p0 = Path.Point.get_coord p0
- and p1 = Path.Point.get_coord p1
- and p0' = Path.Point.get_coord p0'
- and p1' = Path.Point.get_coord p1' in
-
- let path =
- Layer.move_to p1 t.path
- |> Layer.line_to p1'
- |> Layer.line_to p0'
- |> Layer.line_to p0
- |> Layer.line_to p1
- |> Layer.close in
- let path = t.close path in
- { t with path}
-
- let quadratic_to
- : (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t
- = fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') t ->
-
- let p0 = Path.Point.get_coord p0
- and p1 = Path.Point.get_coord p1
- and p0' = Path.Point.get_coord p0'
- and p1' = Path.Point.get_coord p1'
- in
-
- let path =
- Layer.move_to p1 t.path
- |> Layer.line_to p1'
-
- (* Backward *)
- |> Layer.quadratic_to
- ctrl1'
- ctrl0'
- p0'
- |> Layer.line_to p0
-
- (* Forward *)
- |> Layer.quadratic_to
- ctrl0
- ctrl1
- p1
- |> Layer.close
- |> t.close in
-
-
- { t with path }
-
- let stop
- : t -> t
- = fun t ->
- t
-
- let get
- : t -> Layer.t
- = fun t ->
- t.path
+ let start : point -> point -> t -> t =
+ fun p1 _ { close; path } ->
+ let path = Layer.move_to (Path.Point.get_coord p1) path in
+ { close; path }
+
+
+ let line_to : point * point -> point * point -> t -> t =
+ fun (p0, p1) (p0', p1') t ->
+ let p0 = Path.Point.get_coord p0
+ and p1 = Path.Point.get_coord p1
+ and p0' = Path.Point.get_coord p0'
+ and p1' = Path.Point.get_coord p1' in
+
+ let path =
+ Layer.move_to p1 t.path
+ |> Layer.line_to p1'
+ |> Layer.line_to p0'
+ |> Layer.line_to p0
+ |> Layer.line_to p1
+ |> Layer.close
+ in
+ let path = t.close path in
+ { t with path }
+
+
+ let quadratic_to :
+ point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t =
+ fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') t ->
+ let p0 = Path.Point.get_coord p0
+ and p1 = Path.Point.get_coord p1
+ and p0' = Path.Point.get_coord p0'
+ and p1' = Path.Point.get_coord p1' in
+
+ let path =
+ Layer.move_to p1 t.path
+ |> Layer.line_to p1'
+ (* Backward *)
+ |> Layer.quadratic_to ctrl1' ctrl0' p0'
+ |> Layer.line_to p0
+ (* Forward *)
+ |> Layer.quadratic_to ctrl0 ctrl1 p1
+ |> Layer.close
+ |> t.close
+ in
+
+ { t with path }
+
+
+ let stop : t -> t = fun t -> t
+
+ let get : t -> Layer.t = fun t -> t.path
end
diff --git a/script.it/layer/lineEngine.ml b/script.it/layer/lineEngine.ml
index 3d15d9c..c10017a 100755
--- a/script.it/layer/lineEngine.ml
+++ b/script.it/layer/lineEngine.ml
@@ -1,5 +1,6 @@
-module Make(Layer: Repr.PRINTER) = struct
+module Path = Script_path
+module Make (Layer : Repr.PRINTER) = struct
type point = Path.Point.t
let mark point path =
@@ -9,60 +10,50 @@ module Make(Layer: Repr.PRINTER) = struct
let dist = 5.
and dist' = -5. in
- let path = Layer.move_to (point - (of_tuple (dist, dist))) path
- |> Layer.line_to ( point + (of_tuple (dist, dist)))
- |> Layer.move_to (point + (of_tuple (dist', dist)))
- |> Layer.line_to ( point + (of_tuple (dist, dist')))
+ let path =
+ Layer.move_to (point - of_tuple (dist, dist)) path
+ |> Layer.line_to (point + of_tuple (dist, dist))
+ |> Layer.move_to (point + of_tuple (dist', dist))
+ |> Layer.line_to (point + of_tuple (dist, dist'))
in
path
- type t =
- { path: (Layer.t)
- }
+ type t = { path : Layer.t }
type repr = Layer.t
- let create_path
- : 'b -> t
- = fun _ ->
- { path = Layer.create ()
- }
+ let create_path : 'b -> t = fun _ -> { path = Layer.create () }
- let start
- : point -> point -> t -> t
- = fun p1 _ { path } ->
- let path = mark p1 path in
- { path
- }
+ let start : point -> point -> t -> t =
+ fun p1 _ { path } ->
+ let path = mark p1 path in
+ { path }
- let line_to
- : (point * point) -> (point * point) -> t -> t
- = fun (p0, p1) _ {path} ->
- let path = Layer.move_to (Path.Point.get_coord p0) path
- |> Layer.line_to (Path.Point.get_coord p1)
- |> mark p1 in
- { path
- }
- let quadratic_to
- : (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t
- = fun (p0, ctrl0, ctrl1, p1) _ {path} ->
+ let line_to : point * point -> point * point -> t -> t =
+ fun (p0, p1) _ { path } ->
+ let path =
+ Layer.move_to (Path.Point.get_coord p0) path
+ |> Layer.line_to (Path.Point.get_coord p1)
+ |> mark p1
+ in
+ { path }
- let path = Layer.move_to (Path.Point.get_coord p0) path
- |> Layer.quadratic_to ctrl0 ctrl1 (Path.Point.get_coord p1)
- |> mark p1 in
- { path = path }
+ let quadratic_to :
+ point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t =
+ fun (p0, ctrl0, ctrl1, p1) _ { path } ->
+ let path =
+ Layer.move_to (Path.Point.get_coord p0) path
+ |> Layer.quadratic_to ctrl0 ctrl1 (Path.Point.get_coord p1)
+ |> mark p1
+ in
- let stop
- : t -> t
- = fun path -> path
+ { path }
- let get
- : t -> Layer.t
- = fun {path; _} ->
- path
+ let stop : t -> t = fun path -> path
+ let get : t -> Layer.t = fun { path; _ } -> path
end
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
diff --git a/script.it/layer/repr.ml b/script.it/layer/repr.ml
index 552e2b7..4bc5520 100755
--- a/script.it/layer/repr.ml
+++ b/script.it/layer/repr.ml
@@ -1,21 +1,21 @@
-module type PRINTER = sig
+module Path = Script_path
+module type PRINTER = sig
type t
- val create: unit -> t
+ val create : unit -> t
(* Start a new path. *)
- val move_to: Gg.v2 -> t -> t
+ val move_to : Gg.v2 -> t -> t
- val line_to: Gg.v2 -> t -> t
+ val line_to : Gg.v2 -> t -> t
+ val quadratic_to : Gg.v2 -> Gg.v2 -> Gg.v2 -> t -> t
(** [quadratic_to ctrl0 ctrl1 p1] create a quadratic curve from the current
point to [p1], with control points [ctrl0] and [ctrl1] *)
- val quadratic_to: Gg.v2 -> Gg.v2 -> Gg.v2 -> t -> t
+ val close : t -> t
(** Request for the path to be closed *)
- val close: t -> t
-
end
module type ENGINE = sig
@@ -25,25 +25,16 @@ module type ENGINE = sig
type repr
- val get
- : t -> repr
-
- val create_path
- : (repr -> repr) -> t
+ val get : t -> repr
- val start
- : point -> point -> t -> t
+ val create_path : (repr -> repr) -> t
- val line_to
- : (point * point) -> (point * point) -> t -> t
+ val start : point -> point -> t -> t
- val quadratic_to
- : (point * Gg.v2 * Gg.v2 * point)
- -> (point * Gg.v2 * Gg.v2 * point)
- -> t
- -> t
+ val line_to : point * point -> point * point -> t -> t
- val stop
- : t -> t
+ val quadratic_to :
+ point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t
+ val stop : t -> t
end
diff --git a/script.it/layer/wireFramePrinter.ml b/script.it/layer/wireFramePrinter.ml
index 81ab271..e61bd7c 100755
--- a/script.it/layer/wireFramePrinter.ml
+++ b/script.it/layer/wireFramePrinter.ml
@@ -1,80 +1,69 @@
+module Path = Script_path
module Point = Path.Point
-module Make(Repr: Repr.PRINTER) = struct
+module Make (Repr : Repr.PRINTER) = struct
type t = Point.t
type repr =
- { back: (Repr.t -> Repr.t)
- ; path: (Repr.t)
+ { back : Repr.t -> Repr.t
+ ; path : Repr.t
; last_point : Point.t option
}
- let create_path
- : 'b -> repr
- = fun _ ->
- { back = Repr.close
- ; path = Repr.create ()
- ; last_point = None
- }
+ let create_path : 'b -> repr =
+ fun _ -> { back = Repr.close; path = Repr.create (); last_point = None }
+
(* Start a new path. *)
- let start
- : Point.t -> repr -> repr
- = fun t {back; path; _} ->
- let path = Repr.move_to (Point.get_coord t) path in
- let line' = Repr.line_to (Point.get_coord' t) in
- { back = (fun p -> back @@ line' p)
- ; path
- ; last_point = Some t
- }
-
- let line_to
- : Point.t -> Point.t -> repr -> repr
- = fun _ t {back; path; _} ->
- let line' = Repr.line_to (Point.get_coord' t) in
- { back = (fun t -> back @@ line' t)
- ; path = Repr.line_to (Point.get_coord t) path
- ; last_point = Some t
- }
-
- let quadratic_to
- : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr
- = fun p0 ctrl0 ctrl1 p1 t ->
-
- let ctrl0' = Point.copy p1 ctrl0
- and ctrl1' = Point.copy p1 ctrl1 in
-
- let line' path =
- Repr.quadratic_to
- (Point.get_coord' @@ ctrl1')
- (Point.get_coord' ctrl0')
- (Point.get_coord' p0) path in
-
- let path = Repr.quadratic_to
- (Point.get_coord ctrl0')
- (Point.get_coord ctrl1')
- (Point.get_coord p1)
- t.path in
- { back = (fun p -> t.back @@ line' p)
- ; path
- ; last_point = Some p1
- }
-
- let stop
- : repr -> repr
- = fun {back; path; last_point} ->
-
- let path =
- match last_point with
- | Some point -> Repr.line_to (Point.get_coord' point) path
- | None -> path in
-
- { back = (fun x -> x)
- ; path = back path
- ; last_point = None }
-
- let get
- : repr -> Repr.t
- = fun {back; path; _} ->
- back path
+ let start : Point.t -> repr -> repr =
+ fun t { back; path; _ } ->
+ let path = Repr.move_to (Point.get_coord t) path in
+ let line' = Repr.line_to (Point.get_coord' t) in
+ { back = (fun p -> back @@ line' p); path; last_point = Some t }
+
+
+ let line_to : Point.t -> Point.t -> repr -> repr =
+ fun _ t { back; path; _ } ->
+ let line' = Repr.line_to (Point.get_coord' t) in
+ { back = (fun t -> back @@ line' t)
+ ; path = Repr.line_to (Point.get_coord t) path
+ ; last_point = Some t
+ }
+
+
+ let quadratic_to : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr =
+ fun p0 ctrl0 ctrl1 p1 t ->
+ let ctrl0' = Point.copy p1 ctrl0
+ and ctrl1' = Point.copy p1 ctrl1 in
+
+ let line' path =
+ Repr.quadratic_to
+ (Point.get_coord' @@ ctrl1')
+ (Point.get_coord' ctrl0')
+ (Point.get_coord' p0)
+ path
+ in
+
+ let path =
+ Repr.quadratic_to
+ (Point.get_coord ctrl0')
+ (Point.get_coord ctrl1')
+ (Point.get_coord p1)
+ t.path
+ in
+ { back = (fun p -> t.back @@ line' p); path; last_point = Some p1 }
+
+
+ let stop : repr -> repr =
+ fun { back; path; last_point } ->
+ let path =
+ match last_point with
+ | Some point -> Repr.line_to (Point.get_coord' point) path
+ | None -> path
+ in
+
+ { back = (fun x -> x); path = back path; last_point = None }
+
+
+ let get : repr -> Repr.t = fun { back; path; _ } -> back path
end
diff --git a/script.it/layer/wireFramePrinter.mli b/script.it/layer/wireFramePrinter.mli
index b198d58..3b18814 100755
--- a/script.it/layer/wireFramePrinter.mli
+++ b/script.it/layer/wireFramePrinter.mli
@@ -1,27 +1,21 @@
-module Make(Repr:Repr.PRINTER): sig
+module Path = Script_path
- type repr
+module Make (Repr : Repr.PRINTER) : sig
+ type repr
type t = Path.Point.t
- val create_path
- : 'b -> repr
+ val create_path : 'b -> repr
(* Start a new path. *)
- val start
- : Path.Point.t -> repr -> repr
+ val start : Path.Point.t -> repr -> repr
- val line_to
- : Path.Point.t -> Path.Point.t -> repr -> repr
+ val line_to : Path.Point.t -> Path.Point.t -> repr -> repr
- val quadratic_to
- : Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr
+ val quadratic_to :
+ Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr
- val stop
- : repr -> repr
-
-
- val get
- : repr -> Repr.t
+ val stop : repr -> repr
+ val get : repr -> Repr.t
end