aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xlayer/ductusPrinter.mli28
-rwxr-xr-xlayer/fillPrinter.ml132
-rwxr-xr-xlayer/fillPrinter.mli27
-rwxr-xr-xlayer/linePrinter.mli29
-rwxr-xr-xlayer/paths.ml50
-rwxr-xr-xscript.it/script.ml9
-rwxr-xr-xscript.it/state.ml4
7 files changed, 199 insertions, 80 deletions
diff --git a/layer/ductusPrinter.mli b/layer/ductusPrinter.mli
new file mode 100755
index 0000000..cd849ef
--- /dev/null
+++ b/layer/ductusPrinter.mli
@@ -0,0 +1,28 @@
+module Make(Repr:Repr.PRINTER): sig
+
+ type repr
+
+ type t = Path.Point.t
+
+ val create_path
+ : 'b -> repr
+
+ (* Start a new path. *)
+ val start
+ : 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 stop
+ : repr -> repr
+
+ val get
+ : repr -> Repr.t
+
+end
+
+
diff --git a/layer/fillPrinter.ml b/layer/fillPrinter.ml
index 19f0ac4..9b6546c 100755
--- a/layer/fillPrinter.ml
+++ b/layer/fillPrinter.ml
@@ -1,47 +1,7 @@
module Point = Path.Point
-
-
module Make(Repr: Repr.PRINTER) = struct
- (* Divide a curve in subelements *)
- let rec divide level p0 ctrl0 ctrl1 p1 path =
-
- let bezier =
- { Shapes.Bezier.p0 = Path.Point.get_coord p0
- ; ctrl0
- ; ctrl1
- ; p1 = Path.Point.get_coord p1
- } in
-
- let ratio = 0.5 in
- let bezier0, bezier1 = Shapes.Bezier.slice ratio bezier in
- let point = Path.Point.mix ratio bezier0.Shapes.Bezier.p1 p0 p1 in
-
- let ctrl0_0 = Point.copy p0 bezier0.Shapes.Bezier.ctrl0
- and ctrl0_1 = Point.copy point bezier0.Shapes.Bezier.ctrl1
-
- and ctrl1_0 = Point.copy point bezier1.Shapes.Bezier.ctrl0
- and ctrl1_1 = Point.copy p1 bezier1.Shapes.Bezier.ctrl1 in
-
-
- match level with
- | 0 ->
- path :=
- Repr.quadratic_to
- (Point.get_coord' @@ ctrl1_1)
- (Point.get_coord' @@ ctrl1_0)
- (Point.get_coord' point) !path;
-
- path :=
- Repr.quadratic_to
- (Point.get_coord' @@ ctrl0_1)
- (Point.get_coord' @@ ctrl0_0)
- (Point.get_coord' p0) !path;
- | n ->
- divide (n-1) point (Point.get_coord ctrl1_0) (Point.get_coord ctrl1_1) p1 path;
- divide (n-1) p0 (Point.get_coord ctrl0_0) (Point.get_coord ctrl0_1) point path;
-
type t = Point.t
type repr =
@@ -57,55 +17,83 @@ module Make(Repr: Repr.PRINTER) = struct
}
(* Start a new path. *)
- let start
- : Path.Point.t -> repr -> repr
- = fun t {close ; path } ->
- let path = Repr.move_to (Point.get_coord t) path in
+
+ let start'
+ : Gg.v2 -> Gg.v2 -> repr -> repr
+ = fun p1 _ {close ; path } ->
+ let path = Repr.move_to p1 path in
{ close
; path
}
- let line_to
- : Point.t -> Point.t -> repr -> repr
- = fun p0 p1 t ->
+ let start
+ : Path.Point.t -> repr -> repr
+ = fun pt t ->
+ let p = (Point.get_coord pt) in
+ start' p p t
+
+ let line_to'
+ : (Gg.v2 * Gg.v2) -> (Gg.v2 * Gg.v2) -> repr -> repr
+ = fun (p0, p1) (p0', p1') t ->
let path =
- Repr.move_to (Point.get_coord p1) t.path
- |> Repr.line_to (Point.get_coord' p1)
- |> Repr.line_to (Point.get_coord' p0)
- |> Repr.line_to (Point.get_coord p0)
- |> Repr.line_to (Point.get_coord p1)
+ 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
let path = t.close path in
{ t with path}
- let quadratic_to
- : (t * Gg.v2 * Gg.v2 * t) -> repr -> repr
- = fun (p0, ctrl0, ctrl1, p1) t ->
+ let line_to
+ : Point.t -> Point.t -> repr -> repr
+ = fun p0 p1 t ->
- let ctrl0' = Point.copy p1 ctrl0
- and ctrl1' = Point.copy p1 ctrl1 in
+ line_to'
+ ( Point.get_coord p0
+ , Point.get_coord p1 )
+ ( Point.get_coord' p0
+ , Point.get_coord' p1 )
+ t
- let path = Repr.move_to (Point.get_coord p1) t.path
- |> Repr.line_to (Point.get_coord' p1) in
- let path = ref path in
+ let quadratic_to'
+ : (Gg.v2 * Gg.v2 * Gg.v2 * Gg.v2) -> (Gg.v2 * Gg.v2 * Gg.v2 * Gg.v2) -> repr -> repr
+ = fun (p0, ctrl0, ctrl1, p1) (p0', ctrl0', ctrl1', p1') t ->
- (* Backward *)
- divide 3 p0 ctrl0 ctrl1 p1 path ;
- path := Repr.line_to (Point.get_coord p0) !path;
- (* Forward *)
- path := Repr.quadratic_to
- (Point.get_coord ctrl0')
- (Point.get_coord ctrl1')
- (Point.get_coord p1) !path;
+ let path =
+ Repr.move_to p1 t.path
+ |> Repr.line_to p1'
- let path = !path in
+ (* Backward *)
+ |> Repr.quadratic_to
+ ctrl1'
+ ctrl0'
+ p0'
+ |> Repr.line_to p0
- let path = Repr.close path in
+ (* Forward *)
+ |> Repr.quadratic_to
+ ctrl0
+ ctrl1
+ p1
+ |> Repr.close
+ |> t.close in
+
+
+ { t with path }
+
+ let quadratic_to
+ : (t * Gg.v2 * Gg.v2 * t) -> repr -> repr
+ = fun (p0, ctrl0, ctrl1, p1) t ->
- let path = t.close path in
- { t with path}
+ let ctrl0' = Point.get_coord' @@ Point.copy p0 ctrl0
+ and ctrl1' = Point.get_coord' @@ Point.copy p1 ctrl1 in
+ quadratic_to'
+ (Point.get_coord p0, ctrl0, ctrl1, Point.get_coord p1)
+ (Point.get_coord' p0, ctrl0', ctrl1', Point.get_coord' p1)
+ t
let stop
: repr -> repr
diff --git a/layer/fillPrinter.mli b/layer/fillPrinter.mli
new file mode 100755
index 0000000..c1bb30e
--- /dev/null
+++ b/layer/fillPrinter.mli
@@ -0,0 +1,27 @@
+module Make(Repr:Repr.PRINTER): sig
+
+ type repr
+
+ type t = Path.Point.t
+
+ val create_path
+ : (Repr.t -> Repr.t) -> repr
+
+ (* Start a new path. *)
+ val start
+ : 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 stop
+ : repr -> repr
+
+ val get
+ : repr -> Repr.t
+
+end
+
diff --git a/layer/linePrinter.mli b/layer/linePrinter.mli
new file mode 100755
index 0000000..b6e9603
--- /dev/null
+++ b/layer/linePrinter.mli
@@ -0,0 +1,29 @@
+module Make(Repr:Repr.PRINTER): sig
+
+ type repr
+
+ type t = Path.Point.t
+
+ val create_path
+ : 'b -> repr
+
+ (* Start a new path. *)
+ val start
+ : 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 stop
+ : repr -> repr
+
+ val get
+ : repr -> Repr.t
+
+end
+
+
+
diff --git a/layer/paths.ml b/layer/paths.ml
index 927a5f9..e170767 100755
--- a/layer/paths.ml
+++ b/layer/paths.ml
@@ -1,3 +1,4 @@
+open StdLabels
(** Common module for ensuring that the function is evaluated only once *)
module type REPRESENTABLE = sig
@@ -13,7 +14,6 @@ end
module FillCanvaRepr = FillPrinter.Make(CanvaPrinter)
module DuctusCanvaRepr = DuctusPrinter.Make(CanvaPrinter)
module LineCanvaRepr = LinePrinter.Make(CanvaPrinter)
-module WireCanvaRepr = WireFramePrinter.Make(CanvaPrinter)
(* SVG representation *)
@@ -21,7 +21,6 @@ module FillSVGRepr = FillPrinter.Make(Svg)
module DuctusSVGRepr = DuctusPrinter.Make(Svg)
module WireSVGRepr = WireFramePrinter.Make(Svg)
-
type printer =
[ `Fill
| `Line
@@ -96,3 +95,50 @@ 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 t = Path.Point.t
+
+ type repr' =
+ | Move of (Path.Point.t)
+ | Line_to of (Path.Point.t * Path.Point.t)
+ | Quadratic of (t * Gg.v2 * Gg.v2 * t)
+
+ type repr = repr' list
+
+ let start t actions =
+ (Move t)::actions
+
+ let line_to p0 p1 actions =
+ Line_to (p0, p1)::actions
+
+ let quadratic_to
+ : (t * Gg.v2 * Gg.v2 * t) -> repr -> repr
+ = fun q actions ->
+ (Quadratic q)::actions
+
+ let stop
+ : repr -> repr
+ = fun v -> List.rev v
+
+ end
+
+ let repr
+ : t -> (module Path.Repr.M with type t = Path.Point.t and type repr = 's) -> 's -> 's
+ = fun (type s) (path, _) (module Repr:Path.Repr.M with type t = Path.Point.t and type repr = 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/script.it/script.ml b/script.it/script.ml
index ffdff9a..05bec1b 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -4,6 +4,7 @@ open Brr
open Brr_note
+
(** Create the element in the page, and the event handler *)
let canva
: Brr.El.t -> [> State.canva_events] Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t
@@ -223,6 +224,7 @@ let on_change canva mouse_position timer state =
end
in
+
Layer.Paths.to_canva (module Path.Path_Builder) current context state.rendering;
List.iter state.paths
@@ -243,7 +245,7 @@ let on_change canva mouse_position timer state =
| _ -> ()
in
- Layer.Paths.to_canva (module Path.Fixed) path context state.rendering
+ Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (path, path) context state.rendering
);
let () = match state.mode with
@@ -253,7 +255,7 @@ let on_change canva mouse_position timer state =
state.paths
~f:(fun path ->
if id = Path.Fixed.id path then
- Layer.Paths.to_canva (module Path.Fixed) path context `Line
+ Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (path, path) context `Line
)
| Selection (Point (id, point)) ->
(* As before, mark the selected path *)
@@ -276,7 +278,7 @@ let on_change canva mouse_position timer state =
| Some p -> p
end
| None -> path end in
- Layer.Paths.to_canva (module Path.Fixed) path context `Line
+ Layer.Paths.to_canva (module Layer.Paths.ReprFixed) (path, path) context `Line
);
(* Now draw the selected point *)
@@ -389,7 +391,6 @@ let page_main id =
|> 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 _ =
diff --git a/script.it/state.ml b/script.it/state.ml
index cc199d1..107a72b 100755
--- a/script.it/state.ml
+++ b/script.it/state.ml
@@ -325,8 +325,8 @@ let do_action
Layer.Paths.to_svg
~color:Blog.Nord.nord0
- (module Path.Fixed)
- path
+ (module Layer.Paths.ReprFixed)
+ (path, path)
state.rendering
)) in
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 00:13:03 +0000