open StdLabels open Note open Brr module Timer = Events.Timer module Point = Draw.Point module Path = Draw module Path_Builder = Path.Builder.Make(Point) type mode = | Edit | Out type current = Path_Builder.t 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 ~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 = 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' = Point.get_coord p1 in let dist = (norm (p1' - (of_tuple p))) in if dist < 0.05 then ( path ) else ( Path_Builder.add_point point path ) let do_action : events -> state -> state = fun event state -> match event, state.mode with | `Point (_delay, (x, y)), Edit -> (* Add the point in the list *) let current= Path_Builder.add_point (Point.create x y) state.current in { state with current } | `Click _, Out -> Timer.start state.timer 0.3; { state with mode = Edit } | `Out point, Edit -> Timer.stop state.timer; let current = insert_or_replace point state.current in let beziers = Draw.to_path @@ Path_Builder.get current in let paths = beziers::state.paths and current = Path_Builder.empty 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 current = match state.mode, pos with | Edit, Some (x, y) -> Path_Builder.add_point (Point.create x y) state.current | _ -> state.current in let path = Point.get @@ Path_Builder.draw current in stroke context path; (* let points, beziers = Path_Builder.get current in let path = draw_path area (points) 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 = Path_Builder.empty ; 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