From 38cf58ac5e1adb38a1b99ea7cdda19ef7b5e12bf Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Mon, 24 May 2021 22:13:19 +0200 Subject: Refactor --- script.it/state/dune | 13 ++ script.it/state/selection.ml | 71 +++++++++ script.it/state/selection.mli | 33 ++++ script.it/state/state.ml | 357 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 474 insertions(+) create mode 100755 script.it/state/dune create mode 100755 script.it/state/selection.ml create mode 100755 script.it/state/selection.mli create mode 100755 script.it/state/state.ml (limited to 'script.it/state') diff --git a/script.it/state/dune b/script.it/state/dune new file mode 100755 index 0000000..7d4ef3f --- /dev/null +++ b/script.it/state/dune @@ -0,0 +1,13 @@ +(library + (name script_state) + (libraries + brr + brr.note + blog + application + worker_messages + outline + layer + path + ) + ) diff --git a/script.it/state/selection.ml b/script.it/state/selection.ml new file mode 100755 index 0000000..f5f135a --- /dev/null +++ b/script.it/state/selection.ml @@ -0,0 +1,71 @@ +open StdLabels + +type 'a selection = + | Path of 'a + | Point of ('a * Path.Point.t) + +type t = int selection + +let find_selection + : int selection -> Outline.t list -> Outline.t selection option + = fun selection paths -> + match selection with + | Path id -> Option.map (fun p -> Path p) (Outline.find paths id) + | Point (id, pt) -> Option.map (fun p -> Point (p, pt)) (Outline.find paths id) + +let threshold = 20. + +let get_from_paths + : (float * float) -> Outline.t list -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option + = fun position outlines -> + let point = Gg.V2.of_tuple position in + (* If the user click on a curve, select it *) + List.fold_left outlines + ~init:(threshold, None) + ~f:(fun (dist, selection) outline -> + match Path.Fixed.distance point outline.Outline.path with + | Some { closest_point ; distance; p0; p1 ; ratio} when distance < dist -> + ratio, Some (closest_point, outline, p0, p1) + | _ -> dist, selection + ) + +let select_path + : Outline.t -> t + = fun outline -> Path outline.Outline.id + +let select_point + : Outline.t -> Gg.v2 -> t + = fun outline v2_point -> + + let point' = ref None in + let dist = ref threshold in + + Path.Fixed.iter + outline.Outline.path + ~f:(fun p -> + let open Gg.V2 in + let new_dist = norm ((Path.Point.get_coord p) - v2_point) in + match (new_dist < !dist) with + | false -> () + | true -> + dist:= new_dist; + point' := Some p + ); + + match !point' with + | Some point -> + Point (outline.Outline.id, point) + | None -> + Path (outline.Outline.id) + + (* + (* If the point does not exists, find the exact point on the curve *) + let coord = Gg.V2.to_tuple v2_point in + begin match get_from_paths coord [path] with + | _, None -> Path (Path.Fixed.id path) + | f, Some (point, path, p0, p1) -> + + let point' = Path.Point.mix f point p0 p1 in + Point (Path.Fixed.id path, point') + end + *) diff --git a/script.it/state/selection.mli b/script.it/state/selection.mli new file mode 100755 index 0000000..9792a2d --- /dev/null +++ b/script.it/state/selection.mli @@ -0,0 +1,33 @@ +type 'a selection = + | Path of 'a + | Point of ('a * Path.Point.t) + +type t = int selection + +val threshold : float + +(** Return the closest path from the list to a given point. + + The path is returned with all thoses informations : + - The point in the path + - The path itself + - The starting point from the path + - The end point in the path + +*) +val get_from_paths + : (float * float) -> Outline.t list -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option + +val select_path + : Outline.t -> t + +(** Check for selecting a point on the given outline. + + If no point is available, select the path. + +*) +val select_point + : Outline.t -> Gg.v2 -> t + +val find_selection + : int selection -> Outline.t list -> Outline.t selection option diff --git a/script.it/state/state.ml b/script.it/state/state.ml new file mode 100755 index 0000000..d7cb13e --- /dev/null +++ b/script.it/state/state.ml @@ -0,0 +1,357 @@ +open StdLabels +open Brr + +type mode = + | Edit + | Selection of Selection.t + | Out + +(** Events *) +type canva_events = + [ `MouseDown of float * float + ] + +type button_events = + [ `Delete + | `Export + ] +type render_event = + [ + `Rendering of Layer.Paths.printer + ] + +type worker_event = Worker_messages.from_worker + +(* + The state cant hold functionnal values, and thus cannot be used to store + elements like timer + *) +type state = + { mode : mode + ; paths : Outline.t list + ; current : Path.Path_Builder.t + ; width : float + ; angle : float + ; rendering : Layer.Paths.printer + ; mouse_down_position : Gg.v2 + } + +module type Handler = sig + + type t + + val apply: t -> state -> state + +end + +type t = E : 'a * (module Handler with type t = 'a) -> t + +type events = + [ canva_events + | button_events + | render_event + | worker_event + | `Point of float * (float * float) + | `Width of float + | `Angle of float + | `Generic of t + ] + +let post + : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit + = Brr_webworkers.Worker.post + +let insert_or_replace state ((x, y) as p) stamp path = + let width = state.width + and angle = state.angle in + let point = Path.Point.create ~x ~y ~angle ~width ~stamp in + match Path.Path_Builder.peek path with + | None -> + Path.Path_Builder.add_point + point + path + | Some p1 -> + let open Gg.V2 in + + let p1' = Path.Point.get_coord p1 in + + let dist = (norm (p1' - (of_tuple p))) in + if dist < 5. then ( + path + ) else ( + Path.Path_Builder.add_point + point + path + ) + +(** Select the given segment, and modify angle and width accordingly *) +let select_segment _ (_, selected, p0, p1) state dist = + + let point' = Path.Point.mix dist (Path.Point.get_coord p0) p0 p1 in + + let angle = (Float.round @@ 10. *. Path.Point.get_angle point') /. 10. + and width = (Float.round @@ 10. *. Path.Point.get_width point') /. 10. in + + let id = Selection.select_path selected in + { state with + mode = (Selection id) + ; angle + ; width } + +(** Delete the selected element *) +let delete state worker = + match state.mode with + | Selection (Path id) -> + let paths = List.filter + state.paths + ~f:(fun p -> + p.Outline.id != id + ) in + { state with paths ; mode = Out} + + | Selection (Point (id, point)) -> + List.iter + state.paths + ~f:(fun p -> + let id' = p.Outline.id in + match id' = id with + | false -> () + | true -> post worker (`DeletePoint (point, p)) + ); + { state with mode = Selection (Path id) } + | _ -> + state + +(** Tick event + + Tick only occurs when drawing a new path + +*) +let tick (delay, point) state = + match state.mode with + | Edit -> + (* Add the point in the list *) + let current = insert_or_replace + state + point + delay + state.current in + { state with current } + | _ -> state + +let update_property worker state value f = function + | None -> state + | Some (Selection.Path outline) -> + (* Change width for the whole path *) + let outline = { outline with + Outline.path = Path.Fixed.map outline.Outline.path (fun p -> + f p value) + } in + post worker (`Back outline); + state + | Some (Point (outline, point)) -> + let path = Path.Fixed.map + outline.path + (fun pt -> + match Path.Point.id pt = Path.Point.id point with + | false -> pt + | true -> f pt value) + in + let outline = {outline with path} in + post worker (`Back outline); + state + +let width worker width state = + match state.mode with + + | Selection t -> + let state = { state with width } in + Selection.find_selection t state.paths + |> update_property worker state width Path.Point.set_width + | _ -> { state with width } + +let angle worker angle state = + match state.mode with + + | Selection t -> + let state = { state with angle } in + Selection.find_selection t state.paths + |> update_property worker state angle Path.Point.set_angle + | _ -> { state with angle } + + +(** Short click on any element, just do nothing (each element is on MouseDown + event) *) +let click state = function + | _ -> state + +(** Long click, move the selected element if any *) +let longClick mouse_coord state worker = function + | Selection t -> + let mouse_v2 = Gg.V2.of_tuple mouse_coord in + begin match Selection.find_selection t state.paths with + | None -> state + | Some (Point (path, point)) -> + let point' = Path.Point.copy point mouse_v2 in + post worker (`TranslatePoint (point', path)); + (* Just replace the position of the selected point *) + { state with mode = Selection (Point (path.id, point')) } + | Some (Path path) -> + let delta = Gg.V2.(mouse_v2 - state.mouse_down_position) in + post worker (`TranslatePath (path, delta)); + state + end + (* TODO Long click in out mode should translate the slate *) + | _ -> state + +let do_action + : Brr_webworkers.Worker.t -> Elements.Timer.t -> (events, state) Application.t + = fun worker timer event state -> + match event, state.mode with + | `Generic (E (t, (module Handler))), _ -> + Handler.apply t state + | `Point (delay, point), _ -> + tick (delay, point) state + + (* Click anywhere while in Out mode, we switch in edition *) + | `MouseDown ((x, y) as p), Out -> + Elements.Timer.start timer 0.3; + + let width = state.width + and angle = state.angle in + + let stamp = 0. in + let point = + match Selection.get_from_paths p state.paths with + | _, None -> + (* Start a new path with the point clicked *) + Path.Point.create ~x ~y ~angle ~width ~stamp + | _, 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 ~stamp + in + + let current = Path.Path_Builder.add_point + point + state.current in + { state with + current + ; mode = Edit + ; mouse_down_position = Gg.V2.of_tuple (x, y)} + + (* Click anywhere while in selection mode, we either select another path, + or switch to Out mode*) + | `MouseDown position, (Selection (Path id)) + | `MouseDown position, (Selection (Point (id, _))) -> + + let get_any () = + begin match Selection.get_from_paths position state.paths with + | _, None -> + { state with + mode = Out + ; mouse_down_position = Gg.V2.of_tuple position } + | dist, Some selection -> + let _, outline, _, _ = selection in + if outline.Outline.id != id then ( + let mouse_down_position = Gg.V2.of_tuple position in + select_segment position selection { state with mouse_down_position } dist + ) else + (* On the same segment, check for a point *) + let selection = Selection.select_point outline (Gg.V2.of_tuple position) in + match selection with + | Path _ -> + { state with + mode = Selection selection + ; mouse_down_position = Gg.V2.of_tuple position } + | Point (_, pt) -> + (* In order to handle the point move, start the timer *) + Elements.Timer.start timer 0.3; + { state with + mode = Selection selection + ; angle = Path.Point.get_angle pt + ; width = Path.Point.get_width pt + ; mouse_down_position = Gg.V2.of_tuple position } + end + in + + (* First, check for a point in the selected path. If any of them in + found, check anything to select in all the elements *) + begin match Outline.find state.paths id with + | None -> get_any () + | Some outline -> + begin match Selection.select_point outline (Gg.V2.of_tuple position) with + | Path _ -> get_any () + | other -> + Elements.Timer.start timer 0.3; + {state with + mode = Selection other + ; mouse_down_position = Gg.V2.of_tuple position } + end + end + + | `Delete, _ -> + delete state worker + + | `Export, _ -> + let my_host = Uri.host @@ Window.location @@ G.window in + if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then ( + (* Convert the path into an sVG element *) + let svg = Layer.Svg.svg + ~at:Brr.At.[ + v (Jstr.v "xmlns") (Jstr.v "http://www.w3.org/2000/svg") + ; v (Jstr.v "xmlns:xlink") (Jstr.v "http://www.w3.org/1999/xlink") ] + (List.map state.paths + ~f:(fun path -> + + Layer.Paths.to_svg + ~color:Blog.Nord.nord0 + (module Path.Fixed) + Outline.(path.path, path.back) + state.rendering + + )) in + let content = El.prop Elements.Prop.outerHTML svg in + Elements.Transfert.send + ~mime_type:(Jstr.v "image/svg+xml") + ~filename:(Jstr.v "out.svg") + content); + state + + | `Angle value , _ -> + angle worker value state + | `Width value, _ -> + width worker value state + + + | `Rendering rendering, _ -> + { state with rendering} + + | `Other t, _ -> + Console.(log [t]); + state + + | `Complete newPath, _ -> + let paths = List.map + state.paths + ~f:(fun line -> + match Outline.(newPath.id = line.id) with + | true -> newPath + | false -> line) in + { state with paths } + + + (* Some non possible cases *) + | `MouseDown _, Edit + -> state + +let init = + { paths = [] + ; current = Path.Path_Builder.empty + ; mode = Out + ; angle = 30. + ; width = 10. + ; rendering = `Fill + ; mouse_down_position = Gg.V2.ox + } -- cgit v1.2.3