open StdLabels open Note open Brr open Brr_note module State = Script_state.State module Selection = Script_state.Selection module Path = Script_path let post : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit = Brr_webworkers.Worker.post type canva_events = [ `MouseDown of float * float | `Out of float * float ] (** 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 -> (* Adapt the width to the window *) El.set_inline_style El.Style.width (Jstr.v "100%") element; (* See https://stackoverflow.com/a/14855870/13882826 *) El.set_inline_style El.Style.height (Jstr.v "100%") element; El.set_prop El.Prop.width (El.prop Elements.Prop.offsetWidth element) element; El.set_prop El.Prop.height (El.prop Elements.Prop.offsetHeight element) element; El.set_inline_style El.Style.width (Jstr.v "") 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 -> `MouseDown c) in let up = Brr_note_kit.Mouse.left_up mouse |> E.map (fun c -> `Out c) in let position = Brr_note_kit.Mouse.pos mouse in let pos = S.l2 (fun b pos -> if b then Some pos else None) (Brr_note_kit.Mouse.left mouse) position in (E.select [ click; up ], pos, c) let click_event el = Evr.on_el Ev.click Evr.unit el type 'a param_events = { width : float S.t ; angle : float S.t ; export : unit E.t ; delete : unit E.t ; rendering : State.event E.t } type slider = { input : El.t ; legend : El.t } let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = fun element state -> let delete = El.button [ El.i ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-times-circle") ] [] ; El.txt' "Delete " ] in let delete_event = click_event delete in let export = El.button [ El.i ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-download") ] [] ; El.txt' "Download" ] in let export_event = click_event export in let nib_size, nib_size_event = Elements.Input.slider ~at: At. [ type' (Jstr.v "range") ; v (Jstr.v "min") (Jstr.v "1") ; v (Jstr.v "max") (Jstr.v "50") ; At.value (Jstr.of_float state.width) ] in let width = El.div [] in let width_slider = { input = nib_size; legend = width } in let input_angle, angle_event = Elements.Input.slider ~at: At. [ type' (Jstr.v "range") ; v (Jstr.v "min") (Jstr.v "0") ; v (Jstr.v "max") (Jstr.v "90") ; At.value (Jstr.of_float state.angle) ] in let angle = El.div [] in let angle_slider = { input = input_angle; legend = angle } in let render = El.select [ El.option ~at:At.[ value (Jstr.v "1") ] [ El.txt' "Fill" ] ; El.option ~at:At.[ value (Jstr.v "3") ] [ El.txt' "Ductus" ] ] in let rendering' = El.div [ El.txt' "Rendering : "; render ] in let render_event = Evr.on_el Ev.change (fun _ -> let raw_value = El.prop El.Prop.value render |> Jstr.to_int in let render_type = match raw_value with | Some 1 -> `Fill | Some 2 -> `Line | Some 3 -> `Ductus | _ -> `Fill in let module M = struct type t = Layer.Paths.printer let process t state = { state with State.rendering = t } end in State.dispatch (module M) render_type ) rendering' in let () = El.append_children element [ El.hr () ; delete ; export ; rendering' ; El.hr () ; width ; nib_size ; angle ; input_angle ] in ( { delete = delete_event ; angle = angle_event ; width = nib_size_event ; export = export_event ; rendering = render_event } , angle_slider , width_slider ) let backgroundColor = Blog.Nord.nord0 let white = Jstr.v "#eceff4" let green = Jstr.v "#a3be8c" let draw_point point context = let module Cd2d = Brr_canvas.C2d in let x, y = Gg.V2.to_tuple @@ Path.Point.get_coord point in Cd2d.stroke_rect ~x:(x -. 5.) ~y:(y -. 5.) ~w:10. ~h:10. context (** Redraw the canva on update *) let on_change canva mouse_position timer state = let pos = S.rough_value mouse_position in let pos_v2 = Option.map Gg.V2.of_tuple pos in let module Cd2d = Brr_canvas.C2d in let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in let context = Cd2d.create canva in Cd2d.set_fill_style context (Cd2d.color backgroundColor); Cd2d.fill_rect context ~x:0.0 ~y:0.0 ~w ~h; Cd2d.set_stroke_style context (Cd2d.color white); Cd2d.set_fill_style context (Cd2d.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 current = match (state.State.mode, pos) with | Edit, Some point -> let stamp = Elements.Timer.delay timer in State.insert_or_replace state point stamp state.current | _ -> state.current in let back = Path.Path_Builder.map current (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt ) in Layer.Paths.to_canva (module Path.Path_Builder) (current, back) context state.rendering; List.iter state.paths ~f:(fun path -> let () = match state.mode with | Selection (Path id) | Selection (Point (id, _)) -> ( match id = path.Outline.id with | true -> (* If the element is the selected one, change the color *) Cd2d.set_fill_style context (Cd2d.color Blog.Nord.nord8); Cd2d.set_stroke_style context (Cd2d.color Blog.Nord.nord8) | false -> Cd2d.set_stroke_style context (Cd2d.color white); Cd2d.set_fill_style context (Cd2d.color white) ) | _ -> () in let p = path.Outline.path in Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context state.rendering ); (* Draw the selected path, and operate the modifications directly as a preview *) let () = match state.mode with | Selection t -> Cd2d.set_stroke_style context (Cd2d.color white); ( match (pos_v2, Selection.find_selection t state.paths) with (* The selected element does not exist, just do nothing *) | _, None -> () (* There is no click on the canva, print the line *) | None, Some (Path outline) -> Layer.Paths.to_canva (module Path.Fixed) (outline.path, outline.back) context `Line (* The user is modifiying the path *) | Some pos_v2, Some (Path outline) -> (* Translate the path *) let delta = Gg.V2.(pos_v2 - state.State.mouse_down_position) in let path = Path.Fixed.map outline.Outline.path (fun pt -> Path.Point.get_coord pt |> Gg.V2.add delta |> Path.Point.copy pt ) in Layer.Paths.to_canva (module Path.Fixed) (path, path) context `Line (* The user is modifiying the point *) | Some pos_v2, Some (Point (outline, point)) when Elements.Timer.delay timer > 0.3 -> let point' = Path.Point.copy point pos_v2 in let path = match Path.Fixed.replace_point outline.Outline.path point' with | None -> outline.Outline.path | Some p -> p in Layer.Paths.to_canva (module Path.Fixed) (path, path) context `Line; draw_point point context | _, Some (Point (outline, point)) -> Layer.Paths.to_canva (module Path.Fixed) (outline.path, outline.back) context `Line; draw_point point context ) | _ -> () in () let spawn_worker () = try Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js")) with | Jv.Error e -> Error e let page_main id = let timer, tick = Elements.Timer.create () in let parameters, angle_element, width_slider = match Blog.Sidebar.get () with | None -> Jv.throw (Jstr.v "No sidebar") | Some el -> Blog.Sidebar.clean el; set_sidebar el State.init in match Jv.is_none id with | true -> Console.(error [ str "No element with id '%s' found"; id ]) | false -> ( match spawn_worker () with | Error e -> El.set_children (Jv.Id.of_jv id) [ El.p El.[ txt (Jv.Error.message e) ] ] | Ok worker -> let worker_event, worker_send = E.create () in let delete_event = E.map (fun () -> let module Delete = Script_event.Delete in State.dispatch (module Delete) Delete.{ worker } ) parameters.delete and export_event = E.map (fun () -> let module Export = Script_event.Export in State.dispatch (module Export) () ) parameters.export and angle_event = S.changes parameters.angle |> E.map (fun value -> let module Property = Script_event.Property in State.dispatch (module Property) Property.{ value; worker; prop = `Angle } ) and width_event = S.changes parameters.width |> E.map (fun value -> let module Property = Script_event.Property in State.dispatch (module Property) Property.{ value; worker; prop = `Width } ) and worker_event = Note.E.filter_map (function | `Other t -> Console.(log [ t ]); None | `Complete outline -> let module Complete_path = Script_event.Complete_path in Some (State.dispatch (module Complete_path) outline) ) worker_event in let my_host = Uri.host @@ Window.location @@ G.window in ( if Hashtbl.hash my_host = Blog.Hash_host.expected_host then let target = Brr_webworkers.Worker.as_target worker in Ev.listen Brr_io.Message.Ev.message (fun t -> Ev.as_type t |> Brr_io.Message.Ev.data |> worker_send) target ); (* Add the events to the canva : - The mouse position is a signal used for both the update and the canva refresh - Get also the click event for starting to draw *) let canva_events, mouse_position, canva = canva (Jv.Id.of_jv id) in let canva_events = Note.E.map (function | `MouseDown c -> let module MouseDown = Script_event.Mouse_down in State.dispatch (module MouseDown) MouseDown.{ position = c; timer } | `Out c -> let module Click = Script_event.Click in State.dispatch (module Click) Click.{ point = c; worker; timer } ) canva_events in let tick_event = S.sample_filter mouse_position ~on:tick (fun pos f -> let module Tick = Script_event.Tick in Option.map (fun p -> State.dispatch (module Tick) (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 = State.run State.init (E.select [ worker_event ; canva_events ; tick_event ; angle_event ; width_event ; delete_event ; export_event ; parameters.rendering ] ) in (* The seconde evaluation is the canva refresh, which only occurs when the mouse is updated, or on delete events *) let _ = E.select [ E.map (fun _ -> ()) (S.changes mouse_position) ; E.map (fun _ -> ()) parameters.rendering ; E.map (fun _ -> ()) worker_event ; parameters.delete ] |> fun ev -> E.log ev (fun _ -> on_change canva mouse_position timer (S.value state) ) |> Option.iter Logr.hold in (* Ajust the angle slide according to the state *) let angle_signal = S.map (fun s -> Jstr.of_float s.State.angle) state in let _ = Elr.def_prop Elements.Prop.value angle_signal angle_element.input and _ = Elr.def_children angle_element.legend (S.map (fun v -> [ El.txt' "Angle : "; El.txt v; El.txt' "°" ]) angle_signal ) in let width_signal = S.map (fun s -> Jstr.of_float s.State.width) state in let _ = Elr.def_prop Elements.Prop.value width_signal width_slider.input and _ = Elr.def_children width_slider.legend (S.map (fun v -> [ El.txt' "Width : "; El.txt v ]) width_signal) in (* Draw the canva for first time *) on_change canva mouse_position timer State.init; (* Hold the state *) let _ = Logr.hold (S.log state (fun _ -> ())) in () ) let () = let open Jv in let drawer = obj [| ("run", repr page_main) |] in set global "drawer" drawer