blob: 7a32ae19473394b5ed6e326959c5f21c5e879f87 (
plain)
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
|
type t =
{ p: Gg.v2
; size : float
; angle: float
}
let empty =
{ p = Gg.V2.of_tuple (0., 0.)
; size = 0.
; angle = 0.
}
let create x y =
{ p = Gg.V2.v x y
; size = 20.
; angle = Float.neg Gg.Float.pi_div_4
}
let copy point p =
{ point with p }
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
module Repr = CanvaPrinter
type 'a repr =
{ back: ('a Repr.t -> 'a Repr.t)
; path: ('a Repr.t)
; last_point : t option
}
let create_path
: unit -> 'a repr
= fun () ->
{ back = Repr.close
; path = Repr.create ()
; last_point = None
}
(* Start a new path. *)
let start
: t -> 'a repr -> 'a repr
= fun t {back; path; _} ->
let path = Repr.move_to (get_coord t) path in
let line' = Repr.line_to (get_coord' t) in
{ back = (fun p -> back @@ line' p)
; path
; last_point = Some t
}
let line_to
: t -> 'a repr -> 'a repr
= fun t {back; path; _} ->
let line' = Repr.line_to (get_coord' t) in
{ back = (fun t -> back @@ line' t)
; path = Repr.line_to t.p path
; last_point = Some t
}
let quadratic_to
: t -> t -> t -> t -> 'a repr -> 'a repr
= fun p0 ctrl0 ctrl1 p1 t ->
let line' path =
Repr.quadratic_to
(get_coord' ctrl1)
(get_coord' ctrl0)
(get_coord' p0) path in
let path = Repr.quadratic_to
(get_coord ctrl0)
(get_coord ctrl1)
(get_coord p1)
t.path in
{ back = (fun p -> t.back @@ line' p)
; path
; last_point = Some p1
}
let stop
: 'a repr -> 'a repr
= fun {back; path; last_point} ->
let path =
match last_point with
| Some point -> Repr.line_to (get_coord' point) path
| None -> path in
{ back = (fun x -> x)
; path = back path
; last_point = None }
let get
: 'a repr -> 'a Repr.t
= fun {back; path; _} ->
back path
|