From af88c8895bba85fe5340b34aafb3dce7650bd01f Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 1 Jan 2021 11:08:38 +0100 Subject: Use first type module instead of functors --- elements/timer.ml | 2 - layer/canvaPrinter.ml | 12 +-- layer/canvaPrinter.mli | 2 +- layer/repr.ml | 12 +-- layer/svg.ml | 12 +-- path/builder.ml | 203 ++++++++++++++++++++++------------------------ path/builder.mli | 29 +++---- path/fillPrinter.ml | 18 ++-- path/fixed.ml | 164 ++++++++++++++++++------------------- path/fixed.mli | 66 +++++++++++++++ path/linePrinter.ml | 16 ++-- path/wireFramePrinter.ml | 18 ++-- path/wireFramePrinter.mli | 14 ++-- paths.ml | 8 +- script.ml | 14 ++-- state.ml | 89 +++++++++++++------- 16 files changed, 375 insertions(+), 304 deletions(-) create mode 100755 path/fixed.mli diff --git a/elements/timer.ml b/elements/timer.ml index 0a75e12..bd676fd 100755 --- a/elements/timer.ml +++ b/elements/timer.ml @@ -24,7 +24,6 @@ let start let {id; send; _} = t in t.counter <- Time.counter (); - Brr.G.stop_timer id; let timer_id = Brr.G.set_interval ~ms:(int_of_float @@ d *. 1000.) @@ -33,7 +32,6 @@ let start let span = Time.counter_value t.counter in t.counter <- Time.counter (); send span) in - ignore @@ Brr.G.set_timeout ~ms:0 (fun () -> send 0.); t.id <- timer_id diff --git a/layer/canvaPrinter.ml b/layer/canvaPrinter.ml index e696d10..23cf842 100755 --- a/layer/canvaPrinter.ml +++ b/layer/canvaPrinter.ml @@ -1,29 +1,29 @@ module Path = Brr_canvas.C2d.Path module V2 = Gg.V2 -type 'a t = Path.t +type t = Path.t let create - : unit -> 'a t + : unit -> t = Path.create (* Start a new path. *) let move_to - : Gg.v2 -> 'a t -> 'a t + : 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 -> 'a t -> 'a t + : 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 -> 'a t -> 'a t + : 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 @@ -36,7 +36,7 @@ let quadratic_to path let close - : 'a t -> 'a t + : t -> t = fun path -> Path.close path; path diff --git a/layer/canvaPrinter.mli b/layer/canvaPrinter.mli index e273054..0c46448 100755 --- a/layer/canvaPrinter.mli +++ b/layer/canvaPrinter.mli @@ -1,2 +1,2 @@ include Repr.PRINTER - with type 'a t = Brr_canvas.C2d.Path.t + with type t = Brr_canvas.C2d.Path.t diff --git a/layer/repr.ml b/layer/repr.ml index b91442b..f2d114c 100755 --- a/layer/repr.ml +++ b/layer/repr.ml @@ -1,19 +1,19 @@ module type PRINTER = sig - type 'a t + type t - val create: unit -> 'a t + val create: unit -> t (* Start a new path. *) - val move_to: Gg.v2 -> 'a t -> 'a t + val move_to: Gg.v2 -> t -> t - val line_to: Gg.v2 -> 'a t -> 'a t + val line_to: Gg.v2 -> t -> 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 + val quadratic_to: Gg.v2 -> Gg.v2 -> Gg.v2 -> t -> t (** Request for the path to be closed *) - val close: 'a t -> 'a t + val close: t -> t end diff --git a/layer/svg.ml b/layer/svg.ml index f7cc670..2394cb8 100755 --- a/layer/svg.ml +++ b/layer/svg.ml @@ -12,15 +12,15 @@ let path: El.cons = fun ?d ?at childs -> El.v ?d ?at (Jstr.v "path") childs -type 'a t = Jstr.t +type t = Jstr.t let create - : unit -> 'a t + : unit -> t = fun () -> Jstr.empty (* Start a new path. *) let move_to - : Gg.v2 -> 'a t -> 'a t + : Gg.v2 -> t -> t = fun point path -> let x, y = V2.to_tuple point in @@ -31,7 +31,7 @@ let move_to ; Jstr.of_float y ] let line_to - : Gg.v2 -> 'a t -> 'a t + : Gg.v2 -> t -> t = fun point path -> let x, y = V2.to_tuple point in Jstr.concat ~sep:(Jstr.v " ") @@ -41,7 +41,7 @@ let line_to ; (Jstr.of_float y) ] let quadratic_to - : Gg.v2 -> Gg.v2 -> Gg.v2 -> 'a t -> 'a t + : 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 @@ -59,6 +59,6 @@ let quadratic_to ; (Jstr.of_float y) ] let close - : 'a t -> 'a t + : t -> t = fun path -> Jstr.append path (Jstr.v " Z") diff --git a/path/builder.ml b/path/builder.ml index bcad493..cb87fc5 100755 --- a/path/builder.ml +++ b/path/builder.ml @@ -15,20 +15,20 @@ end module type REPR = sig type t - type 'a repr + type repr (* Start a new path. *) val start - : t -> 'a repr -> 'a repr + : t -> repr -> repr val line_to - : t -> t -> 'a repr -> 'a repr + : t -> t -> repr -> repr val quadratic_to - : t -> Gg.v2 -> Gg.v2 -> t -> 'a repr -> 'a repr + : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr val stop - : 'a repr -> 'a repr + : repr -> repr end module Make(Point:P) = struct @@ -122,105 +122,98 @@ module Make(Point:P) = struct | [] -> None | hd::_ -> Some hd - (** Complete path **) - - module Draw(Repr:REPR with type t = Point.t) = struct - - (** Drawing path **) - - let draw - : t -> 'a Repr.repr -> 'a Repr.repr - = fun (points, beziers) path -> - - (* Represent the last points *) - let path = match points with - | [] -> - ( path ) - | p1::[] -> - ( Repr.start p1 path ) - | p1::p2::[] -> - let path = - Repr.start p1 path - |> Repr.line_to p1 p2 in - ( path ) - | p0::p1::p2::[] -> - let path = Repr.start p0 path in - - let b = Shapes.Bezier.quadratic_to_cubic - @@ Shapes.Bezier.three_points_quadratic - (Point.get_coord p0) - (Point.get_coord p1) - (Point.get_coord p2) - in - - let p0' = Point.copy p0 b.Shapes.Bezier.p0 - and p2' = Point.copy p1 b.Shapes.Bezier.p1 in - - ( Repr.quadratic_to - p0' - b.Shapes.Bezier.ctrl0 - b.Shapes.Bezier.ctrl1 - p2' - path ) - | (p0::_ as points) -> - - let (let*) v f = - match v with - | Ok beziers -> f beziers - | _ -> path 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 -> - - (* The first iteration is ignored, as we need both previous and - current point for the two point in the curve. - - Do not forget that there is always n-1 bezier curve for n - points *) - if i > 0 then ( - - let bezier = Array.get beziers (i - 1) in - - path := Repr.quadratic_to - !point - bezier.Shapes.Bezier.ctrl0 - bezier.Shapes.Bezier.ctrl1 - pt - (!path); - point := pt; - ) - ); - ( !path ) - in - - (* Now represent the already evaluated points. Much easer to do, just - iterate on them *) - Repr.stop @@ List.fold_left beziers - ~init:path - ~f:(fun path bezier -> - let p0' = bezier.p0 - and ctrl0 = bezier.ctrl0 - and ctrl1 = bezier.ctrl1 - and p1' = bezier.p1 in - Repr.quadratic_to p0' ctrl0 ctrl1 p1' path - ) - end + let repr + : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's + = fun (type s) (points, beziers) (module Repr : REPR with type t = Point.t and type repr = s) path -> + + (* Represent the last points *) + let path = match points with + | [] -> + ( path ) + | p1::[] -> + ( Repr.start p1 path ) + | p1::p2::[] -> + let path = + Repr.start p1 path + |> Repr.line_to p1 p2 in + ( path ) + | p0::p1::p2::[] -> + let path = Repr.start p0 path in + + let b = Shapes.Bezier.quadratic_to_cubic + @@ Shapes.Bezier.three_points_quadratic + (Point.get_coord p0) + (Point.get_coord p1) + (Point.get_coord p2) + in + + let p0' = Point.copy p0 b.Shapes.Bezier.p0 + and p2' = Point.copy p1 b.Shapes.Bezier.p1 in + + ( Repr.quadratic_to + p0' + b.Shapes.Bezier.ctrl0 + b.Shapes.Bezier.ctrl1 + p2' + path ) + | (p0::_ as points) -> + + let (let*) v f = + match v with + | Ok beziers -> f beziers + | _ -> path 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 -> + + (* The first iteration is ignored, as we need both previous and + current point for the two point in the curve. + + Do not forget that there is always n-1 bezier curve for n + points *) + if i > 0 then ( + + let bezier = Array.get beziers (i - 1) in + + path := Repr.quadratic_to + !point + bezier.Shapes.Bezier.ctrl0 + bezier.Shapes.Bezier.ctrl1 + pt + (!path); + point := pt; + ) + ); + ( !path ) + in + + (* Now represent the already evaluated points. Much easer to do, just + iterate on them *) + Repr.stop @@ List.fold_left beziers + ~init:path + ~f:(fun path bezier -> + let p0' = bezier.p0 + and ctrl0 = bezier.ctrl0 + and ctrl1 = bezier.ctrl1 + and p1' = bezier.p1 in + Repr.quadratic_to p0' ctrl0 ctrl1 p1' path + ) end diff --git a/path/builder.mli b/path/builder.mli index 7f34f10..8c8081b 100755 --- a/path/builder.mli +++ b/path/builder.mli @@ -14,23 +14,23 @@ end module type REPR = sig type t - type 'a repr + type repr (* Start a new path. *) val start - : t -> 'a repr -> 'a repr + : t -> repr -> repr val line_to - : t -> t -> 'a repr -> 'a repr + : t -> t -> repr -> repr val quadratic_to - : t -> Gg.v2 -> Gg.v2 -> t -> 'a repr -> 'a repr + : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr val stop - : 'a repr -> 'a repr + : repr -> repr end -module Make(P:P) : sig +module Make(Point:P) : sig type t @@ -38,25 +38,22 @@ module Make(P:P) : sig val empty: t val add_point - : P.t -> t -> t + : Point.t -> t -> t (** Replace the last alement in the path by the one given in parameter *) val replace_last - : P.t -> t -> t + : Point.t -> t -> t (** Retrieve the last element, if any *) val peek - : t -> P.t option + : t -> Point.t option (** Retrieve the last element, if any *) val peek2 - : t -> (P.t * P.t) option + : t -> (Point.t * Point.t) option - module Draw(Repr:REPR with type t = P.t) : sig - - (** Represent the the current path *) - val draw - : t -> 'a Repr.repr -> 'a Repr.repr - end + (** Represent the path *) + val repr + : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's end diff --git a/path/fillPrinter.ml b/path/fillPrinter.ml index b506f9b..ab5a1eb 100755 --- a/path/fillPrinter.ml +++ b/path/fillPrinter.ml @@ -2,13 +2,13 @@ module Make(Repr: Layer.Repr.PRINTER) = struct type t = Point.t - type 'a repr = - { path: ('a Repr.t) - ; close : 'a Repr.t -> unit + type repr = + { path: (Repr.t) + ; close : Repr.t -> unit } let create_path - : 'b -> 'a repr + : 'b -> repr = fun f -> { close = f ; path = Repr.create () @@ -16,7 +16,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct (* Start a new path. *) let start - : Point.t -> 'a repr -> 'a repr + : Point.t -> repr -> repr = fun t {close ; path } -> let path = Repr.move_to (Point.get_coord t) path in { close @@ -24,7 +24,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct } let line_to - : Point.t -> Point.t -> 'a repr -> 'a repr + : Point.t -> Point.t -> repr -> repr = fun p0 p1 t -> let path = Repr.move_to (Point.get_coord p1) t.path @@ -37,7 +37,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct { t with path} let quadratic_to - : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> 'a repr -> 'a repr + : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr = fun p0 ctrl0 ctrl1 p1 t -> let ctrl0' = Point.copy p1 ctrl0 @@ -61,12 +61,12 @@ module Make(Repr: Layer.Repr.PRINTER) = struct let stop - : 'a repr -> 'a repr + : repr -> repr = fun t -> t let get - : 'a repr -> 'a Repr.t + : repr -> Repr.t = fun t -> t.path end diff --git a/path/fixed.ml b/path/fixed.ml index e339afc..7203ebb 100755 --- a/path/fixed.ml +++ b/path/fixed.ml @@ -16,20 +16,20 @@ end module type REPR = sig type t - type 'a repr + type repr (* Start a new path. *) val start - : t -> 'a repr -> 'a repr + : t -> repr -> repr val line_to - : t -> t -> 'a repr -> 'a repr + : t -> t -> repr -> repr val quadratic_to - : t -> Gg.v2 -> Gg.v2 -> t -> 'a repr -> 'a repr + : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr val stop - : 'a repr -> 'a repr + : repr -> repr end @@ -38,12 +38,8 @@ module Make(Point:P) = struct module type BUILDER = sig type t - module Draw(Repr:REPR with type t = Point.t) : sig - - (** Represent the the current path *) - val draw - : t -> 'a Repr.repr -> 'a Repr.repr - end + val repr + : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's end type bezier = @@ -68,7 +64,7 @@ module Make(Point:P) = struct module ToFixed = struct type t = Point.t - type 'a repr = int * path list + type repr = int * path list let create_path () = 0, [] @@ -78,13 +74,13 @@ module Make(Point:P) = struct t let line_to - : t -> t -> 'a repr -> 'a repr + : t -> t -> repr -> repr = fun p1 p2 (i, t) -> ( i + 1 , Line (p1, p2)::t) let quadratic_to - : t -> Gg.v2 -> Gg.v2 -> t -> 'a repr -> 'a repr + : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr = fun p0 ctrl0 ctrl1 p1 (i, t) -> let curve = Curve { p0 @@ -94,7 +90,6 @@ module Make(Point:P) = struct ( i + 1 , curve::t) - let stop t = t let get @@ -112,48 +107,43 @@ module Make(Point:P) = struct : (module BUILDER with type t = 'a) -> 'a -> t = fun (type s) (module Builder: BUILDER with type t = s) t -> incr internal_id; - let module FixedBuilder = Builder.Draw(ToFixed) in { id = !internal_id - ; path = FixedBuilder.draw t (ToFixed.create_path ()) + ; path = Builder.repr t (module ToFixed) (ToFixed.create_path ()) |> ToFixed.get } - module DrawFixed(Repr:REPR with type t = Point.t) = struct - - let repr_bezier p bezier = - Repr.quadratic_to - bezier.p0 - bezier.ctrl0 - bezier.ctrl1 - bezier.p1 - p - - let draw - : t -> 'a Repr.repr -> 'a Repr.repr - = fun {path; _} repr -> - - let _, repr = Array.fold_left path - ~init:(true, repr) - ~f:(fun (first, path) element -> - match element with - | Empty -> (true, path) - | Line (p0, p1) -> - - let path = if first then - Repr.start p0 path - else path in - - ( false - , Repr.line_to p0 p1 path ) - | Curve bezier -> - let path = if first then - Repr.start bezier.p0 path - else path in - ( false - , repr_bezier path bezier ) - ) in - Repr.stop repr - end + let repr + : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's + = fun (type s) {path; _} (module Repr : REPR with type t = Point.t and type repr = s) repr -> + let repr_bezier p bezier = + Repr.quadratic_to + bezier.p0 + bezier.ctrl0 + bezier.ctrl1 + bezier.p1 + p in + + let _, repr = Array.fold_left path + ~init:(true, repr) + ~f:(fun (first, path) element -> + match element with + | Empty -> (true, path) + | Line (p0, p1) -> + + let path = if first then + Repr.start p0 path + else path in + + ( false + , Repr.line_to p0 p1 path ) + | Curve bezier -> + let path = if first then + Repr.start bezier.p0 path + else path in + ( false + , repr_bezier path bezier ) + ) in + Repr.stop repr let box : bezier -> Gg.box2 @@ -167,40 +157,40 @@ module Make(Point:P) = struct (** Return the distance between a given point and the curve. May return None if the point is out of the curve *) let distance - : Gg.v2 -> t -> float option = - fun point beziers -> - - Array.fold_left beziers.path - ~init:None - ~f:(fun res -> function - | Empty -> None - | Line (p0, p1) -> - let box = Gg.Box2.of_pts (Point.get_coord p0) (Point.get_coord p1) in - begin match Gg.Box2.mem point box with - | false -> res - | true -> - (* TODO Evaluate the normal *) - res - end - | Curve bezier -> - begin match Gg.Box2.mem point (box bezier) with - | false -> res - | true -> - - let bezier' = Shapes.Bezier.( - - { p0 = Point.get_coord bezier.p0 - ; p1 = Point.get_coord bezier.p1 - ; ctrl0 = bezier.ctrl0 - ; ctrl1 = bezier.ctrl1 } - ) in - let _, point' = Shapes.Bezier.get_closest_point point bezier' in - let distance = Gg.V2.( norm (point - point') ) in - match res with - | None -> Some distance - | Some d -> if d < distance then res else (Some distance) - end - ) + : Gg.v2 -> t -> (Gg.v2 * float) option + = fun point beziers -> + + Array.fold_left beziers.path + ~init:None + ~f:(fun res -> function + | Empty -> None + | Line (p0, p1) -> + let box = Gg.Box2.of_pts (Point.get_coord p0) (Point.get_coord p1) in + begin match Gg.Box2.mem point box with + | false -> res + | true -> + (* TODO Evaluate the normal *) + res + end + | Curve bezier -> + begin match Gg.Box2.mem point (box bezier) with + | false -> res + | true -> + + let bezier' = Shapes.Bezier.( + + { p0 = Point.get_coord bezier.p0 + ; p1 = Point.get_coord bezier.p1 + ; ctrl0 = bezier.ctrl0 + ; ctrl1 = bezier.ctrl1 } + ) in + let _, point' = Shapes.Bezier.get_closest_point point bezier' in + let distance = Gg.V2.( norm (point - point') ) in + match res with + | None -> Some (point', distance) + | Some (_, d) -> if d < distance then res else (Some (point', distance)) + end + ) let map_point : t -> (Point.t -> Point.t) -> t diff --git a/path/fixed.mli b/path/fixed.mli new file mode 100755 index 0000000..3fc542c --- /dev/null +++ b/path/fixed.mli @@ -0,0 +1,66 @@ +(** Signature for points *) +module type P = sig + type t + + val empty : t + + val get_coord : t -> Gg.v2 + + (** Copy a point and all thoses properties to the given location *) + val copy : t -> Gg.v2 -> t + +end + +module type REPR = sig + type t + + type repr + + (* Start a new path. *) + val start + : t -> repr -> repr + + val line_to + : t -> t -> repr -> repr + + val quadratic_to + : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr + + val stop + : repr -> repr +end + + +module Make(Point:P) : sig + + module type BUILDER = sig + type t + + val repr + : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's + + end + + type t + + (** Return the identifier for this path *) + val id + : t -> int + + (** Create a path from a builder *) + val to_fixed + : (module BUILDER with type t = 'a) -> 'a -> t + + (** Represent the path *) + val repr + : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's + + (** Return the distance between a given point and the curve. May return + None if the point is out of the curve *) + val distance + : Gg.v2 -> t -> (Gg.v2 * float) option + + val map_point + : t -> (Point.t -> Point.t) -> t + +end diff --git a/path/linePrinter.ml b/path/linePrinter.ml index 247d554..e109e4a 100755 --- a/path/linePrinter.ml +++ b/path/linePrinter.ml @@ -2,19 +2,19 @@ module Repr = Layer.CanvaPrinter type t = Point.t -type 'a repr = - { path: ('a Repr.t) +type repr = + { path: (Repr.t) } let create_path - : 'b -> 'a repr + : 'b -> repr = fun _ -> { path = Repr.create () } (* Start a new path. *) let start - : Point.t -> 'a repr -> 'a repr + : Point.t -> repr -> repr = fun t {path} -> let path = Repr.move_to (Point.get_coord t) path in let path = Repr.line_to (Point.get_coord' t) path in @@ -22,7 +22,7 @@ let start } let line_to - : Point.t -> Point.t -> 'a repr -> 'a repr + : Point.t -> Point.t -> repr -> repr = fun _ t {path} -> let path = Repr.move_to (Point.get_coord t) path in let path = Repr.line_to (Point.get_coord' t) path in @@ -30,7 +30,7 @@ let line_to } let quadratic_to - : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> 'a repr -> 'a repr + : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr = fun _p0 _ctrl0 _ctrl1 p1 {path} -> let path = Repr.move_to (Point.get_coord p1) path in @@ -40,7 +40,7 @@ let quadratic_to } let stop - : 'a repr -> 'a repr + : repr -> repr = fun {path} -> @@ -48,6 +48,6 @@ let stop } let get - : 'a repr -> 'a Repr.t + : repr -> Repr.t = fun {path; _} -> path diff --git a/path/wireFramePrinter.ml b/path/wireFramePrinter.ml index 47eb9d4..796bbd9 100755 --- a/path/wireFramePrinter.ml +++ b/path/wireFramePrinter.ml @@ -1,14 +1,14 @@ module Make(Repr: Layer.Repr.PRINTER) = struct type t = Point.t - type 'a repr = - { back: ('a Repr.t -> 'a Repr.t) - ; path: ('a Repr.t) + type repr = + { back: (Repr.t -> Repr.t) + ; path: (Repr.t) ; last_point : Point.t option } let create_path - : 'b -> 'a repr + : 'b -> repr = fun _ -> { back = Repr.close ; path = Repr.create () @@ -17,7 +17,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct (* Start a new path. *) let start - : Point.t -> 'a repr -> 'a repr + : 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 @@ -27,7 +27,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct } let line_to - : Point.t -> Point.t -> 'a repr -> 'a repr + : 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) @@ -36,7 +36,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct } let quadratic_to - : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> 'a repr -> 'a repr + : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr = fun p0 ctrl0 ctrl1 p1 t -> let ctrl0' = Point.copy p1 ctrl0 @@ -59,7 +59,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct } let stop - : 'a repr -> 'a repr + : repr -> repr = fun {back; path; last_point} -> let path = @@ -72,7 +72,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct ; last_point = None } let get - : 'a repr -> 'a Repr.t + : repr -> Repr.t = fun {back; path; _} -> back path end diff --git a/path/wireFramePrinter.mli b/path/wireFramePrinter.mli index d6f346e..1e76120 100755 --- a/path/wireFramePrinter.mli +++ b/path/wireFramePrinter.mli @@ -1,26 +1,26 @@ module Make(Repr:Layer.Repr.PRINTER): sig - type 'a repr + type repr type t = Point.t val create_path - : 'b -> 'a repr + : 'b -> repr (* Start a new path. *) val start - : Point.t -> 'a repr -> 'a repr + : Point.t -> repr -> repr val line_to - : Point.t -> Point.t -> 'a repr -> 'a repr + : Point.t -> Point.t -> repr -> repr val quadratic_to - : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> 'a repr -> 'a repr + : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr val stop - : 'a repr -> 'a repr + : repr -> repr val get - : 'a repr -> 'a Repr.t + : repr -> Repr.t end diff --git a/paths.ml b/paths.ml index 49bf03a..4ff6c66 100755 --- a/paths.ml +++ b/paths.ml @@ -3,8 +3,10 @@ module Path_Builder = Path.Builder.Make(Path.Point) module Fixed = Path.Fixed.Make(Path.Point) -module SVGRepr = Path.WireFramePrinter.Make(Layer.Svg) -module SVG_Printer = Fixed.DrawFixed(SVGRepr) +(* Canva representation *) module CanvaRepr = Path.FillPrinter.Make(Layer.CanvaPrinter) -module Fixed_Printer = Fixed.DrawFixed(CanvaRepr) + +(* SVG representation *) + +module SVGRepr = Path.WireFramePrinter.Make(Layer.Svg) diff --git a/script.ml b/script.ml index d7d969c..595d975 100755 --- a/script.ml +++ b/script.ml @@ -4,9 +4,6 @@ open Brr open Brr_note -module Path_Printer = Paths.Path_Builder.Draw(Paths.CanvaRepr) -module Fixed_Printer = Paths.Fixed.DrawFixed(Paths.CanvaRepr) - module Mouse = Brr_note_kit.Mouse let get_height el = @@ -168,7 +165,6 @@ let green = Jstr.v "#a3be8c" (** Redraw the canva on update *) let on_change canva mouse_position state = - let module Path' = Path in let open Brr_canvas.C2d in let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in @@ -202,8 +198,9 @@ let on_change canva mouse_position state = in let path = Paths.CanvaRepr.get - @@ Path_Printer.draw + @@ Paths.Path_Builder.repr current + (module Paths.CanvaRepr) (Paths.CanvaRepr.create_path (fun p -> fill context p)) in stroke context path; @@ -211,8 +208,8 @@ let on_change canva mouse_position state = ~f:(fun path -> let () = match state.mode with - | Selection s -> - begin match (Paths.Fixed.id s) = (Paths.Fixed.id path) with + | Selection id -> + begin match id = (Paths.Fixed.id path) with | true -> (* If the element is the selected one, change the color *) set_fill_style context (color Blog.Nord.nord8); @@ -225,8 +222,9 @@ let on_change canva mouse_position state = in let path = Paths.CanvaRepr.get - @@ Fixed_Printer.draw + @@ Paths.Fixed.repr path + (module Paths.CanvaRepr) (Paths.CanvaRepr.create_path (fun p -> fill context p)) in stroke context path; ); diff --git a/state.ml b/state.ml index 35fc2ed..52933f8 100755 --- a/state.ml +++ b/state.ml @@ -9,7 +9,7 @@ let timer, tick = Elements.Timer.create () type mode = | Edit - | Selection of Paths.Fixed.t + | Selection of int | Out type current = Paths.Path_Builder.t @@ -69,40 +69,35 @@ let insert_or_replace state ((x, y) as p) path = path ) +let threshold = 20. + let check_selection - : (float * float) -> Paths.Fixed.t list -> Paths.Fixed.t option + : (float * float) -> Paths.Fixed.t list -> (Gg.v2 * Paths.Fixed.t) option = fun position paths -> let point = Gg.V2.of_tuple position in (* If the user click on a curve, select it *) - List.fold_left paths - ~init:None - ~f:(fun selection path -> - - match selection with - | Some p -> Some p - | None -> - (* TODO : Add a method in the point module *) - begin match Paths.Fixed.distance point path with - | Some p when p < 20. -> - Some path - | _ -> None - end - ) + let _, res = List.fold_left paths + ~init:(threshold, None) + ~f:(fun (dist, selection) path -> + match Paths.Fixed.distance point path with + | Some (point', p) when p < dist -> + dist, Some (point', path) + | _ -> dist, selection + ) in + res (** Update the path in the selection with the given function applied to every point *) -let update_selection s state f = - let s = Paths.Fixed.map_point s f - and id = Paths.Fixed.id s in +let update_selection id state f = let paths = List.map state.paths ~f:(fun path -> let id' = Paths.Fixed.id path in match id = id' with | false -> path - | true -> s + | true -> Paths.Fixed.map_point path f ) in - { state with mode = Selection s ; paths} + { state with paths} let do_action : events -> state -> state @@ -117,9 +112,28 @@ let do_action { state with current } (* Click anywhere while in Out mode, we switch in edition *) - | `Click _, Out -> + | `Click ((x, y) as p), Out -> Elements.Timer.start timer 0.3; - { state with mode = Edit } + + let width = state.width + and angle = state.angle in + + let point = + match check_selection p state.paths with + | None -> + (* Start a new path with the point clicked *) + Path.Point.create ~x ~y ~angle ~width + | Some (p, _) -> + (* If the point is close to an existing path, we use the closest + point in the path instead *) + let x, y = Gg.V2.to_tuple p in + Path.Point.create ~x ~y ~angle ~width + in + + let current = Paths.Path_Builder.add_point + point + state.current in + { state with current; mode = Edit } (* Click anywhere while in selection mode, we either select another path, or switch to Out mode*) @@ -128,20 +142,29 @@ let do_action | None -> { state with mode = Out } - | Some selected -> + | Some (_, selected) -> (* Start the timer in order to handle the mouse moves *) + + let id = Paths.Fixed.id selected in Elements.Timer.start timer 0.3; { state with - mode = (Selection selected)} + mode = (Selection id)} end | `Out point, Edit -> Elements.Timer.stop timer; begin match Paths.Path_Builder.peek2 state.current with (* If there is at last two points selected, handle this as a curve - creation *) + creation. And we add the new point in the current path *) | Some _ -> + +(* + let point = match check_selection point state.paths with + | None -> point + | Some (p, _) -> Gg.V2.to_tuple p in +*) + let current = insert_or_replace state point state.current in let paths = let last = Paths.Fixed.to_fixed @@ -163,14 +186,14 @@ let do_action mode = Out ; current } - | Some selected -> + | Some (_, selected) -> + let id = Paths.Fixed.id selected in { state with - mode = (Selection selected) + mode = (Selection id) ; current } end end - | `Delete, Selection s -> - let id = Paths.Fixed.id s in + | `Delete, Selection id -> let paths = List.filter state.paths ~f:(fun p -> Paths.Fixed.id p != id) in { state with paths ; mode = Out} @@ -188,7 +211,11 @@ let do_action (List.map state.paths ~f:(fun path -> let repr = Paths.SVGRepr.create_path (fun _ -> ()) in - let path = Paths.SVGRepr.get @@ Paths.SVG_Printer.draw path repr in + let path = Paths.SVGRepr.get @@ + Paths.Fixed.repr + path + (module Paths.SVGRepr) + repr in Layer.Svg.path ~at:Brr.At.[ -- cgit v1.2.3