From 0faaa5fda396f0eca6bebf69f3624a344278fa6e Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Sat, 19 Dec 2020 19:59:17 +0100 Subject: First commit --- path/builder.ml | 209 ++++++++++++++++++++++++++++++++++++++++++++++---- path/builder.mli | 36 ++++++++- path/canvaPrinter.ml | 42 ++++++++++ path/canvaPrinter.mli | 2 + path/draw.ml | 79 +++++++++++-------- path/point.ml | 86 ++++++++++++++++++++- path/point.mli | 25 ++++++ path/repr.ml | 19 +++++ 8 files changed, 450 insertions(+), 48 deletions(-) create mode 100755 path/canvaPrinter.ml create mode 100755 path/canvaPrinter.mli create mode 100755 path/repr.ml (limited to 'path') diff --git a/path/builder.ml b/path/builder.ml index f52fb9e..4fe8951 100755 --- a/path/builder.ml +++ b/path/builder.ml @@ -1,21 +1,52 @@ +open StdLabels + (** Signature for points *) module type P = sig type t + val empty : t + val get_coord : t -> Gg.v2 + val copy : t -> Gg.v2 -> t + + type 'a repr + + val create_path + : unit -> 'a repr + + (* Start a new path. *) + val start + : t -> 'a repr -> 'a repr + + val line_to + : t -> 'a repr -> 'a repr + + val quadratic_to + : t -> t -> t -> t -> 'a repr -> 'a repr + + val stop + : 'a repr -> 'a repr end -module Make(P:P) = struct +module Make(Point:P) = struct + + (** Point creation **) - type t = P.t list * Shapes.Bezier.t list + type bezier = + { p0:Point.t (* The starting point *) + ; p1:Point.t (* The end point *) + ; ctrl0:Gg.v2 (* The control point *) + ; ctrl1:Gg.v2 } (* The control point *) + + type t = Point.t list * bezier list let get_new_segment connexion0 p5 p4 p3 p2 p1 = - let p5' = P.get_coord p5 - and p4' = P.get_coord p4 - and p3' = P.get_coord p3 - and p2' = P.get_coord p2 - and p1' = P.get_coord p1 in + let p5' = Point.get_coord p5 + and p4' = Point.get_coord p4 + and p3' = Point.get_coord p3 + and p2' = Point.get_coord p2 + and p1' = Point.get_coord p1 in let points_to_link = [ p1' @@ -28,7 +59,7 @@ module Make(P:P) = struct let empty = ([], []) let add_point - : P.t -> t -> t + : Point.t -> t -> t = fun lastPoint (path, beziers) -> let (let*) v f = match v with @@ -42,21 +73,30 @@ module Make(P:P) = struct in let connexion0 = match beziers with - | hd::_ -> Some hd.Shapes.Bezier.p1 + | hd::_ -> Some (Point.get_coord hd.p1) | _ -> None in match path with | p4::p3::p2::p1::_ -> let* bezier = get_new_segment connexion0 lastPoint p4 p3 p2 p1 in + + let bezier_point = + { p0 = lastPoint + ; p1 = p4 + ; ctrl0 = bezier.Shapes.Bezier.ctrl0 + ; ctrl1 = bezier.Shapes.Bezier.ctrl1 + } in + (* We remove the last point and add the bezier curve in the list*) let firsts = lastPoint::p4::p3::p2::[] in - firsts, (Shapes.Bezier.reverse bezier)::beziers + (*firsts, (Shapes.Bezier.reverse bezier)::beziers*) + firsts, bezier_point::beziers | _ -> lastPoint::path, beziers let replace_last - : P.t -> t -> t + : Point.t -> t -> t = fun lastPoint ((path, beziers) as t) -> match path, beziers with | _::(tl), beziers -> @@ -66,14 +106,14 @@ module Make(P:P) = struct add_point lastPoint t let peek2 - : t -> (P.t * P.t) option + : t -> (Point.t * Point.t) option = fun (path, _) -> match path with | h1::h2::_ -> Some (h1, h2) | _ -> None let peek - : t -> P.t option + : t -> Point.t option = fun (path, _) -> match path with | [] -> None @@ -83,4 +123,147 @@ module Make(P:P) = struct : t -> t = fun t -> t + + (** Complete path **) + + (* Transform the result by replacing each start and end point by the + version given in the list + + This allow to keep the informations like angle or nib width inside the + bezier curve + + *) + let points_to_beziers + : Point.t list -> Shapes.Bezier.t array -> bezier array + = fun points beziers -> + match points with + (* If there is no point to draw, just return empty array *) + | [] -> [||] + | first_point::_ -> + let curves = Array.make + ( (List.length points) -1) + { p0 = Point.empty + ; ctrl0 = Gg.V2.of_tuple (0., 0.) + ; ctrl1 = Gg.V2.of_tuple (0., 0.) + ; p1 = Point.empty } in + + let _ = List.fold_left points + ~init:(true, first_point, 0) + ~f:(fun (first, prev_point, i) point -> + if first then (false, prev_point, i) + else + + let bezier_curve = Array.get beziers i in + + Array.set curves i + { p0 = prev_point + ; ctrl0 = bezier_curve.Shapes.Bezier.ctrl1 + ; ctrl1 = bezier_curve.Shapes.Bezier.ctrl0 + ; p1 = point }; + + + (false, point, i + 1) + ) in + curves + + + (** Drawing path **) + + let draw + : t -> 'a Point.repr + = fun (points, beziers) -> + + let path = Point.create_path () in + let path, last = match points with + | [] -> + ( path + , None ) + | p1::[] -> + ( Point.start p1 path + , Some p1 ) + | p1::p2::[] -> + let path = + Point.start p1 path + |> Point.line_to p2 in + ( path + , Some p2 ) + | p0::p1::p2::[] -> + let path = Point.start p0 path in + + let b = Shapes.Bezier.three_points_quadratic + (Point.get_coord p0) + (Point.get_coord p1) + (Point.get_coord p2) + |> Shapes.Bezier.quadratic_to_cubic in + + let p0' = Point.copy p0 b.Shapes.Bezier.p0 + and ctrl0 = Point.copy p0 b.Shapes.Bezier.ctrl0 + and ctrl1 = Point.copy p1 b.Shapes.Bezier.ctrl1 + and p2' = Point.copy p1 b.Shapes.Bezier.p1 in + + ( Point.quadratic_to p0' ctrl0 ctrl1 p2' path + , Some p2 ) + | (p0::_ as points) -> + + let (let*) v f = + match v with + | Ok beziers -> f beziers + | _ -> path, None in + + let points' = List.map ~f:Point.get_coord points in + let connexion = match beziers with + | [] -> None + | hd ::_ -> Some (Point.get_coord hd.p1) in + + let* beziers = Shapes.Bspline.to_bezier ?connexion1:connexion points' in + + (* Stdlib does not provide fold_left_i function and we need to map + each bezier point with the associated point in the curve. + + So I use references here for keeping each result element + + *) + let path = ref path in + let point = ref p0 in + + List.iteri points + ~f:(fun i pt -> + + if i < Array.length beziers then ( + + let bezier = Array.get beziers i in + + let p0' = Point.copy pt bezier.Shapes.Bezier.p0 + and ctrl0 = Point.copy (!point) bezier.Shapes.Bezier.ctrl0 + and ctrl1 = Point.copy pt bezier.Shapes.Bezier.ctrl1 + and p1' = Point.copy pt bezier.Shapes.Bezier.p1 in + + path := Point.quadratic_to p0' ctrl0 ctrl1 p1' (!path); + + let () = if i > 0 then + point := pt in + () + ) + ); + ( !path + , Some !point ) + in + + let path = match last with + | None -> path + | Some pt -> + + (* TODO : instead of copying the last point, keeep a track for each + point as declared in the type P.t *) + + List.fold_left beziers + ~init:path + ~f:(fun path bezier -> + let p0' = bezier.p0 + and ctrl0 = Point.copy pt bezier.ctrl0 + and ctrl1 = Point.copy pt bezier.ctrl1 + and p1' = bezier.p1 in + Point.quadratic_to p0' ctrl0 ctrl1 p1' path + ) + in Point.stop path end diff --git a/path/builder.mli b/path/builder.mli index d99e0b2..64617fa 100755 --- a/path/builder.mli +++ b/path/builder.mli @@ -2,12 +2,40 @@ module type P = sig type t + val empty : t + val get_coord : t -> Gg.v2 + + val copy : t -> Gg.v2 -> t + + type 'a repr + + val create_path + : unit -> 'a repr + + (* Start a new path. *) + val start + : t -> 'a repr -> 'a repr + + val line_to + : t -> 'a repr -> 'a repr + + val quadratic_to + : t -> t -> t -> t -> 'a repr -> 'a repr + + val stop + : 'a repr -> 'a repr end module Make(P:P) : sig + type bezier = + { p0:P.t (* The starting point *) + ; p1:P.t (* The end point *) + ; ctrl0:Gg.v2 (* The control point *) + ; ctrl1:Gg.v2 } (* The control point *) + type t (** Create an empty path *) @@ -29,5 +57,11 @@ module Make(P:P) : sig : t -> (P.t * P.t) option val get - : t -> P.t list * Shapes.Bezier.t list + : t -> P.t list * bezier list + + val points_to_beziers + : P.t list -> Shapes.Bezier.t array -> bezier array + + val draw + : t -> 'a P.repr end diff --git a/path/canvaPrinter.ml b/path/canvaPrinter.ml new file mode 100755 index 0000000..e696d10 --- /dev/null +++ b/path/canvaPrinter.ml @@ -0,0 +1,42 @@ +module Path = Brr_canvas.C2d.Path +module V2 = Gg.V2 + +type 'a t = Path.t + +let create + : unit -> 'a t + = Path.create + +(* Start a new path. *) +let move_to + : Gg.v2 -> 'a t -> 'a t + = fun point path -> + let x, y = V2.to_tuple point in + Path.move_to ~x ~y path; + path + +let line_to + : Gg.v2 -> 'a t -> 'a 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 -> 'a t -> 'a 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 + : 'a t -> 'a t + = fun path -> + Path.close path; + path diff --git a/path/canvaPrinter.mli b/path/canvaPrinter.mli new file mode 100755 index 0000000..e273054 --- /dev/null +++ b/path/canvaPrinter.mli @@ -0,0 +1,2 @@ +include Repr.PRINTER + with type 'a t = Brr_canvas.C2d.Path.t diff --git a/path/draw.ml b/path/draw.ml index ba5272a..5e05e01 100755 --- a/path/draw.ml +++ b/path/draw.ml @@ -2,14 +2,25 @@ open StdLabels module Path = Brr_canvas.C2d.Path module Point = Point +module Path_Builder = Builder.Make(Point) module Builder = Builder +(* (** Translate the point in the canva area *) let translate_point : area:Gg.v2 -> Gg.v2 -> (float * float) = fun ~area point -> let x, y = Gg.V2.(to_tuple @@ mul area point) in x, ((Gg.V2.y area) -. y) +*) + +let translate_point + : area:Gg.v2 -> Gg.v2 -> (float * float) + = fun ~area point -> + let _ = area in + + let x, y = Gg.V2.(to_tuple @@ point) in + x, y let translate_point' : area:Gg.v2 -> Gg.v2 -> Gg.v2 -> (float * float) @@ -80,11 +91,13 @@ let circle ~stop:Gg.Float.two_pi; path +type bezier = Path_Builder.bezier + type path = | Empty | Line of Point.t * Point.t | Three_point of Point.t * Point.t * Point.t - | Curve of Shapes.Bezier.t array + | Curve of bezier array type t = { id : int @@ -93,6 +106,7 @@ type t = let move_to : area:Gg.v2 -> Brr_canvas.C2d.Path.t -> path -> unit = fun ~area canvaPath path -> + match path with | Empty -> () | Line (p0, _) @@ -102,7 +116,7 @@ let move_to | Curve beziers -> try let bezier = Array.get beziers 0 in - let x, y = translate_point ~area bezier.Shapes.Bezier.p0 in + let x, y = translate_point ~area (Point.get_coord bezier.p0) in Path.move_to canvaPath ~x ~y with _ -> () @@ -124,9 +138,9 @@ let draw Array.iter beziers ~f:(fun bezier -> - let cx, cy = translate_point ~area bezier.Shapes.Bezier.ctrl0 - and cx', cy' = translate_point ~area bezier.Shapes.Bezier.ctrl1 - and x, y = translate_point ~area bezier.Shapes.Bezier.p1 in + let cx, cy = translate_point ~area bezier.Path_Builder.ctrl0 + and cx', cy' = translate_point ~area bezier.Path_Builder.ctrl1 + and x, y = translate_point ~area (Point.get_coord bezier.Path_Builder.p1) in Path.ccurve_to canvaPath ~cx ~cy @@ -138,8 +152,8 @@ let go_back : ?connexion:Point.t -> area:Gg.v2 -> Brr_canvas.C2d.Path.t -> path -> unit = fun ?connexion ~area canvaPath path -> let vect = Gg.V2.of_polar @@ Gg.V2.v - 0.01 - Gg.Float.pi_div_4 + 20. + (Float.neg Gg.Float.pi_div_4) in match connexion, path with | _, Empty -> () @@ -156,7 +170,7 @@ let go_back let last = Array.get beziers ((Array.length beziers) -1) in let x, y = - last.Shapes.Bezier.p1 + (Point.get_coord last.p1) |> translate_point' vect ~area in Path.line_to canvaPath ~x ~y; @@ -166,9 +180,9 @@ let go_back let i = (Array.length beziers) - i in let bezier = Array.get beziers i in - let cx, cy = translate_point' vect ~area bezier.Shapes.Bezier.ctrl1 - and cx', cy' = translate_point' vect ~area bezier.Shapes.Bezier.ctrl0 - and x, y = translate_point' vect ~area bezier.Shapes.Bezier.p0 in + let cx, cy = translate_point' vect ~area bezier.ctrl1 + and cx', cy' = translate_point' vect ~area bezier.ctrl0 + and x, y = translate_point' vect ~area (Point.get_coord bezier.p0) in Path.ccurve_to canvaPath ~cx ~cy @@ -178,7 +192,7 @@ let go_back | _ -> () -type quick_path = Point.t list * Shapes.Bezier.t list +type quick_path = Point.t list * bezier list let id = ref 0 @@ -188,31 +202,29 @@ let to_path incr id; let id = !id in - match beziers with - | [] -> - begin match points with - | p0::p1::[] -> {id; path=Line (p0, p1)} - | p0::p1::p2::[] -> {id; path=Three_point (p0, p1, p2)} - | points -> - - let (let*) v f = - match v with - | Ok beziers -> f beziers - | _ -> {id; path=Empty} in - - let points' = List.map ~f:Point.get_coord points in - - let* beziers = Shapes.Bspline.to_bezier points' in - {id; path=Curve beziers} - end - | _ -> + match beziers, points with + | [], [] -> {id; path = Empty} + | [], p0::p1::[] -> {id; path=Line (p0, p1)} + | [], p0::p1::p2::[] -> {id; path=Three_point (p0, p1, p2)} + | [], points -> + + let (let*) v f = + match v with + | Ok beziers -> f beziers + | _ -> {id; path=Empty} in + + let points' = List.map ~f:Point.get_coord points in + let* beziers = Shapes.Bspline.to_bezier points' in + let curves = Path_Builder.points_to_beziers points beziers in + {id; path=Curve curves} + | _, _ -> let (let*) v f = match v with | Ok beziers -> f beziers | _ -> {id; path=Curve (Array.of_list beziers)} in let connexion = match beziers with - | hd::_ -> Some hd.Shapes.Bezier.p1 + | hd::_ -> Some (Point.get_coord hd.p1) | _ -> None in let* beziers' = Shapes.Bspline.to_bezier @@ -220,9 +232,12 @@ let to_path (List.map points ~f:Point.get_coord) in + let curves = Path_Builder.points_to_beziers points beziers' in + + (* Create a new array with both lenght *) let t = Array.append - beziers' + curves (Array.of_list beziers) in diff --git a/path/point.ml b/path/point.ml index 9e10200..7a32ae1 100755 --- a/path/point.ml +++ b/path/point.ml @@ -4,12 +4,21 @@ type t = ; angle: float } +let empty = + { p = Gg.V2.of_tuple (0., 0.) + ; size = 0. + ; angle = 0. + } + let create x y = { p = Gg.V2.v x y - ; size = 0.1 - ; angle = Gg.Float.pi_div_4 + ; size = 20. + ; angle = Float.neg Gg.Float.pi_div_4 } +let copy point p = + { point with p } + let (+) p1 p2 = { p1 with p = Gg.V2.(+) p1.p p2 } @@ -22,3 +31,76 @@ let get_coord' let trans = of_polar @@ v t.size t.angle in t.p + trans +module Repr = CanvaPrinter + +type 'a repr = + { back: ('a Repr.t -> 'a Repr.t) + ; path: ('a Repr.t) + ; last_point : t option + } + +let create_path + : unit -> 'a repr + = fun () -> + { back = Repr.close + ; path = Repr.create () + ; last_point = None + } + +(* Start a new path. *) +let start + : t -> 'a repr -> 'a repr + = fun t {back; path; _} -> + let path = Repr.move_to (get_coord t) path in + let line' = Repr.line_to (get_coord' t) in + { back = (fun p -> back @@ line' p) + ; path + ; last_point = Some t + } + +let line_to + : t -> 'a repr -> 'a repr + = fun t {back; path; _} -> + let line' = Repr.line_to (get_coord' t) in + { back = (fun t -> back @@ line' t) + ; path = Repr.line_to t.p path + ; last_point = Some t + } + +let quadratic_to + : t -> t -> t -> t -> 'a repr -> 'a repr + = fun p0 ctrl0 ctrl1 p1 t -> + + let line' path = + Repr.quadratic_to + (get_coord' ctrl1) + (get_coord' ctrl0) + (get_coord' p0) path in + + let path = Repr.quadratic_to + (get_coord ctrl0) + (get_coord ctrl1) + (get_coord p1) + t.path in + { back = (fun p -> t.back @@ line' p) + ; path + ; last_point = Some p1 + } + +let stop + : 'a repr -> 'a repr + = fun {back; path; last_point} -> + + let path = + match last_point with + | Some point -> Repr.line_to (get_coord' point) path + | None -> path in + + { back = (fun x -> x) + ; path = back path + ; last_point = None } + +let get + : 'a repr -> 'a Repr.t + = fun {back; path; _} -> + back path diff --git a/path/point.mli b/path/point.mli index 4b75c3c..6418de4 100755 --- a/path/point.mli +++ b/path/point.mli @@ -1,10 +1,35 @@ type t +val empty : t + val (+): t -> Gg.v2 -> t val get_coord : t -> Gg.v2 val create: float -> float -> t +val copy : t -> Gg.v2 -> t + val get_coord' : t -> Gg.v2 + +type 'a repr + +val create_path + : unit -> 'a repr + +(* Start a new path. *) +val start + : t -> 'a repr -> 'a repr + +val line_to + : t -> 'a repr -> 'a repr + +val quadratic_to + : t -> t -> t -> t -> 'a repr -> 'a repr + +val stop + : 'a repr -> 'a repr + +val get + : 'a repr -> 'a CanvaPrinter.t diff --git a/path/repr.ml b/path/repr.ml new file mode 100755 index 0000000..b91442b --- /dev/null +++ b/path/repr.ml @@ -0,0 +1,19 @@ +module type PRINTER = sig + + type 'a t + + val create: unit -> 'a t + + (* Start a new path. *) + val move_to: Gg.v2 -> 'a t -> 'a t + + val line_to: Gg.v2 -> 'a t -> 'a t + + (** [quadratic_to ctrl0 ctrl1 p1] ctreate a quadratic curve from the current + point to [p1], with control points [ctrl0] and [ctrl1] *) + val quadratic_to: Gg.v2 -> Gg.v2 -> Gg.v2 -> 'a t -> 'a t + + (** Request for the path to be closed *) + val close: 'a t -> 'a t + +end -- cgit v1.2.3