aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xlayer/paths.ml161
-rwxr-xr-xpath/builder.ml18
-rwxr-xr-xpath/builder.mli3
-rwxr-xr-xpath/fixed.ml7
-rwxr-xr-xscript.it/outline.ml2
-rwxr-xr-xscript.it/script.ml23
-rwxr-xr-xscript.it/state.ml76
-rwxr-xr-xscript.it/worker.ml6
-rwxr-xr-xscript.it/worker_messages/worker_messages.ml2
9 files changed, 172 insertions, 126 deletions
diff --git a/layer/paths.ml b/layer/paths.ml
index 3a8bfe8..d3baf02 100755
--- a/layer/paths.ml
+++ b/layer/paths.ml
@@ -84,19 +84,19 @@ module MakePrinter(M:Repr.ENGINE) : P
end
(** Transform the two path, into a single one. *)
-module ReprSingle(T:PATH) = struct
+module ReprSingle = struct
- type t = T.t * T.t
+ type point = Path.Point.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 repr' =
- | Move of (point)
- | Line_to of (point * point)
- | Quadratic of (point * Gg.v2 * Gg.v2 * point)
+ module R = struct
+ type t = repr list
- type t = repr' list
+ type point = Path.Point.t
let start t actions =
(Move t)::actions
@@ -111,92 +111,109 @@ module ReprSingle(T:PATH) = struct
let stop
: t -> t
- = fun v -> List.rev v
+ = fun v -> 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
+ : (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
-module ReprFixed = ReprSingle(Path.Fixed)
-module ReprBuild = ReprSingle(Path.Path_Builder)
-
(* Canva representation *)
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)
+module DuctusCanva = DuctusEngine.Make(CanvaPrinter)
(* SVG representation *)
-module FillSVGRepr = MakePrinter(FillEngine.Make(Svg))
-module DuctusSVGRepr = MakePrinter(DuctusEngine.Make(Svg))
+module FillSVG = FillEngine.Make(Svg)
+module DuctusSVG = DuctusEngine.Make(Svg)
+
+(** Draw a path to a canva.contents
-(** Draw a path to a canva *)
+ The code may seems scary, but is very repetitive. Firt, all points (from the
+ 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 -> Brr_canvas.C2d.t -> printer -> unit
- = fun (type s) (module R:PATH with type t = s) path ctx -> function
+ : (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 ->
- R.repr
- path
- (module FillCanvaRepr)
- (FillCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
- |> FillCanvaRepr.get
+ 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 ->
- R.repr
- path
- (module LineCanvaRepr)
- (LineCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
- |> LineCanvaRepr.get
+ 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 ->
- R.repr
- path
- (module DuctusCanvaRepr)
- (DuctusCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
- |> DuctusCanvaRepr.get
+ 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 -> printer -> Brr.El.t
- = fun (type s) (module R:PATH with type t = s) ~color path -> function
+ : (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 _ = R.repr
- path
- (module FillSVGRepr)
- (FillSVGRepr.create_path
- (fun p ->
- let repr = Svg.path
- ~at:Brr.At.[ v (Jstr.v "d") p ]
- [] in
-
- paths := repr::!paths;
- Jstr.empty)) 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.[
@@ -205,11 +222,18 @@ let to_svg
!paths
| `Ductus ->
- let svg_path = R.repr
- path
- (module DuctusSVGRepr)
- (DuctusSVGRepr.create_path (fun _ -> Jstr.empty))
- |> DuctusSVGRepr.get in
+ 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
@@ -218,4 +242,3 @@ let to_svg
[]
| `Line ->
raise Not_found
-
diff --git a/path/builder.ml b/path/builder.ml
index 166c073..4403599 100755
--- a/path/builder.ml
+++ b/path/builder.ml
@@ -203,4 +203,22 @@ module Make(Point:P) = struct
path
)
+ let map
+ : t -> (Point.t -> Point.t) -> t
+ = fun (points, beziers) f ->
+ let points = List.map
+ points
+ ~f
+ and beziers = List.map
+ beziers
+ ~f:(fun bezier ->
+
+ { p0 = f bezier.p0
+ ; p1 = f bezier.p1
+ ; ctrl0 = Point.(get_coord (f ( copy bezier.p0 bezier.ctrl0)))
+ ; ctrl1 = Point.(get_coord (f ( copy bezier.p1 bezier.ctrl1)))
+ }
+ ) in
+ points, beziers
+
end
diff --git a/path/builder.mli b/path/builder.mli
index ff66bcb..2afbd4b 100755
--- a/path/builder.mli
+++ b/path/builder.mli
@@ -37,4 +37,7 @@ module Make(Point:P) : sig
val repr
: t -> (module Repr.M with type point = Point.t and type t = 's) -> 's -> 's
+ val map
+ : t -> (Point.t -> Point.t) -> t
+
end
diff --git a/path/fixed.ml b/path/fixed.ml
index d61bb0a..1362ad3 100755
--- a/path/fixed.ml
+++ b/path/fixed.ml
@@ -179,7 +179,12 @@ module Make(Point:P) = struct
| Curve bezier ->
let point = f step.point in
{ point
- ; move = Curve {bezier with p1 = f bezier.p1} }
+ ; move = Curve
+ { p1 = f bezier.p1
+ ; ctrl0 = Point.get_coord (f (Point.copy step.point bezier.ctrl0))
+ ; ctrl1 = Point.get_coord (f (Point.copy bezier.p1 bezier.ctrl1))
+ }
+ }
)
let iter
diff --git a/script.it/outline.ml b/script.it/outline.ml
index 4962d8e..0dbecd0 100755
--- a/script.it/outline.ml
+++ b/script.it/outline.ml
@@ -6,7 +6,7 @@ type t =
; back: Path.Fixed.t
}
-let get_id =
+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 9ef15fe..3859cc9 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -225,7 +225,10 @@ let on_change canva mouse_position timer state =
in
- Layer.Paths.to_canva (module Layer.Paths.ReprBuild) (current, current) 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 ->
@@ -246,7 +249,7 @@ let on_change canva mouse_position timer state =
in
let p = path.Outline.path in
- Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (p, p) context state.rendering
+ Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context state.rendering
);
let () = match state.mode with
@@ -257,7 +260,7 @@ let on_change canva mouse_position timer state =
~f:(fun path ->
if id = path.Outline.id then
let p = path.Outline.path in
- Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (p, p) context `Line
+ Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context `Line
)
| Selection (Point (id, point)) ->
(* As before, mark the selected path *)
@@ -265,22 +268,22 @@ let on_change canva mouse_position timer state =
List.iter
state.paths
- ~f:(fun path ->
- if id = path.Outline.id then
+ ~f:(fun outline ->
+ if id = outline.Outline.id then
let path = begin match pos with
| Some pos ->
let pos_v2 = Gg.V2.of_tuple pos in
if Elements.Timer.delay timer < 0.3 then
- path.Outline.path
+ outline.Outline.path
else
let point' = Path.Point.copy point pos_v2 in
- begin match Path.Fixed.replace_point path.Outline.path point' with
- | None -> path.Outline.path
+ begin match Path.Fixed.replace_point outline.Outline.path point' with
+ | None -> outline.Outline.path
| Some p -> p
end
- | None -> path.Outline.path end in
- Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (path, path) context `Line
+ | None -> outline.Outline.path end in
+ Layer.Paths.to_canva (module Path.Fixed) (path, outline.Outline.back) context `Line
);
(* Now draw the selected point *)
diff --git a/script.it/state.ml b/script.it/state.ml
index 403efbe..fd35554 100755
--- a/script.it/state.ml
+++ b/script.it/state.ml
@@ -21,10 +21,7 @@ type render_event =
`Rendering of Layer.Paths.printer
]
-type worker_event =
- [ `Basic of Jv.t
- | `Complete of Outline.t
- ]
+type worker_event = Worker_messages.from_worker
type events =
[ canva_events
@@ -280,31 +277,31 @@ let do_action
| Some _ ->
let current = insert_or_replace state point stamp state.current in
- let paths =
-
- 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
-
- let last =
- { Outline.path = path
- ; Outline.back = back
- ; Outline.id = Outline.get_id
- }
- in
-
- let () = post worker (`Complete last) in
- last::state.paths
- and current = Path.Path_Builder.empty in
-
- { state with
- mode = Out
- ; paths; current }
+ 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
+
+ let last =
+ { Outline.path = path
+ ; Outline.back = back
+ ; Outline.id = Outline.get_id ()
+ }
+ in
+
+ (* Send to the worker for a full review *)
+ let () = 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 ->
@@ -357,8 +354,8 @@ let do_action
Layer.Paths.to_svg
~color:Blog.Nord.nord0
- (module Layer.Paths.ReprFixed)
- (path.Outline.path, path.Outline.path)
+ (module Path.Fixed)
+ (path.Outline.path, path.Outline.back)
state.rendering
)) in
@@ -388,20 +385,17 @@ let do_action
| `Rendering rendering, _ ->
{ state with rendering}
-
- | `Basic t, _ ->
+ | `Other t, _ ->
Console.(log [t]);
state
- | `Complete path, _ ->
- let id = path.Outline.id in
- let paths = List.map state.paths
+ | `Complete newPath, _ ->
+ let paths = List.map
+ state.paths
~f:(fun line ->
- let id' = line.Outline.id in
- match id = id' with
- | false -> line
- | true -> path
- ) in
+ match newPath.Outline.id = line.Outline.id with
+ | true -> newPath
+ | false -> line) in
{ state with paths }
diff --git a/script.it/worker.ml b/script.it/worker.ml
index 898df39..51fe49c 100755
--- a/script.it/worker.ml
+++ b/script.it/worker.ml
@@ -19,7 +19,7 @@ let execute (command: [> Worker_messages.to_worker]) =
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})
+ post_message (`Complete {outline with path; back})
(* Remove the point from the main line, and reevaluate the whole path *)
| `DeletePoint (point, outline) ->
@@ -28,7 +28,7 @@ let execute (command: [> Worker_messages.to_worker]) =
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})
+ post_message (`Complete {outline with path; back})
(* Only evaluate the interior *)
| `Back outline ->
@@ -36,7 +36,7 @@ let execute (command: [> Worker_messages.to_worker]) =
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 (`Complete {outline with back})
| _ ->
post_message (`Other (Js.string "Unknown message received"))
diff --git a/script.it/worker_messages/worker_messages.ml b/script.it/worker_messages/worker_messages.ml
index a4d05c8..b33bb23 100755
--- a/script.it/worker_messages/worker_messages.ml
+++ b/script.it/worker_messages/worker_messages.ml
@@ -7,6 +7,6 @@ type to_worker = [
]
type from_worker = [
- | `Complete of Path.Fixed.t
+ | `Complete of Outline.t
| `Other of Js.js_string Js.t
]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 00:10:27 +0000