From 0faaa5fda396f0eca6bebf69f3624a344278fa6e Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
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 +++++
script.ml | 6 ++
9 files changed, 456 insertions(+), 48 deletions(-)
create mode 100755 path/canvaPrinter.ml
create mode 100755 path/canvaPrinter.mli
create mode 100755 path/repr.ml
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
diff --git a/script.ml b/script.ml
index f7db9d3..be7fe8e 100755
--- a/script.ml
+++ b/script.ml
@@ -45,6 +45,7 @@ let canva
(* Mouse events *)
let mouse = Brr_note_kit.Mouse.on_el
+ ~normalize:false
(fun x y -> (x, y)) element in
let click =
@@ -198,11 +199,16 @@ let on_change canva mouse_position state =
state.current
in
+ let path = Point.get @@ Path_Builder.draw current in
+ stroke context path;
+
+(*
let points, beziers = Path_Builder.get current in
let path = draw_path area (points) beziers in
stroke context path;
+*)
List.iter state.paths
~f:(fun path ->
--
cgit v1.2.3