aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xscript.it/dune2
-rwxr-xr-xscript.it/layer/ductusEngine.ml127
-rwxr-xr-xscript.it/layer/dune2
-rwxr-xr-xscript.it/layer/fillEngine.ml133
-rwxr-xr-xscript.it/layer/lineEngine.ml73
-rwxr-xr-xscript.it/layer/paths.ml352
-rwxr-xr-xscript.it/layer/repr.ml37
-rwxr-xr-xscript.it/layer/wireFramePrinter.ml127
-rwxr-xr-xscript.it/layer/wireFramePrinter.mli26
-rwxr-xr-xscript.it/outline/dune2
-rwxr-xr-xscript.it/outline/outline.ml14
-rwxr-xr-xscript.it/path/dune2
-rwxr-xr-xscript.it/path/script_path.ml (renamed from script.it/path/path.ml)0
-rwxr-xr-xscript.it/script.ml678
-rwxr-xr-xscript.it/script_event/click.ml106
-rwxr-xr-xscript.it/script_event/export.ml34
-rwxr-xr-xscript.it/script_event/mouse_down.ml142
-rwxr-xr-xscript.it/script_event/property.ml76
-rwxr-xr-xscript.it/state/dune2
-rwxr-xr-xscript.it/state/selection.ml85
-rwxr-xr-xscript.it/state/selection.mli18
-rwxr-xr-xscript.it/state/state.ml41
-rwxr-xr-xscript.it/worker.ml85
-rwxr-xr-xscript.it/worker_messages/dune2
-rwxr-xr-xscript.it/worker_messages/worker_messages.ml28
25 files changed, 1033 insertions, 1161 deletions
diff --git a/script.it/dune b/script.it/dune
index 2b1d446..c9a28d5 100755
--- a/script.it/dune
+++ b/script.it/dune
@@ -22,7 +22,7 @@
(libraries
js_of_ocaml
shapes
- path
+ script_path
worker_messages
outline
)
diff --git a/script.it/layer/ductusEngine.ml b/script.it/layer/ductusEngine.ml
index b943467..95cf502 100755
--- a/script.it/layer/ductusEngine.ml
+++ b/script.it/layer/ductusEngine.ml
@@ -1,82 +1,67 @@
-module Make(Layer: Repr.PRINTER) = struct
+module Path = Script_path
+module Make (Layer : Repr.PRINTER) = struct
type point = Path.Point.t
- type t =
- { path: (Layer.t)
- }
+ type t = { path : Layer.t }
type repr = Layer.t
- let create_path
- : 'b -> t
- = fun _ ->
- { path = Layer.create ()
- }
+ let create_path : 'b -> t = fun _ -> { path = Layer.create () }
+
+ let start : point -> point -> t -> t =
+ fun p1 p2 { path } ->
+ let path =
+ Layer.move_to (Path.Point.get_coord p1) path
+ |> Layer.line_to (Path.Point.get_coord p2)
+ in
+ { path }
- let start
- : point -> point -> t -> t
- = fun p1 p2 { path } ->
- let path =
- Layer.move_to (Path.Point.get_coord p1) path
- |> Layer.line_to (Path.Point.get_coord p2) in
- { path
- }
- let line_to
- : (point * point) -> (point * point) -> t -> t
- = fun (_, p1) (_, p1') {path} ->
- let path = Layer.move_to (Path.Point.get_coord p1) path in
- let path = Layer.line_to (Path.Point.get_coord p1') path in
- { path
+ let line_to : point * point -> point * point -> t -> t =
+ fun (_, p1) (_, p1') { path } ->
+ let path = Layer.move_to (Path.Point.get_coord p1) path in
+ let path = Layer.line_to (Path.Point.get_coord p1') path in
+ { path }
+
+
+ let quadratic_to :
+ point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t =
+ fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') { path } ->
+ let bezier =
+ { Shapes.Bezier.p0 = Path.Point.get_coord p0
+ ; ctrl0
+ ; ctrl1
+ ; p1 = Path.Point.get_coord p1
+ }
+ and bezier' =
+ { Shapes.Bezier.p0 = Path.Point.get_coord p0'
+ ; ctrl0 = ctrl0'
+ ; ctrl1 = ctrl1'
+ ; p1 = Path.Point.get_coord p1'
}
+ in
+
+ (* Mark each point on the bezier curve. The first point is the most
+ recent point *)
+ let delay = (Path.Point.get_stamp p0 -. Path.Point.get_stamp p1) *. 30. in
+ let path = ref path in
+ for i = 0 to Int.of_float delay do
+ let ratio = Float.of_int i /. delay in
+ let bezier, _ = Shapes.Bezier.slice ratio bezier
+ and bezier', _ = Shapes.Bezier.slice ratio bezier' in
+
+ let point = Path.Point.mix ratio bezier.Shapes.Bezier.p1 p0 p1
+ and point' = Path.Point.mix ratio bezier'.Shapes.Bezier.p1 p0' p1' in
+
+ path := Layer.move_to (Path.Point.get_coord point) !path;
+ path := Layer.line_to (Path.Point.get_coord point') !path
+ done;
+
+ { path = !path }
+
+
+ let stop : t -> t = fun path -> path
- let quadratic_to
- : (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t
- = fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') {path} ->
-
- let bezier =
- { Shapes.Bezier.p0 = Path.Point.get_coord p0
- ; ctrl0
- ; ctrl1
- ; p1 = Path.Point.get_coord p1
- }
-
- and bezier' =
- { Shapes.Bezier.p0 = Path.Point.get_coord p0'
- ; ctrl0 = ctrl0'
- ; ctrl1 = ctrl1'
- ; p1 = Path.Point.get_coord p1'
- } in
-
- (* Mark each point on the bezier curve. The first point is the most
- recent point *)
- let delay =
- ((Path.Point.get_stamp p0) -. (Path.Point.get_stamp p1))
- *. 30.
- in
- let path = ref path in
- for i = 0 to ((Int.of_float delay) ) do
- let ratio = (Float.of_int i) /. delay in
- let bezier, _ = Shapes.Bezier.slice ratio bezier
- and bezier', _ = Shapes.Bezier.slice ratio bezier' in
-
- let point = Path.Point.mix ratio bezier.Shapes.Bezier.p1 p0 p1
- and point' = Path.Point.mix ratio bezier'.Shapes.Bezier.p1 p0' p1' in
-
- path := Layer.move_to (Path.Point.get_coord point) !path;
- path := Layer.line_to (Path.Point.get_coord point') !path;
- done;
-
- { path = !path }
-
- let stop
- : t -> t
- = fun path -> path
-
-
- let get
- : t -> Layer.t
- = fun {path; _} ->
- path
+ let get : t -> Layer.t = fun { path; _ } -> path
end
diff --git a/script.it/layer/dune b/script.it/layer/dune
index 3c617ad..2459d2b 100755
--- a/script.it/layer/dune
+++ b/script.it/layer/dune
@@ -3,6 +3,6 @@
(libraries
gg
brr
- path
+ script_path
)
)
diff --git a/script.it/layer/fillEngine.ml b/script.it/layer/fillEngine.ml
index 9a3fe7e..92f94c7 100755
--- a/script.it/layer/fillEngine.ml
+++ b/script.it/layer/fillEngine.ml
@@ -1,89 +1,70 @@
-module Make(Layer: Repr.PRINTER) = struct
+module Path = Script_path
+module Make (Layer : Repr.PRINTER) = struct
type point = Path.Point.t
type repr = Layer.t
type t =
- { path: Layer.t
+ { path : Layer.t
; close : Layer.t -> Layer.t
}
- let create_path
- : (Layer.t -> Layer.t) -> t
- = fun f ->
- { close = f
- ; path = Layer.create ()
- }
+ let create_path : (Layer.t -> Layer.t) -> t =
+ fun f -> { close = f; path = Layer.create () }
+
(* Start a new path. *)
- let start
- : point -> point -> t -> t
- = fun p1 _ {close ; path } ->
- let path = Layer.move_to (Path.Point.get_coord p1) path in
- { close
- ; path
- }
-
- let line_to
- : (point * point) -> (point * point) -> t -> t
- = fun (p0, p1) (p0', p1') t ->
-
- let p0 = Path.Point.get_coord p0
- and p1 = Path.Point.get_coord p1
- and p0' = Path.Point.get_coord p0'
- and p1' = Path.Point.get_coord p1' in
-
- let path =
- Layer.move_to p1 t.path
- |> Layer.line_to p1'
- |> Layer.line_to p0'
- |> Layer.line_to p0
- |> Layer.line_to p1
- |> Layer.close in
- let path = t.close path in
- { t with path}
-
- let quadratic_to
- : (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t
- = fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') t ->
-
- let p0 = Path.Point.get_coord p0
- and p1 = Path.Point.get_coord p1
- and p0' = Path.Point.get_coord p0'
- and p1' = Path.Point.get_coord p1'
- in
-
- let path =
- Layer.move_to p1 t.path
- |> Layer.line_to p1'
-
- (* Backward *)
- |> Layer.quadratic_to
- ctrl1'
- ctrl0'
- p0'
- |> Layer.line_to p0
-
- (* Forward *)
- |> Layer.quadratic_to
- ctrl0
- ctrl1
- p1
- |> Layer.close
- |> t.close in
-
-
- { t with path }
-
- let stop
- : t -> t
- = fun t ->
- t
-
- let get
- : t -> Layer.t
- = fun t ->
- t.path
+ let start : point -> point -> t -> t =
+ fun p1 _ { close; path } ->
+ let path = Layer.move_to (Path.Point.get_coord p1) path in
+ { close; path }
+
+
+ let line_to : point * point -> point * point -> t -> t =
+ fun (p0, p1) (p0', p1') t ->
+ let p0 = Path.Point.get_coord p0
+ and p1 = Path.Point.get_coord p1
+ and p0' = Path.Point.get_coord p0'
+ and p1' = Path.Point.get_coord p1' in
+
+ let path =
+ Layer.move_to p1 t.path
+ |> Layer.line_to p1'
+ |> Layer.line_to p0'
+ |> Layer.line_to p0
+ |> Layer.line_to p1
+ |> Layer.close
+ in
+ let path = t.close path in
+ { t with path }
+
+
+ let quadratic_to :
+ point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t =
+ fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') t ->
+ let p0 = Path.Point.get_coord p0
+ and p1 = Path.Point.get_coord p1
+ and p0' = Path.Point.get_coord p0'
+ and p1' = Path.Point.get_coord p1' in
+
+ let path =
+ Layer.move_to p1 t.path
+ |> Layer.line_to p1'
+ (* Backward *)
+ |> Layer.quadratic_to ctrl1' ctrl0' p0'
+ |> Layer.line_to p0
+ (* Forward *)
+ |> Layer.quadratic_to ctrl0 ctrl1 p1
+ |> Layer.close
+ |> t.close
+ in
+
+ { t with path }
+
+
+ let stop : t -> t = fun t -> t
+
+ let get : t -> Layer.t = fun t -> t.path
end
diff --git a/script.it/layer/lineEngine.ml b/script.it/layer/lineEngine.ml
index 3d15d9c..c10017a 100755
--- a/script.it/layer/lineEngine.ml
+++ b/script.it/layer/lineEngine.ml
@@ -1,5 +1,6 @@
-module Make(Layer: Repr.PRINTER) = struct
+module Path = Script_path
+module Make (Layer : Repr.PRINTER) = struct
type point = Path.Point.t
let mark point path =
@@ -9,60 +10,50 @@ module Make(Layer: Repr.PRINTER) = struct
let dist = 5.
and dist' = -5. in
- let path = Layer.move_to (point - (of_tuple (dist, dist))) path
- |> Layer.line_to ( point + (of_tuple (dist, dist)))
- |> Layer.move_to (point + (of_tuple (dist', dist)))
- |> Layer.line_to ( point + (of_tuple (dist, dist')))
+ let path =
+ Layer.move_to (point - of_tuple (dist, dist)) path
+ |> Layer.line_to (point + of_tuple (dist, dist))
+ |> Layer.move_to (point + of_tuple (dist', dist))
+ |> Layer.line_to (point + of_tuple (dist, dist'))
in
path
- type t =
- { path: (Layer.t)
- }
+ type t = { path : Layer.t }
type repr = Layer.t
- let create_path
- : 'b -> t
- = fun _ ->
- { path = Layer.create ()
- }
+ let create_path : 'b -> t = fun _ -> { path = Layer.create () }
- let start
- : point -> point -> t -> t
- = fun p1 _ { path } ->
- let path = mark p1 path in
- { path
- }
+ let start : point -> point -> t -> t =
+ fun p1 _ { path } ->
+ let path = mark p1 path in
+ { path }
- let line_to
- : (point * point) -> (point * point) -> t -> t
- = fun (p0, p1) _ {path} ->
- let path = Layer.move_to (Path.Point.get_coord p0) path
- |> Layer.line_to (Path.Point.get_coord p1)
- |> mark p1 in
- { path
- }
- let quadratic_to
- : (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t
- = fun (p0, ctrl0, ctrl1, p1) _ {path} ->
+ let line_to : point * point -> point * point -> t -> t =
+ fun (p0, p1) _ { path } ->
+ let path =
+ Layer.move_to (Path.Point.get_coord p0) path
+ |> Layer.line_to (Path.Point.get_coord p1)
+ |> mark p1
+ in
+ { path }
- let path = Layer.move_to (Path.Point.get_coord p0) path
- |> Layer.quadratic_to ctrl0 ctrl1 (Path.Point.get_coord p1)
- |> mark p1 in
- { path = path }
+ let quadratic_to :
+ point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t =
+ fun (p0, ctrl0, ctrl1, p1) _ { path } ->
+ let path =
+ Layer.move_to (Path.Point.get_coord p0) path
+ |> Layer.quadratic_to ctrl0 ctrl1 (Path.Point.get_coord p1)
+ |> mark p1
+ in
- let stop
- : t -> t
- = fun path -> path
+ { path }
- let get
- : t -> Layer.t
- = fun {path; _} ->
- path
+ let stop : t -> t = fun path -> path
+ let get : t -> Layer.t = fun { path; _ } -> path
end
diff --git a/script.it/layer/paths.ml b/script.it/layer/paths.ml
index d3baf02..1c4251f 100755
--- a/script.it/layer/paths.ml
+++ b/script.it/layer/paths.ml
@@ -1,95 +1,82 @@
-open StdLabels
(** Common module for ensuring that the function is evaluated only once *)
+open StdLabels
+
+module Path = Script_path
(** This represent a single path, which can be transformed throug a [repr]
function. *)
module type PATH = sig
type t
+ val repr :
+ t
+ -> (module Path.Repr.M with type point = Path.Point.t and type t = 's)
+ -> 's
+ -> 's
(** Represent the path *)
- val repr
- : t -> (module Path.Repr.M
- with type point = Path.Point.t
- and type t = 's) -> 's -> 's
end
type printer =
[ `Fill
| `Line
- | `Ductus ]
-
+ | `Ductus
+ ]
module type P = sig
include Path.Repr.M
type repr
- val create_path
- : (repr -> repr) -> t
+ val create_path : (repr -> repr) -> t
- val get
- : t -> repr
+ val get : t -> repr
end
-
-module MakePrinter(M:Repr.ENGINE) : P
- with type point = M.point
- and type t = M.t
- and type repr = M.repr = struct
-
+module MakePrinter (M : Repr.ENGINE) :
+ P with type point = M.point and type t = M.t and type repr = M.repr = struct
type t = M.t
type point = M.point
type repr = M.repr
- let get
- : t -> repr
- = M.get
+ let get : t -> repr = M.get
- let create_path
- : (repr -> repr) -> t
- = M.create_path
+ let create_path : (repr -> repr) -> t = M.create_path
- let start
- : Path.Point.t -> t -> t
- = fun pt t ->
- M.start pt pt t
+ let start : Path.Point.t -> t -> t = fun pt t -> M.start pt pt t
- let line_to
- : Path.Point.t -> Path.Point.t -> t -> t
- = fun p0 p1 t ->
+ let line_to : Path.Point.t -> Path.Point.t -> t -> t =
+ fun p0 p1 t ->
+ M.line_to
+ (p0, p1)
+ ( Path.Point.copy p0 @@ Path.Point.get_coord' p0
+ , Path.Point.copy p1 @@ Path.Point.get_coord' p1 )
+ t
- M.line_to
- ( p0
- , p1 )
- ( Path.Point.copy p0 @@ Path.Point.get_coord' p0
- , Path.Point.copy p1 @@ Path.Point.get_coord' p1 )
- t
- let quadratic_to
- : (Path.Point.t * Gg.v2 * Gg.v2 * Path.Point.t) -> t -> t
- = fun (p0, ctrl0, ctrl1, p1) t ->
+ let quadratic_to : Path.Point.t * Gg.v2 * Gg.v2 * Path.Point.t -> t -> t =
+ fun (p0, ctrl0, ctrl1, p1) t ->
+ let ctrl0' = Path.Point.get_coord' @@ Path.Point.copy p0 ctrl0
+ and ctrl1' = Path.Point.get_coord' @@ Path.Point.copy p1 ctrl1 in
+ M.quadratic_to
+ (p0, ctrl0, ctrl1, p1)
+ ( Path.Point.copy p0 @@ Path.Point.get_coord' p0
+ , ctrl0'
+ , ctrl1'
+ , Path.Point.copy p1 @@ Path.Point.get_coord' p1 )
+ t
- let ctrl0' = Path.Point.get_coord' @@ Path.Point.copy p0 ctrl0
- and ctrl1' = Path.Point.get_coord' @@ Path.Point.copy p1 ctrl1 in
- M.quadratic_to
- (p0, ctrl0, ctrl1, p1)
- (Path.Point.copy p0 @@ Path.Point.get_coord' p0, ctrl0', ctrl1', Path.Point.copy p1 @@ Path.Point.get_coord' p1)
-
- t
-
let stop = M.stop
end
(** Transform the two path, into a single one. *)
module ReprSingle = struct
-
type point = Path.Point.t
type repr =
- | Move of (point)
+ | Move of point
| Line_to of (point * point)
| Quadratic of (point * Gg.v2 * Gg.v2 * point)
@@ -98,42 +85,35 @@ module ReprSingle = struct
type point = Path.Point.t
- let start t actions =
- (Move t)::actions
+ let start t actions = Move t :: actions
- let line_to p0 p1 actions =
- Line_to (p0, p1)::actions
+ let line_to p0 p1 actions = Line_to (p0, p1) :: actions
- let quadratic_to
- : (point * Gg.v2 * Gg.v2 * point) -> t -> t
- = fun q actions ->
- (Quadratic q)::actions
+ let quadratic_to : point * Gg.v2 * Gg.v2 * point -> t -> t =
+ fun q actions -> Quadratic q :: actions
- let stop
- : t -> t
- = fun v -> v
+ let stop : t -> t = fun v -> v
end
- let repr
- : (module PATH with type t = 't) -> 't -> 't -> repr list * repr list
- = fun (type t) (module P:PATH with type t = t) path back ->
- let path = P.repr path (module R) []
- and back = P.repr back (module R) [] in
- path, back
+ let repr : (module PATH with type t = 't) -> 't -> 't -> repr list * repr list
+ =
+ fun (type t) (module P : PATH with type t = t) path back ->
+ let path = P.repr path (module R) []
+ and back = P.repr back (module R) [] in
+ (path, back)
end
(* Canva representation *)
-module FillCanva = FillEngine.Make(CanvaPrinter)
-module LineCanva = LineEngine.Make(CanvaPrinter)
-module DuctusCanva = DuctusEngine.Make(CanvaPrinter)
+module FillCanva = FillEngine.Make (CanvaPrinter)
+module LineCanva = LineEngine.Make (CanvaPrinter)
+module DuctusCanva = DuctusEngine.Make (CanvaPrinter)
(* SVG representation *)
-module FillSVG = FillEngine.Make(Svg)
-module DuctusSVG = DuctusEngine.Make(Svg)
-
+module FillSVG = FillEngine.Make (Svg)
+module DuctusSVG = DuctusEngine.Make (Svg)
(** Draw a path to a canva.contents
@@ -141,104 +121,136 @@ module DuctusSVG = DuctusEngine.Make(Svg)
main stroke, and the interior one) are evaluated. Then, they are both rendered
using the selected engine.
*)
-let to_canva
- : (module PATH with type t = 's) -> 's * 's -> Brr_canvas.C2d.t -> printer -> unit
- = fun (type s) (module R:PATH with type t = s) (path, back) ctx engine ->
- let f, b = ReprSingle.repr (module R) path back in
- match engine with
- | `Fill ->
- let t = List.fold_left2 f b
- ~init:(FillCanva.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
- ~f:(fun ctx f b ->
- match (f, b) with
- | ReprSingle.Move p0, ReprSingle.Move p0' -> FillCanva.start p0 p0' ctx
- | ReprSingle.Line_to l, ReprSingle.Line_to l' -> FillCanva.line_to l l' ctx
- | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> FillCanva.quadratic_to q q' ctx
- | _ -> ctx
- ) in
- FillCanva.get t
- |> Brr_canvas.C2d.stroke ctx
- | `Line ->
- let t = List.fold_left2 f b
- ~init:(LineCanva.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
- ~f:(fun ctx f b ->
- match (f, b) with
- | ReprSingle.Move p0, ReprSingle.Move p0' -> LineCanva.start p0 p0' ctx
- | ReprSingle.Line_to l, ReprSingle.Line_to l' -> LineCanva.line_to l l' ctx
- | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> LineCanva.quadratic_to q q' ctx
- | _ -> ctx
- ) in
- LineCanva.get t
- |> Brr_canvas.C2d.stroke ctx
- | `Ductus ->
- let t = List.fold_left2 f b
- ~init:(DuctusCanva.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
- ~f:(fun ctx f b ->
- match (f, b) with
- | ReprSingle.Move p0, ReprSingle.Move p0' -> DuctusCanva.start p0 p0' ctx
- | ReprSingle.Line_to l, ReprSingle.Line_to l' -> DuctusCanva.line_to l l' ctx
- | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> DuctusCanva.quadratic_to q q' ctx
- | _ -> ctx
- ) in
- DuctusCanva.get t
- |> Brr_canvas.C2d.stroke ctx
-
+let to_canva :
+ (module PATH with type t = 's)
+ -> 's * 's
+ -> Brr_canvas.C2d.t
+ -> printer
+ -> unit =
+ fun (type s) (module R : PATH with type t = s) (path, back) ctx engine ->
+ let f, b = ReprSingle.repr (module R) path back in
+ match engine with
+ | `Fill ->
+ let t =
+ List.fold_left2
+ f
+ b
+ ~init:
+ (FillCanva.create_path (fun p ->
+ Brr_canvas.C2d.fill ctx p;
+ p ) )
+ ~f:(fun ctx f b ->
+ match (f, b) with
+ | ReprSingle.Move p0, ReprSingle.Move p0' ->
+ FillCanva.start p0 p0' ctx
+ | ReprSingle.Line_to l, ReprSingle.Line_to l' ->
+ FillCanva.line_to l l' ctx
+ | ReprSingle.Quadratic q, ReprSingle.Quadratic q' ->
+ FillCanva.quadratic_to q q' ctx
+ | _ -> ctx )
+ in
+ FillCanva.get t |> Brr_canvas.C2d.stroke ctx
+ | `Line ->
+ let t =
+ List.fold_left2
+ f
+ b
+ ~init:
+ (LineCanva.create_path (fun p ->
+ Brr_canvas.C2d.fill ctx p;
+ p ) )
+ ~f:(fun ctx f b ->
+ match (f, b) with
+ | ReprSingle.Move p0, ReprSingle.Move p0' ->
+ LineCanva.start p0 p0' ctx
+ | ReprSingle.Line_to l, ReprSingle.Line_to l' ->
+ LineCanva.line_to l l' ctx
+ | ReprSingle.Quadratic q, ReprSingle.Quadratic q' ->
+ LineCanva.quadratic_to q q' ctx
+ | _ -> ctx )
+ in
+ LineCanva.get t |> Brr_canvas.C2d.stroke ctx
+ | `Ductus ->
+ let t =
+ List.fold_left2
+ f
+ b
+ ~init:
+ (DuctusCanva.create_path (fun p ->
+ Brr_canvas.C2d.fill ctx p;
+ p ) )
+ ~f:(fun ctx f b ->
+ match (f, b) with
+ | ReprSingle.Move p0, ReprSingle.Move p0' ->
+ DuctusCanva.start p0 p0' ctx
+ | ReprSingle.Line_to l, ReprSingle.Line_to l' ->
+ DuctusCanva.line_to l l' ctx
+ | ReprSingle.Quadratic q, ReprSingle.Quadratic q' ->
+ DuctusCanva.quadratic_to q q' ctx
+ | _ -> ctx )
+ in
+ DuctusCanva.get t |> Brr_canvas.C2d.stroke ctx
(** Draw a path and represent it as SVG *)
-let to_svg
- : (module PATH with type t = 's) -> color:Jstr.t -> 's * 's -> printer -> Brr.El.t
- = fun (type s) (module R:PATH with type t = s) ~color (path, back) engine ->
- let f, b = ReprSingle.repr (module R) path back in
- match engine with
- | `Fill ->
-
- (* In order to deal with over crossing path, I cut the path in as
- many segment as there is curve, and fill them all. Then, all of theme
- are grouped inside a single element *)
- let paths = ref [] in
- let init = (FillSVG.create_path
- (fun p ->
- let repr = Svg.path
- ~at:Brr.At.[ v (Jstr.v "d") p ]
- [] in
-
- paths := repr::!paths;
- Jstr.empty)) in
- let _ = List.fold_left2 f b
- ~init
- ~f:(fun ctx f b ->
- match (f, b) with
- | ReprSingle.Move p0, ReprSingle.Move p0' -> FillSVG.start p0 p0' ctx
- | ReprSingle.Line_to l, ReprSingle.Line_to l' -> FillSVG.line_to l l' ctx
- | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> FillSVG.quadratic_to q q' ctx
- | _ -> ctx
- ) in
-
- Brr.El.v (Jstr.v "g")
- ~at:Brr.At.[
- v (Jstr.v "fill") color
- ; v (Jstr.v "stroke") color]
- !paths
-
- | `Ductus ->
- let init = DuctusSVG.create_path (fun _ -> Jstr.empty) in
- let svg_path = List.fold_left2 f b
- ~init
- ~f:(fun ctx f b ->
- match (f, b) with
- | ReprSingle.Move p0, ReprSingle.Move p0' -> DuctusSVG.start p0 p0' ctx
- | ReprSingle.Line_to l, ReprSingle.Line_to l' -> DuctusSVG.line_to l l' ctx
- | ReprSingle.Quadratic q, ReprSingle.Quadratic q' -> DuctusSVG.quadratic_to q q' ctx
- | _ -> ctx
- )
- |> DuctusSVG.get in
-
- Svg.path
- ~at:Brr.At.[
- v (Jstr.v "fill") color
- ; v (Jstr.v "stroke") color
- ; v (Jstr.v "d") svg_path ]
- []
- | `Line ->
- raise Not_found
+let to_svg :
+ (module PATH with type t = 's)
+ -> color:Jstr.t
+ -> 's * 's
+ -> printer
+ -> Brr.El.t =
+ fun (type s) (module R : PATH with type t = s) ~color (path, back) engine ->
+ let f, b = ReprSingle.repr (module R) path back in
+ match engine with
+ | `Fill ->
+ (* In order to deal with over crossing path, I cut the path in as
+ many segment as there is curve, and fill them all. Then, all of theme
+ are grouped inside a single element *)
+ let paths = ref [] in
+ let init =
+ FillSVG.create_path (fun p ->
+ let repr = Svg.path ~at:Brr.At.[ v (Jstr.v "d") p ] [] in
+
+ paths := repr :: !paths;
+ Jstr.empty )
+ in
+ let _ =
+ List.fold_left2 f b ~init ~f:(fun ctx f b ->
+ match (f, b) with
+ | ReprSingle.Move p0, ReprSingle.Move p0' ->
+ FillSVG.start p0 p0' ctx
+ | ReprSingle.Line_to l, ReprSingle.Line_to l' ->
+ FillSVG.line_to l l' ctx
+ | ReprSingle.Quadratic q, ReprSingle.Quadratic q' ->
+ FillSVG.quadratic_to q q' ctx
+ | _ -> ctx )
+ in
+
+ Brr.El.v
+ (Jstr.v "g")
+ ~at:Brr.At.[ v (Jstr.v "fill") color; v (Jstr.v "stroke") color ]
+ !paths
+ | `Ductus ->
+ let init = DuctusSVG.create_path (fun _ -> Jstr.empty) in
+ let svg_path =
+ List.fold_left2 f b ~init ~f:(fun ctx f b ->
+ match (f, b) with
+ | ReprSingle.Move p0, ReprSingle.Move p0' ->
+ DuctusSVG.start p0 p0' ctx
+ | ReprSingle.Line_to l, ReprSingle.Line_to l' ->
+ DuctusSVG.line_to l l' ctx
+ | ReprSingle.Quadratic q, ReprSingle.Quadratic q' ->
+ DuctusSVG.quadratic_to q q' ctx
+ | _ -> ctx )
+ |> DuctusSVG.get
+ in
+
+ Svg.path
+ ~at:
+ Brr.At.
+ [ v (Jstr.v "fill") color
+ ; v (Jstr.v "stroke") color
+ ; v (Jstr.v "d") svg_path
+ ]
+ []
+ | `Line -> raise Not_found
diff --git a/script.it/layer/repr.ml b/script.it/layer/repr.ml
index 552e2b7..4bc5520 100755
--- a/script.it/layer/repr.ml
+++ b/script.it/layer/repr.ml
@@ -1,21 +1,21 @@
-module type PRINTER = sig
+module Path = Script_path
+module type PRINTER = sig
type t
- val create: unit -> t
+ val create : unit -> t
(* Start a new path. *)
- val move_to: Gg.v2 -> t -> t
+ val move_to : Gg.v2 -> t -> t
- val line_to: Gg.v2 -> t -> t
+ val line_to : Gg.v2 -> t -> t
+ val quadratic_to : Gg.v2 -> Gg.v2 -> Gg.v2 -> t -> t
(** [quadratic_to ctrl0 ctrl1 p1] create a quadratic curve from the current
point to [p1], with control points [ctrl0] and [ctrl1] *)
- val quadratic_to: Gg.v2 -> Gg.v2 -> Gg.v2 -> t -> t
+ val close : t -> t
(** Request for the path to be closed *)
- val close: t -> t
-
end
module type ENGINE = sig
@@ -25,25 +25,16 @@ module type ENGINE = sig
type repr
- val get
- : t -> repr
-
- val create_path
- : (repr -> repr) -> t
+ val get : t -> repr
- val start
- : point -> point -> t -> t
+ val create_path : (repr -> repr) -> t
- val line_to
- : (point * point) -> (point * point) -> t -> t
+ val start : point -> point -> t -> t
- val quadratic_to
- : (point * Gg.v2 * Gg.v2 * point)
- -> (point * Gg.v2 * Gg.v2 * point)
- -> t
- -> t
+ val line_to : point * point -> point * point -> t -> t
- val stop
- : t -> t
+ val quadratic_to :
+ point * Gg.v2 * Gg.v2 * point -> point * Gg.v2 * Gg.v2 * point -> t -> t
+ val stop : t -> t
end
diff --git a/script.it/layer/wireFramePrinter.ml b/script.it/layer/wireFramePrinter.ml
index 81ab271..e61bd7c 100755
--- a/script.it/layer/wireFramePrinter.ml
+++ b/script.it/layer/wireFramePrinter.ml
@@ -1,80 +1,69 @@
+module Path = Script_path
module Point = Path.Point
-module Make(Repr: Repr.PRINTER) = struct
+module Make (Repr : Repr.PRINTER) = struct
type t = Point.t
type repr =
- { back: (Repr.t -> Repr.t)
- ; path: (Repr.t)
+ { back : Repr.t -> Repr.t
+ ; path : Repr.t
; last_point : Point.t option
}
- let create_path
- : 'b -> repr
- = fun _ ->
- { back = Repr.close
- ; path = Repr.create ()
- ; last_point = None
- }
+ let create_path : 'b -> repr =
+ fun _ -> { back = Repr.close; path = Repr.create (); last_point = None }
+
(* Start a new path. *)
- let start
- : Point.t -> repr -> repr
- = fun t {back; path; _} ->
- let path = Repr.move_to (Point.get_coord t) path in
- let line' = Repr.line_to (Point.get_coord' t) in
- { back = (fun p -> back @@ line' p)
- ; path
- ; last_point = Some t
- }
-
- let line_to
- : Point.t -> Point.t -> repr -> repr
- = fun _ t {back; path; _} ->
- let line' = Repr.line_to (Point.get_coord' t) in
- { back = (fun t -> back @@ line' t)
- ; path = Repr.line_to (Point.get_coord t) path
- ; last_point = Some t
- }
-
- let quadratic_to
- : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr
- = fun p0 ctrl0 ctrl1 p1 t ->
-
- let ctrl0' = Point.copy p1 ctrl0
- and ctrl1' = Point.copy p1 ctrl1 in
-
- let line' path =
- Repr.quadratic_to
- (Point.get_coord' @@ ctrl1')
- (Point.get_coord' ctrl0')
- (Point.get_coord' p0) path in
-
- let path = Repr.quadratic_to
- (Point.get_coord ctrl0')
- (Point.get_coord ctrl1')
- (Point.get_coord p1)
- t.path in
- { back = (fun p -> t.back @@ line' p)
- ; path
- ; last_point = Some p1
- }
-
- let stop
- : repr -> repr
- = fun {back; path; last_point} ->
-
- let path =
- match last_point with
- | Some point -> Repr.line_to (Point.get_coord' point) path
- | None -> path in
-
- { back = (fun x -> x)
- ; path = back path
- ; last_point = None }
-
- let get
- : repr -> Repr.t
- = fun {back; path; _} ->
- back path
+ let start : Point.t -> repr -> repr =
+ fun t { back; path; _ } ->
+ let path = Repr.move_to (Point.get_coord t) path in
+ let line' = Repr.line_to (Point.get_coord' t) in
+ { back = (fun p -> back @@ line' p); path; last_point = Some t }
+
+
+ let line_to : Point.t -> Point.t -> repr -> repr =
+ fun _ t { back; path; _ } ->
+ let line' = Repr.line_to (Point.get_coord' t) in
+ { back = (fun t -> back @@ line' t)
+ ; path = Repr.line_to (Point.get_coord t) path
+ ; last_point = Some t
+ }
+
+
+ let quadratic_to : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr =
+ fun p0 ctrl0 ctrl1 p1 t ->
+ let ctrl0' = Point.copy p1 ctrl0
+ and ctrl1' = Point.copy p1 ctrl1 in
+
+ let line' path =
+ Repr.quadratic_to
+ (Point.get_coord' @@ ctrl1')
+ (Point.get_coord' ctrl0')
+ (Point.get_coord' p0)
+ path
+ in
+
+ let path =
+ Repr.quadratic_to
+ (Point.get_coord ctrl0')
+ (Point.get_coord ctrl1')
+ (Point.get_coord p1)
+ t.path
+ in
+ { back = (fun p -> t.back @@ line' p); path; last_point = Some p1 }
+
+
+ let stop : repr -> repr =
+ fun { back; path; last_point } ->
+ let path =
+ match last_point with
+ | Some point -> Repr.line_to (Point.get_coord' point) path
+ | None -> path
+ in
+
+ { back = (fun x -> x); path = back path; last_point = None }
+
+
+ let get : repr -> Repr.t = fun { back; path; _ } -> back path
end
diff --git a/script.it/layer/wireFramePrinter.mli b/script.it/layer/wireFramePrinter.mli
index b198d58..3b18814 100755
--- a/script.it/layer/wireFramePrinter.mli
+++ b/script.it/layer/wireFramePrinter.mli
@@ -1,27 +1,21 @@
-module Make(Repr:Repr.PRINTER): sig
+module Path = Script_path
- type repr
+module Make (Repr : Repr.PRINTER) : sig
+ type repr
type t = Path.Point.t
- val create_path
- : 'b -> repr
+ val create_path : 'b -> repr
(* Start a new path. *)
- val start
- : Path.Point.t -> repr -> repr
+ val start : Path.Point.t -> repr -> repr
- val line_to
- : Path.Point.t -> Path.Point.t -> repr -> repr
+ val line_to : Path.Point.t -> Path.Point.t -> repr -> repr
- val quadratic_to
- : Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr
+ val quadratic_to :
+ Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr
- val stop
- : repr -> repr
-
-
- val get
- : repr -> Repr.t
+ val stop : repr -> repr
+ val get : repr -> Repr.t
end
diff --git a/script.it/outline/dune b/script.it/outline/dune
index 73b7998..16a475c 100755
--- a/script.it/outline/dune
+++ b/script.it/outline/dune
@@ -1,7 +1,7 @@
(library
(name outline)
(libraries
- path)
+ script_path)
(modules outline)
(preprocess (pps ppx_hash js_of_ocaml-ppx))
)
diff --git a/script.it/outline/outline.ml b/script.it/outline/outline.ml
index 1df7588..588084e 100755
--- a/script.it/outline/outline.ml
+++ b/script.it/outline/outline.ml
@@ -1,11 +1,12 @@
open StdLabels
+module Path = Script_path
let internal_path_id = ref 0
type t =
{ id : int
- ; path: Path.Fixed.t
- ; back: Path.Fixed.t
+ ; path : Path.Fixed.t
+ ; back : Path.Fixed.t
}
let get_id () =
@@ -13,9 +14,6 @@ let get_id () =
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)
+
+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/path/dune b/script.it/path/dune
index 863c768..699f7fe 100755
--- a/script.it/path/dune
+++ b/script.it/path/dune
@@ -1,5 +1,5 @@
(library
- (name path)
+ (name script_path)
(libraries
gg
shapes
diff --git a/script.it/path/path.ml b/script.it/path/script_path.ml
index ea90de4..ea90de4 100755
--- a/script.it/path/path.ml
+++ b/script.it/path/script_path.ml
diff --git a/script.it/script.ml b/script.it/script.ml
index eb12458..e4cec67 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -2,13 +2,13 @@ open StdLabels
open Note
open Brr
open Brr_note
-
module State = Script_state.State
module Selection = Script_state.Selection
+module Path = Script_path
+
+let post : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit =
+ Brr_webworkers.Worker.post
-let post
- : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit
- = Brr_webworkers.Worker.post
type canva_events =
[ `MouseDown of float * float
@@ -16,71 +16,54 @@ type canva_events =
]
(** Create the element in the page, and the event handler *)
-let canva
- : Brr.El.t -> canva_events Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t
- = fun element ->
-
- (* Adapt the width to the window *)
- El.set_inline_style
- El.Style.width
- (Jstr.v "100%")
- element;
-
- (* See https://stackoverflow.com/a/14855870/13882826 *)
- El.set_inline_style
- El.Style.height
- (Jstr.v "100%")
- element;
-
- El.set_prop
- El.Prop.width
- (El.prop Elements.Prop.offsetWidth element)
- element;
-
- El.set_prop
- El.Prop.height
- (El.prop Elements.Prop.offsetHeight element)
- element;
-
- El.set_inline_style
- El.Style.width
- (Jstr.v "")
- element;
-
- let module C = Brr_canvas.Canvas in
- let c = C.of_el element in
-
- (* Mouse events *)
- let mouse = Brr_note_kit.Mouse.on_el
- ~normalize:false
- (fun x y -> (x, y)) element in
-
- let click =
- Brr_note_kit.Mouse.left_down mouse
- |> E.map (fun c -> `MouseDown c) in
-
- let up =
- Brr_note_kit.Mouse.left_up mouse
- |> E.map (fun c -> `Out c) in
-
- let position = Brr_note_kit.Mouse.pos mouse in
-
- let pos = S.l2
- (fun b pos ->
- if b then
- Some pos
- else
- None )
- (Brr_note_kit.Mouse.left mouse)
- position in
-
- E.select [click; up], pos, c
-
-let click_event el =
- Evr.on_el
- Ev.click
- Evr.unit
- el
+let canva :
+ Brr.El.t
+ -> canva_events Note.E.t
+ * (float * float) option Note.S.t
+ * Brr_canvas.Canvas.t =
+ fun element ->
+ (* Adapt the width to the window *)
+ El.set_inline_style El.Style.width (Jstr.v "100%") element;
+
+ (* See https://stackoverflow.com/a/14855870/13882826 *)
+ El.set_inline_style El.Style.height (Jstr.v "100%") element;
+
+ El.set_prop El.Prop.width (El.prop Elements.Prop.offsetWidth element) element;
+
+ El.set_prop
+ El.Prop.height
+ (El.prop Elements.Prop.offsetHeight element)
+ element;
+
+ El.set_inline_style El.Style.width (Jstr.v "") element;
+
+ let module C = Brr_canvas.Canvas in
+ let c = C.of_el element in
+
+ (* Mouse events *)
+ let mouse =
+ Brr_note_kit.Mouse.on_el ~normalize:false (fun x y -> (x, y)) element
+ in
+
+ let click =
+ Brr_note_kit.Mouse.left_down mouse |> E.map (fun c -> `MouseDown c)
+ in
+
+ let up = Brr_note_kit.Mouse.left_up mouse |> E.map (fun c -> `Out c) in
+
+ let position = Brr_note_kit.Mouse.pos mouse in
+
+ let pos =
+ S.l2
+ (fun b pos -> if b then Some pos else None)
+ (Brr_note_kit.Mouse.left mouse)
+ position
+ in
+
+ (E.select [ click; up ], pos, c)
+
+
+let click_event el = Evr.on_el Ev.click Evr.unit el
type 'a param_events =
{ width : float S.t
@@ -92,129 +75,124 @@ type 'a param_events =
type slider =
{ input : El.t
- ; legend : El.t }
-
-let set_sidebar
- : El.t -> State.state -> _ param_events * slider * slider
- = fun element state ->
-
- let delete =
- El.button
- [ El.i
- ~at:At.[ class' (Jstr.v "fas")
- ; class' (Jstr.v "fa-times-circle") ]
- []
- ; El.txt' "Delete "] in
-
- let delete_event = click_event delete in
-
- let export =
- El.button
- [ El.i
- ~at:At.[ class' (Jstr.v "fas")
- ; class' (Jstr.v "fa-download") ]
- []
- ; El.txt' "Download"] in
- let export_event = click_event export in
-
- let nib_size, nib_size_event =
- Elements.Input.slider
- ~at:At.[ type' (Jstr.v "range")
- ; v (Jstr.v "min") (Jstr.v "1")
- ; v (Jstr.v "max") (Jstr.v "50")
- ; At.value (Jstr.of_float state.width)
- ] in
-
- let width = El.div [] in
- let width_slider =
- { input = nib_size
- ; legend = width } in
-
- let input_angle, angle_event =
- Elements.Input.slider
- ~at:At.[ type' (Jstr.v "range")
- ; v (Jstr.v "min") (Jstr.v "0")
- ; v (Jstr.v "max") (Jstr.v "90")
- ; At.value (Jstr.of_float state.angle)
- ] in
-
- let angle = El.div [] in
- let angle_slider =
- { input = input_angle
- ; legend = angle } in
-
- let render =
- El.select
- [ El.option ~at:At.[value (Jstr.v "1")]
- [ El.txt' "Fill"]
- ; El.option ~at:At.[value (Jstr.v "3")]
- [ El.txt' "Ductus"]
- ] in
-
- let rendering' = El.div
- [ El.txt' "Rendering : "
- ; render ] in
-
- let render_event =
- Evr.on_el
- Ev.change (fun _ ->
- let raw_value = El.prop El.Prop.value render
- |> Jstr.to_int in
- let render_type = match raw_value with
- | Some 1 -> `Fill
- | Some 2 -> `Line
- | Some 3 -> `Ductus
- | _ -> `Fill in
-
- let module M = struct
- type t = Layer.Paths.printer
- let process t state = { state with State.rendering = t }
- end
- in
- State.dispatch (module M) render_type
+ ; legend : El.t
+ }
- ) rendering' in
+let set_sidebar : El.t -> State.state -> _ param_events * slider * slider =
+ fun element state ->
+ let delete =
+ El.button
+ [ El.i
+ ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-times-circle") ]
+ []
+ ; El.txt' "Delete "
+ ]
+ in
- let () =
- El.append_children element
- [ El.hr ()
- ; delete
- ; export
+ let delete_event = click_event delete in
- ; rendering'
+ let export =
+ El.button
+ [ El.i ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-download") ] []
+ ; El.txt' "Download"
+ ]
+ in
+ let export_event = click_event export in
+
+ let nib_size, nib_size_event =
+ Elements.Input.slider
+ ~at:
+ At.
+ [ type' (Jstr.v "range")
+ ; v (Jstr.v "min") (Jstr.v "1")
+ ; v (Jstr.v "max") (Jstr.v "50")
+ ; At.value (Jstr.of_float state.width)
+ ]
+ in
- ; El.hr ()
+ let width = El.div [] in
+ let width_slider = { input = nib_size; legend = width } in
+
+ let input_angle, angle_event =
+ Elements.Input.slider
+ ~at:
+ At.
+ [ type' (Jstr.v "range")
+ ; v (Jstr.v "min") (Jstr.v "0")
+ ; v (Jstr.v "max") (Jstr.v "90")
+ ; At.value (Jstr.of_float state.angle)
+ ]
+ in
+
+ let angle = El.div [] in
+ let angle_slider = { input = input_angle; legend = angle } in
- ; width
- ; nib_size
+ let render =
+ El.select
+ [ El.option ~at:At.[ value (Jstr.v "1") ] [ El.txt' "Fill" ]
+ ; El.option ~at:At.[ value (Jstr.v "3") ] [ El.txt' "Ductus" ]
+ ]
+ in
- ; angle
- ; input_angle
+ let rendering' = El.div [ El.txt' "Rendering : "; render ] in
+
+ let render_event =
+ Evr.on_el
+ Ev.change
+ (fun _ ->
+ let raw_value = El.prop El.Prop.value render |> Jstr.to_int in
+ let render_type =
+ match raw_value with
+ | Some 1 -> `Fill
+ | Some 2 -> `Line
+ | Some 3 -> `Ductus
+ | _ -> `Fill
+ in
+
+ let module M = struct
+ type t = Layer.Paths.printer
+
+ let process t state = { state with State.rendering = t }
+ end in
+ State.dispatch (module M) render_type )
+ rendering'
+ in
+
+ let () =
+ El.append_children
+ element
+ [ El.hr ()
+ ; delete
+ ; export
+ ; rendering'
+ ; El.hr ()
+ ; width
+ ; nib_size
+ ; angle
+ ; input_angle
+ ]
+ in
+ ( { delete = delete_event
+ ; angle = angle_event
+ ; width = nib_size_event
+ ; export = export_event
+ ; rendering = render_event
+ }
+ , angle_slider
+ , width_slider )
- ]
- in
- ( { delete = delete_event
- ; angle = angle_event
- ; width = nib_size_event
- ; export = export_event
- ; rendering = render_event }
- , angle_slider
- , width_slider
- )
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
+ 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 =
@@ -222,17 +200,14 @@ let on_change canva mouse_position timer state =
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
+ let w, h =
+ Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva)
+ in
let context = Cd2d.create canva in
Cd2d.set_fill_style context (Cd2d.color backgroundColor);
- Cd2d.fill_rect context
- ~x:0.0
- ~y:0.0
- ~w
- ~h;
+ Cd2d.fill_rect context ~x:0.0 ~y:0.0 ~w ~h;
Cd2d.set_stroke_style context (Cd2d.color white);
Cd2d.set_fill_style context (Cd2d.color white);
@@ -240,177 +215,170 @@ let on_change canva mouse_position timer state =
Otherwise, we would only display the previous registered point, which can
be far away in the past, and would give to the user a sensation of lag.
-
*)
let current =
- begin match state.State.mode, pos with
- | Edit, Some point ->
+ match (state.State.mode, pos) with
+ | Edit, Some point ->
let stamp = Elements.Timer.delay timer in
State.insert_or_replace state point stamp state.current
- | _ ->
- state.current
- end
+ | _ -> state.current
in
-
- let back = Path.Path_Builder.map
- current
- (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
- Layer.Paths.to_canva (module Path.Path_Builder) (current, back) context state.rendering;
-
- List.iter state.paths
- ~f:(fun path ->
-
- let () = match state.mode with
- | Selection (Path id)
- | Selection (Point (id, _)) ->
- begin match id = path.Outline.id with
- | true ->
- (* If the element is the selected one, change the color *)
- Cd2d.set_fill_style context (Cd2d.color Blog.Nord.nord8);
- Cd2d.set_stroke_style context (Cd2d.color Blog.Nord.nord8)
- | false ->
- Cd2d.set_stroke_style context (Cd2d.color white);
- Cd2d.set_fill_style context (Cd2d.color white);
- end
- | _ -> ()
- in
-
- let p = path.Outline.path in
- Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context state.rendering
- );
+ let back =
+ Path.Path_Builder.map current (fun pt ->
+ Path.Point.copy pt @@ Path.Point.get_coord' pt )
+ in
+ Layer.Paths.to_canva
+ (module Path.Path_Builder)
+ (current, back)
+ context
+ state.rendering;
+
+ List.iter state.paths ~f:(fun path ->
+ let () =
+ match state.mode with
+ | Selection (Path id) | Selection (Point (id, _)) ->
+ ( match id = path.Outline.id with
+ | true ->
+ (* If the element is the selected one, change the color *)
+ Cd2d.set_fill_style context (Cd2d.color Blog.Nord.nord8);
+ Cd2d.set_stroke_style context (Cd2d.color Blog.Nord.nord8)
+ | false ->
+ Cd2d.set_stroke_style context (Cd2d.color white);
+ Cd2d.set_fill_style context (Cd2d.color white) )
+ | _ -> ()
+ in
+
+ let p = path.Outline.path in
+ 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
+ let () =
+ match state.mode with
| Selection t ->
- Cd2d.set_stroke_style context (Cd2d.color white);
- begin match pos_v2, Selection.find_selection t state.paths with
+ Cd2d.set_stroke_style context (Cd2d.color white);
+ ( 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 *)
+ 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
+ (* 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 =
+ match Path.Fixed.replace_point outline.Outline.path point' with
+ | None -> outline.Outline.path
+ | Some p -> p
+ 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
+ Layer.Paths.to_canva
+ (module Path.Fixed)
+ (outline.path, outline.back)
+ context
+ `Line;
+ draw_point point context )
| _ -> ()
in
()
+
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 =
+let page_main id =
let timer, tick = Elements.Timer.create () in
let parameters, angle_element, width_slider =
- begin match Blog.Sidebar.get () with
- | None ->
- Jv.throw (Jstr.v "No sidebar")
- | Some el ->
-
+ match Blog.Sidebar.get () with
+ | None -> Jv.throw (Jstr.v "No sidebar")
+ | Some el ->
Blog.Sidebar.clean el;
set_sidebar el State.init
- end in
-
- begin match (Jv.is_none id) with
- | true -> Console.(error [str "No element with id '%s' found"; id])
- | false ->
-
- match spawn_worker () with
- | Error e -> El.set_children (Jv.Id.of_jv id)
- [ El.p El.[txt (Jv.Error.message e)]]
-
- | Ok worker ->
+ in
+ match Jv.is_none id with
+ | true -> Console.(error [ str "No element with id '%s' found"; id ])
+ | false ->
+ ( 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 worker_event, worker_send = E.create () in
- let delete_event = E.map
+ let delete_event =
+ E.map
(fun () ->
- let module Delete = Script_event.Delete in
- State.dispatch (module Delete) Delete.{ worker })
+ let module Delete = Script_event.Delete in
+ State.dispatch (module Delete) Delete.{ worker } )
parameters.delete
-
and export_event =
- E.map (fun () ->
+ E.map
+ (fun () ->
let module Export = Script_event.Export in
- State.dispatch (module Export ) ())
+ State.dispatch (module Export) () )
parameters.export
- and angle_event = S.changes parameters.angle
- |> E.map (fun value ->
- let module Property = Script_event.Property in
- State.dispatch (module Property) (Property.{ value ; worker ; prop = `Angle}))
-
- and width_event = S.changes parameters.width
- |> E.map (fun value ->
- let module Property = Script_event.Property in
- State.dispatch (module Property) (Property.{ value ; worker ; prop = `Width }))
- and worker_event = Note.E.filter_map
+ and angle_event =
+ S.changes parameters.angle
+ |> E.map (fun value ->
+ let module Property = Script_event.Property in
+ State.dispatch
+ (module Property)
+ Property.{ value; worker; prop = `Angle } )
+ and width_event =
+ S.changes parameters.width
+ |> E.map (fun value ->
+ let module Property = Script_event.Property in
+ State.dispatch
+ (module Property)
+ Property.{ value; worker; prop = `Width } )
+ and worker_event =
+ Note.E.filter_map
(function
| `Other t ->
- Console.(log [t]);
- None
+ Console.(log [ t ]);
+ None
| `Complete outline ->
- let module Complete_path = Script_event.Complete_path in
- Some (
- State.dispatch (module Complete_path) outline))
-
+ let module Complete_path = Script_event.Complete_path in
+ Some (State.dispatch (module Complete_path) outline) )
worker_event
in
let my_host = Uri.host @@ Window.location @@ G.window in
- if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
+ ( if Hashtbl.hash my_host = Blog.Hash_host.expected_host
+ then
let target = Brr_webworkers.Worker.as_target worker in
- Ev.listen Brr_io.Message.Ev.message
- (fun t ->
- Ev.as_type t
- |> Brr_io.Message.Ev.data
- |> worker_send)
- target);
+ Ev.listen
+ Brr_io.Message.Ev.message
+ (fun t -> Ev.as_type t |> Brr_io.Message.Ev.data |> worker_send)
+ target );
(* Add the events to the canva :
@@ -420,25 +388,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
+ let canva_events =
+ Note.E.map
(function
| `MouseDown c ->
- let module MouseDown = Script_event.Mouse_down in
- State.dispatch (module MouseDown) MouseDown.{ position = c ; timer }
-
+ let module MouseDown = Script_event.Mouse_down in
+ State.dispatch
+ (module MouseDown)
+ MouseDown.{ position = c; timer }
| `Out c ->
- let module Click = Script_event.Click in
- State.dispatch (module Click) Click.{ point = c ; worker ; timer }
- ) canva_events in
+ let module Click = Script_event.Click in
+ State.dispatch
+ (module Click)
+ Click.{ point = c; worker; timer } )
+ canva_events
+ in
let tick_event =
- S.sample_filter mouse_position
- ~on:tick
- (fun pos f ->
- let module Tick = Script_event.Tick in
- Option.map (fun p ->
- State.dispatch (module Tick) (f, p))
- pos ) in
+ S.sample_filter mouse_position ~on:tick (fun pos f ->
+ let module Tick = Script_event.Tick in
+ Option.map (fun p -> State.dispatch (module Tick) (f, p)) pos )
+ in
(* The first evaluation is the state. Which is the result of all the
successives events to the initial state *)
@@ -453,69 +423,55 @@ let page_main id =
; width_event
; delete_event
; export_event
- ; parameters.rendering ])
+ ; parameters.rendering
+ ] )
in
(* The seconde evaluation is the canva refresh, which only occurs when
- the mouse is updated, or on delete events *)
+ the mouse is updated, or on delete events *)
let _ =
E.select
[ E.map (fun _ -> ()) (S.changes mouse_position)
; E.map (fun _ -> ()) parameters.rendering
; E.map (fun _ -> ()) worker_event
- ; parameters.delete ]
- |> fun ev -> E.log ev (fun _ ->
+ ; parameters.delete
+ ]
+ |> fun ev ->
+ E.log ev (fun _ ->
on_change canva mouse_position timer (S.value state) )
- |> Option.iter Logr.hold in
-
+ |> Option.iter Logr.hold
+ in
(* Ajust the angle slide according to the state *)
let angle_signal = S.map (fun s -> Jstr.of_float s.State.angle) state in
let _ =
- Elr.def_prop
- Elements.Prop.value
- angle_signal
- angle_element.input
-
- and _ = Elr.def_children
+ Elr.def_prop Elements.Prop.value angle_signal angle_element.input
+ and _ =
+ Elr.def_children
angle_element.legend
(S.map
- (fun v ->
- [ El.txt' "Angle : "
- ; El.txt v
- ; El.txt' "°" ] )
- angle_signal) in
+ (fun v -> [ El.txt' "Angle : "; El.txt v; El.txt' "°" ])
+ angle_signal )
+ in
let width_signal = S.map (fun s -> Jstr.of_float s.State.width) state in
- let _ =
- Elr.def_prop
- Elements.Prop.value
- width_signal
- width_slider.input
-
- and _ = Elr.def_children
+ let _ = Elr.def_prop Elements.Prop.value width_signal width_slider.input
+ and _ =
+ Elr.def_children
width_slider.legend
- (S.map (fun v ->
- [ El.txt' "Width : "
- ; El.txt v ]
- )
- width_signal
- ) in
+ (S.map (fun v -> [ El.txt' "Width : "; El.txt v ]) width_signal)
+ in
(* Draw the canva for first time *)
on_change canva mouse_position timer State.init;
(* Hold the state *)
let _ = Logr.hold (S.log state (fun _ -> ())) in
- ()
+ () )
- end
let () =
-
let open Jv in
- let drawer = obj
- [| "run", (repr page_main)
- |] in
+ let drawer = obj [| ("run", repr page_main) |] in
set global "drawer" drawer
diff --git a/script.it/script_event/click.ml b/script.it/script_event/click.ml
index b7ffcb6..d1fd2e2 100755
--- a/script.it/script_event/click.ml
+++ b/script.it/script_event/click.ml
@@ -1,12 +1,14 @@
module State = Script_state.State
module Selection = Script_state.Selection
+module Path = Script_path
(** Handle a click outside of the selection *)
-type t = { point : float * float
- ; timer : Elements.Timer.t
- ; worker : Brr_webworkers.Worker.t
- }
+type t =
+ { point : float * float
+ ; timer : Elements.Timer.t
+ ; worker : Brr_webworkers.Worker.t
+ }
(** The drag function is incorrectly named, as we dont't care if we are
selecting an element or not.
@@ -14,78 +16,62 @@ type t = { point : float * float
But, in the case we are (point, path…), we effectively move the element with the mouse. *)
let drag 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
+ let mouse_v2 = Gg.V2.of_tuple mouse_coord in
+ ( 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')) }
+ 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
+ let delta = Gg.V2.(mouse_v2 - state.State.mouse_down_position) in
+ State.post worker (`TranslatePath (path, delta));
+ state )
(* TODO Long click in out mode should translate the whole slate *)
| _ -> state
-let process {point; timer ; worker} state =
- match state.State.mode with
+let process { point; timer; worker } state =
+ match state.State.mode with
| Edit ->
- let stamp = Elements.Timer.delay timer in
- Elements.Timer.stop timer;
- begin match Path.Path_Builder.peek2 state.current with
+ let stamp = Elements.Timer.delay timer in
+ Elements.Timer.stop timer;
+ ( match Path.Path_Builder.peek2 state.current with
(* If there is at last two points selected, handle this as a curve
creation. And we add the new point in the current path *)
| Some _ ->
+ let current =
+ State.insert_or_replace state point stamp state.current
+ in
+ let path = Path.Fixed.to_fixed (module Path.Path_Builder) current in
- let current = State.insert_or_replace state point stamp state.current in
- let path = Path.Fixed.to_fixed
- (module Path.Path_Builder)
- current in
-
- (* Create a copy from the path with all the interior points *)
- let back = Path.Fixed.map
- path
- (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
+ (* Create a copy from the path with all the interior points *)
+ let back =
+ Path.Fixed.map path (fun pt ->
+ Path.Point.copy pt @@ Path.Point.get_coord' pt )
+ in
- let last =
- Outline.{ path
- ; back
- ; id = Outline.get_id ()
- }
- in
+ let last = Outline.{ path; back; id = Outline.get_id () } in
- (* Send to the worker for a full review *)
- let () = State.post worker (`Complete last) in
+ (* Send to the worker for a full review *)
+ let () = State.post worker (`Complete last) in
- let state =
- { state with
- mode = Out
- ; paths = last::state.paths
- ; current = Path.Path_Builder.empty } in
- state
-
- (* Else, check if there is a curve under the cursor, and remove it *)
- | None ->
- let current = Path.Path_Builder.empty in
- begin match Selection.get_from_paths point state.paths with
- | _, None ->
+ let state =
{ state with
mode = Out
- ; current
+ ; paths = last :: state.paths
+ ; current = Path.Path_Builder.empty
}
+ in
+ state
+ (* Else, check if there is a curve under the cursor, and remove it *)
+ | None ->
+ let current = Path.Path_Builder.empty in
+ ( match Selection.get_from_paths point state.paths with
+ | _, None -> { state with mode = Out; current }
| dist, Some selection ->
- State.select_segment point selection { state with current } dist
-
- end
- end
-
- | _ when Elements.Timer.delay timer < 0.3 ->
- state
-
- | _ ->
- drag point state worker state.mode
-
+ State.select_segment point selection { state with current } dist
+ ) )
+ | _ when Elements.Timer.delay timer < 0.3 -> state
+ | _ -> drag point state worker state.mode
diff --git a/script.it/script_event/export.ml b/script.it/script_event/export.ml
index 10dd937..db2f89c 100755
--- a/script.it/script_event/export.ml
+++ b/script.it/script_event/export.ml
@@ -1,30 +1,32 @@
open StdLabels
open Brr
module State = Script_state.State
+module Path = Script_path
type t = unit
let process () state =
let my_host = Uri.host @@ Window.location @@ G.window in
- if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
+ ( 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.State.paths
- ~f:(fun path ->
-
- Layer.Paths.to_svg
- ~color:Blog.Nord.nord0
- (module Path.Fixed)
- Outline.(path.path, path.back)
- state.State.rendering
-
- )) in
+ 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.State.paths ~f:(fun path ->
+ Layer.Paths.to_svg
+ ~color:Blog.Nord.nord0
+ (module Path.Fixed)
+ Outline.(path.path, path.back)
+ state.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);
+ content );
state
diff --git a/script.it/script_event/mouse_down.ml b/script.it/script_event/mouse_down.ml
index 1c25a7d..88fefb4 100755
--- a/script.it/script_event/mouse_down.ml
+++ b/script.it/script_event/mouse_down.ml
@@ -1,84 +1,90 @@
module State = Script_state.State
module Selection = Script_state.Selection
+module Path = Script_path
-type t = { position : float * float
- ; timer : Elements.Timer.t }
+type t =
+ { position : float * float
+ ; timer : Elements.Timer.t
+ }
let process { 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 x, y = position in
+ Elements.Timer.start timer 0.3;
- 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 width = state.width
+ and angle = state.angle 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 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 get_any () =
- begin match Selection.get_from_paths position state.paths with
+ 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 () =
+ match Selection.get_from_paths position state.paths with
| _, None ->
- { state with
- mode = Out
- ; mouse_down_position = Gg.V2.of_tuple position }
+ { 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
+ 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
+ } )
+ in
+ (* First, check for a point in the selected path. If any of them in
+ found, check anything to select in all the elements *)
+ ( 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 ->
+ ( 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
+ { state with
+ mode = Selection other
+ ; mouse_down_position = Gg.V2.of_tuple position
+ } ) )
| Edit -> state
diff --git a/script.it/script_event/property.ml b/script.it/script_event/property.ml
index dbdc1de..b41d3f8 100755
--- a/script.it/script_event/property.ml
+++ b/script.it/script_event/property.ml
@@ -1,52 +1,52 @@
module State = Script_state.State
module Selection = Script_state.Selection
+module Path = Script_path
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
- State.post worker (`Back outline);
- state
+ (* Change width for the whole path *)
+ let outline =
+ { outline with
+ Outline.path =
+ Path.Fixed.map outline.Outline.path (fun p -> f p value)
+ }
+ in
+ State.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
- State.post worker (`Back outline);
- state
+ 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
+ State.post worker (`Back outline);
+ state
-type t = { prop : [`Angle | `Width ]
- ; value : float
- ; worker : Brr_webworkers.Worker.t
- }
-let process { prop; value ; worker } state =
+type t =
+ { prop : [ `Angle | `Width ]
+ ; value : float
+ ; worker : Brr_webworkers.Worker.t
+ }
+
+let process { prop; value; worker } state =
match prop with
| `Angle ->
- let angle = value in
- begin match state.State.mode with
-
+ let angle = value in
+ ( match state.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 }
- end
+ let state = { state with angle } in
+ Selection.find_selection t state.paths
+ |> update_property worker state angle Path.Point.set_angle
+ | _ -> { state with angle } )
| `Width ->
- let width = value in
- begin match state.State.mode with
-
+ let width = value in
+ ( match state.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 }
- end
+ let state = { state with width } in
+ Selection.find_selection t state.paths
+ |> update_property worker state width Path.Point.set_width
+ | _ -> { state with width } )
diff --git a/script.it/state/dune b/script.it/state/dune
index 7d4ef3f..d838c04 100755
--- a/script.it/state/dune
+++ b/script.it/state/dune
@@ -8,6 +8,6 @@
worker_messages
outline
layer
- path
+ script_path
)
)
diff --git a/script.it/state/selection.ml b/script.it/state/selection.ml
index f5f135a..3590a98 100755
--- a/script.it/state/selection.ml
+++ b/script.it/state/selection.ml
@@ -1,4 +1,5 @@
open StdLabels
+module Path = Script_path
type 'a selection =
| Path of 'a
@@ -6,59 +7,55 @@ type 'a selection =
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 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 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 select_path : Outline.t -> t = fun outline -> Path outline.Outline.id
- let point' = ref None in
- let dist = ref threshold in
+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
- );
+ 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)
+ 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
diff --git a/script.it/state/selection.mli b/script.it/state/selection.mli
index 9792a2d..2020dab 100755
--- a/script.it/state/selection.mli
+++ b/script.it/state/selection.mli
@@ -1,3 +1,5 @@
+module Path = Script_path
+
type 'a selection =
| Path of 'a
| Point of ('a * Path.Point.t)
@@ -6,6 +8,10 @@ type t = int selection
val threshold : float
+val get_from_paths :
+ float * float
+ -> Outline.t list
+ -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option
(** Return the closest path from the list to a given point.
The path is returned with all thoses informations :
@@ -15,19 +21,15 @@ val threshold : float
- 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
+val select_path : Outline.t -> t
+val select_point : Outline.t -> Gg.v2 -> 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
+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
index f3be91d..6c48979 100755
--- a/script.it/state/state.ml
+++ b/script.it/state/state.ml
@@ -1,3 +1,5 @@
+module Path = Script_path
+
type mode =
| Edit
| Selection of Selection.t
@@ -19,48 +21,37 @@ type state =
; mouse_down_position : Gg.v2
}
-include Application.Make(struct type t = state end)
+include Application.Make (struct
+ type t = state
+end)
+
+let post : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit =
+ Brr_webworkers.Worker.post
-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
+ | None -> Path.Path_Builder.add_point point path
| Some p1 ->
- let open Gg.V2 in
+ let open Gg.V2 in
+ let p1' = Path.Point.get_coord p1 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
- 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 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 }
+ { state with mode = Selection id; angle; width }
let init =
diff --git a/script.it/worker.ml b/script.it/worker.ml
index 62104ec..9455765 100755
--- a/script.it/worker.ml
+++ b/script.it/worker.ml
@@ -1,67 +1,60 @@
open Js_of_ocaml
+module Path = Script_path
-let (let=?) : 'a option -> ('a -> unit) -> unit
- = fun f opt -> Option.iter opt f
+let ( let=? ) : 'a option -> ('a -> unit) -> unit =
+ fun f opt -> Option.iter opt f
-let post_message
- : Worker_messages.from_worker -> unit
- = Worker.post_message
+let post_message : Worker_messages.from_worker -> unit = Worker.post_message
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.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})
+ post_message (`Complete { outline with path; back })
-let execute (command: Worker_messages.to_worker) =
- match command with
+let execute (command : Worker_messages.to_worker) =
+ match command with
(* Full rebuild, evaluate the whole path *)
- | `Complete outline ->
- rebuild outline
-
+ | `Complete outline -> 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
- rebuild { outline with path }
-
+ let=? path = Path.Fixed.remove_point outline.Outline.path point in
+ rebuild { outline with path }
(* Only evaluate the interior *)
| `Back outline ->
- let back = Path.Fixed.map
- outline.Outline.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 back})
-
+ let back =
+ Path.Fixed.map outline.Outline.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 back })
| `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})
-
+ 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
+ (* 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 }
- rebuild { outline with path }
-let () =
- Worker.set_onmessage execute
+let () = Worker.set_onmessage execute
diff --git a/script.it/worker_messages/dune b/script.it/worker_messages/dune
index b4e1c2b..5b80cd3 100755
--- a/script.it/worker_messages/dune
+++ b/script.it/worker_messages/dune
@@ -3,5 +3,5 @@
(libraries
js_of_ocaml
outline
- path)
+ script_path)
)
diff --git a/script.it/worker_messages/worker_messages.ml b/script.it/worker_messages/worker_messages.ml
index 7efd3d3..2d07895 100755
--- a/script.it/worker_messages/worker_messages.ml
+++ b/script.it/worker_messages/worker_messages.ml
@@ -1,19 +1,17 @@
open Js_of_ocaml
+module Path = Script_path
-type to_worker = [
- | `Complete of Outline.t
- | `DeletePoint of (Path.Point.t * Outline.t)
+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
+ ]
- (* 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 = [
- | `Complete of Outline.t
+type from_worker =
+ [ `Complete of Outline.t
| `Other of Js.js_string Js.t
-]
+ ]