open StdLabels open Note open Brr module Timer = Events.Timer module Point = Draw.Point type mode = | Edit | Out type current = { points : Point.t list (* The list of points to draw *) ; beziers : Shapes.Bezier.t list (* All the points already fixed *) } type state = { mode : mode ; paths : Draw.t list (* All the previous paths *) ; current : current ; timer : Timer.t } (** Events *) type canva_events = [ `Click of float * float | `Out of float * float ] type events = [ canva_events | `Point of float * (float * float) ] type canva_signal = 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 (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 do_action : events -> state -> state = fun event state -> match event, state.mode with | `Point (_delay, point), Edit -> (* Add the point in the list *) let points, beziers = Point.add_point_in_path point state.current.points state.current.beziers in let current= {points; beziers} in { state with current } | `Click _, Out -> Timer.start state.timer 0.3; { state with mode = Edit } | `Out p, Edit -> Timer.stop state.timer; (* Add the point in the list *) let points, beziers = match state.current.points, state.current.beziers with | hd::(tl), beziers -> let open Gg.V2 in let p' = of_tuple p and hd' = Point.get_coord hd in if (norm (hd' - p' )) < 0.05 then (Point.create (fst p) (snd p))::tl , beziers else ( Point.add_point_in_path p state.current.points state.current.beziers ) | _ -> Point.add_point_in_path p state.current.points state.current.beziers in (* let points, beziers = Point.add_point_in_path p state.current.points state.current.beziers in *) let beziers = Draw.to_path (points, beziers) in let paths = beziers::state.paths and current = { points = []; beziers = []} in { state with mode = Out; paths; current } | _ -> state let backgroundColor = Jstr.v "#2e3440" let white = Jstr.v "#eceff4" let green = Jstr.v "#a3be8c" let nord8 = Jstr.v "#81a1c1" let draw : ?connexion:Gg.v2 -> area:Gg.v2 -> Point.t list -> Brr_canvas.C2d.Path.t = fun ?connexion ~area points -> let open Brr_canvas.C2d in let path = Path.create () in let () = match points with | [] -> () | hd::_ -> let vect = Draw.Line (hd, Point.create 0. 0.) in Draw.move_to ~area path vect in let _ = match points with | [] | _::[] -> () | _::p1::[] -> Draw.line area ~p1 path | p0::p1::p2::[] -> Draw.three_points area ~p0 ~p1 ~p2 path | _ -> Draw.multi_points ?connexion area points path in path let draw_path area points beziers = let open Brr_canvas.C2d in let connexion = match beziers with | [] -> None | hd ::_ -> Some hd.Shapes.Bezier.p1 in (* Firt draw all the points most recent points *) let path = draw ?connexion ~area points in (* Then add the fixed ones *) let path = List.fold_left beziers ~init:path ~f:(fun path bezier -> let cx, cy = Draw.translate_point ~area bezier.Shapes.Bezier.ctrl0 and cx', cy' = Draw.translate_point ~area bezier.Shapes.Bezier.ctrl1 and x, y = Draw.translate_point ~area bezier.Shapes.Bezier.p1 in Path.ccurve_to path ~cx ~cy ~cx' ~cy' ~x ~y; path ) in path let on_change canva mouse_position state = 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 points = match state.mode, pos with | Edit, Some (x, y) -> (Point.create x y)::state.current.points | _ -> set_image_smoothing_enabled context true; set_image_smoothing_quality context Image_smoothing_quality.high; state.current.points in let path = draw_path area (points) state.current.beziers in stroke context path; List.iter state.paths ~f:(fun path -> (* This is ugly, and probably non efficient, but is an appropriate solution for the cases of overlapping path *) match path.Draw.path with | Draw.Curve beziers -> Array.iter beziers ~f:(fun bezier -> let b = Draw.Curve [|bezier|] in let p = Path.create () in Draw.move_to ~area p b; Draw.draw ~area p b; Draw.go_back ~area p b; Path.close p; fill context p; stroke context p ) | _ -> let p = Path.create () in Draw.move_to ~area p path.Draw.path; Draw.draw ~area p path.Draw.path; Draw.go_back ~area p path.Draw.path; Path.close p; fill context p; stroke context p ); () let page_main id = let timer, tick = Timer.create () in let init = { paths = [] ; current = { points = [] ; beziers = [] } ; mode = Out ; timer } 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