summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xpath/builder.ml185
-rwxr-xr-xpath/builder.mli22
-rwxr-xr-xpath/fixed.ml216
-rwxr-xr-xpaths.ml6
-rwxr-xr-xscript.ml31
-rwxr-xr-xstate.ml62
6 files changed, 274 insertions, 248 deletions
diff --git a/path/builder.ml b/path/builder.ml
index 39ff75e..bcad493 100755
--- a/path/builder.ml
+++ b/path/builder.ml
@@ -43,15 +43,6 @@ module Make(Point:P) = struct
type t = Point.t list * bezier list
- type path =
- | Empty
- | Line of Point.t * Point.t
- | Curve of bezier
-
- type fixedPath =
- { id: int
- ; path : path array }
-
let get_new_segment connexion0 p5 p4 p3 p2 p1 =
let p5' = Point.get_coord p5
and p4' = Point.get_coord p4
@@ -70,7 +61,7 @@ module Make(Point:P) = struct
let empty = ([], [])
let add_point
- : Point.t -> t -> t * fixedPath option
+ : Point.t -> t -> t
= fun lastPoint (path, beziers) ->
let (let*) v f =
match v with
@@ -78,11 +69,9 @@ module Make(Point:P) = struct
if Array.length bezier > 0 then
f (Array.get bezier 0)
else
- ( (lastPoint::path, beziers)
- , None )
+ (lastPoint::path, beziers)
| _ ->
- ( (lastPoint::path, beziers)
- , None )
+ (lastPoint::path, beziers)
in
let connexion0 = match beziers with
@@ -103,22 +92,19 @@ module Make(Point:P) = struct
(* We remove the last point and add the bezier curve in the list*)
let firsts = lastPoint::p4::p3::p2::[] in
- ( (firsts, bezier_point::beziers)
- , None )
+ (firsts, bezier_point::beziers)
| _ ->
- ( ( lastPoint::path
- , beziers)
- , None )
+ ( lastPoint::path
+ , beziers)
let replace_last
- : Point.t -> t -> t * fixedPath option
+ : Point.t -> t -> t
= fun lastPoint ((path, beziers) as t) ->
match path, beziers with
| _::(tl), beziers ->
- ( ( lastPoint::tl
- , beziers )
- , None )
+ ( lastPoint::tl
+ , beziers )
| _ ->
add_point lastPoint t
@@ -237,157 +223,4 @@ module Make(Point:P) = struct
)
end
- module ToFixed = struct
- type t = Point.t
-
- type 'a repr = int * path list
-
- let create_path () = 0, []
-
- (* Start a new path. *)
- let start point t =
- let _ = point in
- t
-
- let line_to
- : t -> t -> 'a repr -> 'a repr
- = fun p1 p2 (i, t) ->
- ( i + 1
- , Line (p1, p2)::t)
-
-
- let quadratic_to
- : t -> Gg.v2 -> Gg.v2 -> t -> 'a repr -> 'a repr
- = fun p0 ctrl0 ctrl1 p1 (i, t) ->
- let curve = Curve
- { p0
- ; ctrl0
- ; ctrl1
- ; p1} in
- ( i + 1
- , curve::t)
-
-
- let stop t = t
-
- let get
- : int * path list -> path array
- = fun (n, t) ->
- let res = Array.make n Empty in
- List.iteri t
- ~f:(fun i elem -> Array.set res (n - i - 1) elem );
- res
- end
-
- let id = ref 0
- module FixedBuilder = Draw(ToFixed)
- let to_fixed
- : t -> fixedPath
- = fun t ->
- incr id;
- { id = !id
- ; path = FixedBuilder.draw t (ToFixed.create_path ())
- |> ToFixed.get
- }
-
- module DrawFixed(Repr:REPR with type t = Point.t) = struct
-
-
- let repr_bezier p bezier =
- Repr.quadratic_to
- bezier.p0
- bezier.ctrl0
- bezier.ctrl1
- bezier.p1
- p
-
- let draw
- : fixedPath -> 'a Repr.repr -> 'a Repr.repr
- = fun {path; _} repr ->
-
- let _, repr = Array.fold_left path
- ~init:(true, repr)
- ~f:(fun (first, path) element ->
- match element with
- | Empty -> (true, path)
- | Line (p0, p1) ->
-
- let path = if first then
- Repr.start p0 path
- else path in
-
- ( false
- , Repr.line_to p0 p1 path )
- | Curve bezier ->
- let path = if first then
- Repr.start bezier.p0 path
- else path in
- ( false
- , repr_bezier path bezier )
- ) in
- Repr.stop repr
- end
-
- let box
- : bezier -> Gg.box2
- = fun bezier ->
- Gg.Box2.of_pts
- (Point.get_coord bezier.p0)
- (Point.get_coord bezier.p1)
- |> (fun b -> Gg.Box2.add_pt b bezier.ctrl0)
- |> (fun b -> Gg.Box2.add_pt b bezier.ctrl1)
-
- (** Return the distance between a given point and the curve. May return
- None if the point is out of the curve *)
- let distance
- : Gg.v2 -> fixedPath -> float option =
- fun point beziers ->
-
- Array.fold_left beziers.path
- ~init:None
- ~f:(fun res -> function
- | Empty -> None
- | Line (p0, p1) ->
- let box = Gg.Box2.of_pts (Point.get_coord p0) (Point.get_coord p1) in
- begin match Gg.Box2.mem point box with
- | false -> res
- | true ->
- (* TODO Evaluate the normal *)
- res
- end
- | Curve bezier ->
- begin match Gg.Box2.mem point (box bezier) with
- | false -> res
- | true ->
-
- let bezier' = Shapes.Bezier.(
-
- { p0 = Point.get_coord bezier.p0
- ; p1 = Point.get_coord bezier.p1
- ; ctrl0 = bezier.ctrl0
- ; ctrl1 = bezier.ctrl1 }
- ) in
- let _, point' = Shapes.Bezier.get_closest_point point bezier' in
- let distance = Gg.V2.( norm (point - point') ) in
- match res with
- | None -> Some distance
- | Some d -> if d < distance then res else (Some distance)
- end
- )
-
- let id
- : fixedPath -> int
- = fun {id; _} -> id
-
- let map_point
- : fixedPath -> (Point.t -> Point.t) -> fixedPath
- = fun {id; path} f ->
- let path = Array.map path
- ~f:(function
- | Empty -> Empty
- | Line (p1, p2) -> Line (f p1, f p2)
- | Curve bezier -> Curve {bezier with p0 = f bezier.p0 ; p1 = f bezier.p1}
- ) in
- {id; path}
-
end
diff --git a/path/builder.mli b/path/builder.mli
index ca496f7..7f34f10 100755
--- a/path/builder.mli
+++ b/path/builder.mli
@@ -34,17 +34,15 @@ module Make(P:P) : sig
type t
- type fixedPath
-
(** Create an empty path *)
val empty: t
val add_point
- : P.t -> t -> t * fixedPath option
+ : P.t -> t -> t
(** Replace the last alement in the path by the one given in parameter *)
val replace_last
- : P.t -> t -> t * fixedPath option
+ : P.t -> t -> t
(** Retrieve the last element, if any *)
val peek
@@ -61,20 +59,4 @@ module Make(P:P) : sig
: t -> 'a Repr.repr -> 'a Repr.repr
end
- val to_fixed : t -> fixedPath
-
- module DrawFixed(Repr:REPR with type t = P.t) : sig
- val draw
- : fixedPath -> 'a Repr.repr -> 'a Repr.repr
- end
-
- (** Return the shortest distance between the mouse and a point *)
- val distance
- : Gg.v2 -> fixedPath -> float option
-
- val id
- : fixedPath -> int
-
- val map_point
- : fixedPath -> (P.t -> P.t) -> fixedPath
end
diff --git a/path/fixed.ml b/path/fixed.ml
new file mode 100755
index 0000000..e339afc
--- /dev/null
+++ b/path/fixed.ml
@@ -0,0 +1,216 @@
+open StdLabels
+
+(** Signature for points *)
+module type P = sig
+ type t
+
+ val empty : t
+
+ val get_coord : t -> Gg.v2
+
+ (** Copy a point and all thoses properties to the given location *)
+ val copy : t -> Gg.v2 -> t
+
+end
+
+module type REPR = sig
+ type t
+
+ type 'a repr
+
+ (* Start a new path. *)
+ val start
+ : t -> 'a repr -> 'a repr
+
+ val line_to
+ : t -> t -> 'a repr -> 'a repr
+
+ val quadratic_to
+ : t -> Gg.v2 -> Gg.v2 -> t -> 'a repr -> 'a repr
+
+ val stop
+ : 'a repr -> 'a repr
+end
+
+
+module Make(Point:P) = struct
+
+ module type BUILDER = sig
+ type t
+
+ module Draw(Repr:REPR with type t = Point.t) : sig
+
+ (** Represent the the current path *)
+ val draw
+ : t -> 'a Repr.repr -> 'a Repr.repr
+ end
+ end
+
+ type bezier =
+ { p0:Point.t (* The starting point *)
+ ; p1:Point.t (* The end point *)
+ ; ctrl0:Gg.v2 (* The control point *)
+ ; ctrl1:Gg.v2 } (* The control point *)
+
+ type path =
+ | Empty
+ | Line of Point.t * Point.t
+ | Curve of bezier
+
+ type t =
+ { id: int
+ ; path : path array }
+
+ let id
+ : t -> int
+ = fun {id; _} -> id
+
+ module ToFixed = struct
+ type t = Point.t
+
+ type 'a repr = int * path list
+
+ let create_path () = 0, []
+
+ (* Start a new path. *)
+ let start point t =
+ let _ = point in
+ t
+
+ let line_to
+ : t -> t -> 'a repr -> 'a repr
+ = fun p1 p2 (i, t) ->
+ ( i + 1
+ , Line (p1, p2)::t)
+
+ let quadratic_to
+ : t -> Gg.v2 -> Gg.v2 -> t -> 'a repr -> 'a repr
+ = fun p0 ctrl0 ctrl1 p1 (i, t) ->
+ let curve = Curve
+ { p0
+ ; ctrl0
+ ; ctrl1
+ ; p1} in
+ ( i + 1
+ , curve::t)
+
+
+ let stop t = t
+
+ let get
+ : int * path list -> path array
+ = fun (n, t) ->
+ let res = Array.make n Empty in
+ List.iteri t
+ ~f:(fun i elem -> Array.set res (n - i - 1) elem );
+ 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;
+ let module FixedBuilder = Builder.Draw(ToFixed) in
+ { id = !internal_id
+ ; path = FixedBuilder.draw t (ToFixed.create_path ())
+ |> ToFixed.get
+ }
+
+ module DrawFixed(Repr:REPR with type t = Point.t) = struct
+
+ let repr_bezier p bezier =
+ Repr.quadratic_to
+ bezier.p0
+ bezier.ctrl0
+ bezier.ctrl1
+ bezier.p1
+ p
+
+ let draw
+ : t -> 'a Repr.repr -> 'a Repr.repr
+ = fun {path; _} repr ->
+
+ let _, repr = Array.fold_left path
+ ~init:(true, repr)
+ ~f:(fun (first, path) element ->
+ match element with
+ | Empty -> (true, path)
+ | Line (p0, p1) ->
+
+ let path = if first then
+ Repr.start p0 path
+ else path in
+
+ ( false
+ , Repr.line_to p0 p1 path )
+ | Curve bezier ->
+ let path = if first then
+ Repr.start bezier.p0 path
+ else path in
+ ( false
+ , repr_bezier path bezier )
+ ) in
+ Repr.stop repr
+ end
+
+ let box
+ : bezier -> Gg.box2
+ = fun bezier ->
+ Gg.Box2.of_pts
+ (Point.get_coord bezier.p0)
+ (Point.get_coord bezier.p1)
+ |> (fun b -> Gg.Box2.add_pt b bezier.ctrl0)
+ |> (fun b -> Gg.Box2.add_pt b bezier.ctrl1)
+
+ (** Return the distance between a given point and the curve. May return
+ None if the point is out of the curve *)
+ let distance
+ : Gg.v2 -> t -> float option =
+ fun point beziers ->
+
+ Array.fold_left beziers.path
+ ~init:None
+ ~f:(fun res -> function
+ | Empty -> None
+ | Line (p0, p1) ->
+ let box = Gg.Box2.of_pts (Point.get_coord p0) (Point.get_coord p1) in
+ begin match Gg.Box2.mem point box with
+ | false -> res
+ | true ->
+ (* TODO Evaluate the normal *)
+ res
+ end
+ | Curve bezier ->
+ begin match Gg.Box2.mem point (box bezier) with
+ | false -> res
+ | true ->
+
+ let bezier' = Shapes.Bezier.(
+
+ { p0 = Point.get_coord bezier.p0
+ ; p1 = Point.get_coord bezier.p1
+ ; ctrl0 = bezier.ctrl0
+ ; ctrl1 = bezier.ctrl1 }
+ ) in
+ let _, point' = Shapes.Bezier.get_closest_point point bezier' in
+ let distance = Gg.V2.( norm (point - point') ) in
+ match res with
+ | None -> Some distance
+ | Some d -> if d < distance then res else (Some distance)
+ end
+ )
+
+ let map_point
+ : t -> (Point.t -> Point.t) -> t
+ = fun {id; path} f ->
+ let path = Array.map path
+ ~f:(function
+ | Empty -> Empty
+ | Line (p1, p2) -> Line (f p1, f p2)
+ | Curve bezier -> Curve {bezier with p0 = f bezier.p0 ; p1 = f bezier.p1}
+ ) in
+ {id; path}
+
+end
diff --git a/paths.ml b/paths.ml
index 82eca48..49bf03a 100755
--- a/paths.ml
+++ b/paths.ml
@@ -1,4 +1,10 @@
(** Common module for ensuring that the function is evaluated only once *)
module Path_Builder = Path.Builder.Make(Path.Point)
+module Fixed = Path.Fixed.Make(Path.Point)
+module SVGRepr = Path.WireFramePrinter.Make(Layer.Svg)
+module SVG_Printer = Fixed.DrawFixed(SVGRepr)
+
+module CanvaRepr = Path.FillPrinter.Make(Layer.CanvaPrinter)
+module Fixed_Printer = Fixed.DrawFixed(CanvaRepr)
diff --git a/script.ml b/script.ml
index a250c7f..d7d969c 100755
--- a/script.ml
+++ b/script.ml
@@ -3,12 +3,9 @@ open Note
open Brr
open Brr_note
-module CanvaRepr = Path.FillPrinter.Make(Layer.CanvaPrinter)
-module Path_Printer = Paths.Path_Builder.Draw(CanvaRepr)
-module Fixed_Printer = Paths.Path_Builder.DrawFixed(CanvaRepr)
-
-type canva_signal = Path.Point.t
+module Path_Printer = Paths.Path_Builder.Draw(Paths.CanvaRepr)
+module Fixed_Printer = Paths.Fixed.DrawFixed(Paths.CanvaRepr)
module Mouse = Brr_note_kit.Mouse
@@ -195,32 +192,29 @@ let on_change canva mouse_position state =
*)
let pos = S.rough_value mouse_position in
- let current, paths =
+ let current =
begin match state.State.mode, pos with
| Edit, Some point ->
- begin match State.insert_or_replace state point state.current with
- | current, None -> current, state.paths
- | current, Some p -> current, p::state.paths
- end
+ State.insert_or_replace state point state.current
| _ ->
- state.current, state.paths
+ state.current
end
in
- let path = CanvaRepr.get
+ let path = Paths.CanvaRepr.get
@@ Path_Printer.draw
current
- (* (CanvaRepr.create_path (fun p -> fill context p)) in *)
- (CanvaRepr.create_path (fun _ -> () )) in
+ (Paths.CanvaRepr.create_path (fun p -> fill context p)) in
stroke context path;
- List.iter paths
+ List.iter state.paths
~f:(fun path ->
let () = match state.mode with
| Selection s ->
- begin match (Paths.Path_Builder.id s) = (Paths.Path_Builder.id path) with
+ begin match (Paths.Fixed.id s) = (Paths.Fixed.id path) with
| true ->
+ (* If the element is the selected one, change the color *)
set_fill_style context (color Blog.Nord.nord8);
set_stroke_style context (color Blog.Nord.nord8)
| false ->
@@ -230,10 +224,10 @@ let on_change canva mouse_position state =
| _ -> ()
in
- let path = CanvaRepr.get
+ let path = Paths.CanvaRepr.get
@@ Fixed_Printer.draw
path
- (CanvaRepr.create_path (fun p -> fill context p)) in
+ (Paths.CanvaRepr.create_path (fun p -> fill context p)) in
stroke context path;
);
()
@@ -241,7 +235,6 @@ let on_change canva mouse_position state =
let page_main id =
-
let delete_event', angle_signal', width_signal', export_event' =
begin match Blog.Sidebar.get () with
| None ->
diff --git a/state.ml b/state.ml
index e41c328..35fc2ed 100755
--- a/state.ml
+++ b/state.ml
@@ -1,10 +1,6 @@
open StdLabels
open Brr
-module Path_Builder = Paths.Path_Builder
-module SVGRepr = Path.WireFramePrinter.Make(Layer.Svg)
-module SVG_Fixed_Printer = Path_Builder.DrawFixed(SVGRepr)
-
let expected_host = Blog.Hash_host.expected_host
let backgroundColor = Blog.Nord.nord0
@@ -13,10 +9,10 @@ let timer, tick = Elements.Timer.create ()
type mode =
| Edit
- | Selection of Path_Builder.fixedPath
+ | Selection of Paths.Fixed.t
| Out
-type current = Path_Builder.t
+type current = Paths.Path_Builder.t
(** Events *)
@@ -44,7 +40,7 @@ type events =
*)
type state =
{ mode : mode
- ; paths : Path_Builder.fixedPath list
+ ; paths : Paths.Fixed.t list
; current : current
; width : float
; angle : float
@@ -54,9 +50,9 @@ let insert_or_replace state ((x, y) as p) path =
let width = state.width
and angle = state.angle in
let point = Path.Point.create ~x ~y ~angle ~width in
- match Path_Builder.peek path with
+ match Paths.Path_Builder.peek path with
| None ->
- Path_Builder.add_point
+ Paths.Path_Builder.add_point
point
path
| Some p1 ->
@@ -66,15 +62,15 @@ let insert_or_replace state ((x, y) as p) path =
let dist = (norm (p1' - (of_tuple p))) in
if dist < 5. then (
- path, None
+ path
) else (
- Path_Builder.add_point
+ Paths.Path_Builder.add_point
point
path
)
let check_selection
- : (float * float) -> Path_Builder.fixedPath list -> Path_Builder.fixedPath option
+ : (float * float) -> Paths.Fixed.t list -> Paths.Fixed.t option
= fun position paths ->
let point = Gg.V2.of_tuple position in
(* If the user click on a curve, select it *)
@@ -86,7 +82,7 @@ let check_selection
| Some p -> Some p
| None ->
(* TODO : Add a method in the point module *)
- begin match Path_Builder.distance point path with
+ begin match Paths.Fixed.distance point path with
| Some p when p < 20. ->
Some path
| _ -> None
@@ -96,12 +92,12 @@ let check_selection
(** Update the path in the selection with the given function applied to
every point *)
let update_selection s state f =
- let s = Path_Builder.map_point s f
- and id = Path_Builder.id s in
+ let s = Paths.Fixed.map_point s f
+ and id = Paths.Fixed.id s in
let paths = List.map state.paths
~f:(fun path ->
- let id' = Path_Builder.id path in
+ let id' = Paths.Fixed.id path in
match id = id' with
| false -> path
| true -> s
@@ -114,14 +110,11 @@ let do_action
match event, state.mode with
| `Point (_delay, point), Edit ->
(* Add the point in the list *)
- let current, fixed_path = insert_or_replace
+ let current = insert_or_replace
state
point
state.current in
- let paths = match fixed_path with
- | None -> state.paths
- | Some p -> p::state.paths in
- { state with current; paths }
+ { state with current }
(* Click anywhere while in Out mode, we switch in edition *)
| `Click _, Out ->
@@ -145,22 +138,25 @@ let do_action
| `Out point, Edit ->
Elements.Timer.stop timer;
- begin match Path_Builder.peek2 state.current with
+ begin match Paths.Path_Builder.peek2 state.current with
(* If there is at last two points selected, handle this as a curve
creation *)
| Some _ ->
- let current, fixed_path = insert_or_replace state point state.current in
- let paths = match fixed_path with
- | None -> Path_Builder.to_fixed current::state.paths
- | Some p -> p::state.paths
- and current = Path_Builder.empty in
+ let current = insert_or_replace state point state.current in
+ let paths =
+ let last = Paths.Fixed.to_fixed
+ (module Paths.Path_Builder)
+ current
+ in
+ last::state.paths
+ and current = Paths.Path_Builder.empty in
{ state with
mode = Out
; paths; current }
(* Else, check if there is a curve undre the cursor, and remove it *)
| None ->
- let current = Path_Builder.empty in
+ let current = Paths.Path_Builder.empty in
begin match check_selection point state.paths with
| None ->
{ state with
@@ -174,8 +170,8 @@ let do_action
end
end
| `Delete, Selection s ->
- let id = Path_Builder.id s in
- let paths = List.filter state.paths ~f:(fun p -> Path_Builder.id p != id) in
+ let id = Paths.Fixed.id s in
+ let paths = List.filter state.paths ~f:(fun p -> Paths.Fixed.id p != id) in
{ state with paths ; mode = Out}
@@ -191,8 +187,8 @@ 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 = SVGRepr.create_path (fun _ -> ()) in
- let path = SVGRepr.get @@ SVG_Fixed_Printer.draw path repr in
+ let repr = Paths.SVGRepr.create_path (fun _ -> ()) in
+ let path = Paths.SVGRepr.get @@ Paths.SVG_Printer.draw path repr in
Layer.Svg.path
~at:Brr.At.[
@@ -245,7 +241,7 @@ let do_action
let init =
{ paths = []
- ; current = Path_Builder.empty
+ ; current = Paths.Path_Builder.empty
; mode = Out
; angle = 30.
; width = 10.