From 6a75fb043ed30389fff1ce97fe20ee56b1c95066 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Tue, 25 May 2021 11:08:00 +0200 Subject: Update script.it project --- script.it/script.ml | 103 ++++++++++++++++-------- script.it/script_event/click.ml | 91 +++++++++++++++++++++ script.it/script_event/complete_path.ml | 14 ++++ script.it/script_event/delete.ml | 2 +- script.it/script_event/export.ml | 30 +++++++ script.it/script_event/mouse_down.ml | 2 +- script.it/script_event/out.ml | 88 --------------------- script.it/script_event/property.ml | 52 ++++++++++++ script.it/script_event/tick.ml | 20 +++++ script.it/state/state.ml | 136 ++------------------------------ 10 files changed, 285 insertions(+), 253 deletions(-) create mode 100755 script.it/script_event/click.ml create mode 100755 script.it/script_event/complete_path.ml create mode 100755 script.it/script_event/export.ml delete mode 100755 script.it/script_event/out.ml create mode 100755 script.it/script_event/property.ml create mode 100755 script.it/script_event/tick.ml diff --git a/script.it/script.ml b/script.it/script.ml index a21afa9..29bf2c9 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -87,7 +87,7 @@ type 'a param_events = ; angle : float S.t ; export : unit E.t ; delete : unit E.t - ; rendering : ([> State.render_event] as 'a) E.t + ; rendering : State.events E.t } type slider = @@ -160,11 +160,22 @@ let set_sidebar Ev.change (fun _ -> let raw_value = El.prop El.Prop.value render |> Jstr.to_int in - match raw_value with - | Some 1 -> `Rendering `Fill - | Some 2 -> `Rendering `Line - | Some 3 -> `Rendering `Ductus - | _ -> `Rendering `Fill + 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 update t state = { state with State.rendering = t } + end + in + + State.E + ( render_type + , (module M: State.Handler with type t = Layer.Paths.printer )) + ) rendering' in let () = @@ -358,22 +369,52 @@ let page_main 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 () -> `Generic ( - let module Delete = Script_event.Delete in - State.E ( Delete.{ worker } - , (module Delete: State.Handler with type t = Delete.t) - ))) + (fun () -> + let module Delete = Script_event.Delete in + State.E + ( Delete.{ worker } + , (module Delete: State.Handler with type t = Delete.t ))) parameters.delete - and export_event = E.map (fun () -> `Export) parameters.export + and export_event = + E.map (fun () -> + let module Export = Script_event.Export in + State.E + ( () + , (module Export: State.Handler with type t = Export.t ))) + parameters.export and angle_event = S.changes parameters.angle - |> E.map (fun value -> `Angle value) + |> E.map (fun value -> + let module Property = Script_event.Property in + State.E + ( Property.{ value ; worker ; prop = `Angle } + , (module Property: State.Handler with type t = Property.t ))) + and width_event = S.changes parameters.width - |> E.map (fun value -> `Width value) + |> E.map (fun value -> + let module Property = Script_event.Property in + State.E + ( Property.{ value ; worker ; prop = `Width } + , (module Property: State.Handler with type t = Property.t ))) + 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.E + ( outline + , (module Complete_path: State.Handler with type t = Complete_path.t )))) + + worker_event in - let worker_event, worker_send = E.create () 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 @@ -396,35 +437,33 @@ let page_main id = (function | `MouseDown c -> let module MouseDown = Script_event.Mouse_down in - `Generic ( - State.E - ( MouseDown.{ position = c - ; timer - } - , (module MouseDown: State.Handler with type t = MouseDown.t))) + State.E + ( MouseDown.{ position = c ; timer } + , (module MouseDown: State.Handler with type t = MouseDown.t )) | `Out c -> - let module Out = Script_event.Out in - `Generic ( - State.E - ( Out.{ point = c - ; worker - ; timer - } - , (module Out: State.Handler with type t = Out.t))) - + let module Click = Script_event.Click in + State.E + ( Click.{ point = c ; worker; timer } + , (module Click: State.Handler with type t = Click.t )) ) canva_events in let tick_event = S.sample_filter mouse_position ~on:tick - (fun pos f -> Option.map (fun p -> `Point (f, p)) pos ) in + (fun pos f -> + let module Tick = Script_event.Tick in + Option.map (fun p -> + State.E + ( (f, p) + , (module Tick: State.Handler with type t = Tick.t ))) + pos ) in (* The first evaluation is the state. Which is the result of all the successives events to the initial state *) let state = Application.run - (State.do_action worker) + State.do_action State.init (E.select [ worker_event diff --git a/script.it/script_event/click.ml b/script.it/script_event/click.ml new file mode 100755 index 0000000..591887b --- /dev/null +++ b/script.it/script_event/click.ml @@ -0,0 +1,91 @@ +module State = Script_state.State +module Selection = Script_state.Selection + +(** Handle a click outside of the selection *) + +type t = { point : float * float + ; timer : Elements.Timer.t + ; worker : Brr_webworkers.Worker.t + } + +(** The drag function is incorrectly named, as we dont't care if we are + selecting an element or not. + + But, in the case we are (point, path…), we effectively move the element with the mouse. *) +let drag mouse_coord state worker = function + | State.Selection t -> + let mouse_v2 = Gg.V2.of_tuple mouse_coord in + begin match Selection.find_selection t state.State.paths with + | None -> state + | Some (Point (path, point)) -> + let point' = Path.Point.copy point mouse_v2 in + State.post worker (`TranslatePoint (point', path)); + (* Just replace the position of the selected point *) + { state with mode = Selection (Point (path.id, point')) } + | Some (Path path) -> + let delta = Gg.V2.(mouse_v2 - state.State.mouse_down_position) in + State.post worker (`TranslatePath (path, delta)); + state + end + (* TODO Long click in out mode should translate the whole slate *) + | _ -> state + +let update {point; timer ; worker} state = + match state.State.mode with + + | Edit -> + let stamp = Elements.Timer.delay timer in + 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 current = State.insert_or_replace state point stamp state.current in + let path = Path.Fixed.to_fixed + (module Path.Path_Builder) + current in + + (* Create a copy from the path with all the interior points *) + let back = Path.Fixed.map + path + (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in + + let last = + Outline.{ path + ; back + ; id = Outline.get_id () + } + in + + (* Send to the worker for a full review *) + let () = State.post worker (`Complete last) in + + let state = + { state with + mode = Out + ; paths = last::state.paths + ; current = Path.Path_Builder.empty } in + state + + (* Else, check if there is a curve under the cursor, and remove it *) + | None -> + let current = Path.Path_Builder.empty in + begin match Selection.get_from_paths point state.paths with + | _, None -> + { state with + mode = Out + ; current + } + | dist, Some selection -> + State.select_segment point selection { state with current } dist + + end + end + + | _ when Elements.Timer.delay timer < 0.3 -> + state + + | _ -> + drag point state worker state.mode + diff --git a/script.it/script_event/complete_path.ml b/script.it/script_event/complete_path.ml new file mode 100755 index 0000000..99dd6ae --- /dev/null +++ b/script.it/script_event/complete_path.ml @@ -0,0 +1,14 @@ +open StdLabels +module State = Script_state.State + +type t = Outline.t + +let update newPath state = + let paths = List.map + state.State.paths + ~f:(fun line -> + match Outline.(newPath.id = line.id) with + | true -> newPath + | false -> line) in + { state with paths } + diff --git a/script.it/script_event/delete.ml b/script.it/script_event/delete.ml index edd5d23..6aac5d2 100755 --- a/script.it/script_event/delete.ml +++ b/script.it/script_event/delete.ml @@ -7,7 +7,7 @@ module Selection = Script_state.Selection type t = { worker : Brr_webworkers.Worker.t } (* Click anywhere while in Out mode, we switch in edition *) -let apply { worker } state = +let update { worker } state = match state.State.mode with | Selection (Path id) -> let paths = List.filter diff --git a/script.it/script_event/export.ml b/script.it/script_event/export.ml new file mode 100755 index 0000000..9e900c7 --- /dev/null +++ b/script.it/script_event/export.ml @@ -0,0 +1,30 @@ +open StdLabels +open Brr +module State = Script_state.State + +type t = unit + +let update () state = + let my_host = Uri.host @@ Window.location @@ G.window in + if (Hashtbl.hash my_host) = Blog.Hash_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.State.paths + ~f:(fun path -> + + Layer.Paths.to_svg + ~color:Blog.Nord.nord0 + (module Path.Fixed) + Outline.(path.path, path.back) + state.State.rendering + + )) in + let content = El.prop Elements.Prop.outerHTML svg in + Elements.Transfert.send + ~mime_type:(Jstr.v "image/svg+xml") + ~filename:(Jstr.v "out.svg") + content); + state diff --git a/script.it/script_event/mouse_down.ml b/script.it/script_event/mouse_down.ml index 04ea2fd..98e866a 100755 --- a/script.it/script_event/mouse_down.ml +++ b/script.it/script_event/mouse_down.ml @@ -4,7 +4,7 @@ module Selection = Script_state.Selection type t = { position : float * float ; timer : Elements.Timer.t } -let apply { position; timer } state = +let update { position; timer } state = match state.State.mode with | Out -> diff --git a/script.it/script_event/out.ml b/script.it/script_event/out.ml deleted file mode 100755 index b8b8599..0000000 --- a/script.it/script_event/out.ml +++ /dev/null @@ -1,88 +0,0 @@ -module State = Script_state.State -module Selection = Script_state.Selection - -(** Handle a click outside of the selection *) - -type t = { point : float * float - ; timer : Elements.Timer.t - ; worker : Brr_webworkers.Worker.t - } - -(** Long click, move the selected element if any *) -let longClick mouse_coord state worker = function - | State.Selection t -> - let mouse_v2 = Gg.V2.of_tuple mouse_coord in - begin match Selection.find_selection t state.State.paths with - | None -> state - | Some (Point (path, point)) -> - let point' = Path.Point.copy point mouse_v2 in - State.post worker (`TranslatePoint (point', path)); - (* Just replace the position of the selected point *) - { state with mode = Selection (Point (path.id, point')) } - | Some (Path path) -> - let delta = Gg.V2.(mouse_v2 - state.State.mouse_down_position) in - State.post worker (`TranslatePath (path, delta)); - state - end - (* TODO Long click in out mode should translate the slate *) - | _ -> state - -let apply {point; timer ; worker} state = - match state.State.mode with - - | Edit -> - let stamp = Elements.Timer.delay timer in - 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 current = State.insert_or_replace state point stamp state.current in - let path = Path.Fixed.to_fixed - (module Path.Path_Builder) - current in - - (* Create a copy from the path with all the interior points *) - let back = Path.Fixed.map - path - (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in - - let last = - Outline.{ path - ; back - ; id = Outline.get_id () - } - in - - (* Send to the worker for a full review *) - let () = State.post worker (`Complete last) in - - let state = - { state with - mode = Out - ; paths = last::state.paths - ; current = Path.Path_Builder.empty } in - state - - (* Else, check if there is a curve under the cursor, and remove it *) - | None -> - let current = Path.Path_Builder.empty in - begin match Selection.get_from_paths point state.paths with - | _, None -> - { state with - mode = Out - ; current - } - | dist, Some selection -> - State.select_segment point selection { state with current } dist - - end - end - - | _ when Elements.Timer.delay timer < 0.3 -> - state - - | _ -> - longClick point state worker state.mode - diff --git a/script.it/script_event/property.ml b/script.it/script_event/property.ml new file mode 100755 index 0000000..e637ab7 --- /dev/null +++ b/script.it/script_event/property.ml @@ -0,0 +1,52 @@ +module State = Script_state.State +module Selection = Script_state.Selection + +let update_property worker state value f = function + | None -> state + | Some (Selection.Path outline) -> + (* Change width for the whole path *) + let outline = { outline with + Outline.path = Path.Fixed.map outline.Outline.path (fun p -> + f p value) + } in + State.post worker (`Back outline); + state + | Some (Point (outline, point)) -> + let path = Path.Fixed.map + outline.path + (fun pt -> + match Path.Point.id pt = Path.Point.id point with + | false -> pt + | true -> f pt value) + in + let outline = {outline with path} in + State.post worker (`Back outline); + state + +type t = { prop : [`Angle | `Width ] + ; value : float + ; worker : Brr_webworkers.Worker.t + } + +let update { prop; value ; worker } state = + match prop with + | `Angle -> + let angle = value in + begin match state.State.mode with + + | Selection t -> + let state = { state with angle } in + Selection.find_selection t state.paths + |> update_property worker state angle Path.Point.set_angle + | _ -> { state with angle } + end + | `Width -> + let width = value in + begin match state.State.mode with + + | Selection t -> + let state = { state with width } in + Selection.find_selection t state.paths + |> update_property worker state width Path.Point.set_width + | _ -> { state with width } + end diff --git a/script.it/script_event/tick.ml b/script.it/script_event/tick.ml new file mode 100755 index 0000000..c927a2a --- /dev/null +++ b/script.it/script_event/tick.ml @@ -0,0 +1,20 @@ +module State = Script_state.State + +type t = float * (float * float) + +(** Tick event + + Tick only occurs when drawing a new path + +*) +let update (delay, point) state = + match state.State.mode with + | Edit -> + (* Add the point in the list *) + let current = State.insert_or_replace + state + point + delay + state.current in + { state with current } + | _ -> state diff --git a/script.it/state/state.ml b/script.it/state/state.ml index 4cf6992..e8cd87e 100755 --- a/script.it/state/state.ml +++ b/script.it/state/state.ml @@ -1,17 +1,8 @@ -open StdLabels -open Brr - type mode = | Edit | Selection of Selection.t | Out -(** Events *) -type render_event = - [ - `Rendering of Layer.Paths.printer - ] - type worker_event = Worker_messages.from_worker (* @@ -32,21 +23,13 @@ module type Handler = sig type t - val apply: t -> state -> state + val update: t -> state -> state end type t = E : 'a * (module Handler with type t = 'a) -> t -type events = - [ `Export - | render_event - | worker_event - | `Point of float * (float * float) - | `Width of float - | `Angle of float - | `Generic of t - ] +type events = t let post : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit @@ -89,120 +72,11 @@ let select_segment _ (_, selected, p0, p1) state dist = ; angle ; width } -(** Tick event - - Tick only occurs when drawing a new path - -*) -let tick (delay, point) state = - match state.mode with - | Edit -> - (* Add the point in the list *) - let current = insert_or_replace - state - point - delay - state.current in - { state with current } - | _ -> state - -let update_property worker state value f = function - | None -> state - | Some (Selection.Path outline) -> - (* Change width for the whole path *) - let outline = { outline with - Outline.path = Path.Fixed.map outline.Outline.path (fun p -> - f p value) - } in - post worker (`Back outline); - state - | Some (Point (outline, point)) -> - let path = Path.Fixed.map - outline.path - (fun pt -> - match Path.Point.id pt = Path.Point.id point with - | false -> pt - | true -> f pt value) - in - let outline = {outline with path} in - post worker (`Back outline); - state - -let width worker width state = - match state.mode with - - | Selection t -> - let state = { state with width } in - Selection.find_selection t state.paths - |> update_property worker state width Path.Point.set_width - | _ -> { state with width } - -let angle worker angle state = - match state.mode with - - | Selection t -> - let state = { state with angle } in - Selection.find_selection t state.paths - |> update_property worker state angle Path.Point.set_angle - | _ -> { state with angle } - let do_action - : Brr_webworkers.Worker.t -> (events, state) Application.t - = fun worker event state -> - match event, state.mode with - | `Generic (E (t, (module Handler))), _ -> - Handler.apply t state - | `Point (delay, point), _ -> - tick (delay, point) state - - - | `Export, _ -> - let my_host = Uri.host @@ Window.location @@ G.window in - if (Hashtbl.hash my_host) = Blog.Hash_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 -> - - Layer.Paths.to_svg - ~color:Blog.Nord.nord0 - (module Path.Fixed) - Outline.(path.path, path.back) - state.rendering - - )) in - let content = El.prop Elements.Prop.outerHTML svg in - Elements.Transfert.send - ~mime_type:(Jstr.v "image/svg+xml") - ~filename:(Jstr.v "out.svg") - content); - state - - | `Angle value , _ -> - angle worker value state - | `Width value, _ -> - width worker value state - - - | `Rendering rendering, _ -> - { state with rendering} - - | `Other t, _ -> - Console.(log [t]); - state - - | `Complete newPath, _ -> - let paths = List.map - state.paths - ~f:(fun line -> - match Outline.(newPath.id = line.id) with - | true -> newPath - | false -> line) in - { state with paths } + : (events, state) Application.t + = fun (E (t, (module Handler))) state -> + Handler.update t state let init = -- cgit v1.2.3