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
|
(**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Command
open Num
open Point
open Path
open Num.Infix
open Types
let pi = Num.pi
let kappa = mkF (4. *. (sqrt 2. -. 1.) /. 3.)
let mkappa = mkF (1. -. (4. *. (sqrt 2. -. 1.) /. 3.))
type t = Path.t
(** Rectangles *)
let round_rect width height rx ry =
let hw,hh = width/./ 2.,height/./ 2. in
let rx = maxn zero (minn rx hw) in
let ry = maxn zero (minn ry hh) in
(* let ul, ur, br, bl = *)
(* pt (-.hw, hh), pt (hw, hh), *)
(* pt (hw, -.hh), pt (-.hw, -.hh) in *)
let ul1, ul2 =
pt (neg hw, hh-/(mkappa*/ry)), pt (mkappa*/rx-/hw, hh) in
let ur1, ur2 =
pt (hw-/mkappa*/rx, hh), pt (hw, hh-/mkappa*/ry) in
let br1, br2 =
pt (hw, mkappa*/ry-/hh), pt (hw-/mkappa*/rx, neg hh) in
let bl1, bl2 =
pt (mkappa*/rx-/hw, neg hh), pt (neg hw, mkappa*/ry-/hh) in
let knots = knotlist
[(noDir, pt (rx-/hw, hh), mkVec right);
(noDir, pt (hw-/rx, hh), mkVec right);
(noDir, pt (hw, hh-/ry), mkVec down);
(noDir, pt (hw, ry-/hh), mkVec down);
(noDir, pt (hw-/rx, neg hh), mkVec left);
(noDir, pt (rx-/hw, neg hh), mkVec left);
(noDir, pt (neg hw, ry-/hh), mkVec up);
(noDir, pt (neg hw, hh-/ry), mkVec up)]
in
let joints =
[jLine; mkJControls ur1 ur2; jLine; mkJControls br1 br2;
jLine; mkJControls bl1 bl2; jLine] in
cycle ~dir:(mkVec right) ~style:(mkJControls ul1 ul2)
(jointpathk knots joints)
(** Ellipses and Arcs *)
let ellipse rx ry =
let m theta = pt (rx */ (mkF (cos theta)), ry */ (mkF (sin theta))) in
let knots = knotlist
[(noDir, m 0., mkVec up); (noDir, m (pi /. 2.), mkVec left);
(noDir, m pi, mkVec down); (noDir, m (-. pi /. 2.), mkVec right)] in
let r1, r2 = pt (rx, neg (ry*/kappa)), pt (rx, ry*/kappa) in
let t1, t2 = pt (rx*/kappa , ry), pt (neg (rx*/kappa), ry) in
let l1, l2 = pt (neg rx, ry*/kappa), pt (neg rx, neg (ry*/kappa)) in
let b1, b2 = pt (neg (rx*/kappa), neg ry), pt (rx*/kappa, neg ry) in
let joints = [mkJControls r2 t1; mkJControls t2 l1; mkJControls l2 b1] in
cycle ~dir:(mkVec up)
~style:(mkJControls b2 r1) (jointpathk knots joints)
let round_box width height =
let w = width /./ 2. and h = height /./ 2. in
let mw = neg w and mh = neg h in
let dx = h /./ 5. and dy = h /./ 5. in
let style = jCurveNoInflex in
Path.pathn ~cycle:style ~style
[ mw -/ dx, zero; zero, mh -/ dy;
w +/ dx, zero; zero, h +/ dy;]
(*
let arc_ellipse_path ?(close=false) rx ry theta1 theta2 =
let curvabs theta = (2. *. theta) /. pi in
let path =
subpath (curvabs theta1) (curvabs theta2) (full_ellipse_path rx ry) in
if close then
cycle ~style:JLine (concat ~style:JLine path (NoDir,origin,NoDir))
else path
*)
let rectangle width height =
let w = width /./ 2. in
let h = height /./ 2. in
let mw = neg w in
let mh = neg h in
Path.pathn ~cycle:jLine ~style:jLine [ w, mh; w, h; mw, h; mw, mh]
let patatoid width height =
let wmin,wmax = -0.5 *./ width, 0.5 *./ width in
let hmin,hmax = -0.5 *./ height, 0.5 *./ height in
let ll = pt (wmin,hmin) in
let lr = pt (wmax,hmin) in
let ur = pt (wmax,hmax) in
let ul = pt (wmin, hmax) in
let a = segment (Random.float 1.) ll lr in
let b = segment (Random.float 1.) lr ur in
let c = segment (Random.float 1.) ur ul in
let d = segment (Random.float 1.) ul ll in
pathp ~cycle:jCurve [a;b;c;d]
let patatoid2 width height =
let wmin,wmax = -0.5 *./ width, 0.5 *./ width in
let hmin,hmax = -0.5 *./ height, 0.5 *./ height in
let ll = pt (wmin,hmin) in
let lr = pt (wmax,hmin) in
let ur = pt (wmax,hmax) in
let ul = pt (wmin, hmax) in
let f cl cr x y p =
let d = pt (bp x, bp y) in
let r = Point.rotate (Random.float 60. -. 30.) d in
let l = Point.sub Point.origin r in
let r = Point.scale ((Random.float 1. +. 0.5) *./ cl) r in
let l = Point.scale ((Random.float 1. +. 0.5) *./ cr) l in
(Point.shift p l, Point.shift p r)
in
let c = 0.25 in
let ch = c *./ width in
let cv = c *./ height in
let l1, r1 = f ch cv 1. 1. ul in
let l2, r2 = f cv ch 1. (-1.) ur in
let l3, r3 = f ch cv (-1.) (-1.) lr in
let l4, r4 = f cv ch (-1.) 1. ll in
let path = jointpathp [
ul;
ur;
lr;
ll;
] [
jControls r1 l2;
jControls r2 l3;
jControls r3 l4;
] in
cycle ~style: (jControls r4 l1) path
let circle d = Path.scale d Path.fullcircle
|
