From 4f262d6540281487f79870aff589ca92f5d2f6c6 Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
Date: Wed, 16 Dec 2020 14:39:42 +0100
Subject: Initial commit

---
 draw/draw.ml   | 233 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 draw/dune      |   8 ++
 draw/point.ml  |  78 +++++++++++++++++++
 draw/point.mli |  13 ++++
 4 files changed, 332 insertions(+)
 create mode 100755 draw/draw.ml
 create mode 100755 draw/dune
 create mode 100755 draw/point.ml
 create mode 100755 draw/point.mli

(limited to 'draw')

diff --git a/draw/draw.ml b/draw/draw.ml
new file mode 100755
index 0000000..12a1abc
--- /dev/null
+++ b/draw/draw.ml
@@ -0,0 +1,233 @@
+open StdLabels
+module Path = Brr_canvas.C2d.Path
+
+module Point = Point
+
+(** Translate the point in the canva area *)
+let translate_point
+  : area:Gg.v2 -> Gg.v2 -> (float * float)
+  = fun ~area point ->
+    let x, y = Gg.V2.(to_tuple @@ mul area point) in
+    x, ((Gg.V2.y area) -. y)
+
+let translate_point'
+  : area:Gg.v2 -> Gg.v2 -> Gg.v2 -> (float * float)
+  = fun ~area vect point ->
+    let open Gg.V2 in
+    translate_point ~area
+      (point + vect)
+
+
+(* Draw a straight line between two points *)
+let line
+  : Gg.v2 -> p1:Point.t -> Path.t -> unit
+  = fun area ~p1 path ->
+    let x, y = translate_point ~area (Point.get_coord p1) in
+    Path.line_to path ~x ~y
+
+(* Draw a simple bezier curve from the three given points *)
+let three_points
+  : Gg.v2 -> p0:Point.t -> p1:Point.t -> p2:Point.t -> Path.t -> unit
+  = fun area ~p0 ~p1 ~p2 path ->
+    let p0 = Point.get_coord p0
+    and p1 = Point.get_coord p1
+    and p2 = Point.get_coord p2 in
+    let bezier = Curves.Bezier.three_points_quadratic p0 p1 p2
+                 |> Curves.Bezier.quadratic_to_cubic in
+    let cx, cy = translate_point ~area bezier.Curves.Bezier.ctrl0
+    and cx', cy' = translate_point ~area bezier.Curves.Bezier.ctrl1
+    and x, y = translate_point ~area bezier.Curves.Bezier.p1 in
+
+    Path.ccurve_to path
+      ~cx ~cy
+      ~cx' ~cy'
+      ~x ~y
+
+let multi_points
+  : ?connexion:Gg.v2 -> Gg.v2 -> Point.t list -> Path.t -> unit
+  = fun ?connexion area points path ->
+
+    let (let*) v f =
+      match v with
+      | Ok beziers -> f beziers
+      | _ -> () in
+
+    let points = List.map ~f:Point.get_coord points in
+
+    let* beziers = Curves.Bspline.to_bezier ?connexion1:connexion points in
+    Array.iter beziers
+      ~f:(fun bezier ->
+          let cx, cy = translate_point ~area bezier.Curves.Bezier.ctrl0
+          and cx', cy' = translate_point ~area bezier.Curves.Bezier.ctrl1
+          and x, y = translate_point ~area bezier.Curves.Bezier.p1 in
+
+          Path.ccurve_to path
+            ~cx ~cy
+            ~cx' ~cy'
+            ~x ~y
+        )
+
+let circle
+  : Gg.v2 -> center:Gg.v2 -> float -> Path.t -> Path.t
+  = fun area ~center r path ->
+
+    let cx, cy = translate_point ~area center in
+    Path.arc
+      path
+      ~cx ~cy
+      ~r
+      ~start:0.
+      ~stop:Gg.Float.two_pi;
+    path
+
+type path =
+  | Empty
+  | Line of Point.t * Point.t
+  | Three_point of Point.t * Point.t * Point.t
+  | Curve of Curves.Bezier.t array
+
+type t =
+  { id : int
+  ; path : path }
+
+let move_to
+  : area:Gg.v2 -> Brr_canvas.C2d.Path.t -> path -> unit
+  = fun ~area canvaPath path ->
+    match path with
+    | Empty -> ()
+    | Line (p0, _)
+    | Three_point (p0, _, _) ->
+      let x, y = translate_point ~area (Point.get_coord p0) in
+      Path.move_to canvaPath ~x ~y
+    | Curve beziers ->
+      try
+        let bezier = Array.get beziers 0 in
+        let x, y = translate_point ~area bezier.Curves.Bezier.p0 in
+        Path.move_to canvaPath ~x ~y
+      with _ -> ()
+
+let draw
+  : ?connexion:Point.t -> area:Gg.v2 -> Brr_canvas.C2d.Path.t -> path -> unit
+  = fun ?connexion ~area canvaPath path ->
+    match connexion, path with
+
+    | _, Empty -> ()
+    | None, Line (_, p1) ->
+      ignore @@ line area ~p1 canvaPath
+
+    | Some p0, Line (p1, p2)
+    | None, Three_point (p0, p1, p2)
+    | Some _, Three_point (p0, p1, p2) ->
+      ignore @@ three_points area ~p0 ~p1 ~p2 canvaPath
+
+    | _, Curve beziers ->
+      Array.iter beziers
+        ~f:(fun bezier ->
+
+            let cx, cy = translate_point ~area bezier.Curves.Bezier.ctrl0
+            and cx', cy' = translate_point ~area bezier.Curves.Bezier.ctrl1
+            and x, y = translate_point ~area bezier.Curves.Bezier.p1 in
+
+            Path.ccurve_to canvaPath
+              ~cx ~cy
+              ~cx' ~cy'
+              ~x ~y
+          )
+
+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
+        Gg.Float.pi_div_4
+    in
+    match connexion, path with
+    | _, Empty -> ()
+    | _, Three_point (p0, p1, p2) ->
+      let open Point in
+      let p0' = p0 + vect
+      and p1' = p1 + vect
+      and p2' = p2 + vect in
+
+      let x, y = translate_point' ~area vect @@ Point.get_coord p2 in
+      Path.line_to canvaPath ~x ~y;
+      ignore @@ three_points area ~p0:p2' ~p1:p1' ~p2:p0' canvaPath
+    | _, Curve beziers ->
+      let last = Array.get beziers ((Array.length beziers) -1) in
+
+      let x, y =
+        last.Curves.Bezier.p1
+        |> translate_point' vect ~area in
+
+      Path.line_to canvaPath ~x ~y;
+
+      for i = 1 to Array.length beziers do
+
+        let i = (Array.length beziers) - i in
+        let bezier = Array.get beziers i in
+
+        let cx, cy = translate_point' vect ~area bezier.Curves.Bezier.ctrl1
+        and cx', cy' = translate_point' vect ~area bezier.Curves.Bezier.ctrl0
+        and x, y = translate_point' vect ~area bezier.Curves.Bezier.p0 in
+
+        Path.ccurve_to canvaPath
+          ~cx ~cy
+          ~cx' ~cy'
+          ~x ~y
+      done;
+      let x, y =
+        (Array.get beziers 0).Curves.Bezier.p0
+        |> translate_point' vect ~area in
+      Path.line_to canvaPath ~x ~y;
+
+    | _ -> ()
+
+type quick_path = Point.t list * Curves.Bezier.t list
+
+let id = ref 0
+
+let to_path
+  : quick_path -> t
+  = fun (points, beziers) ->
+
+    incr id;
+    let id = !id in
+    match beziers with
+    | [] ->
+      begin match points with
+        | p0::p1::[] -> {id; path=Line (p0, p1)}
+        | p0::p1::p2::[] -> {id; path=Three_point (p0, p1, p2)}
+        | points ->
+
+          let (let*) v f =
+            match v with
+            | Ok beziers -> f beziers
+            | _ -> {id; path=Empty} in
+
+          let points' = List.map ~f:Point.get_coord points in
+
+          let* beziers = Curves.Bspline.to_bezier points' in
+          {id; path=Curve beziers}
+      end
+    | _ ->
+      let (let*) v f =
+        match v with
+        | Ok beziers -> f beziers
+        | _ -> {id; path=Curve (Array.of_list beziers)} in
+
+      let connexion = match beziers with
+        | hd::_ -> Some hd.Curves.Bezier.p1
+        | _ -> None in
+
+      let* beziers' = Curves.Bspline.to_bezier
+          ?connexion1:connexion
+          (List.map points ~f:Point.get_coord) in
+
+
+      (* Create a new array with both lenght *)
+      let t = Array.append
+          beziers'
+          (Array.of_list beziers)
+      in
+
+      {id; path = Curve t}
diff --git a/draw/dune b/draw/dune
new file mode 100755
index 0000000..1791604
--- /dev/null
+++ b/draw/dune
@@ -0,0 +1,8 @@
+(library
+ (name draw)
+ (libraries 
+   gg
+   brr
+   curves
+   )
+ )
diff --git a/draw/point.ml b/draw/point.ml
new file mode 100755
index 0000000..150bc8e
--- /dev/null
+++ b/draw/point.ml
@@ -0,0 +1,78 @@
+open StdLabels
+
+type t =
+  { p: Gg.v2
+  ; size : float
+  ; angle: float
+  }
+
+let create x y =
+  { p = Gg.V2.v x y
+  ; size = 0.1
+  ; angle = Gg.Float.pi_div_4
+  }
+
+let (+) p1 p2 =
+  { p1 with p = Gg.V2.(+) p1.p p2 }
+
+let get_coord { p; _ } = p
+
+let get_coord'
+  : t -> Gg.v2
+  = fun t ->
+    let open Gg.V2 in
+    let trans = of_polar @@ v t.size t.angle in
+    t.p + trans
+
+let return_segment
+  : Curves.Bezier.t -> Curves.Bezier.t list -> Curves.Bezier.t list
+  = fun bezier beziers ->
+    (* We gave the points in reverse order, so we have to revert the
+       curve *)
+    let bezier' = Curves.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
+  Curves.Bspline.to_bezier ?connexion0 points_to_link
+
+let add_point_in_path
+  : float -> float -> t list -> Curves.Bezier.t list -> t list * Curves.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.Curves.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/draw/point.mli b/draw/point.mli
new file mode 100755
index 0000000..8e3f5aa
--- /dev/null
+++ b/draw/point.mli
@@ -0,0 +1,13 @@
+type t
+
+val (+): t -> Gg.v2 -> t
+
+val get_coord : t -> Gg.v2
+
+val create: float -> float -> t
+
+val add_point_in_path
+  : float -> float -> t list -> Curves.Bezier.t list -> t list * Curves.Bezier.t list
+
+val get_coord'
+  : t -> Gg.v2
-- 
cgit v1.2.3