diff options
| -rwxr-xr-x | path/builder.ml | 185 | ||||
| -rwxr-xr-x | path/builder.mli | 22 | ||||
| -rwxr-xr-x | path/fixed.ml | 216 | ||||
| -rwxr-xr-x | paths.ml | 6 | ||||
| -rwxr-xr-x | script.ml | 31 | ||||
| -rwxr-xr-x | state.ml | 62 |
6 files changed, 274 insertions, 248 deletions
diff --git a/path/builder.ml b/path/builder.ml index 39ff75e..bcad493 100755 --- a/path/builder.ml +++ b/path/builder.ml @@ -43,15 +43,6 @@ module Make(Point:P) = struct type t = Point.t list * bezier list - type path = - | Empty - | Line of Point.t * Point.t - | Curve of bezier - - type fixedPath = - { id: int - ; path : path array } - let get_new_segment connexion0 p5 p4 p3 p2 p1 = let p5' = Point.get_coord p5 and p4' = Point.get_coord p4 @@ -70,7 +61,7 @@ module Make(Point:P) = struct let empty = ([], []) let add_point - : Point.t -> t -> t * fixedPath option + : Point.t -> t -> t = fun lastPoint (path, beziers) -> let (let*) v f = match v with @@ -78,11 +69,9 @@ module Make(Point:P) = struct if Array.length bezier > 0 then f (Array.get bezier 0) else - ( (lastPoint::path, beziers) - , None ) + (lastPoint::path, beziers) | _ -> - ( (lastPoint::path, beziers) - , None ) + (lastPoint::path, beziers) in let connexion0 = match beziers with @@ -103,22 +92,19 @@ module Make(Point:P) = struct (* We remove the last point and add the bezier curve in the list*) let firsts = lastPoint::p4::p3::p2::[] in - ( (firsts, bezier_point::beziers) - , None ) + (firsts, bezier_point::beziers) | _ -> - ( ( lastPoint::path - , beziers) - , None ) + ( lastPoint::path + , beziers) let replace_last - : Point.t -> t -> t * fixedPath option + : Point.t -> t -> t = fun lastPoint ((path, beziers) as t) -> match path, beziers with | _::(tl), beziers -> - ( ( lastPoint::tl - , beziers ) - , None ) + ( lastPoint::tl + , beziers ) | _ -> add_point lastPoint t @@ -237,157 +223,4 @@ module Make(Point:P) = struct ) end - module ToFixed = struct - type t = Point.t - - type 'a repr = int * path list - - let create_path () = 0, [] - - (* Start a new path. *) - let start point t = - let _ = point in - t - - let line_to - : t -> t -> 'a repr -> 'a 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 - = fun p0 ctrl0 ctrl1 p1 (i, t) -> - let curve = Curve - { p0 - ; ctrl0 - ; ctrl1 - ; p1} in - ( i + 1 - , curve::t) - - - let stop t = t - - let get - : int * path list -> path array - = fun (n, t) -> - let res = Array.make n Empty in - List.iteri t - ~f:(fun i elem -> Array.set res (n - i - 1) elem ); - res - end - - let id = ref 0 - module FixedBuilder = Draw(ToFixed) - let to_fixed - : t -> fixedPath - = fun t -> - incr id; - { id = !id - ; path = FixedBuilder.draw t (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 - : fixedPath -> '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 box - : bezier -> Gg.box2 - = fun bezier -> - Gg.Box2.of_pts - (Point.get_coord bezier.p0) - (Point.get_coord bezier.p1) - |> (fun b -> Gg.Box2.add_pt b bezier.ctrl0) - |> (fun b -> Gg.Box2.add_pt b bezier.ctrl1) - - (** 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 -> fixedPath -> 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 - ) - - let id - : fixedPath -> int - = fun {id; _} -> id - - let map_point - : fixedPath -> (Point.t -> Point.t) -> fixedPath - = fun {id; path} f -> - let path = Array.map path - ~f:(function - | Empty -> Empty - | Line (p1, p2) -> Line (f p1, f p2) - | Curve bezier -> Curve {bezier with p0 = f bezier.p0 ; p1 = f bezier.p1} - ) in - {id; path} - end diff --git a/path/builder.mli b/path/builder.mli index ca496f7..7f34f10 100755 --- a/path/builder.mli +++ b/path/builder.mli @@ -34,17 +34,15 @@ module Make(P:P) : sig type t - type fixedPath - (** Create an empty path *) val empty: t val add_point - : P.t -> t -> t * fixedPath option + : P.t -> t -> t (** Replace the last alement in the path by the one given in parameter *) val replace_last - : P.t -> t -> t * fixedPath option + : P.t -> t -> t (** Retrieve the last element, if any *) val peek @@ -61,20 +59,4 @@ module Make(P:P) : sig : t -> 'a Repr.repr -> 'a Repr.repr end - val to_fixed : t -> fixedPath - - module DrawFixed(Repr:REPR with type t = P.t) : sig - val draw - : fixedPath -> 'a Repr.repr -> 'a Repr.repr - end - - (** Return the shortest distance between the mouse and a point *) - val distance - : Gg.v2 -> fixedPath -> float option - - val id - : fixedPath -> int - - val map_point - : fixedPath -> (P.t -> P.t) -> fixedPath end diff --git a/path/fixed.ml b/path/fixed.ml new file mode 100755 index 0000000..e339afc --- /dev/null +++ b/path/fixed.ml @@ -0,0 +1,216 @@ +open StdLabels + +(** 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 'a repr + + (* Start a new path. *) + val start + : t -> 'a repr -> 'a repr + + val line_to + : t -> t -> 'a repr -> 'a repr + + val quadratic_to + : t -> Gg.v2 -> Gg.v2 -> t -> 'a repr -> 'a repr + + val stop + : 'a repr -> 'a repr +end + + +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 + end + + 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 path = + | Empty + | Line of Point.t * Point.t + | Curve of bezier + + type t = + { id: int + ; path : path array } + + let id + : t -> int + = fun {id; _} -> id + + module ToFixed = struct + type t = Point.t + + type 'a repr = int * path list + + let create_path () = 0, [] + + (* Start a new path. *) + let start point t = + let _ = point in + t + + let line_to + : t -> t -> 'a repr -> 'a 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 + = fun p0 ctrl0 ctrl1 p1 (i, t) -> + let curve = Curve + { p0 + ; ctrl0 + ; ctrl1 + ; p1} in + ( i + 1 + , curve::t) + + + let stop t = t + + let get + : int * path list -> path array + = fun (n, t) -> + let res = Array.make n Empty in + List.iteri t + ~f:(fun i elem -> Array.set res (n - i - 1) elem ); + res + end + + let internal_id = ref 0 + + let to_fixed + : (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 ()) + |> 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 box + : bezier -> Gg.box2 + = fun bezier -> + Gg.Box2.of_pts + (Point.get_coord bezier.p0) + (Point.get_coord bezier.p1) + |> (fun b -> Gg.Box2.add_pt b bezier.ctrl0) + |> (fun b -> Gg.Box2.add_pt b bezier.ctrl1) + + (** 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 + ) + + let map_point + : t -> (Point.t -> Point.t) -> t + = fun {id; path} f -> + let path = Array.map path + ~f:(function + | Empty -> Empty + | Line (p1, p2) -> Line (f p1, f p2) + | Curve bezier -> Curve {bezier with p0 = f bezier.p0 ; p1 = f bezier.p1} + ) in + {id; path} + +end @@ -1,4 +1,10 @@ (** Common module for ensuring that the function is evaluated only once *) 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) + +module CanvaRepr = Path.FillPrinter.Make(Layer.CanvaPrinter) +module Fixed_Printer = Fixed.DrawFixed(CanvaRepr) @@ -3,12 +3,9 @@ open Note open Brr open Brr_note -module CanvaRepr = Path.FillPrinter.Make(Layer.CanvaPrinter) -module Path_Printer = Paths.Path_Builder.Draw(CanvaRepr) -module Fixed_Printer = Paths.Path_Builder.DrawFixed(CanvaRepr) - -type canva_signal = Path.Point.t +module Path_Printer = Paths.Path_Builder.Draw(Paths.CanvaRepr) +module Fixed_Printer = Paths.Fixed.DrawFixed(Paths.CanvaRepr) module Mouse = Brr_note_kit.Mouse @@ -195,32 +192,29 @@ let on_change canva mouse_position state = *) let pos = S.rough_value mouse_position in - let current, paths = + let current = begin match state.State.mode, pos with | Edit, Some point -> - begin match State.insert_or_replace state point state.current with - | current, None -> current, state.paths - | current, Some p -> current, p::state.paths - end + State.insert_or_replace state point state.current | _ -> - state.current, state.paths + state.current end in - let path = CanvaRepr.get + let path = Paths.CanvaRepr.get @@ Path_Printer.draw current - (* (CanvaRepr.create_path (fun p -> fill context p)) in *) - (CanvaRepr.create_path (fun _ -> () )) in + (Paths.CanvaRepr.create_path (fun p -> fill context p)) in stroke context path; - List.iter paths + List.iter state.paths ~f:(fun path -> let () = match state.mode with | Selection s -> - begin match (Paths.Path_Builder.id s) = (Paths.Path_Builder.id path) with + begin match (Paths.Fixed.id s) = (Paths.Fixed.id path) with | true -> + (* If the element is the selected one, change the color *) set_fill_style context (color Blog.Nord.nord8); set_stroke_style context (color Blog.Nord.nord8) | false -> @@ -230,10 +224,10 @@ let on_change canva mouse_position state = | _ -> () in - let path = CanvaRepr.get + let path = Paths.CanvaRepr.get @@ Fixed_Printer.draw path - (CanvaRepr.create_path (fun p -> fill context p)) in + (Paths.CanvaRepr.create_path (fun p -> fill context p)) in stroke context path; ); () @@ -241,7 +235,6 @@ let on_change canva mouse_position state = let page_main id = - let delete_event', angle_signal', width_signal', export_event' = begin match Blog.Sidebar.get () with | None -> @@ -1,10 +1,6 @@ open StdLabels open Brr -module Path_Builder = Paths.Path_Builder -module SVGRepr = Path.WireFramePrinter.Make(Layer.Svg) -module SVG_Fixed_Printer = Path_Builder.DrawFixed(SVGRepr) - let expected_host = Blog.Hash_host.expected_host let backgroundColor = Blog.Nord.nord0 @@ -13,10 +9,10 @@ let timer, tick = Elements.Timer.create () type mode = | Edit - | Selection of Path_Builder.fixedPath + | Selection of Paths.Fixed.t | Out -type current = Path_Builder.t +type current = Paths.Path_Builder.t (** Events *) @@ -44,7 +40,7 @@ type events = *) type state = { mode : mode - ; paths : Path_Builder.fixedPath list + ; paths : Paths.Fixed.t list ; current : current ; width : float ; angle : float @@ -54,9 +50,9 @@ let insert_or_replace state ((x, y) as p) path = let width = state.width and angle = state.angle in let point = Path.Point.create ~x ~y ~angle ~width in - match Path_Builder.peek path with + match Paths.Path_Builder.peek path with | None -> - Path_Builder.add_point + Paths.Path_Builder.add_point point path | Some p1 -> @@ -66,15 +62,15 @@ let insert_or_replace state ((x, y) as p) path = let dist = (norm (p1' - (of_tuple p))) in if dist < 5. then ( - path, None + path ) else ( - Path_Builder.add_point + Paths.Path_Builder.add_point point path ) let check_selection - : (float * float) -> Path_Builder.fixedPath list -> Path_Builder.fixedPath option + : (float * float) -> Paths.Fixed.t list -> Paths.Fixed.t option = fun position paths -> let point = Gg.V2.of_tuple position in (* If the user click on a curve, select it *) @@ -86,7 +82,7 @@ let check_selection | Some p -> Some p | None -> (* TODO : Add a method in the point module *) - begin match Path_Builder.distance point path with + begin match Paths.Fixed.distance point path with | Some p when p < 20. -> Some path | _ -> None @@ -96,12 +92,12 @@ let check_selection (** Update the path in the selection with the given function applied to every point *) let update_selection s state f = - let s = Path_Builder.map_point s f - and id = Path_Builder.id s in + let s = Paths.Fixed.map_point s f + and id = Paths.Fixed.id s in let paths = List.map state.paths ~f:(fun path -> - let id' = Path_Builder.id path in + let id' = Paths.Fixed.id path in match id = id' with | false -> path | true -> s @@ -114,14 +110,11 @@ let do_action match event, state.mode with | `Point (_delay, point), Edit -> (* Add the point in the list *) - let current, fixed_path = insert_or_replace + let current = insert_or_replace state point state.current in - let paths = match fixed_path with - | None -> state.paths - | Some p -> p::state.paths in - { state with current; paths } + { state with current } (* Click anywhere while in Out mode, we switch in edition *) | `Click _, Out -> @@ -145,22 +138,25 @@ let do_action | `Out point, Edit -> Elements.Timer.stop timer; - begin match Path_Builder.peek2 state.current with + begin match Paths.Path_Builder.peek2 state.current with (* If there is at last two points selected, handle this as a curve creation *) | Some _ -> - let current, fixed_path = insert_or_replace state point state.current in - let paths = match fixed_path with - | None -> Path_Builder.to_fixed current::state.paths - | Some p -> p::state.paths - and current = Path_Builder.empty in + let current = insert_or_replace state point state.current in + let paths = + let last = Paths.Fixed.to_fixed + (module Paths.Path_Builder) + current + in + last::state.paths + and current = Paths.Path_Builder.empty in { state with mode = Out ; paths; current } (* Else, check if there is a curve undre the cursor, and remove it *) | None -> - let current = Path_Builder.empty in + let current = Paths.Path_Builder.empty in begin match check_selection point state.paths with | None -> { state with @@ -174,8 +170,8 @@ let do_action end end | `Delete, Selection s -> - let id = Path_Builder.id s in - let paths = List.filter state.paths ~f:(fun p -> Path_Builder.id p != id) in + let id = Paths.Fixed.id s in + let paths = List.filter state.paths ~f:(fun p -> Paths.Fixed.id p != id) in { state with paths ; mode = Out} @@ -191,8 +187,8 @@ let do_action ; v (Jstr.v "xmlns:xlink") (Jstr.v "http://www.w3.org/1999/xlink") ] (List.map state.paths ~f:(fun path -> - let repr = SVGRepr.create_path (fun _ -> ()) in - let path = SVGRepr.get @@ SVG_Fixed_Printer.draw path repr in + let repr = Paths.SVGRepr.create_path (fun _ -> ()) in + let path = Paths.SVGRepr.get @@ Paths.SVG_Printer.draw path repr in Layer.Svg.path ~at:Brr.At.[ @@ -245,7 +241,7 @@ let do_action let init = { paths = [] - ; current = Path_Builder.empty + ; current = Paths.Path_Builder.empty ; mode = Out ; angle = 30. ; width = 10. |