aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xpath/builder.ml86
-rwxr-xr-xpath/builder.mli33
-rwxr-xr-xpath/draw.ml4
-rwxr-xr-xpath/point.ml54
-rwxr-xr-xpath/point.mli3
-rwxr-xr-xscript.ml99
6 files changed, 164 insertions, 115 deletions
diff --git a/path/builder.ml b/path/builder.ml
new file mode 100755
index 0000000..f52fb9e
--- /dev/null
+++ b/path/builder.ml
@@ -0,0 +1,86 @@
+(** Signature for points *)
+module type P = sig
+ type t
+
+ val get_coord : t -> Gg.v2
+
+end
+
+module Make(P:P) = struct
+
+ type t = P.t list * Shapes.Bezier.t list
+
+ let get_new_segment connexion0 p5 p4 p3 p2 p1 =
+ let p5' = P.get_coord p5
+ and p4' = P.get_coord p4
+ and p3' = P.get_coord p3
+ and p2' = P.get_coord p2
+ and p1' = P.get_coord p1 in
+
+ let points_to_link =
+ [ p1'
+ ; p2'
+ ; p3'
+ ; p4'
+ ; p5' ] in
+ Shapes.Bspline.to_bezier ?connexion0 points_to_link
+
+ let empty = ([], [])
+
+ let add_point
+ : P.t -> t -> t
+ = fun lastPoint (path, beziers) ->
+ let (let*) v f =
+ match v with
+ | Ok bezier ->
+ if Array.length bezier > 0 then
+ f (Array.get bezier 0)
+ else
+ lastPoint::path, beziers
+ | _ ->
+ lastPoint::path, beziers
+ in
+
+ let connexion0 = match beziers with
+ | hd::_ -> Some hd.Shapes.Bezier.p1
+ | _ -> None in
+
+ match path with
+ | p4::p3::p2::p1::_ ->
+ let* bezier = get_new_segment connexion0
+ lastPoint p4 p3 p2 p1 in
+ (* We remove the last point and add the bezier curve in the list*)
+ let firsts = lastPoint::p4::p3::p2::[] in
+ firsts, (Shapes.Bezier.reverse bezier)::beziers
+ | _ ->
+ lastPoint::path, beziers
+
+ let replace_last
+ : P.t -> t -> t
+ = fun lastPoint ((path, beziers) as t) ->
+ match path, beziers with
+ | _::(tl), beziers ->
+ lastPoint::tl
+ , beziers
+ | _ ->
+ add_point lastPoint t
+
+ let peek2
+ : t -> (P.t * P.t) option
+ = fun (path, _) ->
+ match path with
+ | h1::h2::_ -> Some (h1, h2)
+ | _ -> None
+
+ let peek
+ : t -> P.t option
+ = fun (path, _) ->
+ match path with
+ | [] -> None
+ | hd::_ -> Some hd
+
+ let get
+ : t -> t
+ = fun t -> t
+
+end
diff --git a/path/builder.mli b/path/builder.mli
new file mode 100755
index 0000000..d99e0b2
--- /dev/null
+++ b/path/builder.mli
@@ -0,0 +1,33 @@
+(** Signature for points *)
+module type P = sig
+ type t
+
+ val get_coord : t -> Gg.v2
+end
+
+
+module Make(P:P) : sig
+
+ type t
+
+ (** Create an empty path *)
+ val empty: t
+
+ val add_point
+ : P.t -> t -> t
+
+ (** Replace the last alement in the path by the one given in parameter *)
+ val replace_last
+ : P.t -> t -> t
+
+ (** Retrieve the last element, if any *)
+ val peek
+ : t -> P.t option
+
+ (** Retrieve the last element, if any *)
+ val peek2
+ : t -> (P.t * P.t) option
+
+ val get
+ : t -> P.t list * Shapes.Bezier.t list
+end
diff --git a/path/draw.ml b/path/draw.ml
index 757c778..ba5272a 100755
--- a/path/draw.ml
+++ b/path/draw.ml
@@ -2,6 +2,7 @@ open StdLabels
module Path = Brr_canvas.C2d.Path
module Point = Point
+module Builder = Builder
(** Translate the point in the canva area *)
let translate_point
@@ -17,7 +18,6 @@ let translate_point'
translate_point ~area
(point + vect)
-
(* Draw a straight line between two points *)
let line
: Gg.v2 -> p1:Point.t -> Path.t -> unit
@@ -138,7 +138,7 @@ let go_back
: ?connexion:Point.t -> area:Gg.v2 -> Brr_canvas.C2d.Path.t -> path -> unit
= fun ?connexion ~area canvaPath path ->
let vect = Gg.V2.of_polar @@ Gg.V2.v
- 0.02
+ 0.01
Gg.Float.pi_div_4
in
match connexion, path with
diff --git a/path/point.ml b/path/point.ml
index 91b68c2..9e10200 100755
--- a/path/point.ml
+++ b/path/point.ml
@@ -1,5 +1,3 @@
-open StdLabels
-
type t =
{ p: Gg.v2
; size : float
@@ -24,55 +22,3 @@ let get_coord'
let trans = of_polar @@ v t.size t.angle in
t.p + trans
-let return_segment
- : Shapes.Bezier.t -> Shapes.Bezier.t list -> Shapes.Bezier.t list
- = fun bezier beziers ->
- (* We gave the points in reverse order, so we have to revert the
- curve *)
- let bezier' = Shapes.Bezier.reverse bezier in
- bezier'::beziers
-
-
-let get_new_segment connexion0 p5 p4 p3 p2 p1 =
- let p5' = get_coord p5
- and p4' = get_coord p4
- and p3' = get_coord p3
- and p2' = get_coord p2
- and p1' = get_coord p1 in
-
- let points_to_link =
- [ p1'
- ; p2'
- ; p3'
- ; p4'
- ; p5' ] in
- Shapes.Bspline.to_bezier ?connexion0 points_to_link
-
-let add_point_in_path
- : float * float -> t list -> Shapes.Bezier.t list -> t list * Shapes.Bezier.t list
- = fun (x, y) path beziers ->
- let lastClick = create x y in
- let (let*) v f =
- match v with
- | Ok bezier ->
- if Array.length bezier > 0 then
- f (Array.get bezier 0)
- else
- lastClick::path, beziers
- | _ ->
- lastClick::path, beziers
- in
-
- let connexion0 = match beziers with
- | hd::_ -> Some hd.Shapes.Bezier.p1
- | _ -> None in
-
- match path with
- | p4::p3::p2::p1::_ ->
- let* bezier = get_new_segment connexion0
- lastClick p4 p3 p2 p1 in
- (* We remove the last point and add the bezier curve in the list*)
- let firsts = lastClick::p4::p3::p2::[] in
- firsts, return_segment bezier beziers
- | _ ->
- lastClick::path, beziers
diff --git a/path/point.mli b/path/point.mli
index 068f4c1..4b75c3c 100755
--- a/path/point.mli
+++ b/path/point.mli
@@ -6,8 +6,5 @@ val get_coord : t -> Gg.v2
val create: float -> float -> t
-val add_point_in_path
- : (float * float) -> t list -> Shapes.Bezier.t list -> t list * Shapes.Bezier.t list
-
val get_coord'
: t -> Gg.v2
diff --git a/script.ml b/script.ml
index 9cd8a22..f7db9d3 100755
--- a/script.ml
+++ b/script.ml
@@ -5,15 +5,15 @@ open Brr
module Timer = Events.Timer
module Point = Draw.Point
+module Path = Draw
+
+module Path_Builder = Path.Builder.Make(Point)
type mode =
| Edit
| Out
-type current =
- { points : Point.t list (* The list of points to draw *)
- ; beziers : Shapes.Bezier.t list (* All the points already fixed *)
- }
+type current = Path_Builder.t
type state =
{ mode : mode
@@ -66,60 +66,47 @@ let canva
E.select [click; up], pos, c
+let insert_or_replace ((x, y) as p) path =
+ let point = Point.create x y in
+ match Path_Builder.peek path with
+ | None ->
+ Path_Builder.add_point
+ point
+ path
+ | Some p1 ->
+ let open Gg.V2 in
+
+ let p1' = Point.get_coord p1 in
+
+ let dist = (norm (p1' - (of_tuple p))) in
+ if dist < 0.05 then (
+ path
+ ) else (
+ Path_Builder.add_point
+ point
+ path
+ )
+
let do_action
: events -> state -> state
= fun event state ->
match event, state.mode with
- | `Point (_delay, point), Edit ->
+ | `Point (_delay, (x, y)), Edit ->
(* Add the point in the list *)
- let points, beziers = Point.add_point_in_path
- point
- state.current.points
- state.current.beziers in
-
- let current= {points; beziers} in
-
+ let current= Path_Builder.add_point
+ (Point.create x y)
+ state.current in
{ state with current }
+
| `Click _, Out ->
Timer.start state.timer 0.3;
{ state with mode = Edit }
- | `Out p, Edit ->
+ | `Out point, Edit ->
Timer.stop state.timer;
- (* Add the point in the list *)
-
- let points, beziers = match state.current.points, state.current.beziers with
- | hd::(tl), beziers ->
-
- let open Gg.V2 in
- let p' = of_tuple p
- and hd' = Point.get_coord hd in
- if (norm (hd' - p' )) < 0.05 then
- (Point.create (fst p) (snd p))::tl
- , beziers
- else (
- Point.add_point_in_path
- p
- state.current.points
- state.current.beziers
- )
- | _ ->
- Point.add_point_in_path
- p
- state.current.points
- state.current.beziers
- in
-
-
-(*
- let points, beziers = Point.add_point_in_path
- p
- state.current.points
- state.current.beziers in
-*)
- let beziers = Draw.to_path (points, beziers) in
-
+ let current = insert_or_replace point state.current in
+ let beziers = Draw.to_path @@ Path_Builder.get current in
let paths = beziers::state.paths
- and current = { points = []; beziers = []} in
+ and current = Path_Builder.empty in
{ state with mode = Out; paths; current }
| _ -> state
@@ -195,6 +182,7 @@ let on_change canva mouse_position state =
set_stroke_style context (color white);
set_fill_style context (color white);
+
(* If we are in edit mode, we add a point under the cursor.
Otherwise, we would only display the previous registered point, which can
@@ -202,16 +190,17 @@ let on_change canva mouse_position state =
*)
let pos = S.rough_value mouse_position in
- let points =
+ let current =
match state.mode, pos with
| Edit, Some (x, y) ->
- (Point.create x y)::state.current.points
+ Path_Builder.add_point (Point.create x y) state.current
| _ ->
- set_image_smoothing_enabled context true;
- set_image_smoothing_quality context Image_smoothing_quality.high;
- state.current.points in
+ state.current
+ in
+
+ let points, beziers = Path_Builder.get current in
- let path = draw_path area (points) state.current.beziers in
+ let path = draw_path area (points) beziers in
stroke context path;
List.iter state.paths
@@ -234,7 +223,6 @@ let on_change canva mouse_position state =
fill context p;
stroke context p
-
)
| _ ->
@@ -256,8 +244,7 @@ let page_main id =
let init =
{ paths = []
- ; current = { points = []
- ; beziers = [] }
+ ; current = Path_Builder.empty
; mode = Out
; timer
} in