summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSébastien Dailly <sebastien@chimrod.com>2021-01-01 16:48:23 +0100
committerSébastien Dailly <sebastien@chimrod.com>2021-01-01 16:48:23 +0100
commit74cd42c5cae6644914334448e198d562f4145511 (patch)
treed502e0798a04566c16d345c194ce725330631145
parentaf88c8895bba85fe5340b34aafb3dce7650bd01f (diff)
Use first type module instead of functors pt.2
-rwxr-xr-xpath/builder.ml23
-rwxr-xr-xpath/builder.mli21
-rwxr-xr-xpath/fillPrinter.ml10
-rwxr-xr-xpath/fixed.ml26
-rwxr-xr-xpath/fixed.mli24
-rwxr-xr-xpath/linePrinter.ml99
-rwxr-xr-xpath/repr.ml18
-rwxr-xr-xpath/wireFramePrinter.mli1
-rwxr-xr-xpaths.ml106
-rwxr-xr-xscript.ml16
-rwxr-xr-xstate.ml20
11 files changed, 197 insertions, 167 deletions
diff --git a/path/builder.ml b/path/builder.ml
index cb87fc5..182fc13 100755
--- a/path/builder.ml
+++ b/path/builder.ml
@@ -12,25 +12,6 @@ module type P = sig
end
-module type REPR = sig
- type t
-
- type repr
-
- (* Start a new path. *)
- val start
- : t -> repr -> repr
-
- val line_to
- : t -> t -> repr -> repr
-
- val quadratic_to
- : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr
-
- val stop
- : repr -> repr
-end
-
module Make(Point:P) = struct
(** Point creation **)
@@ -123,8 +104,8 @@ module Make(Point:P) = struct
| hd::_ -> Some hd
let repr
- : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's
- = fun (type s) (points, beziers) (module Repr : REPR with type t = Point.t and type repr = s) path ->
+ : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's
+ = fun (type s) (points, beziers) (module Repr : Repr.M with type t = Point.t and type repr = s) path ->
(* Represent the last points *)
let path = match points with
diff --git a/path/builder.mli b/path/builder.mli
index 8c8081b..78bb778 100755
--- a/path/builder.mli
+++ b/path/builder.mli
@@ -11,25 +11,6 @@ module type P = sig
end
-module type REPR = sig
- type t
-
- type repr
-
- (* Start a new path. *)
- val start
- : t -> repr -> repr
-
- val line_to
- : t -> t -> repr -> repr
-
- val quadratic_to
- : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr
-
- val stop
- : repr -> repr
-end
-
module Make(Point:P) : sig
type t
@@ -54,6 +35,6 @@ module Make(Point:P) : sig
(** Represent the path *)
val repr
- : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's
+ : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's
end
diff --git a/path/fillPrinter.ml b/path/fillPrinter.ml
index ab5a1eb..76056c7 100755
--- a/path/fillPrinter.ml
+++ b/path/fillPrinter.ml
@@ -3,12 +3,12 @@ module Make(Repr: Layer.Repr.PRINTER) = struct
type t = Point.t
type repr =
- { path: (Repr.t)
- ; close : Repr.t -> unit
+ { path: Repr.t
+ ; close : Repr.t -> Repr.t
}
let create_path
- : 'b -> repr
+ : (Repr.t -> Repr.t) -> repr
= fun f ->
{ close = f
; path = Repr.create ()
@@ -33,7 +33,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct
|> Repr.line_to (Point.get_coord p0)
|> Repr.line_to (Point.get_coord p1)
|> Repr.close in
- t.close path;
+ let path = t.close path in
{ t with path}
let quadratic_to
@@ -56,7 +56,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct
(Point.get_coord ctrl1')
(Point.get_coord p1)
|> Repr.close in
- t.close path;
+ let path = t.close path in
{ t with path}
diff --git a/path/fixed.ml b/path/fixed.ml
index 7203ebb..0ff4aad 100755
--- a/path/fixed.ml
+++ b/path/fixed.ml
@@ -13,33 +13,13 @@ module type P = sig
end
-module type REPR = sig
- type t
-
- type repr
-
- (* Start a new path. *)
- val start
- : t -> repr -> repr
-
- val line_to
- : t -> t -> repr -> repr
-
- val quadratic_to
- : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr
-
- val stop
- : repr -> repr
-end
-
-
module Make(Point:P) = struct
module type BUILDER = sig
type t
val repr
- : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's
+ : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's
end
type bezier =
@@ -113,8 +93,8 @@ module Make(Point:P) = struct
}
let repr
- : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's
- = fun (type s) {path; _} (module Repr : REPR with type t = Point.t and type repr = s) repr ->
+ : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's
+ = fun (type s) {path; _} (module Repr : Repr.M with type t = Point.t and type repr = s) repr ->
let repr_bezier p bezier =
Repr.quadratic_to
bezier.p0
diff --git a/path/fixed.mli b/path/fixed.mli
index 3fc542c..1f02aed 100755
--- a/path/fixed.mli
+++ b/path/fixed.mli
@@ -11,33 +11,13 @@ module type P = sig
end
-module type REPR = sig
- type t
-
- type repr
-
- (* Start a new path. *)
- val start
- : t -> repr -> repr
-
- val line_to
- : t -> t -> repr -> repr
-
- val quadratic_to
- : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr
-
- val stop
- : repr -> repr
-end
-
-
module Make(Point:P) : sig
module type BUILDER = sig
type t
val repr
- : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's
+ : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's
end
@@ -53,7 +33,7 @@ module Make(Point:P) : sig
(** Represent the path *)
val repr
- : t -> (module REPR with type t = Point.t and type repr = 's) -> 's -> 's
+ : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's
(** Return the distance between a given point and the curve. May return
None if the point is out of the curve *)
diff --git a/path/linePrinter.ml b/path/linePrinter.ml
index e109e4a..c0a7d58 100755
--- a/path/linePrinter.ml
+++ b/path/linePrinter.ml
@@ -1,53 +1,54 @@
-module Repr = Layer.CanvaPrinter
+module Make(Repr: Layer.Repr.PRINTER) = struct
-type t = Point.t
+ type t = Point.t
-type repr =
- { path: (Repr.t)
- }
-
-let create_path
- : 'b -> repr
- = fun _ ->
- { path = Repr.create ()
- }
-
-(* Start a new path. *)
-let start
- : Point.t -> repr -> repr
- = fun t {path} ->
- let path = Repr.move_to (Point.get_coord t) path in
- let path = Repr.line_to (Point.get_coord' t) path in
- { path
- }
-
-let line_to
- : Point.t -> Point.t -> repr -> repr
- = fun _ t {path} ->
- let path = Repr.move_to (Point.get_coord t) path in
- let path = Repr.line_to (Point.get_coord' t) path in
- { path
- }
-
-let quadratic_to
- : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr
- = fun _p0 _ctrl0 _ctrl1 p1 {path} ->
-
- let path = Repr.move_to (Point.get_coord p1) path in
- let path = Repr.line_to (Point.get_coord' p1) path in
-
- { path
- }
-
-let stop
- : repr -> repr
- = fun {path} ->
-
-
- { path
+ type repr =
+ { path: (Repr.t)
}
-let get
- : repr -> Repr.t
- = fun {path; _} ->
- path
+ let create_path
+ : 'b -> repr
+ = fun _ ->
+ { path = Repr.create ()
+ }
+
+ (* Start a new path. *)
+ let start
+ : Point.t -> repr -> repr
+ = fun t {path} ->
+ let path = Repr.move_to (Point.get_coord t) path in
+ let path = Repr.line_to (Point.get_coord' t) path in
+ { path
+ }
+
+ let line_to
+ : Point.t -> Point.t -> repr -> repr
+ = fun _ t {path} ->
+ let path = Repr.move_to (Point.get_coord t) path in
+ let path = Repr.line_to (Point.get_coord' t) path in
+ { path
+ }
+
+ let quadratic_to
+ : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr
+ = fun _p0 _ctrl0 _ctrl1 p1 {path} ->
+
+ let path = Repr.move_to (Point.get_coord p1) path in
+ let path = Repr.line_to (Point.get_coord' p1) path in
+
+ { path
+ }
+
+ let stop
+ : repr -> repr
+ = fun {path} ->
+
+
+ { path
+ }
+
+ let get
+ : repr -> Repr.t
+ = fun {path; _} ->
+ path
+end
diff --git a/path/repr.ml b/path/repr.ml
new file mode 100755
index 0000000..63e7ba0
--- /dev/null
+++ b/path/repr.ml
@@ -0,0 +1,18 @@
+module type M = sig
+ type t
+
+ type repr
+
+ (* Start a new path. *)
+ val start
+ : t -> repr -> repr
+
+ val line_to
+ : t -> t -> repr -> repr
+
+ val quadratic_to
+ : t -> Gg.v2 -> Gg.v2 -> t -> repr -> repr
+
+ val stop
+ : repr -> repr
+end
diff --git a/path/wireFramePrinter.mli b/path/wireFramePrinter.mli
index 1e76120..fa8a5a8 100755
--- a/path/wireFramePrinter.mli
+++ b/path/wireFramePrinter.mli
@@ -19,6 +19,7 @@ module Make(Repr:Layer.Repr.PRINTER): sig
val stop
: repr -> repr
+
val get
: repr -> Repr.t
diff --git a/paths.ml b/paths.ml
index 4ff6c66..9d968f0 100755
--- a/paths.ml
+++ b/paths.ml
@@ -5,8 +5,110 @@ module Fixed = Path.Fixed.Make(Path.Point)
(* Canva representation *)
-module CanvaRepr = Path.FillPrinter.Make(Layer.CanvaPrinter)
+module FillCanvaRepr = Path.FillPrinter.Make(Layer.CanvaPrinter)
+module LineCanvaRepr = Path.LinePrinter.Make(Layer.CanvaPrinter)
+module WireCanvaRepr = Path.WireFramePrinter.Make(Layer.CanvaPrinter)
+
(* SVG representation *)
-module SVGRepr = Path.WireFramePrinter.Make(Layer.Svg)
+module FillSVGRepr = Path.FillPrinter.Make(Layer.Svg)
+module LineSVGRepr = Path.LinePrinter.Make(Layer.Svg)
+module WireSVGRepr = Path.WireFramePrinter.Make(Layer.Svg)
+
+
+module type REPRESENTABLE = sig
+ type t
+
+ (** Represent the path *)
+ val repr
+ : t -> (module Path.Repr.M with type t = Path.Point.t and type repr = 's) -> 's -> 's
+end
+
+type printer =
+ [ `Fill
+ | `Line
+ | `Wire
+ ]
+
+(** 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
+ | `Fill ->
+ R.repr
+ path
+ (module FillCanvaRepr)
+ (FillCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
+ |> FillCanvaRepr.get
+ |> 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
+ |> Brr_canvas.C2d.stroke ctx
+ | `Wire ->
+ R.repr
+ path
+ (module WireCanvaRepr)
+ (WireCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
+ |> WireCanvaRepr.get
+ |> Brr_canvas.C2d.stroke ctx
+
+
+(** 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
+ | `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 = Layer.Svg.path
+ ~at:Brr.At.[ v (Jstr.v "d") p ]
+ [] in
+
+ paths := repr::!paths;
+ Jstr.empty)) in
+
+ Brr.El.v (Jstr.v "g")
+ ~at:Brr.At.[
+ v (Jstr.v "fill") color
+ ; v (Jstr.v "stroke") color]
+ !paths
+
+ | `Line ->
+ let svg_path = R.repr
+ path
+ (module LineSVGRepr)
+ (LineSVGRepr.create_path (fun _ -> ()))
+ |> LineSVGRepr.get in
+ Layer.Svg.path
+ ~at:Brr.At.[
+ v (Jstr.v "fill") color
+ ; v (Jstr.v "stroke") color
+ ; v (Jstr.v "d") svg_path ]
+ []
+ | `Wire ->
+ let svg_path = R.repr
+ path
+ (module WireSVGRepr)
+ (WireSVGRepr.create_path (fun _ -> ()))
+ |> WireSVGRepr.get in
+ Layer.Svg.path
+ ~at:Brr.At.[
+ v (Jstr.v "fill") color
+ ; v (Jstr.v "stroke") color
+ ; v (Jstr.v "d") svg_path ]
+ []
+
+
diff --git a/script.ml b/script.ml
index 595d975..d501b10 100755
--- a/script.ml
+++ b/script.ml
@@ -197,12 +197,9 @@ let on_change canva mouse_position state =
end
in
- let path = Paths.CanvaRepr.get
- @@ Paths.Path_Builder.repr
- current
- (module Paths.CanvaRepr)
- (Paths.CanvaRepr.create_path (fun p -> fill context p)) in
- stroke context path;
+ let repr = `Wire in
+
+ Paths.to_canva (module Paths.Path_Builder) current context repr;
List.iter state.paths
~f:(fun path ->
@@ -221,12 +218,7 @@ let on_change canva mouse_position state =
| _ -> ()
in
- let path = Paths.CanvaRepr.get
- @@ Paths.Fixed.repr
- path
- (module Paths.CanvaRepr)
- (Paths.CanvaRepr.create_path (fun p -> fill context p)) in
- stroke context path;
+ Paths.to_canva (module Paths.Fixed) path context repr
);
()
diff --git a/state.ml b/state.ml
index 52933f8..57007b3 100755
--- a/state.ml
+++ b/state.ml
@@ -210,19 +210,13 @@ let do_action
; v (Jstr.v "xmlns:xlink") (Jstr.v "http://www.w3.org/1999/xlink") ]
(List.map state.paths
~f:(fun path ->
- let repr = Paths.SVGRepr.create_path (fun _ -> ()) in
- let path = Paths.SVGRepr.get @@
- Paths.Fixed.repr
- path
- (module Paths.SVGRepr)
- repr in
-
- Layer.Svg.path
- ~at:Brr.At.[
- v (Jstr.v "fill") backgroundColor
- ; v (Jstr.v "stroke") backgroundColor
- ; v (Jstr.v "d") path ]
- []
+
+ Paths.to_svg
+ ~color:backgroundColor
+ (module Paths.Fixed)
+ path
+ `Fill
+
)) in
let content = El.prop Elements.Prop.outerHTML svg in