1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
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 Make(Point:P) = struct
module type BUILDER = sig
type t
val repr
: t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's
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 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 -> repr -> repr
= fun p1 p2 (i, t) ->
( i + 1
, Line (p1, p2)::t)
let quadratic_to
: t -> Gg.v2 -> Gg.v2 -> t -> repr -> 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;
{ id = !internal_id
; path = Builder.repr t (module ToFixed) (ToFixed.create_path ())
|> ToFixed.get
}
let 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
bezier.ctrl0
bezier.ctrl1
bezier.p1
p in
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
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 -> (Gg.v2 * 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 (point', distance)
| Some (_, d) -> if d < distance then res else (Some (point', 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
|
