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 -> state = 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 }