summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xscript.it/script.ml61
-rwxr-xr-xscript.it/script_event/delete.ml31
-rwxr-xr-xscript.it/script_event/mouse_down.ml84
-rwxr-xr-xscript.it/script_event/out.ml25
-rwxr-xr-xscript.it/state/state.ml147
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