diff options
| -rwxr-xr-x | path/builder.ml | 23 | ||||
| -rwxr-xr-x | path/builder.mli | 21 | ||||
| -rwxr-xr-x | path/fillPrinter.ml | 10 | ||||
| -rwxr-xr-x | path/fixed.ml | 26 | ||||
| -rwxr-xr-x | path/fixed.mli | 24 | ||||
| -rwxr-xr-x | path/linePrinter.ml | 99 | ||||
| -rwxr-xr-x | path/repr.ml | 18 | ||||
| -rwxr-xr-x | path/wireFramePrinter.mli | 1 | ||||
| -rwxr-xr-x | paths.ml | 106 | ||||
| -rwxr-xr-x | script.ml | 16 | ||||
| -rwxr-xr-x | state.ml | 20 |
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 @@ -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 ] + [] + + @@ -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 ); () @@ -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 |