diff options
Diffstat (limited to 'layer')
| -rwxr-xr-x | layer/canvaPrinter.ml | 42 | ||||
| -rwxr-xr-x | layer/canvaPrinter.mli | 2 | ||||
| -rwxr-xr-x | layer/ductusEngine.ml | 82 | ||||
| -rwxr-xr-x | layer/ductusEngine.mli | 2 | ||||
| -rwxr-xr-x | layer/dune | 8 | ||||
| -rwxr-xr-x | layer/fillEngine.ml | 89 | ||||
| -rwxr-xr-x | layer/fillEngine.mli | 2 | ||||
| -rwxr-xr-x | layer/lineEngine.ml | 68 | ||||
| -rwxr-xr-x | layer/lineEngine.mli | 2 | ||||
| -rwxr-xr-x | layer/paths.ml | 244 | ||||
| -rwxr-xr-x | layer/repr.ml | 49 | ||||
| -rwxr-xr-x | layer/svg.ml | 64 | ||||
| -rwxr-xr-x | layer/wireFramePrinter.ml | 80 | ||||
| -rwxr-xr-x | layer/wireFramePrinter.mli | 27 |
14 files changed, 0 insertions, 761 deletions
diff --git a/layer/canvaPrinter.ml b/layer/canvaPrinter.ml deleted file mode 100755 index 23cf842..0000000 --- a/layer/canvaPrinter.ml +++ /dev/null @@ -1,42 +0,0 @@ -module Path = Brr_canvas.C2d.Path -module V2 = Gg.V2 - -type t = Path.t - -let create - : unit -> t - = Path.create - -(* Start a new path. *) -let move_to - : Gg.v2 -> t -> t - = fun point path -> - let x, y = V2.to_tuple point in - Path.move_to ~x ~y path; - path - -let line_to - : Gg.v2 -> t -> t - = fun point path -> - let x, y = V2.to_tuple point in - Path.line_to ~x ~y path; - path - -let quadratic_to - : Gg.v2 -> Gg.v2 -> Gg.v2 -> t -> t - = fun ctrl0 ctrl1 p1 path -> - let cx, cy = V2.to_tuple ctrl0 - and cx', cy' = V2.to_tuple ctrl1 - and x, y = V2.to_tuple p1 in - Path.ccurve_to - ~cx ~cy - ~cx' ~cy' - ~x ~y - path; - path - -let close - : t -> t - = fun path -> - Path.close path; - path diff --git a/layer/canvaPrinter.mli b/layer/canvaPrinter.mli deleted file mode 100755 index 0c46448..0000000 --- a/layer/canvaPrinter.mli +++ /dev/null @@ -1,2 +0,0 @@ -include Repr.PRINTER - with type t = Brr_canvas.C2d.Path.t diff --git a/layer/ductusEngine.ml b/layer/ductusEngine.ml deleted file mode 100755 index b943467..0000000 --- a/layer/ductusEngine.ml +++ /dev/null @@ -1,82 +0,0 @@ -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 deleted file mode 100755 index e1660f4..0000000 --- a/layer/ductusEngine.mli +++ /dev/null @@ -1,2 +0,0 @@ -module Make(R:Repr.PRINTER): - Repr.ENGINE with type repr = R.t diff --git a/layer/dune b/layer/dune deleted file mode 100755 index 3c617ad..0000000 --- a/layer/dune +++ /dev/null @@ -1,8 +0,0 @@ -(library - (name layer) - (libraries - gg - brr - path - ) - ) diff --git a/layer/fillEngine.ml b/layer/fillEngine.ml deleted file mode 100755 index 9a3fe7e..0000000 --- a/layer/fillEngine.ml +++ /dev/null @@ -1,89 +0,0 @@ -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 deleted file mode 100755 index e1660f4..0000000 --- a/layer/fillEngine.mli +++ /dev/null @@ -1,2 +0,0 @@ -module Make(R:Repr.PRINTER): - Repr.ENGINE with type repr = R.t diff --git a/layer/lineEngine.ml b/layer/lineEngine.ml deleted file mode 100755 index 3d15d9c..0000000 --- a/layer/lineEngine.ml +++ /dev/null @@ -1,68 +0,0 @@ -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 deleted file mode 100755 index 86ef5fb..0000000 --- a/layer/lineEngine.mli +++ /dev/null @@ -1,2 +0,0 @@ -module Make(R:Repr.PRINTER): - Repr.ENGINE with type repr = R.t 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 diff --git a/layer/repr.ml b/layer/repr.ml deleted file mode 100755 index 552e2b7..0000000 --- a/layer/repr.ml +++ /dev/null @@ -1,49 +0,0 @@ -module type PRINTER = sig - - type t - - val create: unit -> t - - (* Start a new path. *) - val move_to: Gg.v2 -> t -> t - - val line_to: 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 - - (** Request for the path to be closed *) - val close: t -> t - -end - -module type ENGINE = sig - type t - - type point = Path.Point.t - - type repr - - val get - : t -> repr - - val create_path - : (repr -> repr) -> t - - val start - : point -> point -> t -> t - - val line_to - : (point * point) -> (point * point) -> 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/layer/svg.ml b/layer/svg.ml deleted file mode 100755 index 2394cb8..0000000 --- a/layer/svg.ml +++ /dev/null @@ -1,64 +0,0 @@ -(** SVG representation *) - -open Brr - -module V2 = Gg.V2 - -let svg : El.cons - = fun ?d ?at childs -> - El.v ?d ?at (Jstr.v "svg") childs - -let path: El.cons - = fun ?d ?at childs -> - El.v ?d ?at (Jstr.v "path") childs - -type t = Jstr.t - -let create - : unit -> t - = fun () -> Jstr.empty - -(* Start a new path. *) -let move_to - : Gg.v2 -> t -> t - = fun point path -> - let x, y = V2.to_tuple point in - - Jstr.concat ~sep:(Jstr.v " ") - [ path - ; Jstr.v "M" - ; Jstr.of_float x - ; Jstr.of_float y ] - -let line_to - : Gg.v2 -> t -> t - = fun point path -> - let x, y = V2.to_tuple point in - Jstr.concat ~sep:(Jstr.v " ") - [ path - ; (Jstr.v "L") - ; (Jstr.of_float x) - ; (Jstr.of_float y) ] - -let quadratic_to - : Gg.v2 -> Gg.v2 -> Gg.v2 -> t -> t - = fun ctrl0 ctrl1 p1 path -> - let cx, cy = V2.to_tuple ctrl0 - and cx', cy' = V2.to_tuple ctrl1 - and x, y = V2.to_tuple p1 in - Jstr.concat ~sep:(Jstr.v " ") - [ path - ; (Jstr.v "C") - ; (Jstr.of_float cx) - ; (Jstr.of_float cy) - ; (Jstr.v ",") - ; (Jstr.of_float cx') - ; (Jstr.of_float cy') - ; (Jstr.v ",") - ; (Jstr.of_float x) - ; (Jstr.of_float y) ] - -let close - : t -> t - = fun path -> - Jstr.append path (Jstr.v " Z") diff --git a/layer/wireFramePrinter.ml b/layer/wireFramePrinter.ml deleted file mode 100755 index 81ab271..0000000 --- a/layer/wireFramePrinter.ml +++ /dev/null @@ -1,80 +0,0 @@ -module Point = Path.Point - -module Make(Repr: Repr.PRINTER) = struct - type t = Point.t - - type repr = - { 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 - } - - (* 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 -end diff --git a/layer/wireFramePrinter.mli b/layer/wireFramePrinter.mli deleted file mode 100755 index b198d58..0000000 --- a/layer/wireFramePrinter.mli +++ /dev/null @@ -1,27 +0,0 @@ -module Make(Repr:Repr.PRINTER): sig - - type repr - - type t = Path.Point.t - - val create_path - : 'b -> repr - - (* Start a new path. *) - val start - : 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 stop - : repr -> repr - - - val get - : repr -> Repr.t - -end |