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/dune | 11 +- script.it/outline.ml | 21 --- script.it/outline/dune | 9 + script.it/outline/outline.ml | 21 +++ script.it/script.ml | 97 +++++++++- script.it/selection.ml | 71 -------- script.it/selection.mli | 33 ---- script.it/state.ml | 401 ------------------------------------------ script.it/state/dune | 13 ++ script.it/state/selection.ml | 71 ++++++++ script.it/state/selection.mli | 33 ++++ script.it/state/state.ml | 357 +++++++++++++++++++++++++++++++++++++ 12 files changed, 602 insertions(+), 536 deletions(-) delete mode 100755 script.it/outline.ml create mode 100755 script.it/outline/dune create mode 100755 script.it/outline/outline.ml delete mode 100755 script.it/selection.ml delete mode 100755 script.it/selection.mli delete mode 100755 script.it/state.ml 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 diff --git a/script.it/dune b/script.it/dune index ceae76c..dd1f7d2 100755 --- a/script.it/dune +++ b/script.it/dune @@ -1,16 +1,9 @@ -(library - (name outline) - (libraries - path) - (modules outline) - (preprocess (pps ppx_hash js_of_ocaml-ppx)) - ) - (executable (name script) (libraries brr brr.note + script_state shapes elements blog @@ -20,7 +13,7 @@ outline ) (modes js) - (modules script state selection) + (modules script) (preprocess (pps ppx_hash js_of_ocaml-ppx)) (link_flags (:standard -no-check-prims)) ) diff --git a/script.it/outline.ml b/script.it/outline.ml deleted file mode 100755 index 1df7588..0000000 --- a/script.it/outline.ml +++ /dev/null @@ -1,21 +0,0 @@ -open StdLabels - -let internal_path_id = ref 0 - -type t = - { id : int - ; path: Path.Fixed.t - ; back: Path.Fixed.t - } - -let get_id () = - let id = !internal_path_id in - incr internal_path_id; - id - -let find - : t list -> int -> t option - = fun ts id -> - List.find_opt - ts - ~f:(fun p -> p.id = id) diff --git a/script.it/outline/dune b/script.it/outline/dune new file mode 100755 index 0000000..db080a3 --- /dev/null +++ b/script.it/outline/dune @@ -0,0 +1,9 @@ +(library + (name outline) + (libraries + path) + (modules outline) + (preprocess (pps ppx_hash js_of_ocaml-ppx)) + ) + + diff --git a/script.it/outline/outline.ml b/script.it/outline/outline.ml new file mode 100755 index 0000000..1df7588 --- /dev/null +++ b/script.it/outline/outline.ml @@ -0,0 +1,21 @@ +open StdLabels + +let internal_path_id = ref 0 + +type t = + { id : int + ; path: Path.Fixed.t + ; back: Path.Fixed.t + } + +let get_id () = + let id = !internal_path_id in + incr internal_path_id; + id + +let find + : t list -> int -> t option + = fun ts id -> + List.find_opt + ts + ~f:(fun p -> p.id = id) diff --git a/script.it/script.ml b/script.it/script.ml index ba6b828..bc79a22 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -3,13 +3,88 @@ open Note open Brr open Brr_note +module State = Script_state.State +module Selection = Script_state.Selection + +module Out = struct + type t = { point : float * float + ; timer : Elements.Timer.t + ; worker : Brr_webworkers.Worker.t + } + + let apply {point; timer ; worker} state = + match state.State.mode with + + | Edit -> + let stamp = Elements.Timer.delay timer in + Elements.Timer.stop timer; + 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 _ -> + + let current = State.insert_or_replace state point stamp state.current in + let path = Path.Fixed.to_fixed + (module Path.Path_Builder) + current in + + (* Create a copy from the path with all the interior points *) + let back = Path.Fixed.map + path + (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in + + let last = + Outline.{ path + ; back + ; id = Outline.get_id () + } + in + + (* Send to the worker for a full review *) + let () = State.post worker (`Complete last) in + + let state = + { state with + mode = Out + ; paths = last::state.paths + ; current = Path.Path_Builder.empty } in + state + + (* Else, check if there is a curve under the cursor, and remove it *) + | None -> + let current = Path.Path_Builder.empty in + begin match Selection.get_from_paths point state.paths with + | _, None -> + { state with + mode = Out + ; current + } + | dist, Some selection -> + State.select_segment point selection { state with current } dist + + end + end + + | mode when Elements.Timer.delay timer < 0.3 -> + State.click state mode + + | _ -> + State.longClick point state worker state.mode + +end + let post : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit = Brr_webworkers.Worker.post +type canva_events = + [ `MouseDown of float * float + | `Out of float * float + ] + (** Create the element in the page, and the event handler *) let canva - : Brr.El.t -> [> State.canva_events] Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t + : Brr.El.t -> canva_events Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t = fun element -> (* Adapt the width to the window *) @@ -384,6 +459,26 @@ let page_main id = let canva_events, mouse_position, canva = canva (Jv.Id.of_jv id) in + let canva_events = Note.E.map + (function + | `MouseDown c -> `MouseDown c + | `Out c -> + + `Generic ( + State.E + ( Out.{ point = c + ; worker + ; timer + } + , (module Out: State.Handler with type t = Out.t) + + + ) + + ) + + ) canva_events in + let tick_event = S.sample_filter mouse_position ~on:tick diff --git a/script.it/selection.ml b/script.it/selection.ml deleted file mode 100755 index f5f135a..0000000 --- a/script.it/selection.ml +++ /dev/null @@ -1,71 +0,0 @@ -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/selection.mli b/script.it/selection.mli deleted file mode 100755 index 9792a2d..0000000 --- a/script.it/selection.mli +++ /dev/null @@ -1,33 +0,0 @@ -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.ml b/script.it/state.ml deleted file mode 100755 index 77a24a3..0000000 --- a/script.it/state.ml +++ /dev/null @@ -1,401 +0,0 @@ -open StdLabels -open Brr - -type mode = - | Edit - | Selection of Selection.t - | Out - -(** Events *) -type canva_events = - [ `MouseDown of float * float - | `Out of float * float - ] - -type button_events = - [ `Delete - | `Export - ] -type render_event = - [ - `Rendering of Layer.Paths.printer - ] - -type worker_event = Worker_messages.from_worker - -type events = - [ canva_events - | button_events - | render_event - | worker_event - | `Point of float * (float * float) - | `Width of float - | `Angle of float - ] - -(* - 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 - } - -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 - | `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 - - | `Out point, Edit -> - let stamp = Elements.Timer.delay timer in - Elements.Timer.stop timer; - 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 _ -> - - let current = insert_or_replace state point stamp state.current in - let path = Path.Fixed.to_fixed - (module Path.Path_Builder) - current in - - (* Create a copy from the path with all the interior points *) - let back = Path.Fixed.map - path - (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in - - let last = - Outline.{ path - ; back - ; id = Outline.get_id () - } - in - - (* Send to the worker for a full review *) - let () = post worker (`Complete last) in - - let state = - { state with - mode = Out - ; paths = last::state.paths - ; current = Path.Path_Builder.empty } in - state - - (* Else, check if there is a curve under the cursor, and remove it *) - | None -> - let current = Path.Path_Builder.empty in - begin match Selection.get_from_paths point state.paths with - | _, None -> - { state with - mode = Out - ; current - } - | dist, Some selection -> - select_segment point selection { state with current } dist - - end - end - - | `Out _, mode when Elements.Timer.delay timer < 0.3 -> - click state mode - - | `Out mouse_coord, mode -> - longClick mouse_coord state worker mode - - | `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 - } 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