From 7bb561f31e0ee57a388032b760b7db943dd6b36c Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 1 Jan 2021 23:18:35 +0100 Subject: Update --- path/path.ml | 112 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ paths.ml | 114 ----------------------------------------------------------- script.ml | 43 ++++++++++++++-------- state.ml | 42 +++++++++++----------- 4 files changed, 162 insertions(+), 149 deletions(-) create mode 100755 path/path.ml delete mode 100755 paths.ml diff --git a/path/path.ml b/path/path.ml new file mode 100755 index 0000000..9b6b9c4 --- /dev/null +++ b/path/path.ml @@ -0,0 +1,112 @@ +(** Common module for ensuring that the function is evaluated only once *) + +module Point = Point + +module type REPRESENTABLE = sig + type t + + (** Represent the path *) + val repr + : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's +end + +module Path_Builder = Builder.Make(Point) +module Fixed = Fixed.Make(Point) + +(* Canva representation *) + +module FillCanvaRepr = FillPrinter.Make(Layer.CanvaPrinter) +module LineCanvaRepr = LinePrinter.Make(Layer.CanvaPrinter) +module WireCanvaRepr = WireFramePrinter.Make(Layer.CanvaPrinter) + +(* SVG representation *) + +module FillSVGRepr = FillPrinter.Make(Layer.Svg) +module LineSVGRepr = LinePrinter.Make(Layer.Svg) +module WireSVGRepr = WireFramePrinter.Make(Layer.Svg) + + +type printer = + [ `Fill + | `Line + | `Wire ] + +(** Draw a path to a canva *) +let to_canva + : (module REPRESENTABLE with type t = 's) -> 's -> Brr_canvas.C2d.t -> printer -> unit + = fun (type s) (module R:REPRESENTABLE with type t = s) path ctx -> function + | `Fill -> + R.repr + path + (module FillCanvaRepr) + (FillCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) + |> FillCanvaRepr.get + |> Brr_canvas.C2d.stroke ctx + | `Line -> + R.repr + path + (module LineCanvaRepr) + (LineCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) + |> LineCanvaRepr.get + |> Brr_canvas.C2d.stroke ctx + | `Wire -> + R.repr + path + (module WireCanvaRepr) + (WireCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) + |> WireCanvaRepr.get + |> Brr_canvas.C2d.stroke ctx + + +(** Draw a path and represent it as SVG *) +let to_svg + : (module REPRESENTABLE with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t + = fun (type s) (module R:REPRESENTABLE with type t = s) ~color path -> function + | `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 _ = R.repr + path + (module FillSVGRepr) + (FillSVGRepr.create_path + (fun p -> + let repr = Layer.Svg.path + ~at:Brr.At.[ v (Jstr.v "d") p ] + [] in + + paths := repr::!paths; + Jstr.empty)) in + + Brr.El.v (Jstr.v "g") + ~at:Brr.At.[ + v (Jstr.v "fill") color + ; v (Jstr.v "stroke") color] + !paths + + | `Line -> + let svg_path = R.repr + path + (module LineSVGRepr) + (LineSVGRepr.create_path (fun _ -> ())) + |> LineSVGRepr.get in + Layer.Svg.path + ~at:Brr.At.[ + v (Jstr.v "fill") color + ; v (Jstr.v "stroke") color + ; v (Jstr.v "d") svg_path ] + [] + | `Wire -> + let svg_path = R.repr + path + (module WireSVGRepr) + (WireSVGRepr.create_path (fun _ -> ())) + |> WireSVGRepr.get in + Layer.Svg.path + ~at:Brr.At.[ + v (Jstr.v "fill") color + ; v (Jstr.v "stroke") color + ; v (Jstr.v "d") svg_path ] + [] diff --git a/paths.ml b/paths.ml deleted file mode 100755 index 9d968f0..0000000 --- a/paths.ml +++ /dev/null @@ -1,114 +0,0 @@ -(** 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) - -(* Canva representation *) - -module FillCanvaRepr = Path.FillPrinter.Make(Layer.CanvaPrinter) -module LineCanvaRepr = Path.LinePrinter.Make(Layer.CanvaPrinter) -module WireCanvaRepr = Path.WireFramePrinter.Make(Layer.CanvaPrinter) - - -(* SVG representation *) - -module FillSVGRepr = Path.FillPrinter.Make(Layer.Svg) -module LineSVGRepr = Path.LinePrinter.Make(Layer.Svg) -module WireSVGRepr = Path.WireFramePrinter.Make(Layer.Svg) - - -module type REPRESENTABLE = sig - type t - - (** Represent the path *) - val repr - : t -> (module Path.Repr.M with type t = Path.Point.t and type repr = 's) -> 's -> 's -end - -type printer = - [ `Fill - | `Line - | `Wire - ] - -(** Draw a path to a canva *) -let to_canva - : (module REPRESENTABLE with type t = 's) -> 's -> Brr_canvas.C2d.t -> printer -> unit - = fun (type s) (module R:REPRESENTABLE with type t = s) path ctx -> function - | `Fill -> - R.repr - path - (module FillCanvaRepr) - (FillCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - |> FillCanvaRepr.get - |> Brr_canvas.C2d.stroke ctx - | `Line -> - R.repr - path - (module LineCanvaRepr) - (LineCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - |> LineCanvaRepr.get - |> Brr_canvas.C2d.stroke ctx - | `Wire -> - R.repr - path - (module WireCanvaRepr) - (WireCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p)) - |> WireCanvaRepr.get - |> Brr_canvas.C2d.stroke ctx - - -(** Draw a path and represent it as SVG *) -let to_svg - : (module REPRESENTABLE with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t - = fun (type s) (module R:REPRESENTABLE with type t = s) ~color path -> function - | `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 _ = R.repr - path - (module FillSVGRepr) - (FillSVGRepr.create_path - (fun p -> - let repr = Layer.Svg.path - ~at:Brr.At.[ v (Jstr.v "d") p ] - [] in - - paths := repr::!paths; - Jstr.empty)) in - - Brr.El.v (Jstr.v "g") - ~at:Brr.At.[ - v (Jstr.v "fill") color - ; v (Jstr.v "stroke") color] - !paths - - | `Line -> - let svg_path = R.repr - path - (module LineSVGRepr) - (LineSVGRepr.create_path (fun _ -> ())) - |> LineSVGRepr.get in - Layer.Svg.path - ~at:Brr.At.[ - v (Jstr.v "fill") color - ; v (Jstr.v "stroke") color - ; v (Jstr.v "d") svg_path ] - [] - | `Wire -> - let svg_path = R.repr - path - (module WireSVGRepr) - (WireSVGRepr.create_path (fun _ -> ())) - |> WireSVGRepr.get in - Layer.Svg.path - ~at:Brr.At.[ - v (Jstr.v "fill") color - ; v (Jstr.v "stroke") color - ; v (Jstr.v "d") svg_path ] - [] - - diff --git a/script.ml b/script.ml index d501b10..398e4f2 100755 --- a/script.ml +++ b/script.ml @@ -142,6 +142,18 @@ let set_sidebar ) ); + + let br = El.br () in + let render = + El.select + [ El.option ~at:At.[value (Jstr.v "Fill")] + [ txt' "Fill"] + ; El.option ~at:At.[value (Jstr.v "Wireframe")] + [ txt' "Wireframe"] + ; El.option ~at:At.[value (Jstr.v "Ductus")] + [ txt' "Ductus"] + ] in + let () = El.append_children element [ hr () @@ -155,6 +167,9 @@ let set_sidebar ; angle ; input_angle + ; br + ; render + ] in delete_event, angle_event, nib_size_event, export_event @@ -165,20 +180,20 @@ let green = Jstr.v "#a3be8c" (** Redraw the canva on update *) let on_change canva mouse_position state = - let open Brr_canvas.C2d in + let module Cd2d = Brr_canvas.C2d in let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in - let context = create canva in + let context = Cd2d.create canva in - set_fill_style context (color backgroundColor); - fill_rect context + Cd2d.set_fill_style context (Cd2d.color backgroundColor); + Cd2d.fill_rect context ~x:0.0 ~y:0.0 ~w ~h; - set_stroke_style context (color white); - set_fill_style context (color white); + Cd2d.set_stroke_style context (Cd2d.color white); + Cd2d.set_fill_style context (Cd2d.color white); (* If we are in edit mode, we add a point under the cursor. @@ -197,28 +212,28 @@ let on_change canva mouse_position state = end in - let repr = `Wire in + let repr = `Fill in - Paths.to_canva (module Paths.Path_Builder) current context repr; + Path.to_canva (module Path.Path_Builder) current context repr; List.iter state.paths ~f:(fun path -> let () = match state.mode with | Selection id -> - begin match id = (Paths.Fixed.id path) with + begin match id = (Path.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) + Cd2d.set_fill_style context (Cd2d.color Blog.Nord.nord8); + Cd2d.set_stroke_style context (Cd2d.color Blog.Nord.nord8) | false -> - set_stroke_style context (color white); - set_fill_style context (color white); + Cd2d.set_stroke_style context (Cd2d.color white); + Cd2d.set_fill_style context (Cd2d.color white); end | _ -> () in - Paths.to_canva (module Paths.Fixed) path context repr + Path.to_canva (module Path.Fixed) path context repr ); () diff --git a/state.ml b/state.ml index 57007b3..52fe5a6 100755 --- a/state.ml +++ b/state.ml @@ -12,7 +12,7 @@ type mode = | Selection of int | Out -type current = Paths.Path_Builder.t +type current = Path.Path_Builder.t (** Events *) @@ -40,7 +40,7 @@ type events = *) type state = { mode : mode - ; paths : Paths.Fixed.t list + ; paths : Path.Fixed.t list ; current : current ; width : float ; angle : float @@ -50,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 Paths.Path_Builder.peek path with + match Path.Path_Builder.peek path with | None -> - Paths.Path_Builder.add_point + Path.Path_Builder.add_point point path | Some p1 -> @@ -64,7 +64,7 @@ let insert_or_replace state ((x, y) as p) path = if dist < 5. then ( path ) else ( - Paths.Path_Builder.add_point + Path.Path_Builder.add_point point path ) @@ -72,14 +72,14 @@ let insert_or_replace state ((x, y) as p) path = let threshold = 20. let check_selection - : (float * float) -> Paths.Fixed.t list -> (Gg.v2 * Paths.Fixed.t) option + : (float * float) -> Path.Fixed.t list -> (Gg.v2 * Path.Fixed.t) option = fun position paths -> let point = Gg.V2.of_tuple position in (* If the user click on a curve, select it *) let _, res = List.fold_left paths ~init:(threshold, None) ~f:(fun (dist, selection) path -> - match Paths.Fixed.distance point path with + match Path.Fixed.distance point path with | Some (point', p) when p < dist -> dist, Some (point', path) | _ -> dist, selection @@ -92,10 +92,10 @@ let update_selection id state f = let paths = List.map state.paths ~f:(fun path -> - let id' = Paths.Fixed.id path in + let id' = Path.Fixed.id path in match id = id' with | false -> path - | true -> Paths.Fixed.map_point path f + | true -> Path.Fixed.map_point path f ) in { state with paths} @@ -130,7 +130,7 @@ let do_action Path.Point.create ~x ~y ~angle ~width in - let current = Paths.Path_Builder.add_point + let current = Path.Path_Builder.add_point point state.current in { state with current; mode = Edit } @@ -146,7 +146,7 @@ let do_action (* Start the timer in order to handle the mouse moves *) - let id = Paths.Fixed.id selected in + let id = Path.Fixed.id selected in Elements.Timer.start timer 0.3; { state with mode = (Selection id)} @@ -154,7 +154,7 @@ let do_action | `Out point, Edit -> Elements.Timer.stop timer; - begin match Paths.Path_Builder.peek2 state.current with + begin match Path.Path_Builder.peek2 state.current with (* If there is at last two points selected, handle this as a curve creation. And we add the new point in the current path *) | Some _ -> @@ -167,19 +167,19 @@ let do_action let current = insert_or_replace state point state.current in let paths = - let last = Paths.Fixed.to_fixed - (module Paths.Path_Builder) + let last = Path.Fixed.to_fixed + (module Path.Path_Builder) current in last::state.paths - and current = Paths.Path_Builder.empty in + and current = Path.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 = Paths.Path_Builder.empty in + let current = Path.Path_Builder.empty in begin match check_selection point state.paths with | None -> { state with @@ -187,14 +187,14 @@ let do_action ; current } | Some (_, selected) -> - let id = Paths.Fixed.id selected in + let id = Path.Fixed.id selected in { state with mode = (Selection id) ; current } end end | `Delete, Selection id -> - let paths = List.filter state.paths ~f:(fun p -> Paths.Fixed.id p != id) in + let paths = List.filter state.paths ~f:(fun p -> Path.Fixed.id p != id) in { state with paths ; mode = Out} @@ -211,9 +211,9 @@ let do_action (List.map state.paths ~f:(fun path -> - Paths.to_svg + Path.to_svg ~color:backgroundColor - (module Paths.Fixed) + (module Path.Fixed) path `Fill @@ -262,7 +262,7 @@ let do_action let init = { paths = [] - ; current = Paths.Path_Builder.empty + ; current = Path.Path_Builder.empty ; mode = Out ; angle = 30. ; width = 10. -- cgit v1.2.3