aboutsummaryrefslogtreecommitdiff
path: root/script.it/state
diff options
context:
space:
mode:
authorSébastien Dailly <sebastien@chimrod.com>2021-05-24 22:13:19 +0200
committerSébastien Dailly <sebastien@dailly.me>2022-02-07 16:22:43 +0100
commit38cf58ac5e1adb38a1b99ea7cdda19ef7b5e12bf (patch)
tree4f94bff126e1dff186e0dafe5fca86657233acb1 /script.it/state
parent1a53943340d068a1dbcef2f006e44905bab47bff (diff)
Refactor
Diffstat (limited to 'script.it/state')
-rwxr-xr-xscript.it/state/dune13
-rwxr-xr-xscript.it/state/selection.ml71
-rwxr-xr-xscript.it/state/selection.mli33
-rwxr-xr-xscript.it/state/state.ml357
4 files changed, 474 insertions, 0 deletions
diff --git a/script.it/state/dune b/script.it/state/dune
new file mode 100755
index 0000000..7d4ef3f
--- /dev/null
+++ b/script.it/state/dune
@@ -0,0 +1,13 @@
+(library
+ (name script_state)
+ (libraries
+ brr
+ brr.note
+ blog
+ application
+ worker_messages
+ outline
+ layer
+ path
+ )
+ )
diff --git a/script.it/state/selection.ml b/script.it/state/selection.ml
new file mode 100755
index 0000000..f5f135a
--- /dev/null
+++ b/script.it/state/selection.ml
@@ -0,0 +1,71 @@
+open StdLabels
+
+type 'a selection =
+ | Path of 'a
+ | Point of ('a * Path.Point.t)
+
+type t = int selection
+
+let find_selection
+ : int selection -> Outline.t list -> Outline.t selection option
+ = fun selection paths ->
+ match selection with
+ | Path id -> Option.map (fun p -> Path p) (Outline.find paths id)
+ | Point (id, pt) -> Option.map (fun p -> Point (p, pt)) (Outline.find paths id)
+
+let threshold = 20.
+
+let get_from_paths
+ : (float * float) -> Outline.t list -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option
+ = fun position outlines ->
+ let point = Gg.V2.of_tuple position in
+ (* If the user click on a curve, select it *)
+ List.fold_left outlines
+ ~init:(threshold, None)
+ ~f:(fun (dist, selection) outline ->
+ match Path.Fixed.distance point outline.Outline.path with
+ | Some { closest_point ; distance; p0; p1 ; ratio} when distance < dist ->
+ ratio, Some (closest_point, outline, p0, p1)
+ | _ -> dist, selection
+ )
+
+let select_path
+ : Outline.t -> t
+ = fun outline -> Path outline.Outline.id
+
+let select_point
+ : Outline.t -> Gg.v2 -> t
+ = fun outline v2_point ->
+
+ let point' = ref None in
+ let dist = ref threshold in
+
+ Path.Fixed.iter
+ outline.Outline.path
+ ~f:(fun p ->
+ let open Gg.V2 in
+ let new_dist = norm ((Path.Point.get_coord p) - v2_point) in
+ match (new_dist < !dist) with
+ | false -> ()
+ | true ->
+ dist:= new_dist;
+ point' := Some p
+ );
+
+ match !point' with
+ | Some point ->
+ Point (outline.Outline.id, point)
+ | None ->
+ Path (outline.Outline.id)
+
+ (*
+ (* If the point does not exists, find the exact point on the curve *)
+ let coord = Gg.V2.to_tuple v2_point in
+ begin match get_from_paths coord [path] with
+ | _, None -> Path (Path.Fixed.id path)
+ | f, Some (point, path, p0, p1) ->
+
+ let point' = Path.Point.mix f point p0 p1 in
+ Point (Path.Fixed.id path, point')
+ end
+ *)
diff --git a/script.it/state/selection.mli b/script.it/state/selection.mli
new file mode 100755
index 0000000..9792a2d
--- /dev/null
+++ b/script.it/state/selection.mli
@@ -0,0 +1,33 @@
+type 'a selection =
+ | Path of 'a
+ | Point of ('a * Path.Point.t)
+
+type t = int selection
+
+val threshold : float
+
+(** Return the closest path from the list to a given point.
+
+ The path is returned with all thoses informations :
+ - The point in the path
+ - The path itself
+ - The starting point from the path
+ - The end point in the path
+
+*)
+val get_from_paths
+ : (float * float) -> Outline.t list -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option
+
+val select_path
+ : Outline.t -> t
+
+(** Check for selecting a point on the given outline.
+
+ If no point is available, select the path.
+
+*)
+val select_point
+ : Outline.t -> Gg.v2 -> t
+
+val find_selection
+ : int selection -> Outline.t list -> Outline.t selection option
diff --git a/script.it/state/state.ml b/script.it/state/state.ml
new file mode 100755
index 0000000..d7cb13e
--- /dev/null
+++ b/script.it/state/state.ml
@@ -0,0 +1,357 @@
+open StdLabels
+open Brr
+
+type mode =
+ | Edit
+ | Selection of Selection.t
+ | Out
+
+(** Events *)
+type canva_events =
+ [ `MouseDown of float * float
+ ]
+
+type button_events =
+ [ `Delete
+ | `Export
+ ]
+type render_event =
+ [
+ `Rendering of Layer.Paths.printer
+ ]
+
+type worker_event = Worker_messages.from_worker
+
+(*
+ The state cant hold functionnal values, and thus cannot be used to store
+ elements like timer
+ *)
+type state =
+ { mode : mode
+ ; paths : Outline.t list
+ ; current : Path.Path_Builder.t
+ ; width : float
+ ; angle : float
+ ; rendering : Layer.Paths.printer
+ ; mouse_down_position : Gg.v2
+ }
+
+module type Handler = sig
+
+ type t
+
+ val apply: t -> state -> state
+
+end
+
+type t = E : 'a * (module Handler with type t = 'a) -> t
+
+type events =
+ [ canva_events
+ | button_events
+ | render_event
+ | worker_event
+ | `Point of float * (float * float)
+ | `Width of float
+ | `Angle of float
+ | `Generic of t
+ ]
+
+let post
+ : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit
+ = Brr_webworkers.Worker.post
+
+let insert_or_replace state ((x, y) as p) stamp path =
+ let width = state.width
+ and angle = state.angle in
+ let point = Path.Point.create ~x ~y ~angle ~width ~stamp 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
+ )
+
+(** Select the given segment, and modify angle and width accordingly *)
+let select_segment _ (_, selected, p0, p1) state dist =
+
+ let point' = Path.Point.mix dist (Path.Point.get_coord p0) p0 p1 in
+
+ let angle = (Float.round @@ 10. *. Path.Point.get_angle point') /. 10.
+ and width = (Float.round @@ 10. *. Path.Point.get_width point') /. 10. in
+
+ let id = Selection.select_path selected in
+ { state with
+ mode = (Selection id)
+ ; 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
+
+*)
+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 }
+
+
+(** 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 ->
+ 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
+ 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 }
+
+
+ (* Some non possible cases *)
+ | `MouseDown _, Edit
+ -> state
+
+let init =
+ { paths = []
+ ; current = Path.Path_Builder.empty
+ ; mode = Out
+ ; angle = 30.
+ ; width = 10.
+ ; rendering = `Fill
+ ; mouse_down_position = Gg.V2.ox
+ }