open StdLabels open Brr type mode = | Edit | Selection of Selection.t | Out (** Events *) type canva_events = [ `Click of float * float | `Out of float * float ] type button_events = [ `Delete | `Export ] type render_event = [ `Rendering of Layer.Paths.printer ] type worker_event = [ `Basic of Jv.t | `Complete of Path.Fixed.t ] 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 : Path.Fixed.t list ; current : Path.Path_Builder.t ; width : float ; angle : float ; rendering : Layer.Paths.printer } 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 ) (** Update the path in the selection with the given function applied to every point *) let update_path_selection id paths f = List.map paths ~f:(fun path -> let id' = Path.Fixed.id path in match id = id' with | false -> path | true -> Path.Fixed.map path f ) let update_point_selection state path_id point f = let paths = List.map state.paths ~f:(fun p -> match Path.Fixed.id p = path_id with | false -> p | true -> Path.Fixed.map p (fun p -> if (Path.Point.id p = Path.Point.id point) then f p else p ) ) in { state with paths } (** 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 } (** Handle the deletion event. Deletion only apply to a selection *) let delete state worker = match state.mode with | Selection (Path id) -> let paths = List.filter state.paths ~f:(fun p -> Path.Fixed.id p != id ) in { state with paths ; mode = Out} | Selection (Point (id, point)) -> List.iter state.paths ~f:(fun p -> let id' = Path.Fixed.id p in match id' = id with | false -> () | true -> (* Send the job to the worker *) 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 angle angle state = match state.mode with (* Change angle for the whole path *) | Selection (Path s) -> let state = { state with angle } in let paths = update_path_selection s state.paths (fun p -> Path.Point.set_angle p angle) in {state with paths } (* Change angle localy *) | Selection (Point (s, point)) -> let state = update_point_selection state s point (fun p -> Path.Point.set_angle p angle) in { state with angle } | _ -> { state with angle} let width width state = match state.mode with | Selection (Path s) -> let state = { state with width } in let paths = update_path_selection s state.paths (fun p -> Path.Point.set_width p width) in {state with paths } | Selection (Point (s, point)) -> let state = update_point_selection state s point (fun p -> Path.Point.set_width p width) in { state with width } | _ -> { state with width } 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 *) | `Click ((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 } (* Click anywhere while in selection mode, we either select another path, or switch to Out mode*) | `Click position, (Selection (Path id)) | `Click position, (Selection (Point (id, _))) -> begin match Selection.get_from_paths position state.paths with | _, None -> { state with mode = Out } | dist, Some selection -> let _, path, _, _ = selection in if Path.Fixed.id path != id then select_segment position selection state dist else (* On the same segment, check for a point *) let selection = Selection.select_point path (Gg.V2.of_tuple position) in match selection with | Path _ -> { state with mode = Selection selection } | 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 } 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 paths = let last = Path.Fixed.to_fixed (module Path.Path_Builder) current in let () = post worker (`Complete last) in last::state.paths and current = Path.Path_Builder.empty in { state with mode = Out ; paths; current } (* 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 mouse_coord, Selection (Point (id, point)) -> let mouse_v2 = Gg.V2.of_tuple mouse_coord in if Elements.Timer.delay timer < 0.3 then state else let point' = Path.Point.copy point mouse_v2 in List.iter state.paths ~f:(fun path -> let id' = Path.Fixed.id path in match id = id' with | false -> () | true -> Option.iter (fun p -> post worker (`Complete p)) (Path.Fixed.replace_point path point') ); { state with mode = Selection (Path id) } | `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) path state.rendering )) in let content = El.prop Elements.Prop.outerHTML svg in let btoa = Jv.get Jv.global "btoa" in let base64data = Jv.apply btoa [| Jv.of_jstr content |] in (* Create the link to download the the element, and simulate a click on it *) let a = El.a ~at:At.[ href Jstr.( (v "data:image/svg+xml;base64,") + (Jv.Id.of_jv base64data)) ; v (Jstr.v "download") (Jstr.v "out.svg") ] [] in El.click a ); state | `Angle value , _ -> angle value state | `Width value, _ -> width value state | `Rendering rendering, _ -> { state with rendering} | `Basic t, _ -> Console.(log [t]); state | `Complete path, _ -> let id = Path.Fixed.id path in let paths = List.map state.paths ~f:(fun path' -> let id' = Path.Fixed.id path' in match id = id' with | false -> path' | true -> path ) in { state with paths } (* Some non possible cases *) | `Out _, Out | `Out _, Selection _ | `Click _, Edit -> state let init = { paths = [] ; current = Path.Path_Builder.empty ; mode = Out ; angle = 30. ; width = 10. ; rendering = `Fill }