From 20addbe8fd0ac4c79c8a69a4f888ec320a9ca4c3 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Sat, 2 Jan 2021 16:20:42 +0100 Subject: Refactor --- script.it/dune | 26 +++++ script.it/script.ml | 326 ++++++++++++++++++++++++++++++++++++++++++++++++++++ script.it/state.ml | 266 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 618 insertions(+) create mode 100755 script.it/dune create mode 100755 script.it/script.ml create mode 100755 script.it/state.ml (limited to 'script.it') diff --git a/script.it/dune b/script.it/dune new file mode 100755 index 0000000..1536f2b --- /dev/null +++ b/script.it/dune @@ -0,0 +1,26 @@ +(executables + (names script) + (libraries + js_of_ocaml + brr + brr.note + vg + vg.htmlc + messages + messages_json + worker + shapes + tools + elements + blog + path + ) + (modes js) + (preprocess (pps ppx_hash)) + (link_flags (:standard -no-check-prims)) + ) + +(rule + (targets script.js) + (deps script.bc.js) + (action (run cp %{deps} %{targets}))) diff --git a/script.it/script.ml b/script.it/script.ml new file mode 100755 index 0000000..3e52f5c --- /dev/null +++ b/script.it/script.ml @@ -0,0 +1,326 @@ +open StdLabels +open Note +open Brr +open Brr_note + + +module Mouse = Brr_note_kit.Mouse + +let get_height el = + match El.at (Jstr.v "height") el with + | None -> 0 + | Some att -> + Option.value ~default:0 (Jstr.to_int att) + +(** Create the element in the page, and the event handler *) +let canva + : Brr.El.t -> [> State.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 -> `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 click_event el = + Evr.on_el + Ev.click + Evr.unit + el + +let show_value input = + El.txt (Jstr.of_float input) + +let set_sidebar + : El.t -> State.state -> unit E.t * float S.t * float S.t *unit E.t + = fun element state -> + + let open El in + + let delete = + button + [ El.i + ~at:At.[ class' (Jstr.v "fas") + ; class' (Jstr.v "fa-times-circle") ] + [] + ; txt' "Delete "] in + + let delete_event = click_event delete in + + let export = + button + [ El.i + ~at:At.[ class' (Jstr.v "fas") + ; class' (Jstr.v "fa-download") ] + [] + ; 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 + Elr.def_children + width + (nib_size_event + |> S.map (fun v -> + [ txt' "Width : " + ; show_value v ] + ) + ); + + 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 + Elr.def_children + angle + (angle_event + |> S.map (fun v -> + [ txt' "Angle : " + ; show_value v + ; txt' "°" ] + ) + ); + + let render = + El.select + [ El.option ~at:At.[value (Jstr.v "Fill")] + [ txt' "Fill"] + ; El.option ~at:At.[value (Jstr.v "Wireframe")] + [ txt' "Wireframe"] + ; El.option ~at:At.[value (Jstr.v "Ductus")] + [ txt' "Ductus"] + ] in + let rendering' = El.div + [ txt' "Rendering : " + ; render ] in + + let () = + El.append_children element + [ hr () + ; delete + ; export + + ; rendering' + + ; hr () + + ; width + ; nib_size + + ; angle + ; input_angle + + ] + in + delete_event, angle_event, nib_size_event, export_event + +let backgroundColor = Blog.Nord.nord0 +let white = Jstr.v "#eceff4" +let green = Jstr.v "#a3be8c" + +(** Redraw the canva on update *) +let on_change canva mouse_position state = + 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 pos = S.rough_value mouse_position in + let current = + begin match state.State.mode, pos with + | Edit, Some point -> + State.insert_or_replace state point state.current + | _ -> + state.current + end + in + + let repr = `Fill in + + Path.to_canva (module Path.Path_Builder) current context repr; + + List.iter state.paths + ~f:(fun path -> + + let () = match state.mode with + | Selection id -> + begin match id = (Path.Fixed.id path) 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); + end + | _ -> () + in + + Path.to_canva (module Path.Fixed) path context repr + ); + () + + +let page_main id = + + let delete_event', angle_signal', width_signal', export_event' = + begin match Blog.Sidebar.get () with + | None -> + Jv.throw (Jstr.v "No sidebar") + | Some el -> + + Blog.Sidebar.clean el; + set_sidebar el State.init + end in + let delete_event = E.map (fun () -> `Delete) delete_event' + and export_event = E.map (fun () -> `Export) export_event' + and angle_event = S.changes angle_signal' + |> E.map (fun value -> `Angle value) + and width_event = S.changes width_signal' + |> E.map (fun value -> `Width value) + 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 -> + + (* 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 tick_event = + S.sample_filter mouse_position + ~on:State.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 + ; angle_event + ; width_event + ; delete_event + ; export_event ] + |> E.map State.do_action + |> Note.S.accum State.init 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 _ -> ()) (S.changes angle_signal') + ; E.map (fun _ -> ()) (S.changes width_signal') + ; delete_event' ] + |> fun ev -> E.log ev (fun _ -> on_change canva mouse_position (S.value state) ) + |> Option.iter Logr.hold in + + + (* Draw the canva for first time *) + on_change canva mouse_position State.init; + + (* Hold the state *) + let _ = Logr.hold (S.log state (fun _ -> ())) 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 + ) diff --git a/script.it/state.ml b/script.it/state.ml new file mode 100755 index 0000000..5a1ef8f --- /dev/null +++ b/script.it/state.ml @@ -0,0 +1,266 @@ +open StdLabels +open Brr + +let expected_host = Blog.Hash_host.expected_host + +let backgroundColor = Blog.Nord.nord0 + +let timer, tick = Elements.Timer.create () + +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 events = + [ canva_events + | button_events + | `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 + } + +let insert_or_replace state ((x, y) as p) path = + let width = state.width + and angle = state.angle in + let point = Path.Point.create ~x ~y ~angle ~width 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) 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) when p < dist -> + dist, Some (point', path) + | _ -> 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 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 = insert_or_replace + state + point + 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 point = + match check_selection p state.paths with + | None -> + (* Start a new path with the point clicked *) + Path.Point.create ~x ~y ~angle ~width + | 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 + 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 (_, selected) -> + + (* Start the timer in order to handle the mouse moves *) + + let id = Path.Fixed.id selected in + Elements.Timer.start timer 0.3; + { state with + mode = (Selection id)} + end + + | `Out point, Edit -> + 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 point = match check_selection point state.paths with + | None -> point + | Some (p, _) -> Gg.V2.to_tuple p in +*) + + let current = insert_or_replace state point state.current in + let paths = + let last = Path.Fixed.to_fixed + (module Path.Path_Builder) + current + in + last::state.paths + and current = Path.Path_Builder.empty in + { state with + mode = Out + ; paths; current } + + (* Else, check if there is a curve undre 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 (_, selected) -> + let id = Path.Fixed.id selected in + { state with + mode = (Selection id) + ; 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) = 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 -> + + Path.to_svg + ~color:backgroundColor + (module Path.Fixed) + path + `Fill + + )) 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 + + (* 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. + } -- cgit v1.2.3