From 20addbe8fd0ac4c79c8a69a4f888ec320a9ca4c3 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Sat, 2 Jan 2021 16:20:42 +0100 Subject: Refactor --- blog/dune | 4 +- blog/hash_host/hash_blog.ml | 1 + blog/hash_host/hash_localhost.ml | 1 + blog/hash_prod/hash_blog.ml | 1 - blog/hash_prod/hash_localhost.ml | 1 - dune | 26 ---- script.it/dune | 26 ++++ script.it/script.ml | 326 +++++++++++++++++++++++++++++++++++++++ script.it/state.ml | 266 ++++++++++++++++++++++++++++++++ script.ml | 326 --------------------------------------- state.ml | 266 -------------------------------- 11 files changed, 622 insertions(+), 622 deletions(-) create mode 100755 blog/hash_host/hash_blog.ml create mode 100755 blog/hash_host/hash_localhost.ml delete mode 100755 blog/hash_prod/hash_blog.ml delete mode 100755 blog/hash_prod/hash_localhost.ml delete mode 100755 dune create mode 100755 script.it/dune create mode 100755 script.it/script.ml create mode 100755 script.it/state.ml delete mode 100755 script.ml delete mode 100755 state.ml diff --git a/blog/dune b/blog/dune index fef8506..c38558e 100755 --- a/blog/dune +++ b/blog/dune @@ -1,12 +1,12 @@ (rule (targets hash_host.ml) (enabled_if (= %{profile} dev)) - (action (run cp hash_prod/hash_localhost.ml hash_host.ml))) + (action (run cp hash_host/hash_localhost.ml hash_host.ml))) (rule (targets hash_host.ml) (enabled_if (<> %{profile} dev)) - (action (run cp hash_prod/hash_blog.ml hash_host.ml))) + (action (run cp hash_host/hash_blog.ml hash_host.ml))) (library (name blog) diff --git a/blog/hash_host/hash_blog.ml b/blog/hash_host/hash_blog.ml new file mode 100755 index 0000000..f5e172e --- /dev/null +++ b/blog/hash_host/hash_blog.ml @@ -0,0 +1 @@ +let expected_host = [%static_hash "blog.chimrod.com"] diff --git a/blog/hash_host/hash_localhost.ml b/blog/hash_host/hash_localhost.ml new file mode 100755 index 0000000..c652b6a --- /dev/null +++ b/blog/hash_host/hash_localhost.ml @@ -0,0 +1 @@ +let expected_host = [%static_hash ""] diff --git a/blog/hash_prod/hash_blog.ml b/blog/hash_prod/hash_blog.ml deleted file mode 100755 index f5e172e..0000000 --- a/blog/hash_prod/hash_blog.ml +++ /dev/null @@ -1 +0,0 @@ -let expected_host = [%static_hash "blog.chimrod.com"] diff --git a/blog/hash_prod/hash_localhost.ml b/blog/hash_prod/hash_localhost.ml deleted file mode 100755 index c652b6a..0000000 --- a/blog/hash_prod/hash_localhost.ml +++ /dev/null @@ -1 +0,0 @@ -let expected_host = [%static_hash ""] diff --git a/dune b/dune deleted file mode 100755 index 1536f2b..0000000 --- a/dune +++ /dev/null @@ -1,26 +0,0 @@ -(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/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. + } diff --git a/script.ml b/script.ml deleted file mode 100755 index 3e52f5c..0000000 --- a/script.ml +++ /dev/null @@ -1,326 +0,0 @@ -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/state.ml b/state.ml deleted file mode 100755 index 5a1ef8f..0000000 --- a/state.ml +++ /dev/null @@ -1,266 +0,0 @@ -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