diff options
| -rwxr-xr-x | script.it/script.ml | 61 | ||||
| -rwxr-xr-x | script.it/script_event/delete.ml | 31 | ||||
| -rwxr-xr-x | script.it/script_event/mouse_down.ml | 84 | ||||
| -rwxr-xr-x | script.it/script_event/out.ml | 25 | ||||
| -rwxr-xr-x | script.it/state/state.ml | 147 |
5 files changed, 173 insertions, 175 deletions
diff --git a/script.it/script.ml b/script.it/script.ml index 200d118..a21afa9 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -332,10 +332,8 @@ let on_change canva mouse_position timer state = () let spawn_worker () = - try - Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js")) - with - | Jv.Error e -> Error e + try Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js")) + with Jv.Error e -> Error e let page_main id = @@ -351,17 +349,6 @@ let page_main id = set_sidebar el State.init end in - - let delete_event = E.map (fun () -> `Delete) parameters.delete - and export_event = E.map (fun () -> `Export) parameters.export - and angle_event = S.changes parameters.angle - |> E.map (fun value -> `Angle value) - and width_event = S.changes parameters.width - |> 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 -> @@ -369,7 +356,22 @@ let page_main id = 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 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) + ))) + parameters.delete + + and export_event = E.map (fun () -> `Export) parameters.export + and angle_event = S.changes parameters.angle + |> E.map (fun value -> `Angle value) + and width_event = S.changes parameters.width + |> E.map (fun value -> `Width value) + in let worker_event, worker_send = E.create () in let my_host = Uri.host @@ Window.location @@ G.window in @@ -389,24 +391,27 @@ let page_main id = - 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 -> `MouseDown c - | `Out c -> - + | `MouseDown c -> + let module MouseDown = Script_event.Mouse_down in `Generic ( State.E - ( Script_event.Out.{ point = c - ; worker - ; timer - } - , (module Script_event.Out: State.Handler with type t = Script_event.Out.t) - ) + ( 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))) ) canva_events in @@ -419,7 +424,7 @@ let page_main id = successives events to the initial state *) let state = Application.run - (State.do_action worker timer) + (State.do_action worker) State.init (E.select [ worker_event diff --git a/script.it/script_event/delete.ml b/script.it/script_event/delete.ml new file mode 100755 index 0000000..edd5d23 --- /dev/null +++ b/script.it/script_event/delete.ml @@ -0,0 +1,31 @@ +(** Delete the selected element *) + +open StdLabels +module State = Script_state.State +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 = + match state.State.mode with + | Selection (Path id) -> + let paths = List.filter + state.State.paths + ~f:(fun p -> + p.Outline.id != id + ) in + { state with paths ; mode = Out} + + | Selection (Point (id, point)) -> + List.iter + state.State.paths + ~f:(fun p -> + let id' = p.Outline.id in + match id' = id with + | false -> () + | true -> State.post worker (`DeletePoint (point, p)) + ); + { state with mode = Selection (Path id) } + + | _ -> state diff --git a/script.it/script_event/mouse_down.ml b/script.it/script_event/mouse_down.ml new file mode 100755 index 0000000..04ea2fd --- /dev/null +++ b/script.it/script_event/mouse_down.ml @@ -0,0 +1,84 @@ +module State = Script_state.State +module Selection = Script_state.Selection + +type t = { position : float * float + ; timer : Elements.Timer.t } + +let apply { position; timer } state = + match state.State.mode with + + | Out -> + let x, y = position in + Elements.Timer.start timer 0.3; + + let width = state.width + and angle = state.angle in + + let stamp = 0. in + let point = + match Selection.get_from_paths position state.paths with + | _, None -> + (* Start a new path with the point clicked *) + Path.Point.create ~x ~y ~angle ~width ~stamp + | _, 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 ~stamp + in + + let current = Path.Path_Builder.add_point + point + state.current in + { state with + current + ; mode = Edit + ; mouse_down_position = Gg.V2.of_tuple (x, y)} + + | (Selection (Path id)) + | (Selection (Point (id, _))) -> + + let get_any () = + begin match Selection.get_from_paths position state.paths with + | _, None -> + { state with + mode = Out + ; mouse_down_position = Gg.V2.of_tuple position } + | dist, Some selection -> + let _, outline, _, _ = selection in + if outline.Outline.id != id then ( + let mouse_down_position = Gg.V2.of_tuple position in + State.select_segment position selection { state with mouse_down_position } dist + ) else + (* On the same segment, check for a point *) + let selection = Selection.select_point outline (Gg.V2.of_tuple position) in + match selection with + | Path _ -> + { state with + mode = Selection selection + ; mouse_down_position = Gg.V2.of_tuple position } + | Point (_, pt) -> + (* In order to handle the point move, start the timer *) + Elements.Timer.start timer 0.3; + { state with + mode = Selection selection + ; angle = Path.Point.get_angle pt + ; width = Path.Point.get_width pt + ; mouse_down_position = Gg.V2.of_tuple position } + end + in + (* First, check for a point in the selected path. If any of them in + found, check anything to select in all the elements *) + begin match Outline.find state.paths id with + | None -> get_any () + | Some outline -> + begin match Selection.select_point outline (Gg.V2.of_tuple position) with + | Path _ -> get_any () + | other -> + Elements.Timer.start timer 0.3; + {state with + mode = Selection other + ; mouse_down_position = Gg.V2.of_tuple position } + end + end + | Edit -> state diff --git a/script.it/script_event/out.ml b/script.it/script_event/out.ml index 45f05d3..b8b8599 100755 --- a/script.it/script_event/out.ml +++ b/script.it/script_event/out.ml @@ -8,6 +8,25 @@ type t = { point : float * float ; 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 @@ -61,9 +80,9 @@ let apply {point; timer ; worker} state = end end - | mode when Elements.Timer.delay timer < 0.3 -> - State.click state mode + | _ when Elements.Timer.delay timer < 0.3 -> + state | _ -> - State.longClick point state worker state.mode + longClick point state worker state.mode diff --git a/script.it/state/state.ml b/script.it/state/state.ml index d7cb13e..4cf6992 100755 --- a/script.it/state/state.ml +++ b/script.it/state/state.ml @@ -7,14 +7,6 @@ type mode = | Out (** Events *) -type canva_events = - [ `MouseDown of float * float - ] - -type button_events = - [ `Delete - | `Export - ] type render_event = [ `Rendering of Layer.Paths.printer @@ -47,8 +39,7 @@ end type t = E : 'a * (module Handler with type t = 'a) -> t type events = - [ canva_events - | button_events + [ `Export | render_event | worker_event | `Point of float * (float * float) @@ -98,30 +89,6 @@ let select_segment _ (_, selected, p0, p1) state dist = ; angle ; width } -(** Delete the selected element *) -let delete state worker = - match state.mode with - | Selection (Path id) -> - let paths = List.filter - state.paths - ~f:(fun p -> - p.Outline.id != id - ) in - { state with paths ; mode = Out} - - | Selection (Point (id, point)) -> - List.iter - state.paths - ~f:(fun p -> - let id' = p.Outline.id in - match id' = id with - | false -> () - | true -> post worker (`DeletePoint (point, p)) - ); - { state with mode = Selection (Path id) } - | _ -> - state - (** Tick event Tick only occurs when drawing a new path @@ -180,119 +147,15 @@ let angle worker angle state = | _ -> { state with angle } -(** Short click on any element, just do nothing (each element is on MouseDown - event) *) -let click state = function - | _ -> state - -(** Long click, move the selected element if any *) -let longClick mouse_coord state worker = function - | Selection t -> - let mouse_v2 = Gg.V2.of_tuple mouse_coord in - begin match Selection.find_selection t state.paths with - | None -> state - | Some (Point (path, point)) -> - let point' = Path.Point.copy point mouse_v2 in - 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.mouse_down_position) in - post worker (`TranslatePath (path, delta)); - state - end - (* TODO Long click in out mode should translate the slate *) - | _ -> state - let do_action - : Brr_webworkers.Worker.t -> Elements.Timer.t -> (events, state) Application.t - = fun worker timer event state -> + : 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 - (* Click anywhere while in Out mode, we switch in edition *) - | `MouseDown ((x, y) as p), Out -> - Elements.Timer.start timer 0.3; - - let width = state.width - and angle = state.angle in - - let stamp = 0. in - let point = - match Selection.get_from_paths p state.paths with - | _, None -> - (* Start a new path with the point clicked *) - Path.Point.create ~x ~y ~angle ~width ~stamp - | _, 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 ~stamp - in - - let current = Path.Path_Builder.add_point - point - state.current in - { state with - current - ; mode = Edit - ; mouse_down_position = Gg.V2.of_tuple (x, y)} - - (* Click anywhere while in selection mode, we either select another path, - or switch to Out mode*) - | `MouseDown position, (Selection (Path id)) - | `MouseDown position, (Selection (Point (id, _))) -> - - let get_any () = - begin match Selection.get_from_paths position state.paths with - | _, None -> - { state with - mode = Out - ; mouse_down_position = Gg.V2.of_tuple position } - | dist, Some selection -> - let _, outline, _, _ = selection in - if outline.Outline.id != id then ( - let mouse_down_position = Gg.V2.of_tuple position in - select_segment position selection { state with mouse_down_position } dist - ) else - (* On the same segment, check for a point *) - let selection = Selection.select_point outline (Gg.V2.of_tuple position) in - match selection with - | Path _ -> - { state with - mode = Selection selection - ; mouse_down_position = Gg.V2.of_tuple position } - | Point (_, pt) -> - (* In order to handle the point move, start the timer *) - Elements.Timer.start timer 0.3; - { state with - mode = Selection selection - ; angle = Path.Point.get_angle pt - ; width = Path.Point.get_width pt - ; mouse_down_position = Gg.V2.of_tuple position } - end - in - - (* First, check for a point in the selected path. If any of them in - found, check anything to select in all the elements *) - begin match Outline.find state.paths id with - | None -> get_any () - | Some outline -> - begin match Selection.select_point outline (Gg.V2.of_tuple position) with - | Path _ -> get_any () - | other -> - Elements.Timer.start timer 0.3; - {state with - mode = Selection other - ; mouse_down_position = Gg.V2.of_tuple position } - end - end - - | `Delete, _ -> - delete state worker | `Export, _ -> let my_host = Uri.host @@ Window.location @@ G.window in @@ -342,10 +205,6 @@ let do_action { state with paths } - (* Some non possible cases *) - | `MouseDown _, Edit - -> state - let init = { paths = [] ; current = Path.Path_Builder.empty |