open StdLabels open Brr let backgroundColor = Blog.Nord.nord0 type mode = | Edit | Selection of int | 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 (int * (Path.Fixed.path array)) ] 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 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 ) let threshold = 20. let check_selection : (float * float) -> Path.Fixed.t list -> (Gg.v2 * Path.Fixed.t * Path.Point.t * Path.Point.t) option = fun position paths -> let point = Gg.V2.of_tuple position in (* If the user click on a curve, select it *) let _, res = List.fold_left paths ~init:(threshold, None) ~f:(fun (dist, selection) path -> match Path.Fixed.distance point path with | Some (point', p, p0, p1) when p < dist -> dist, Some (point', path, p0, p1) | _ -> dist, selection ) in res (** Update the path in the selection with the given function applied to every point *) let update_selection id state f = let paths = List.map state.paths ~f:(fun path -> let id' = Path.Fixed.id path in match id = id' with | false -> path | true -> Path.Fixed.map_point path f ) in { state with paths } let select_segment point (p, selected, p0, p1) state = let angle0 = Path.Point.get_angle p0 and angle1 = Path.Point.get_angle p1 in let width0 = Path.Point.get_width p0 and width1 = Path.Point.get_width p1 in let dist = Gg.V2.(norm ( p - (Gg.V2.of_tuple point))) in let angle = angle0 +. dist *. ( angle1 -. angle0 ) in let width = width0 +. dist *. ( width1 -. width0 ) in let id = Path.Fixed.id selected in { state with mode = (Selection id) ; angle ; 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), Edit -> (* Add the point in the list *) let current = insert_or_replace state point delay state.current in { state with current } (* 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 check_selection 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 _) -> begin match check_selection position state.paths with | None -> { state with mode = Out } | Some selection -> select_segment position selection state 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 id = Path.Fixed.id last and path = Path.Fixed.path last in let () = Brr_webworkers.Worker.post worker (`Complete (id, path)) 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 check_selection point state.paths with | None -> { state with mode = Out ; current } | Some selection -> select_segment point selection { state with current } end end | `Delete, Selection id -> let paths = List.filter state.paths ~f:(fun p -> Path.Fixed.id p != id) in { state with paths ; mode = Out} | `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:backgroundColor (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 (* Change the select curve with the appropriate setting *) | `Angle angle, Selection s -> let state = { state with angle } in update_selection s state (fun p -> Path.Point.set_angle p angle) | `Width width, Selection s -> let state = { state with width } in update_selection s state (fun p -> Path.Point.set_width p width) | `Angle angle, _ -> { state with angle} | `Width width, _ -> { state with width} | `Delete, Out -> state | `Rendering rendering, _ -> { state with rendering} | `Basic t, _ -> Console.(log [t]); state | `Complete (id, paths), _ -> let paths = List.map state.paths ~f:(fun path -> let id' = Path.Fixed.id path in match id = id' with | false -> path | true -> Path.Fixed.update path paths ) in { state with paths } (* Some non possible cases *) | `Out _, Out | `Point _, Out | `Point _, Selection _ | `Out _, Selection _ | `Click _, Edit | `Delete, Edit -> state let init = { paths = [] ; current = Path.Path_Builder.empty ; mode = Out ; angle = 30. ; width = 10. ; rendering = `Fill }