summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xlayer/ductusEngine.ml (renamed from layer/ductusPrinter.ml)22
-rwxr-xr-xlayer/ductusEngine.mli2
-rwxr-xr-xlayer/ductusPrinter.mli2
-rwxr-xr-xlayer/fillEngine.ml (renamed from layer/fillPrinter.ml)40
-rwxr-xr-xlayer/fillEngine.mli2
-rwxr-xr-xlayer/fillPrinter.mli2
-rwxr-xr-xlayer/lineEngine.ml (renamed from layer/linePrinter.ml)26
-rwxr-xr-xlayer/lineEngine.mli2
-rwxr-xr-xlayer/linePrinter.mli2
-rwxr-xr-xlayer/paths.ml131
-rwxr-xr-xlayer/repr.ml2
-rwxr-xr-xpath/fixed.ml188
-rwxr-xr-xpath/fixed.mli4
-rwxr-xr-xscript.it/dune10
-rwxr-xr-xscript.it/outline.ml12
-rwxr-xr-xscript.it/script.ml22
-rwxr-xr-xscript.it/selection.ml26
-rwxr-xr-xscript.it/selection.mli6
-rwxr-xr-xscript.it/state.ml114
-rwxr-xr-xscript.it/worker.ml42
-rwxr-xr-xscript.it/worker_messages/dune1
-rwxr-xr-xscript.it/worker_messages/worker_messages.ml5
22 files changed, 367 insertions, 296 deletions
diff --git a/layer/ductusPrinter.ml b/layer/ductusEngine.ml
index db34481..b943467 100755
--- a/layer/ductusPrinter.ml
+++ b/layer/ductusEngine.ml
@@ -1,33 +1,33 @@
-module Make(Repr: Repr.PRINTER) = struct
+module Make(Layer: Repr.PRINTER) = struct
type point = Path.Point.t
type t =
- { path: (Repr.t)
+ { path: (Layer.t)
}
- type repr = Repr.t
+ type repr = Layer.t
let create_path
: 'b -> t
= fun _ ->
- { path = Repr.create ()
+ { path = Layer.create ()
}
let start
: point -> point -> t -> t
= fun p1 p2 { path } ->
let path =
- Repr.move_to (Path.Point.get_coord p1) path
- |> Repr.line_to (Path.Point.get_coord p2) in
+ 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 = Repr.move_to (Path.Point.get_coord p1) path in
- let path = Repr.line_to (Path.Point.get_coord p1') path in
+ 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
}
@@ -64,8 +64,8 @@ module Make(Repr: Repr.PRINTER) = struct
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 := Repr.move_to (Path.Point.get_coord point) !path;
- path := Repr.line_to (Path.Point.get_coord point') !path;
+ path := Layer.move_to (Path.Point.get_coord point) !path;
+ path := Layer.line_to (Path.Point.get_coord point') !path;
done;
{ path = !path }
@@ -76,7 +76,7 @@ module Make(Repr: Repr.PRINTER) = struct
let get
- : t -> Repr.t
+ : t -> Layer.t
= fun {path; _} ->
path
end
diff --git a/layer/ductusEngine.mli b/layer/ductusEngine.mli
new file mode 100755
index 0000000..e1660f4
--- /dev/null
+++ b/layer/ductusEngine.mli
@@ -0,0 +1,2 @@
+module Make(R:Repr.PRINTER):
+ Repr.ENGINE with type repr = R.t
diff --git a/layer/ductusPrinter.mli b/layer/ductusPrinter.mli
deleted file mode 100755
index cdcaa7c..0000000
--- a/layer/ductusPrinter.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-module Make(R:Repr.PRINTER):
- Repr.LAYER with type repr = R.t
diff --git a/layer/fillPrinter.ml b/layer/fillEngine.ml
index f3717c2..9a3fe7e 100755
--- a/layer/fillPrinter.ml
+++ b/layer/fillEngine.ml
@@ -1,19 +1,19 @@
-module Make(Repr: Repr.PRINTER) = struct
+module Make(Layer: Repr.PRINTER) = struct
type point = Path.Point.t
- type repr = Repr.t
+ type repr = Layer.t
type t =
- { path: Repr.t
- ; close : Repr.t -> Repr.t
+ { path: Layer.t
+ ; close : Layer.t -> Layer.t
}
let create_path
- : (Repr.t -> Repr.t) -> t
+ : (Layer.t -> Layer.t) -> t
= fun f ->
{ close = f
- ; path = Repr.create ()
+ ; path = Layer.create ()
}
(* Start a new path. *)
@@ -21,7 +21,7 @@ module Make(Repr: Repr.PRINTER) = struct
let start
: point -> point -> t -> t
= fun p1 _ {close ; path } ->
- let path = Repr.move_to (Path.Point.get_coord p1) path in
+ let path = Layer.move_to (Path.Point.get_coord p1) path in
{ close
; path
}
@@ -36,12 +36,12 @@ module Make(Repr: Repr.PRINTER) = struct
and p1' = Path.Point.get_coord p1' in
let path =
- Repr.move_to p1 t.path
- |> Repr.line_to p1'
- |> Repr.line_to p0'
- |> Repr.line_to p0
- |> Repr.line_to p1
- |> Repr.close in
+ 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}
@@ -56,22 +56,22 @@ module Make(Repr: Repr.PRINTER) = struct
in
let path =
- Repr.move_to p1 t.path
- |> Repr.line_to p1'
+ Layer.move_to p1 t.path
+ |> Layer.line_to p1'
(* Backward *)
- |> Repr.quadratic_to
+ |> Layer.quadratic_to
ctrl1'
ctrl0'
p0'
- |> Repr.line_to p0
+ |> Layer.line_to p0
(* Forward *)
- |> Repr.quadratic_to
+ |> Layer.quadratic_to
ctrl0
ctrl1
p1
- |> Repr.close
+ |> Layer.close
|> t.close in
@@ -83,7 +83,7 @@ module Make(Repr: Repr.PRINTER) = struct
t
let get
- : t -> Repr.t
+ : t -> Layer.t
= fun t ->
t.path
end
diff --git a/layer/fillEngine.mli b/layer/fillEngine.mli
new file mode 100755
index 0000000..e1660f4
--- /dev/null
+++ b/layer/fillEngine.mli
@@ -0,0 +1,2 @@
+module Make(R:Repr.PRINTER):
+ Repr.ENGINE with type repr = R.t
diff --git a/layer/fillPrinter.mli b/layer/fillPrinter.mli
deleted file mode 100755
index cdcaa7c..0000000
--- a/layer/fillPrinter.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-module Make(R:Repr.PRINTER):
- Repr.LAYER with type repr = R.t
diff --git a/layer/linePrinter.ml b/layer/lineEngine.ml
index d223760..3d15d9c 100755
--- a/layer/linePrinter.ml
+++ b/layer/lineEngine.ml
@@ -1,4 +1,4 @@
-module Make(Repr: Repr.PRINTER) = struct
+module Make(Layer: Repr.PRINTER) = struct
type point = Path.Point.t
@@ -9,24 +9,24 @@ module Make(Repr: Repr.PRINTER) = struct
let dist = 5.
and dist' = -5. in
- let path = Repr.move_to (point - (of_tuple (dist, dist))) path
- |> Repr.line_to ( point + (of_tuple (dist, dist)))
- |> Repr.move_to (point + (of_tuple (dist', dist)))
- |> Repr.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: (Repr.t)
+ { path: (Layer.t)
}
- type repr = Repr.t
+ type repr = Layer.t
let create_path
: 'b -> t
= fun _ ->
- { path = Repr.create ()
+ { path = Layer.create ()
}
let start
@@ -39,8 +39,8 @@ module Make(Repr: Repr.PRINTER) = struct
let line_to
: (point * point) -> (point * point) -> t -> t
= fun (p0, p1) _ {path} ->
- let path = Repr.move_to (Path.Point.get_coord p0) path
- |> Repr.line_to (Path.Point.get_coord p1)
+ let path = Layer.move_to (Path.Point.get_coord p0) path
+ |> Layer.line_to (Path.Point.get_coord p1)
|> mark p1 in
{ path
}
@@ -49,8 +49,8 @@ module Make(Repr: Repr.PRINTER) = struct
: (point * Gg.v2 * Gg.v2 * point) -> (point * Gg.v2 * Gg.v2 * point) -> t -> t
= 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)
+ 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 }
@@ -61,7 +61,7 @@ module Make(Repr: Repr.PRINTER) = struct
let get
- : t -> Repr.t
+ : t -> Layer.t
= fun {path; _} ->
path
diff --git a/layer/lineEngine.mli b/layer/lineEngine.mli
new file mode 100755
index 0000000..86ef5fb
--- /dev/null
+++ b/layer/lineEngine.mli
@@ -0,0 +1,2 @@
+module Make(R:Repr.PRINTER):
+ Repr.ENGINE with type repr = R.t
diff --git a/layer/linePrinter.mli b/layer/linePrinter.mli
deleted file mode 100755
index 191830a..0000000
--- a/layer/linePrinter.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-module Make(R:Repr.PRINTER):
- Repr.LAYER with type repr = R.t
diff --git a/layer/paths.ml b/layer/paths.ml
index 6d0157e..3a8bfe8 100755
--- a/layer/paths.ml
+++ b/layer/paths.ml
@@ -1,12 +1,16 @@
open StdLabels
(** Common module for ensuring that the function is evaluated only once *)
-module type REPRESENTABLE = sig
+(** This represent a single path, which can be transformed throug a [repr]
+ function. *)
+module type PATH = sig
type t
(** Represent the path *)
val repr
- : t -> (module Path.Repr.M with type point = Path.Point.t and type t = 's) -> 's -> 's
+ : t -> (module Path.Repr.M
+ with type point = Path.Point.t
+ and type t = 's) -> 's -> 's
end
type printer =
@@ -28,7 +32,10 @@ module type P = sig
end
-module MakePrinter(M:Repr.LAYER) : 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
@@ -76,22 +83,76 @@ module MakePrinter(M:Repr.LAYER) : P with type point = M.point and type t = M.t
let stop = M.stop
end
+(** Transform the two path, into a single one. *)
+module ReprSingle(T:PATH) = struct
+
+ type t = T.t * T.t
+
+ module R = struct
+ type point = Path.Point.t
+
+ type repr' =
+ | Move of (point)
+ | Line_to of (point * point)
+ | Quadratic of (point * Gg.v2 * Gg.v2 * point)
+
+ type t = repr' list
+
+ let start t actions =
+ (Move t)::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 stop
+ : t -> t
+ = fun v -> List.rev v
+
+ end
+
+ let repr
+ : t -> (module Path.Repr.M with type point = Path.Point.t and type t = 's) -> 's -> 's
+ = fun (type s) (path, _) (module Repr:Path.Repr.M with type point = Path.Point.t and type t = s) state ->
+ let elems = T.repr path (module R) [] in
+
+ let state = List.fold_left elems
+ ~init:state
+ ~f:(fun state -> function
+ | R.Move pt -> Repr.start pt state
+ | R.Line_to (p0, p1) -> Repr.line_to p0 p1 state
+ | R.Quadratic t -> Repr.quadratic_to t state
+ )
+ in Repr.stop state
+end
+
+module ReprFixed = ReprSingle(Path.Fixed)
+module ReprBuild = ReprSingle(Path.Path_Builder)
+
(* Canva representation *)
-module FillCanvaRepr = MakePrinter(FillPrinter.Make(CanvaPrinter))
-module DuctusCanvaRepr = MakePrinter(DuctusPrinter.Make(CanvaPrinter))
-module LineCanvaRepr = MakePrinter(LinePrinter.Make(CanvaPrinter))
+module FillCanva = FillEngine.Make(CanvaPrinter)
+module LineCanva = LineEngine.Make(CanvaPrinter)
+module DuctusCanva = FillEngine.Make(CanvaPrinter)
+
+module FillCanvaRepr = MakePrinter(FillCanva)
+module DuctusCanvaRepr = MakePrinter(DuctusCanva)
+module LineCanvaRepr = MakePrinter(LineCanva)
(* SVG representation *)
-module FillSVGRepr = MakePrinter(FillPrinter.Make(Svg))
-module DuctusSVGRepr = MakePrinter(DuctusPrinter.Make(Svg))
+module FillSVGRepr = MakePrinter(FillEngine.Make(Svg))
+module DuctusSVGRepr = MakePrinter(DuctusEngine.Make(Svg))
(** Draw a path to a canva *)
let to_canva
- : (module REPRESENTABLE with type t = 's) -> 's -> Brr_canvas.C2d.t -> printer -> unit
- = fun (type s) (module R:REPRESENTABLE with type t = s) path ctx -> function
+ : (module PATH with type t = 's) -> 's -> Brr_canvas.C2d.t -> printer -> unit
+ = fun (type s) (module R:PATH with type t = s) path ctx -> function
| `Fill ->
R.repr
path
@@ -117,8 +178,8 @@ let to_canva
(** Draw a path and represent it as SVG *)
let to_svg
- : (module REPRESENTABLE with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t
- = fun (type s) (module R:REPRESENTABLE with type t = s) ~color path -> function
+ : (module PATH with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t
+ = fun (type s) (module R:PATH with type t = s) ~color path -> function
| `Fill ->
(* In order to deal with over crossing path, I cut the path in as
@@ -158,49 +219,3 @@ let to_svg
| `Line ->
raise Not_found
-(** Transform the two fixed path, into a single one. *)
-module ReprFixed = struct
-
- type t = Path.Fixed.t * Path.Fixed.t
-
- module R = struct
- type point = Path.Point.t
-
- type repr' =
- | Move of (point)
- | Line_to of (point * point)
- | Quadratic of (point * Gg.v2 * Gg.v2 * point)
-
- type t = repr' list
-
- let start t actions =
- (Move t)::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 stop
- : t -> t
- = fun v -> List.rev v
-
- end
-
- let repr
- : t -> (module Path.Repr.M with type point = Path.Point.t and type t = 's) -> 's -> 's
- = fun (type s) (path, _) (module Repr:Path.Repr.M with type point = Path.Point.t and type t = s) state ->
- let elems = Path.Fixed.repr path (module R) [] in
-
- let state = List.fold_left elems
- ~init:state
- ~f:(fun state -> function
- | R.Move pt -> Repr.start pt state
- | R.Line_to (p0, p1) -> Repr.line_to p0 p1 state
- | R.Quadratic t -> Repr.quadratic_to t state
- )
- in Repr.stop state
-end
diff --git a/layer/repr.ml b/layer/repr.ml
index 85b0f3b..552e2b7 100755
--- a/layer/repr.ml
+++ b/layer/repr.ml
@@ -18,7 +18,7 @@ module type PRINTER = sig
end
-module type LAYER = sig
+module type ENGINE = sig
type t
type point = Path.Point.t
diff --git a/path/fixed.ml b/path/fixed.ml
index 2eda3c1..d61bb0a 100755
--- a/path/fixed.ml
+++ b/path/fixed.ml
@@ -37,14 +37,7 @@ module Make(Point:P) = struct
; move : path
}
- type t =
- { id: int
- ; path : step array
- }
-
- let id
- : t -> int
- = fun {id; _} -> id
+ type t = step array
module ToFixed = struct
type point = Point.t
@@ -93,20 +86,15 @@ module Make(Point:P) = struct
res
end
- let internal_id = ref 0
-
let to_fixed
: (module BUILDER with type t = 'a) -> 'a -> t
= fun (type s) (module Builder: BUILDER with type t = s) t ->
- incr internal_id;
- { id = !internal_id
- ; path = Builder.repr t (module ToFixed) (ToFixed.create_path ())
- |> ToFixed.get
- }
+ Builder.repr t (module ToFixed) (ToFixed.create_path ())
+ |> ToFixed.get
let repr
: t -> (module Repr.M with type point = Point.t and type t = 's) -> 's -> 's
- = fun (type s) {path; _} (module Repr : Repr.M with type point = Point.t and type t = s) repr ->
+ = fun (type s) t (module Repr : Repr.M with type point = Point.t and type t = s) repr ->
let repr_bezier p p0 bezier =
Repr.quadratic_to
( p0
@@ -115,7 +103,7 @@ module Make(Point:P) = struct
, bezier.p1 )
p in
- let _, repr = Array.fold_left path
+ let _, repr = Array.fold_left t
~init:(true, repr)
~f:(fun (first, path) element ->
let path = if first then
@@ -143,9 +131,9 @@ module Make(Point:P) = struct
None if the point is out of the curve *)
let distance
: Gg.v2 -> t -> approx option
- = fun point path ->
+ = fun point t ->
- Array.fold_left path.path
+ Array.fold_left t
~init:None
~f:(fun res step ->
match step.move with
@@ -180,25 +168,24 @@ module Make(Point:P) = struct
let map
: t -> (Point.t -> Point.t) -> t
- = fun {id; path} f ->
- let path = Array.map path
- ~f:(fun step ->
- match step.move with
- | Line p2 ->
- { point = f step.point
- ; move = Line (f p2)
- }
- | Curve bezier ->
- let point = f step.point in
- { point
- ; move = Curve {bezier with p1 = f bezier.p1} }
- ) in
- {id; path}
+ = fun t f ->
+ Array.map t
+ ~f:(fun step ->
+ match step.move with
+ | Line p2 ->
+ { point = f step.point
+ ; move = Line (f p2)
+ }
+ | Curve bezier ->
+ let point = f step.point in
+ { point
+ ; move = Curve {bezier with p1 = f bezier.p1} }
+ )
let iter
: t -> f:(Point.t -> unit) -> unit
- = fun {path; _} ~f ->
- Array.iter path
+ = fun t ~f ->
+ Array.iter t
~f:(fun step ->
match step.move with
| Line p2 -> f step.point; f p2
@@ -230,7 +217,7 @@ module Make(Point:P) = struct
}
- let build_from_three_points id p0 p1 p2 =
+ let build_from_three_points p0 p1 p2 =
let bezier =
Shapes.Bezier.quadratic_to_cubic
@@ Shapes.Bezier.three_points_quadratic
@@ -249,52 +236,48 @@ module Make(Point:P) = struct
and p1' = Point.copy p1 b0.Shapes.Bezier.p1
and p2' = Point.copy p2 b1.Shapes.Bezier.p1 in
- { id
- ; path =
- [| { point = p0'
- ; move =
- Curve { ctrl0 = b0.Shapes.Bezier.ctrl0
- ; ctrl1 = b0.Shapes.Bezier.ctrl1
- ; p1 = p1'
- } }
- ; { point = p1'
- ; move = Curve { ctrl0 = b1.Shapes.Bezier.ctrl0
- ; ctrl1 = b1.Shapes.Bezier.ctrl1
- ; p1 = p2' }
- } |]
- }
+ [| { point = p0'
+ ; move =
+ Curve { ctrl0 = b0.Shapes.Bezier.ctrl0
+ ; ctrl1 = b0.Shapes.Bezier.ctrl1
+ ; p1 = p1'
+ } }
+ ; { point = p1'
+ ; move = Curve { ctrl0 = b1.Shapes.Bezier.ctrl0
+ ; ctrl1 = b1.Shapes.Bezier.ctrl1
+ ; p1 = p2' }
+ } |]
(** Rebuild the whole curve by evaluating all the points *)
let rebuild
: t -> t option
- = fun {id ; path} ->
+ = fun t ->
- match Array.length path with
+ match Array.length t with
| 0 -> None
| 1 ->
- let step = Array.get path 0 in
+ let step = Array.get t 0 in
begin match step.move with
| Curve {p1; _}
| Line p1 ->
Some
- { id
- ; path= [|
- { point = step.point
- ; move = Line p1 } |]}
+ [|
+ { point = step.point
+ ; move = Line p1 } |]
end
| 2 ->
- let p0 = (Array.get path 0).point
- and p1 = (Array.get path 1).point
- and p2 = get_point' @@ Array.get path 1 in
- Some (build_from_three_points id p0 p1 p2)
+ let p0 = (Array.get t 0).point
+ and p1 = (Array.get t 1).point
+ and p2 = get_point' @@ Array.get t 1 in
+ Some (build_from_three_points p0 p1 p2)
| _ ->
(* Convert all the points in list *)
let points = List.init
- ~len:((Array.length path) )
- ~f:(fun i -> Point.get_coord @@ get_point' (Array.get path i)) in
- let p0 = Point.get_coord @@ (Array.get path 0).point in
+ ~len:((Array.length t) )
+ ~f:(fun i -> Point.get_coord @@ get_point' (Array.get t i)) in
+ let p0 = Point.get_coord @@ (Array.get t 0).point in
let points = p0::points in
@@ -305,8 +288,8 @@ module Make(Point:P) = struct
(* Now for each point, reassociate the same point information,
We should have as many points as before *)
- let rebuilded = Array.map2 beziers path ~f:assoc_point in
- Some {id; path = rebuilded}
+ let rebuilded = Array.map2 beziers t ~f:assoc_point in
+ Some rebuilded
end
let find_pt_index
@@ -338,44 +321,43 @@ module Make(Point:P) = struct
let remove_point
: t -> Point.t -> t option
- = fun {id; path} point ->
+ = fun t point ->
- match Array.length path with
+ match Array.length t with
| 0
| 1 -> None
| 2 ->
(* Two segment, we get the points and transform this into a single line *)
- let p0 = (Array.get path 0).point
- and p1 = (Array.get path 1).point
- and p2 = get_point' @@ Array.get path 1 in
+ let p0 = (Array.get t 0).point
+ and p1 = (Array.get t 1).point
+ and p2 = get_point' @@ Array.get t 1 in
let elms = List.filter [p0; p1; p2]
~f:(fun pt -> Point.id pt != Point.id point) in
begin match elms with
| p0::p1::[] ->
Some
- { id
- ; path = [| { point = p0
- ; move = Line p1 }|]}
+ [| { point = p0
+ ; move = Line p1 }|]
| _ -> None
end
| l ->
- match find_pt_index point path with
- | None -> Some {id; path}
+ match find_pt_index point t with
+ | None -> Some t
| Some 0 ->
(* Remove the first point *)
let path = Array.init (l-1)
- ~f:( fun i -> Array.get path (i+1)) in
- Some { id ; path }
- | Some n when n = (Array.length path) ->
+ ~f:( fun i -> Array.get t (i+1)) in
+ Some path
+ | Some n when n = (Array.length t) ->
(* Remove the last point *)
let path = Array.init (l-1)
- ~f:( fun i -> Array.get path i) in
- Some { id ; path }
+ ~f:( fun i -> Array.get t i) in
+ Some path
| Some n ->
let path' = Array.init (l-1)
~f:(fun i ->
if i < (n-1) then
- Array.get path (i)
+ Array.get t (i)
else if i = (n-1) then
(* We know that the point is not the first nor the last one.
So it is safe to call n-1 or n + 1 point
@@ -383,9 +365,9 @@ module Make(Point:P) = struct
We have to rebuild the point and set that
point_(-1).id = point_(+1).id
*)
- let p0 = (Array.get path i).point in
+ let p0 = (Array.get t i).point in
- match (Array.get path (i+1)).move with
+ match (Array.get t (i+1)).move with
| Line p1 ->
{ point = p0
; move = Line p1 }
@@ -394,11 +376,9 @@ module Make(Point:P) = struct
; move = Curve c }
else
- Array.get path (i+1)
+ Array.get t (i+1)
) in
- rebuild
- { id
- ; path=path'}
+ rebuild path'
let first_point
: step -> Point.t
@@ -406,46 +386,46 @@ module Make(Point:P) = struct
let replace_point
: t -> Point.t -> t option
- = fun {id; path } p ->
+ = fun t p ->
let add_path paths idx f points =
if 0 <= idx && idx < Array.length paths then
- let path = Array.get path idx in
+ let path = Array.get t idx in
Point.get_coord (f path)
:: points
else points in
- match Array.length path with
+ match Array.length t with
| 0 -> None
| 1 -> (* Only one point, easy ? *)
- let step = Array.get path 0 in
+ let step = Array.get t 0 in
begin match step.move with
| Curve {p1; _}
| Line p1 ->
let p0 = if (Point.id step.point = Point.id p) then p else step.point
and p1 = if (Point.id p1 = Point.id p) then p else p1 in
- Some {id; path=[|
- { point = p0
- ; move = Line p1 }
- |]}
+ Some [|
+ { point = p0
+ ; move = Line p1 }
+ |]
end
| 2 ->
- let p0 = (Array.get path 0).point
- and p1 = (Array.get path 1).point
- and p2 = get_point' @@ Array.get path 1 in
+ let p0 = (Array.get t 0).point
+ and p1 = (Array.get t 1).point
+ and p2 = get_point' @@ Array.get t 1 in
let p0 = if (Point.id p0 = Point.id p) then p else p0
and p1 = if (Point.id p1 = Point.id p) then p else p1
and p2 = if (Point.id p2 = Point.id p) then p else p2 in
- Some (build_from_three_points id p0 p1 p2)
+ Some (build_from_three_points p0 p1 p2)
(* More than two segmend, it is ok for a partial reevaluation *)
| _ ->
- match find_pt_index p path with
+ match find_pt_index p t with
| None -> None
| Some n ->
- let path = Array.copy path in
+ let path = Array.copy t in
let p0, p1 =
@@ -480,7 +460,7 @@ module Make(Point:P) = struct
if (n-2 < idx) && (idx < n +2) && idx < Array.length path then
Array.set path idx (assoc_point bezier (Array.get path idx))
);
- Some {id; path}
+ Some path
| Error _ ->
let bezier', _ = Shapes.Bezier.three_points_quadratic
(Point.get_coord p)
@@ -497,6 +477,6 @@ module Make(Point:P) = struct
; p1
})
};
- Some {id; path}
+ Some path
end
end
diff --git a/path/fixed.mli b/path/fixed.mli
index 862409b..111187c 100755
--- a/path/fixed.mli
+++ b/path/fixed.mli
@@ -22,10 +22,6 @@ module Make(Point:P) : sig
type t
- (** Return the identifier for this path *)
- val id
- : t -> int
-
(** Create a path from a builder *)
val to_fixed
: (module BUILDER with type t = 'a) -> 'a -> t
diff --git a/script.it/dune b/script.it/dune
index c51c43b..bb5ca5f 100755
--- a/script.it/dune
+++ b/script.it/dune
@@ -1,3 +1,11 @@
+(library
+ (name outline)
+ (libraries
+ path)
+ (modules outline)
+ (preprocess (pps ppx_hash js_of_ocaml-ppx))
+ )
+
(executable
(name script)
(libraries
@@ -8,6 +16,7 @@
blog
layer
worker_messages
+ outline
)
(modes js)
(modules script state selection)
@@ -29,6 +38,7 @@
shapes
path
worker_messages
+ outline
)
(modes js)
(preprocess (pps ppx_hash js_of_ocaml-ppx))
diff --git a/script.it/outline.ml b/script.it/outline.ml
new file mode 100755
index 0000000..4962d8e
--- /dev/null
+++ b/script.it/outline.ml
@@ -0,0 +1,12 @@
+let internal_path_id = ref 0
+
+type t =
+ { id : int
+ ; path: Path.Fixed.t
+ ; back: Path.Fixed.t
+ }
+
+let get_id =
+ let id = !internal_path_id in
+ incr internal_path_id;
+ id
diff --git a/script.it/script.ml b/script.it/script.ml
index 05bec1b..9ef15fe 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -225,7 +225,7 @@ let on_change canva mouse_position timer state =
in
- Layer.Paths.to_canva (module Path.Path_Builder) current context state.rendering;
+ Layer.Paths.to_canva (module Layer.Paths.ReprBuild) (current, current) context state.rendering;
List.iter state.paths
~f:(fun path ->
@@ -233,7 +233,7 @@ let on_change canva mouse_position timer state =
let () = match state.mode with
| Selection (Path id)
| Selection (Point (id, _)) ->
- begin match id = (Path.Fixed.id path) with
+ 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);
@@ -245,7 +245,8 @@ let on_change canva mouse_position timer state =
| _ -> ()
in
- Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (path, path) context state.rendering
+ let p = path.Outline.path in
+ Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (p, p) context state.rendering
);
let () = match state.mode with
@@ -254,8 +255,9 @@ let on_change canva mouse_position timer state =
List.iter
state.paths
~f:(fun path ->
- if id = Path.Fixed.id path then
- Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (path, path) context `Line
+ if id = path.Outline.id then
+ let p = path.Outline.path in
+ Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (p, p) context `Line
)
| Selection (Point (id, point)) ->
(* As before, mark the selected path *)
@@ -264,20 +266,20 @@ let on_change canva mouse_position timer state =
List.iter
state.paths
~f:(fun path ->
- if id = Path.Fixed.id path then
+ if id = path.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
- path
+ path.Outline.path
else
let point' = Path.Point.copy point pos_v2 in
- begin match Path.Fixed.replace_point path point' with
- | None -> path
+ begin match Path.Fixed.replace_point path.Outline.path point' with
+ | None -> path.Outline.path
| Some p -> p
end
- | None -> path end in
+ | None -> path.Outline.path end in
Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (path, path) context `Line
);
diff --git a/script.it/selection.ml b/script.it/selection.ml
index 591ea38..d00f026 100755
--- a/script.it/selection.ml
+++ b/script.it/selection.ml
@@ -7,32 +7,32 @@ type t =
let threshold = 20.
let get_from_paths
- : (float * float) -> Path.Fixed.t list -> float * (Gg.v2 * Path.Fixed.t * Path.Point.t * Path.Point.t) option
- = fun position 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 paths
+ List.fold_left outlines
~init:(threshold, None)
- ~f:(fun (dist, selection) path ->
- match Path.Fixed.distance point path with
+ ~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, path, p0, p1)
+ ratio, Some (closest_point, outline, p0, p1)
| _ -> dist, selection
)
let select_path
- : Path.Fixed.t -> t
- = fun path -> Path (Path.Fixed.id path)
+ : Outline.t -> t
+ = fun outline -> Path outline.Outline.id
let select_point
- : Path.Fixed.t -> Gg.v2 -> t
- = fun path v2_point ->
+ : Outline.t -> Gg.v2 -> t
+ = fun outline v2_point ->
let point' = ref None in
let dist = ref threshold in
Path.Fixed.iter
- path
+ outline.Outline.path
~f:(fun p ->
let open Gg.V2 in
let new_dist = norm ((Path.Point.get_coord p) - v2_point) in
@@ -45,9 +45,9 @@ let select_point
match !point' with
| Some point ->
- Point (Path.Fixed.id path, point)
+ Point (outline.Outline.id, point)
| None ->
- Path (Path.Fixed.id path)
+ Path (outline.Outline.id)
(*
(* If the point does not exists, find the exact point on the curve *)
diff --git a/script.it/selection.mli b/script.it/selection.mli
index a405edc..984eae6 100755
--- a/script.it/selection.mli
+++ b/script.it/selection.mli
@@ -14,10 +14,10 @@ val threshold : float
*)
val get_from_paths
- : (float * float) -> Path.Fixed.t list -> float * (Gg.v2 * Path.Fixed.t * Path.Point.t * Path.Point.t) option
+ : (float * float) -> Outline.t list -> float * (Gg.v2 * Outline.t * Path.Point.t * Path.Point.t) option
val select_path
- : Path.Fixed.t -> t
+ : Outline.t -> t
val select_point
- : Path.Fixed.t -> Gg.v2 -> t
+ : Outline.t -> Gg.v2 -> t
diff --git a/script.it/state.ml b/script.it/state.ml
index c147c2c..403efbe 100755
--- a/script.it/state.ml
+++ b/script.it/state.ml
@@ -23,7 +23,7 @@ type render_event =
type worker_event =
[ `Basic of Jv.t
- | `Complete of Path.Fixed.t
+ | `Complete of Outline.t
]
type events =
@@ -42,7 +42,7 @@ type events =
*)
type state =
{ mode : mode
- ; paths : Path.Fixed.t list
+ ; paths : Outline.t list
; current : Path.Path_Builder.t
; width : float
; angle : float
@@ -78,29 +78,31 @@ let insert_or_replace state ((x, y) as p) stamp path =
(** Update the path in the selection with the given function applied to
every point *)
-let update_path_selection id paths f =
- List.map paths
- ~f:(fun path ->
- let id' = Path.Fixed.id path in
- match id = id' with
- | false -> path
- | true -> Path.Fixed.map path f
- )
+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 Path.Fixed.id p = path_id with
+ match p.Outline.id = path_id with
| false -> p
| true ->
- Path.Fixed.map
- p
- (fun p ->
- if (Path.Point.id p = Path.Point.id point) then
- f p
- else
- p
- )
+ { 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 }
@@ -129,7 +131,7 @@ let delete state worker =
let paths = List.filter
state.paths
~f:(fun p ->
- Path.Fixed.id p != id
+ p.Outline.id != id
) in
{ state with paths ; mode = Out}
@@ -137,7 +139,7 @@ let delete state worker =
List.iter
state.paths
~f:(fun p ->
- let id' = Path.Fixed.id p in
+ let id' = p.Outline.id in
match id' = id with
| false -> ()
| true ->
@@ -165,30 +167,46 @@ let tick (delay, point) state =
{ state with current }
| _ -> state
-let angle angle 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
+ 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
+ post worker (`Back outline);
{ state with angle }
| _ ->
{ state with angle}
-let width width state =
+let width worker width state =
match state.mode with
| Selection (Path s) ->
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 }
@@ -234,12 +252,12 @@ let do_action
{ state with
mode = Out }
| dist, Some selection ->
- let _, path, _, _ = selection in
- if Path.Fixed.id path != id then
+ 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 path (Gg.V2.of_tuple position) in
+ let selection = Selection.select_point outline (Gg.V2.of_tuple position) in
match selection with
| Path _ ->
{ state with mode = Selection selection }
@@ -263,9 +281,21 @@ let do_action
let current = insert_or_replace state point stamp state.current in
let paths =
- let last = Path.Fixed.to_fixed
+
+ let path = Path.Fixed.to_fixed
(module Path.Path_Builder)
- current
+ 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
+
+ let last =
+ { Outline.path = path
+ ; Outline.back = back
+ ; Outline.id = Outline.get_id
+ }
in
let () = post worker (`Complete last) in
@@ -298,14 +328,17 @@ let do_action
else
let point' = Path.Point.copy point mouse_v2 in
List.iter state.paths
- ~f:(fun path ->
- let id' = Path.Fixed.id path in
+ ~f:(fun outline ->
+ let id' = outline.Outline.id in
match id = id' with
| false -> ()
| true ->
Option.iter
- (fun p -> post worker (`Complete p))
- (Path.Fixed.replace_point path point')
+ (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')) }
| `Delete, _ ->
@@ -325,7 +358,7 @@ let do_action
Layer.Paths.to_svg
~color:Blog.Nord.nord0
(module Layer.Paths.ReprFixed)
- (path, path)
+ (path.Outline.path, path.Outline.path)
state.rendering
)) in
@@ -347,9 +380,9 @@ let do_action
state
| `Angle value , _ ->
- angle value state
+ angle worker value state
| `Width value, _ ->
- width value state
+ width worker value state
| `Rendering rendering, _ ->
@@ -361,14 +394,13 @@ let do_action
state
| `Complete path, _ ->
- let id = Path.Fixed.id path in
+ let id = path.Outline.id in
let paths = List.map state.paths
- ~f:(fun path' ->
- let id' = Path.Fixed.id path' in
+ ~f:(fun line ->
+ let id' = line.Outline.id in
match id = id' with
- | false -> path'
- | true ->
- path
+ | false -> line
+ | true -> path
) in
{ state with paths }
diff --git a/script.it/worker.ml b/script.it/worker.ml
index 00e4595..898df39 100755
--- a/script.it/worker.ml
+++ b/script.it/worker.ml
@@ -1,21 +1,43 @@
open Js_of_ocaml
+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 execute (command: [> Worker_messages.to_worker]) =
match command with
- | `Complete path ->
- begin match Path.Fixed.rebuild path with
- | Some path -> Worker.post_message (`Complete path)
- | None -> ()
- end
- | `DeletePoint (point, path) ->
- begin match Path.Fixed.remove_point path point with
- | Some path -> Worker.post_message (`Complete path)
- | None -> ()
- end
+
+ (* 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
+ Worker.post_message (`Complete {outline with path; back})
+
+ (* 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
+ Worker.post_message (`Complete {outline with path; back})
+
+ (* 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
+ Worker.post_message (`Complete {outline with back})
+
| _ ->
post_message (`Other (Js.string "Unknown message received"))
diff --git a/script.it/worker_messages/dune b/script.it/worker_messages/dune
index d1511a6..b4e1c2b 100755
--- a/script.it/worker_messages/dune
+++ b/script.it/worker_messages/dune
@@ -2,5 +2,6 @@
(name worker_messages)
(libraries
js_of_ocaml
+ outline
path)
)
diff --git a/script.it/worker_messages/worker_messages.ml b/script.it/worker_messages/worker_messages.ml
index 992ec29..a4d05c8 100755
--- a/script.it/worker_messages/worker_messages.ml
+++ b/script.it/worker_messages/worker_messages.ml
@@ -1,8 +1,9 @@
open Js_of_ocaml
type to_worker = [
- | `Complete of Path.Fixed.t
- | `DeletePoint of (Path.Point.t * Path.Fixed.t)
+ | `Complete of Outline.t
+ | `DeletePoint of (Path.Point.t * Outline.t)
+ | `Back of Outline.t
]
type from_worker = [
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 01:51:44 +0000