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 }