diff options
| -rwxr-xr-x | script.it/outline.ml | 9 | ||||
| -rwxr-xr-x | script.it/script.ml | 120 | ||||
| -rwxr-xr-x | script.it/selection.ml | 15 | ||||
| -rwxr-xr-x | script.it/selection.mli | 16 | ||||
| -rwxr-xr-x | script.it/state.ml | 256 | ||||
| -rwxr-xr-x | script.it/worker.ml | 54 | ||||
| -rwxr-xr-x | script.it/worker_messages/worker_messages.ml | 7 |
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 = [ |