From 42c3c122c4f53dd68bcdd89411835887c3ae0af9 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Mon, 11 Jan 2021 11:33:32 +0100 Subject: Outline module --- layer/ductusEngine.ml | 82 ++++++++++++++++++++++++++++++ layer/ductusEngine.mli | 2 + layer/ductusPrinter.ml | 82 ------------------------------ layer/ductusPrinter.mli | 2 - layer/fillEngine.ml | 89 ++++++++++++++++++++++++++++++++ layer/fillEngine.mli | 2 + layer/fillPrinter.ml | 89 -------------------------------- layer/fillPrinter.mli | 2 - layer/lineEngine.ml | 68 +++++++++++++++++++++++++ layer/lineEngine.mli | 2 + layer/linePrinter.ml | 68 ------------------------- layer/linePrinter.mli | 2 - layer/paths.ml | 131 +++++++++++++++++++++++++++--------------------- layer/repr.ml | 2 +- 14 files changed, 319 insertions(+), 304 deletions(-) create mode 100755 layer/ductusEngine.ml create mode 100755 layer/ductusEngine.mli delete mode 100755 layer/ductusPrinter.ml delete mode 100755 layer/ductusPrinter.mli create mode 100755 layer/fillEngine.ml create mode 100755 layer/fillEngine.mli delete mode 100755 layer/fillPrinter.ml delete mode 100755 layer/fillPrinter.mli create mode 100755 layer/lineEngine.ml create mode 100755 layer/lineEngine.mli delete mode 100755 layer/linePrinter.ml delete mode 100755 layer/linePrinter.mli (limited to 'layer') diff --git a/layer/ductusEngine.ml b/layer/ductusEngine.ml new file mode 100755 index 0000000..b943467 --- /dev/null +++ b/layer/ductusEngine.ml @@ -0,0 +1,82 @@ +module Make(Layer: Repr.PRINTER) = struct + + type point = Path.Point.t + + type t = + { path: (Layer.t) + } + + type repr = Layer.t + + 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 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 get + : t -> Layer.t + = fun {path; _} -> + path +end diff --git a/layer/ductusEngine.mli b/layer/ductusEngine.mli new file mode 100755 index 0000000..e1660f4 --- /dev/null +++ b/layer/ductusEngine.mli @@ -0,0 +1,2 @@ +module Make(R:Repr.PRINTER): + Repr.ENGINE with type repr = R.t diff --git a/layer/ductusPrinter.ml b/layer/ductusPrinter.ml deleted file mode 100755 index db34481..0000000 --- a/layer/ductusPrinter.ml +++ /dev/null @@ -1,82 +0,0 @@ -module Make(Repr: Repr.PRINTER) = struct - - type point = Path.Point.t - - type t = - { path: (Repr.t) - } - - type repr = Repr.t - - let create_path - : 'b -> t - = fun _ -> - { path = Repr.create () - } - - let start - : point -> point -> t -> t - = fun p1 p2 { path } -> - let path = - Repr.move_to (Path.Point.get_coord p1) path - |> Repr.line_to (Path.Point.get_coord p2) in - { path - } - - let line_to - : (point * point) -> (point * point) -> t -> t - = fun (_, p1) (_, p1') {path} -> - let path = Repr.move_to (Path.Point.get_coord p1) path in - let path = Repr.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 := Repr.move_to (Path.Point.get_coord point) !path; - path := Repr.line_to (Path.Point.get_coord point') !path; - done; - - { path = !path } - - let stop - : t -> t - = fun path -> path - - - let get - : t -> Repr.t - = fun {path; _} -> - path -end diff --git a/layer/ductusPrinter.mli b/layer/ductusPrinter.mli deleted file mode 100755 index cdcaa7c..0000000 --- a/layer/ductusPrinter.mli +++ /dev/null @@ -1,2 +0,0 @@ -module Make(R:Repr.PRINTER): - Repr.LAYER with type repr = R.t diff --git a/layer/fillEngine.ml b/layer/fillEngine.ml new file mode 100755 index 0000000..9a3fe7e --- /dev/null +++ b/layer/fillEngine.ml @@ -0,0 +1,89 @@ +module Make(Layer: Repr.PRINTER) = struct + + type point = Path.Point.t + + type repr = Layer.t + + type t = + { path: Layer.t + ; close : Layer.t -> Layer.t + } + + 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 +end diff --git a/layer/fillEngine.mli b/layer/fillEngine.mli new file mode 100755 index 0000000..e1660f4 --- /dev/null +++ b/layer/fillEngine.mli @@ -0,0 +1,2 @@ +module Make(R:Repr.PRINTER): + Repr.ENGINE with type repr = R.t diff --git a/layer/fillPrinter.ml b/layer/fillPrinter.ml deleted file mode 100755 index f3717c2..0000000 --- a/layer/fillPrinter.ml +++ /dev/null @@ -1,89 +0,0 @@ -module Make(Repr: Repr.PRINTER) = struct - - type point = Path.Point.t - - type repr = Repr.t - - type t = - { path: Repr.t - ; close : Repr.t -> Repr.t - } - - let create_path - : (Repr.t -> Repr.t) -> t - = fun f -> - { close = f - ; path = Repr.create () - } - - (* Start a new path. *) - - let start - : point -> point -> t -> t - = fun p1 _ {close ; path } -> - let path = Repr.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 = - Repr.move_to p1 t.path - |> Repr.line_to p1' - |> Repr.line_to p0' - |> Repr.line_to p0 - |> Repr.line_to p1 - |> Repr.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 = - Repr.move_to p1 t.path - |> Repr.line_to p1' - - (* Backward *) - |> Repr.quadratic_to - ctrl1' - ctrl0' - p0' - |> Repr.line_to p0 - - (* Forward *) - |> Repr.quadratic_to - ctrl0 - ctrl1 - p1 - |> Repr.close - |> t.close in - - - { t with path } - - let stop - : t -> t - = fun t -> - t - - let get - : t -> Repr.t - = fun t -> - t.path -end diff --git a/layer/fillPrinter.mli b/layer/fillPrinter.mli deleted file mode 100755 index cdcaa7c..0000000 --- a/layer/fillPrinter.mli +++ /dev/null @@ -1,2 +0,0 @@ -module Make(R:Repr.PRINTER): - Repr.LAYER with type repr = R.t diff --git a/layer/lineEngine.ml b/layer/lineEngine.ml new file mode 100755 index 0000000..3d15d9c --- /dev/null +++ b/layer/lineEngine.ml @@ -0,0 +1,68 @@ +module Make(Layer: Repr.PRINTER) = struct + + type point = Path.Point.t + + let mark point path = + let open Gg.V2 in + let point = Path.Point.get_coord point in + + 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'))) + in + path + + + type t = + { path: (Layer.t) + } + + type repr = Layer.t + + 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 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 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 stop + : t -> t + = fun path -> path + + + let get + : t -> Layer.t + = fun {path; _} -> + path + +end diff --git a/layer/lineEngine.mli b/layer/lineEngine.mli new file mode 100755 index 0000000..86ef5fb --- /dev/null +++ b/layer/lineEngine.mli @@ -0,0 +1,2 @@ +module Make(R:Repr.PRINTER): + Repr.ENGINE with type repr = R.t diff --git a/layer/linePrinter.ml b/layer/linePrinter.ml deleted file mode 100755 index d223760..0000000 --- a/layer/linePrinter.ml +++ /dev/null @@ -1,68 +0,0 @@ -module Make(Repr: Repr.PRINTER) = struct - - type point = Path.Point.t - - let mark point path = - let open Gg.V2 in - let point = Path.Point.get_coord point in - - let dist = 5. - and dist' = -5. in - - let path = Repr.move_to (point - (of_tuple (dist, dist))) path - |> Repr.line_to ( point + (of_tuple (dist, dist))) - |> Repr.move_to (point + (of_tuple (dist', dist))) - |> Repr.line_to ( point + (of_tuple (dist, dist'))) - in - path - - - type t = - { path: (Repr.t) - } - - type repr = Repr.t - - let create_path - : 'b -> t - = fun _ -> - { path = Repr.create () - } - - 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 = Repr.move_to (Path.Point.get_coord p0) path - |> Repr.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 path = Repr.move_to (Path.Point.get_coord p0) path - |> Repr.quadratic_to ctrl0 ctrl1 (Path.Point.get_coord p1) - |> mark p1 in - - { path = path } - - let stop - : t -> t - = fun path -> path - - - let get - : t -> Repr.t - = fun {path; _} -> - path - -end diff --git a/layer/linePrinter.mli b/layer/linePrinter.mli deleted file mode 100755 index 191830a..0000000 --- a/layer/linePrinter.mli +++ /dev/null @@ -1,2 +0,0 @@ -module Make(R:Repr.PRINTER): - Repr.LAYER with type repr = R.t diff --git a/layer/paths.ml b/layer/paths.ml index 6d0157e..3a8bfe8 100755 --- a/layer/paths.ml +++ b/layer/paths.ml @@ -1,12 +1,16 @@ open StdLabels (** Common module for ensuring that the function is evaluated only once *) -module type REPRESENTABLE = sig +(** 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 + : t -> (module Path.Repr.M + with type point = Path.Point.t + and type t = 's) -> 's -> 's end type printer = @@ -28,7 +32,10 @@ module type P = sig end -module MakePrinter(M:Repr.LAYER) : 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 @@ -76,22 +83,76 @@ module MakePrinter(M:Repr.LAYER) : P with type point = M.point and type t = M.t let stop = M.stop end +(** Transform the two path, into a single one. *) +module ReprSingle(T:PATH) = struct + + type t = T.t * T.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 t = repr' list + + 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 -> List.rev 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 +end + +module ReprFixed = ReprSingle(Path.Fixed) +module ReprBuild = ReprSingle(Path.Path_Builder) + (* Canva representation *) -module FillCanvaRepr = MakePrinter(FillPrinter.Make(CanvaPrinter)) -module DuctusCanvaRepr = MakePrinter(DuctusPrinter.Make(CanvaPrinter)) -module LineCanvaRepr = MakePrinter(LinePrinter.Make(CanvaPrinter)) +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) (* SVG representation *) -module FillSVGRepr = MakePrinter(FillPrinter.Make(Svg)) -module DuctusSVGRepr = MakePrinter(DuctusPrinter.Make(Svg)) +module FillSVGRepr = MakePrinter(FillEngine.Make(Svg)) +module DuctusSVGRepr = MakePrinter(DuctusEngine.Make(Svg)) (** Draw a path to a canva *) let to_canva - : (module REPRESENTABLE with type t = 's) -> 's -> Brr_canvas.C2d.t -> printer -> unit - = fun (type s) (module R:REPRESENTABLE with type t = s) path ctx -> function + : (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 | `Fill -> R.repr path @@ -117,8 +178,8 @@ let to_canva (** Draw a path and represent it as SVG *) let to_svg - : (module REPRESENTABLE with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t - = fun (type s) (module R:REPRESENTABLE with type t = s) ~color path -> function + : (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 | `Fill -> (* In order to deal with over crossing path, I cut the path in as @@ -158,49 +219,3 @@ let to_svg | `Line -> raise Not_found -(** Transform the two fixed path, into a single one. *) -module ReprFixed = struct - - type t = Path.Fixed.t * Path.Fixed.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 t = repr' list - - 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 -> List.rev 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 = Path.Fixed.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 -end diff --git a/layer/repr.ml b/layer/repr.ml index 85b0f3b..552e2b7 100755 --- a/layer/repr.ml +++ b/layer/repr.ml @@ -18,7 +18,7 @@ module type PRINTER = sig end -module type LAYER = sig +module type ENGINE = sig type t type point = Path.Point.t -- cgit v1.2.3