aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xscript.it/outline.ml9
-rwxr-xr-xscript.it/script.ml120
-rwxr-xr-xscript.it/selection.ml15
-rwxr-xr-xscript.it/selection.mli16
-rwxr-xr-xscript.it/state.ml256
-rwxr-xr-xscript.it/worker.ml54
-rwxr-xr-xscript.it/worker_messages/worker_messages.ml7
7 files changed, 277 insertions, 200 deletions
diff --git a/script.it/outline.ml b/script.it/outline.ml
index 0dbecd0..1df7588 100755
--- a/script.it/outline.ml
+++ b/script.it/outline.ml
@@ -1,3 +1,5 @@
+open StdLabels
+
let internal_path_id = ref 0
type t =
@@ -10,3 +12,10 @@ let get_id () =
let id = !internal_path_id in
incr internal_path_id;
id
+
+let find
+ : t list -> int -> t option
+ = fun ts id ->
+ List.find_opt
+ ts
+ ~f:(fun p -> p.id = id)
diff --git a/script.it/script.ml b/script.it/script.ml
index 3859cc9..73e5ac3 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -3,7 +3,9 @@ open Note
open Brr
open Brr_note
-
+let post
+ : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit
+ = Brr_webworkers.Worker.post
(** Create the element in the page, and the event handler *)
let canva
@@ -47,7 +49,7 @@ let canva
let click =
Brr_note_kit.Mouse.left_down mouse
- |> E.map (fun c -> `Click c) in
+ |> E.map (fun c -> `MouseDown c) in
let up =
Brr_note_kit.Mouse.left_up mouse
@@ -190,8 +192,21 @@ let backgroundColor = Blog.Nord.nord0
let white = Jstr.v "#eceff4"
let green = Jstr.v "#a3be8c"
+let draw_point point context =
+ let module Cd2d = Brr_canvas.C2d in
+ let x, y = Gg.V2.to_tuple @@ Path.Point.get_coord point in
+ Cd2d.stroke_rect
+ ~x:(x -. 5.)
+ ~y:(y -. 5.)
+ ~w:10.
+ ~h:10.
+ context
+
(** Redraw the canva on update *)
let on_change canva mouse_position timer state =
+ let pos = S.rough_value mouse_position in
+ let pos_v2 = Option.map Gg.V2.of_tuple pos in
+
let module Cd2d = Brr_canvas.C2d in
let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in
@@ -213,7 +228,6 @@ let on_change canva mouse_position timer state =
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 ->
@@ -252,52 +266,63 @@ let on_change canva mouse_position timer state =
Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context state.rendering
);
+ (* Draw the selected path, and operate the modifications directly as a preview *)
let () = match state.mode with
- | Selection (Path id) ->
- Cd2d.set_stroke_style context (Cd2d.color white);
- List.iter
- state.paths
- ~f:(fun path ->
- if id = path.Outline.id then
- let p = path.Outline.path in
- Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context `Line
- )
- | Selection (Point (id, point)) ->
- (* As before, mark the selected path *)
+ | Selection t ->
Cd2d.set_stroke_style context (Cd2d.color white);
-
- List.iter
- state.paths
- ~f:(fun outline ->
- if id = outline.Outline.id then
- let path = begin match pos with
- | Some pos ->
-
- let pos_v2 = Gg.V2.of_tuple pos in
- if Elements.Timer.delay timer < 0.3 then
- outline.Outline.path
- else
- let point' = Path.Point.copy point pos_v2 in
- begin match Path.Fixed.replace_point outline.Outline.path point' with
- | None -> outline.Outline.path
- | Some p -> p
- end
- | None -> outline.Outline.path end in
- Layer.Paths.to_canva (module Path.Fixed) (path, outline.Outline.back) context `Line
- );
-
- (* Now draw the selected point *)
- let x, y = Gg.V2.to_tuple @@ Path.Point.get_coord point in
- Cd2d.stroke_rect
- ~x:(x -. 5.)
- ~y:(y -. 5.)
- ~w:10.
- ~h:10.
- context;
+ begin match pos_v2, Selection.find_selection t state.paths with
+ (* The selected element does not exist, just do nothing *)
+ | _, None -> ()
+
+ (* There is no click on the canva, print the line *)
+ | None, Some (Path outline) ->
+ Layer.Paths.to_canva
+ (module Path.Fixed)
+ (outline.path, outline.back)
+ context
+ `Line;
+
+ (* The user is modifiying the path *)
+ | Some pos_v2, Some (Path outline) ->
+ (* Translate the path *)
+ let delta = Gg.V2.(pos_v2 - state.State.mouse_down_position) in
+ let path = Path.Fixed.map
+ outline.Outline.path
+ (fun pt -> Path.Point.get_coord pt
+ |> Gg.V2.add delta
+ |> Path.Point.copy pt) in
+ Layer.Paths.to_canva
+ (module Path.Fixed)
+ (path, path)
+ context
+ `Line;
+
+ (* The user is modifiying the point *)
+ | Some pos_v2, Some (Point (outline, point)) when Elements.Timer.delay timer > 0.3 ->
+ let point' = Path.Point.copy point pos_v2 in
+ let path = begin match Path.Fixed.replace_point outline.Outline.path point' with
+ | None -> outline.Outline.path
+ | Some p -> p
+ end in
+
+ Layer.Paths.to_canva
+ (module Path.Fixed)
+ (path, path)
+ context
+ `Line;
+ draw_point point context
+
+ | _, Some (Point (outline, point)) ->
+ Layer.Paths.to_canva
+ (module Path.Fixed)
+ (outline.path, outline.back)
+ context
+ `Line;
+ draw_point point context
+
+ end
| _ -> ()
in
-
-
()
let spawn_worker () =
@@ -387,12 +412,11 @@ let page_main id =
let _ =
E.select
[ E.map (fun _ -> ()) (S.changes mouse_position)
- ; E.map (fun _ -> ()) (S.changes parameters.angle)
- ; E.map (fun _ -> ()) (S.changes parameters.width)
; E.map (fun _ -> ()) parameters.rendering
; E.map (fun _ -> ()) worker_event
; parameters.delete ]
- |> fun ev -> E.log ev (fun _ -> on_change canva mouse_position timer (S.value state) )
+ |> fun ev -> E.log ev (fun _ ->
+ on_change canva mouse_position timer (S.value state) )
|> Option.iter Logr.hold in
diff --git a/script.it/selection.ml b/script.it/selection.ml
index d00f026..f5f135a 100755
--- a/script.it/selection.ml
+++ b/script.it/selection.ml
@@ -1,8 +1,17 @@
open StdLabels
-type t =
- | Path of int
- | Point of (int * Path.Point.t)
+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.
diff --git a/script.it/selection.mli b/script.it/selection.mli
index 984eae6..9792a2d 100755
--- a/script.it/selection.mli
+++ b/script.it/selection.mli
@@ -1,6 +1,8 @@
-type t =
- | Path of int
- | Point of (int * Path.Point.t)
+type 'a selection =
+ | Path of 'a
+ | Point of ('a * Path.Point.t)
+
+type t = int selection
val threshold : float
@@ -19,5 +21,13 @@ val get_from_paths
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.ml b/script.it/state.ml
index fd35554..f5698ef 100755
--- a/script.it/state.ml
+++ b/script.it/state.ml
@@ -8,7 +8,7 @@ type mode =
(** Events *)
type canva_events =
- [ `Click of float * float
+ [ `MouseDown of float * float
| `Out of float * float
]
@@ -44,6 +44,7 @@ type state =
; width : float
; angle : float
; rendering : Layer.Paths.printer
+ ; mouse_down_position : Gg.v2
}
let post
@@ -73,37 +74,6 @@ let insert_or_replace state ((x, y) as p) stamp path =
path
)
-(** Update the path in the selection with the given function applied to
- every point *)
-let update_path_selection
- : int -> Outline.t list -> (Path.Point.t -> Path.Point.t) -> Outline.t list
- = fun id outlines f ->
- List.map outlines
- ~f:(fun outline ->
- let id' = outline.Outline.id in
- match id = id' with
- | false -> outline
- | true -> {outline with path = Path.Fixed.map outline.path f}
- )
-
-let update_point_selection state path_id point f =
- let paths = List.map state.paths
- ~f:(fun p ->
- match p.Outline.id = path_id with
- | false -> p
- | true ->
- { p with path = Path.Fixed.map
- p.path
- (fun p ->
- if (Path.Point.id p = Path.Point.id point) then
- f p
- else
- p
- ) }
- ) in
- { state with paths }
-
-
(** Select the given segment, and modify angle and width accordingly *)
let select_segment _ (_, selected, p0, p1) state dist =
@@ -118,10 +88,7 @@ let select_segment _ (_, selected, p0, p1) state dist =
; angle
; width }
-(** Handle the deletion event.
-
- Deletion only apply to a selection
-*)
+(** Delete the selected element *)
let delete state worker =
match state.mode with
| Selection (Path id) ->
@@ -139,9 +106,7 @@ let delete state worker =
let id' = p.Outline.id in
match id' = id with
| false -> ()
- | true ->
- (* Send the job to the worker *)
- post worker (`DeletePoint (point, p))
+ | true -> post worker (`DeletePoint (point, p))
);
{ state with mode = Selection (Path id) }
| _ ->
@@ -164,49 +129,70 @@ let tick (delay, point) state =
{ state with current }
| _ -> state
-let angle worker angle state =
- match state.mode with
- (* Change angle for the whole path *)
- | Selection (Path s) ->
- let state = { state with angle } in
- let paths = update_path_selection s state.paths (fun p -> Path.Point.set_angle p angle) in
- (* Update the event to the worker *)
- let outline = List.find paths
- ~f:(fun o -> o.Outline.id = s) in
+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 with paths }
- (* Change angle localy *)
- | Selection (Point (s, point)) ->
- let state = update_point_selection state s point
- (fun p -> Path.Point.set_angle p angle) in
- (* Update the event to the worker *)
- let outline = List.find state.paths
- ~f:(fun o -> o.Outline.id = s) in
+ 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 with angle }
- | _ ->
- { state with angle}
+ state
let width worker width state =
match state.mode with
- | Selection (Path s) ->
+
+ | Selection t ->
let state = { state with width } in
- let paths = update_path_selection s state.paths (fun p -> Path.Point.set_width p width) in
- (* Update the event to the worker *)
- let outline = List.find paths
- ~f:(fun o -> o.Outline.id = s) in
- post worker (`Back outline);
- {state with paths }
- | Selection (Point (s, point)) ->
- let state = update_point_selection state s point
- (fun p -> Path.Point.set_width p width) in
- (* Update the event to the worker *)
- let outline = List.find state.paths
- ~f:(fun o -> o.Outline.id = s) in
- post worker (`Back outline);
- { state with width }
- | _ ->
- { state with width }
+ Selection.find_selection t state.paths
+ |> update_property worker state width Path.Point.set_width
+ | _ -> state
+
+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
+
+
+(** 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 -> state
@@ -216,7 +202,7 @@ let do_action
tick (delay, point) state
(* Click anywhere while in Out mode, we switch in edition *)
- | `Click ((x, y) as p), Out ->
+ | `MouseDown ((x, y) as p), Out ->
Elements.Timer.start timer 0.3;
let width = state.width
@@ -238,34 +224,59 @@ let do_action
let current = Path.Path_Builder.add_point
point
state.current in
- { state with current; mode = Edit }
+ { 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*)
- | `Click position, (Selection (Path id))
- | `Click position, (Selection (Point (id, _))) ->
- begin match Selection.get_from_paths position state.paths with
- | _, None ->
- { state with
- mode = Out }
- | dist, Some selection ->
- let _, outline, _, _ = selection in
- if outline.Outline.id != id then
- select_segment position selection state 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 }
- | Point (_, pt) ->
- (* In order to handle the point move, start the timer *)
+ | `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 selection
- ; angle = Path.Point.get_angle pt
- ; width = Path.Point.get_width pt
- }
+ {state with
+ mode = Selection other
+ ; mouse_down_position = Gg.V2.of_tuple position }
+ end
end
| `Out point, Edit ->
@@ -287,10 +298,10 @@ let do_action
(fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
let last =
- { Outline.path = path
- ; Outline.back = back
- ; Outline.id = Outline.get_id ()
- }
+ Outline.{ path
+ ; back
+ ; id = Outline.get_id ()
+ }
in
(* Send to the worker for a full review *)
@@ -318,26 +329,12 @@ let do_action
end
end
- | `Out mouse_coord, Selection (Point (id, point)) ->
- let mouse_v2 = Gg.V2.of_tuple mouse_coord in
- if Elements.Timer.delay timer < 0.3 then
- state
- else
- let point' = Path.Point.copy point mouse_v2 in
- List.iter state.paths
- ~f:(fun outline ->
- let id' = outline.Outline.id in
- match id = id' with
- | false -> ()
- | true ->
- Option.iter
- (fun p ->
-
- let outline = {outline with path = p} in
- post worker (`Complete outline))
- (Path.Fixed.replace_point outline.Outline.path point')
- );
- { state with mode = Selection (Point (id, point')) }
+ | `Out _, mode when Elements.Timer.delay timer < 0.3 ->
+ click state mode
+
+ | `Out mouse_coord, mode ->
+ longClick mouse_coord state worker mode
+
| `Delete, _ ->
delete state worker
@@ -355,7 +352,7 @@ let do_action
Layer.Paths.to_svg
~color:Blog.Nord.nord0
(module Path.Fixed)
- (path.Outline.path, path.Outline.back)
+ Outline.(path.path, path.back)
state.rendering
)) in
@@ -393,16 +390,14 @@ let do_action
let paths = List.map
state.paths
~f:(fun line ->
- match newPath.Outline.id = line.Outline.id with
+ match Outline.(newPath.id = line.id) with
| true -> newPath
| false -> line) in
{ state with paths }
(* Some non possible cases *)
- | `Out _, Out
- | `Out _, Selection _
- | `Click _, Edit
+ | `MouseDown _, Edit
-> state
let init =
@@ -412,4 +407,5 @@ let init =
; angle = 30.
; width = 10.
; rendering = `Fill
+ ; mouse_down_position = Gg.V2.ox
}
diff --git a/script.it/worker.ml b/script.it/worker.ml
index 51fe49c..62104ec 100755
--- a/script.it/worker.ml
+++ b/script.it/worker.ml
@@ -7,28 +7,28 @@ let post_message
: Worker_messages.from_worker -> unit
= Worker.post_message
-let execute (command: [> Worker_messages.to_worker]) =
+
+let rebuild outline =
+ let path = outline.Outline.path in
+
+ let=? path = Path.Fixed.rebuild path in
+ let back = Path.Fixed.map
+ path
+ (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
+ let=? back = Path.Fixed.rebuild back in
+ post_message (`Complete {outline with path; back})
+
+let execute (command: Worker_messages.to_worker) =
match command with
(* Full rebuild, evaluate the whole path *)
| `Complete outline ->
- let path = outline.Outline.path in
-
- let=? path = Path.Fixed.rebuild path in
- let back = Path.Fixed.map
- path
- (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
- let=? back = Path.Fixed.rebuild back in
- post_message (`Complete {outline with path; back})
+ rebuild outline
(* Remove the point from the main line, and reevaluate the whole path *)
| `DeletePoint (point, outline) ->
let=? path = Path.Fixed.remove_point outline.Outline.path point in
- let back = Path.Fixed.map
- path
- (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
- let=? back = Path.Fixed.rebuild back in
- post_message (`Complete {outline with path; back})
+ rebuild { outline with path }
(* Only evaluate the interior *)
| `Back outline ->
@@ -38,8 +38,30 @@ let execute (command: [> Worker_messages.to_worker]) =
let=? back = Path.Fixed.rebuild back in
post_message (`Complete {outline with back})
- | _ ->
- post_message (`Other (Js.string "Unknown message received"))
+ | `TranslatePath (outline, delta) ->
+ let path = Path.Fixed.map
+ outline.path
+ (fun pt -> Path.Point.get_coord pt
+ |> Gg.V2.add delta
+ |> Path.Point.copy pt)
+ and back = Path.Fixed.map
+ outline.back
+ (fun pt -> Path.Point.get_coord pt
+ |> Gg.V2.add delta
+ |> Path.Point.copy pt) in
+ post_message (`Complete {outline with path; back})
+
+ | `TranslatePoint (point, outline) ->
+ (* I do not use the function Path.Fixed.replace_point here, I just
+ replace the point position and run a full rebuild *)
+ let path = Path.Fixed.map outline.path
+ (fun pt ->
+ match Path.Point.id pt = Path.Point.id point with
+ | true -> point
+ | false -> pt
+ ) in
+
+ rebuild { outline with path }
let () =
Worker.set_onmessage execute
diff --git a/script.it/worker_messages/worker_messages.ml b/script.it/worker_messages/worker_messages.ml
index b33bb23..7efd3d3 100755
--- a/script.it/worker_messages/worker_messages.ml
+++ b/script.it/worker_messages/worker_messages.ml
@@ -3,7 +3,14 @@ open Js_of_ocaml
type to_worker = [
| `Complete of Outline.t
| `DeletePoint of (Path.Point.t * Outline.t)
+
+ (* Update the interior path *)
| `Back of Outline.t
+
+ (* Translate a path *)
+ | `TranslatePath of (Outline.t * Gg.v2)
+
+ | `TranslatePoint of (Path.Point.t * Outline.t)
]
type from_worker = [