From 329b774e315b41bc0d5b7daf8737222768c8d1f3 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Sat, 9 Jan 2021 11:35:40 +0100 Subject: Formalized exchanges between worker and app --- layer/ductusPrinter.ml | 4 ++-- layer/fillPrinter.ml | 4 ++-- layer/linePrinter.ml | 4 ++-- path/builder.ml | 35 ++++++++++++++-------------- path/fixed.ml | 24 +++++++++---------- path/repr.ml | 2 +- script.it/dune | 2 ++ script.it/script.ml | 21 ++--------------- script.it/state.ml | 14 ++++++----- script.it/worker.ml | 13 +++++------ script.it/worker_messages/dune | 6 +++++ script.it/worker_messages/worker_messages.ml | 11 +++++++++ 12 files changed, 72 insertions(+), 68 deletions(-) create mode 100755 script.it/worker_messages/dune create mode 100755 script.it/worker_messages/worker_messages.ml diff --git a/layer/ductusPrinter.ml b/layer/ductusPrinter.ml index 8383a9c..8f796b4 100755 --- a/layer/ductusPrinter.ml +++ b/layer/ductusPrinter.ml @@ -30,8 +30,8 @@ module Make(Repr: Repr.PRINTER) = struct } let quadratic_to - : Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr - = fun p0 ctrl0 ctrl1 p1 { path } -> + : (t * Gg.v2 * Gg.v2 * t) -> repr -> repr + = fun (p0, ctrl0, ctrl1, p1) { path } -> let path = ref path in diff --git a/layer/fillPrinter.ml b/layer/fillPrinter.ml index 3093ada..19f0ac4 100755 --- a/layer/fillPrinter.ml +++ b/layer/fillPrinter.ml @@ -79,8 +79,8 @@ module Make(Repr: Repr.PRINTER) = struct { t with path} let quadratic_to - : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr - = fun p0 ctrl0 ctrl1 p1 t -> + : (t * Gg.v2 * Gg.v2 * t) -> repr -> repr + = fun (p0, ctrl0, ctrl1, p1) t -> let ctrl0' = Point.copy p1 ctrl0 and ctrl1' = Point.copy p1 ctrl1 in diff --git a/layer/linePrinter.ml b/layer/linePrinter.ml index 38dae5c..45ee801 100755 --- a/layer/linePrinter.ml +++ b/layer/linePrinter.ml @@ -45,8 +45,8 @@ module Make(Repr: Repr.PRINTER) = struct } let quadratic_to - : Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr - = fun p0 ctrl0 ctrl1 p1 { path } -> + : (t * Gg.v2 * Gg.v2 * t) -> repr -> repr + = fun (p0, ctrl0, ctrl1, p1) { path } -> let path = Repr.move_to (Path.Point.get_coord p0) path |> Repr.quadratic_to ctrl0 ctrl1 (Path.Point.get_coord p1) diff --git a/path/builder.ml b/path/builder.ml index fd772ea..7901e78 100755 --- a/path/builder.ml +++ b/path/builder.ml @@ -133,15 +133,15 @@ module Make(Point:P) = struct Repr.start p0 path |> Repr.quadratic_to - p0' - b0.Shapes.Bezier.ctrl0 - b0.Shapes.Bezier.ctrl1 - p1' + ( p0' + , b0.Shapes.Bezier.ctrl0 + , b0.Shapes.Bezier.ctrl1 + , p1' ) |> Repr.quadratic_to - p1' - b1.Shapes.Bezier.ctrl0 - b1.Shapes.Bezier.ctrl1 - p2' + ( p1' + , b1.Shapes.Bezier.ctrl0 + , b1.Shapes.Bezier.ctrl1 + , p2' ) | (p0::_ as points) -> let (let*) v f = @@ -179,10 +179,10 @@ module Make(Point:P) = struct let bezier = Array.get beziers (i - 1) in path := Repr.quadratic_to - !point - bezier.Shapes.Bezier.ctrl0 - bezier.Shapes.Bezier.ctrl1 - pt + ( !point + , bezier.Shapes.Bezier.ctrl0 + , bezier.Shapes.Bezier.ctrl1 + , pt ) (!path); point := pt; ) @@ -195,11 +195,12 @@ module Make(Point:P) = struct Repr.stop @@ List.fold_left beziers ~init:path ~f:(fun path bezier -> - let p0' = bezier.p0 - and ctrl0 = bezier.ctrl0 - and ctrl1 = bezier.ctrl1 - and p1' = bezier.p1 in - Repr.quadratic_to p0' ctrl0 ctrl1 p1' path + Repr.quadratic_to + ( bezier.p0 + , bezier.ctrl0 + , bezier.ctrl1 + , bezier.p1 ) + path ) end diff --git a/path/fixed.ml b/path/fixed.ml index 812dd3b..d9abcb5 100755 --- a/path/fixed.ml +++ b/path/fixed.ml @@ -14,6 +14,12 @@ end module Make(Point:P) = struct + type bezier = + { p0:Point.t (* The starting point *) + ; p1:Point.t (* The end point *) + ; ctrl0:Gg.v2 (* The control point *) + ; ctrl1:Gg.v2 } (* The control point *) + module type BUILDER = sig type t @@ -21,12 +27,6 @@ module Make(Point:P) = struct : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's end - type bezier = - { p0:Point.t (* The starting point *) - ; p1:Point.t (* The end point *) - ; ctrl0:Gg.v2 (* The control point *) - ; ctrl1:Gg.v2 } (* The control point *) - type path = | Line of Point.t * Point.t | Curve of bezier @@ -58,8 +58,8 @@ module Make(Point:P) = struct , Line (p1, p2)::t) let quadratic_to - : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr - = fun p0 ctrl0 ctrl1 p1 (i, t) -> + : (t * Gg.v2 * Gg.v2 * t) -> repr -> repr + = fun (p0, ctrl0, ctrl1, p1) (i, t) -> let curve = Curve { p0 ; ctrl0 @@ -99,10 +99,10 @@ module Make(Point:P) = struct = fun (type s) {path; _} (module Repr : Repr.M with type t = Point.t and type repr = s) repr -> let repr_bezier p bezier = Repr.quadratic_to - bezier.p0 - bezier.ctrl0 - bezier.ctrl1 - bezier.p1 + ( bezier.p0 + , bezier.ctrl0 + , bezier.ctrl1 + , bezier.p1 ) p in let _, repr = Array.fold_left path diff --git a/path/repr.ml b/path/repr.ml index 63e7ba0..55a2920 100755 --- a/path/repr.ml +++ b/path/repr.ml @@ -11,7 +11,7 @@ module type M = sig : t -> t -> repr -> repr val quadratic_to - : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr + : (t * Gg.v2 * Gg.v2 * t) -> repr -> repr val stop : repr -> repr diff --git a/script.it/dune b/script.it/dune index 84b91f6..c51c43b 100755 --- a/script.it/dune +++ b/script.it/dune @@ -7,6 +7,7 @@ elements blog layer + worker_messages ) (modes js) (modules script state selection) @@ -27,6 +28,7 @@ js_of_ocaml shapes path + worker_messages ) (modes js) (preprocess (pps ppx_hash js_of_ocaml-ppx)) diff --git a/script.it/script.ml b/script.it/script.ml index ca831ba..3133269 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -4,14 +4,6 @@ open Brr open Brr_note -module Mouse = Brr_note_kit.Mouse - -let get_height el = - match El.at (Jstr.v "height") el with - | None -> 0 - | Some att -> - Option.value ~default:0 (Jstr.to_int att) - (** Create the element in the page, and the event handler *) let canva : Brr.El.t -> [> State.canva_events] Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t @@ -60,14 +52,14 @@ let canva Brr_note_kit.Mouse.left_up mouse |> E.map (fun c -> `Out c) in - let position = Mouse.pos mouse in + let position = Brr_note_kit.Mouse.pos mouse in let pos = S.l2 (fun b pos -> if b then Some pos else None - ) (Mouse.left mouse) position in + ) (Brr_note_kit.Mouse.left mouse) position in E.select [click; up], pos, c @@ -293,15 +285,6 @@ let on_change canva mouse_position timer state = ~w:10. ~h:10. context; - -(* - Cd2d.stroke_text - context - (Jstr.of_float @@ Path.Point.get_stamp point) - ~x:(x +. 15.) - ~y; -*) - | _ -> () in diff --git a/script.it/state.ml b/script.it/state.ml index da97b13..cc199d1 100755 --- a/script.it/state.ml +++ b/script.it/state.ml @@ -1,8 +1,6 @@ open StdLabels open Brr -let backgroundColor = Blog.Nord.nord0 - type mode = | Edit | Selection of Selection.t @@ -51,6 +49,10 @@ type state = ; rendering : Layer.Paths.printer } +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 @@ -140,7 +142,7 @@ let delete state worker = | false -> () | true -> (* Send the job to the worker *) - Brr_webworkers.Worker.post worker (`DeletePoint (point, p)) + post worker (`DeletePoint (point, p)) ); { state with mode = Selection (Path id) } | _ -> @@ -266,7 +268,7 @@ let do_action current in - let () = Brr_webworkers.Worker.post worker (`Complete last) in + let () = post worker (`Complete last) in last::state.paths and current = Path.Path_Builder.empty in @@ -302,7 +304,7 @@ let do_action | false -> () | true -> Option.iter - (fun p -> Brr_webworkers.Worker.post worker (`Complete p)) + (fun p -> post worker (`Complete p)) (Path.Fixed.replace_point path point') ); @@ -322,7 +324,7 @@ let do_action ~f:(fun path -> Layer.Paths.to_svg - ~color:backgroundColor + ~color:Blog.Nord.nord0 (module Path.Fixed) path state.rendering diff --git a/script.it/worker.ml b/script.it/worker.ml index 4ea9220..00e4595 100755 --- a/script.it/worker.ml +++ b/script.it/worker.ml @@ -1,11 +1,10 @@ open Js_of_ocaml -type message = [ - | `Complete of Path.Fixed.t - | `DeletePoint of (Path.Point.t * Path.Fixed.t) -] +let post_message + : Worker_messages.from_worker -> unit + = Worker.post_message -let execute (command: [> message]) = +let execute (command: [> Worker_messages.to_worker]) = match command with | `Complete path -> begin match Path.Fixed.rebuild path with @@ -17,8 +16,8 @@ let execute (command: [> message]) = | Some path -> Worker.post_message (`Complete path) | None -> () end - | any -> - Worker.post_message (`Other any) + | _ -> + post_message (`Other (Js.string "Unknown message received")) let () = Worker.set_onmessage execute diff --git a/script.it/worker_messages/dune b/script.it/worker_messages/dune new file mode 100755 index 0000000..d1511a6 --- /dev/null +++ b/script.it/worker_messages/dune @@ -0,0 +1,6 @@ +(library + (name worker_messages) + (libraries + js_of_ocaml + path) + ) diff --git a/script.it/worker_messages/worker_messages.ml b/script.it/worker_messages/worker_messages.ml new file mode 100755 index 0000000..992ec29 --- /dev/null +++ b/script.it/worker_messages/worker_messages.ml @@ -0,0 +1,11 @@ +open Js_of_ocaml + +type to_worker = [ + | `Complete of Path.Fixed.t + | `DeletePoint of (Path.Point.t * Path.Fixed.t) +] + +type from_worker = [ + | `Complete of Path.Fixed.t + | `Other of Js.js_string Js.t +] -- cgit v1.2.3