open StdLabels open Note open Brr module Timer = Events.Timer module Repr = Path.FillPrinter module Path_Builder = Path.Builder.Make(Path.Point) module Path_Printer = Path_Builder.Draw(Repr) module Fixed_Printer = Path_Builder.DrawFixed(Repr) type mode = | Edit | Selection of Path_Builder.fixedPath | Out let timer, tick = Timer.create () type current = Path_Builder.t (* The state cannt hold functionnal values, and thus cannot be used to store elements like timer *) type state = { mode : mode ; paths : Path_Builder.fixedPath list ; current : current } (** Events *) type canva_events = [ `Click of float * float | `Out of float * float ] type events = [ canva_events | `Point of float * (float * float) ] type canva_signal = Path.Point.t module Mouse = Brr_note_kit.Mouse (** Create the element in the page, and the event handler *) let canva : Brr.El.t -> [> canva_events] Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t = fun element -> let module C = Brr_canvas.Canvas in let c = C.of_el element in (* Mouse events *) let mouse = Brr_note_kit.Mouse.on_el ~normalize:false (fun x y -> (x, y)) element in let click = Brr_note_kit.Mouse.left_down mouse |> E.map (fun c -> `Click c) in let up = Brr_note_kit.Mouse.left_up mouse |> E.map (fun c -> `Out c) in let position = Mouse.pos mouse in let pos = S.l2 (fun b pos -> if b then Some pos else None ) (Mouse.left mouse) position in E.select [click; up], pos, c let insert_or_replace ((x, y) as p) path = let point = Path.Point.create x y in match Path_Builder.peek path with | None -> 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, None ) else ( Path_Builder.add_point point path ) let check_selection position paths = let point = Gg.V2.of_tuple position in (* If the user click on a curve, select it *) List.fold_left paths ~init:None ~f:(fun selection path -> match selection with | Some p -> Some p | None -> (* TODO : Add a method in the point module *) begin match Path_Builder.distance point path with | Some p when p < 20. -> Some path | _ -> None end ) let do_action : events -> state -> state = fun event state -> match event, state.mode with | `Point (_delay, point), Edit -> (* Add the point in the list *) let current, fixed_path = insert_or_replace point state.current in let paths = match fixed_path with | None -> state.paths | Some p -> p::state.paths in { state with current; paths } (* Click anywhere while in Out mode, we switch in edition *) | `Click _, Out -> Timer.start timer 0.3; { state with 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 selected -> (* Start the timer in order to handle the mouse moves *) Timer.start timer 0.3; { state with mode = (Selection selected)} end | `Out point, Edit -> Timer.stop timer; begin match Path_Builder.peek2 state.current with (** If there is at last two points selected, handle this as a curve creation *) | Some _ -> let current, fixed_path = insert_or_replace point state.current in let paths = match fixed_path with | None -> Path_Builder.to_fixed current::state.paths | Some p -> p::state.paths and current = Path_Builder.empty in { mode = Out ; paths; current } (** Else, check if there is a curve undre the cursor, and remove it *) | None -> let current = Path_Builder.empty in begin match check_selection point state.paths with | None -> { state with mode = Out ; current } | Some selected -> { state with mode = (Selection selected) ; current } end end | _ -> state let backgroundColor = Jstr.v "#2e3440" let white = Jstr.v "#eceff4" let green = Jstr.v "#a3be8c" let nord8 = Jstr.v "#81a1c1" let on_change canva mouse_position state = let module Path' = Path in let open Brr_canvas.C2d in let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in let _area = Gg.V2.v w h in let context = create canva in set_fill_style context (color backgroundColor); fill_rect context ~x:0.0 ~y:0.0 ~w ~h; set_stroke_style context (color white); set_fill_style context (color white); (* If we are in edit mode, we add a point under the cursor. Otherwise, we would only display the previous registered point, which can be far away in the past, and would give to the user a sensation of lag. *) let pos = S.rough_value mouse_position in let current, paths = begin match state.mode, pos with | Edit, Some point -> begin match insert_or_replace point state.current with | current, None -> current, state.paths | current, Some p -> current, p::state.paths end | _ -> state.current, state.paths end in let path = Repr.get @@ Path_Printer.draw current (Repr.create_path (fun p -> fill context p)) in stroke context path; List.iter paths ~f:(fun path -> let path = Repr.get @@ Fixed_Printer.draw path (Repr.create_path (fun p -> fill context p)) in stroke context path; ); (* If there is a selection draw it *) let () = match state.mode with | Selection path -> set_fill_style context (color nord8); set_stroke_style context (color nord8); let path = Repr.get @@ Fixed_Printer.draw path (Repr.create_path (fun p -> fill context p)) in stroke context path; | _ -> () in () let page_main id = let init = { paths = [] ; current = Path_Builder.empty ; mode = Out } in (*begin match Document.find_el_by_id G.document id with*) begin match (Jv.is_none id) with | true -> Console.(error [str "No element with id '%s' found"; id]) | false -> let canva_events, mouse_position, canva = canva (Jv.Id.of_jv id) in let tick_event = S.sample_filter mouse_position ~on:tick (fun pos f -> Option.map (fun p -> `Point (f, p)) pos ) in (* The first evaluation is the state. Which is the result of all the successives events to the initial state *) let state = E.select [canva_events; tick_event] |> E.map do_action |> Note.S.accum init in (* The seconde evaluation is the canva refresh, which only occurs when the mouse is updated *) let v = E.map (fun _ -> state) (S.changes mouse_position) |> E.map (fun x -> on_change canva mouse_position (S.value x) ) |> fun ev -> E.log ev (fun _ -> ()) in (* Draw the canva for first time *) on_change canva mouse_position init; let _ = Logr.hold (S.log state (fun _ -> ())) in let _ = match v with | None -> () | Some log -> Logr.hold log in () end let () = if Brr_webworkers.Worker.ami () then () else let open Jv in let drawer = obj [| "run", (repr page_main) |] in set global "drawer" drawer