never executed always true always false
1 {-# LANGUAGE DeriveFoldable #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE DeriveTraversable #-}
4 {-# LANGUAGE FunctionalDependencies #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 {-|
8 Module : Geom2D.CubicBezier.Linear
9 Copyright : Written by David Himmelstrup
10 License : Unlicense
11 Maintainer : lemmih@gmail.com
12 Stability : experimental
13 Portability : POSIX
14
15 Convenience wrapper around 'Geom2D.CubicBezier'
16
17 -}
18 module Geom2D.CubicBezier.Linear
19 ( AnyBezier(..)
20 , CubicBezier(..)
21 , QuadBezier(..)
22 , OpenPath(..)
23 , ClosedPath(..)
24 , PathJoin(..)
25 , ClosedMetaPath(..)
26 , OpenMetaPath(..)
27 , MetaJoin(..)
28 , MetaNodeType(..)
29 , FillRule(..)
30 , Tension(..)
31 , quadToCubic
32 , arcLength
33 , arcLengthParam
34 , C.splitBezier
35 , colinear
36 , evalBezier
37 , evalBezierDeriv
38 , bezierHoriz
39 , bezierVert
40 , C.bezierSubsegment
41 , C.reorient
42 , closedPathCurves
43 , openPathCurves
44 , curvesToClosed
45 , closest
46 , unmetaOpen
47 , unmetaClosed
48 , union
49 , bezierIntersection
50 , interpolateVector
51 , vectorDistance
52 , findBezierInflection
53 , findBezierCusp
54 ) where
55
56 import qualified Data.Vector.Unboxed as V
57 import qualified Geom2D.CubicBezier as C
58 import Graphics.SvgTree (FillRule (..))
59 import Linear.V2
60
61 ------------------------------------------------------------
62 -- Data types
63
64 -- | A bezier curve of any degree.
65 newtype AnyBezier a = AnyBezier (V.Vector (V2 a))
66
67 -- | A cubic bezier curve.
68 data CubicBezier a = CubicBezier
69 { cubicC0 :: !(V2 a)
70 , cubicC1 :: !(V2 a)
71 , cubicC2 :: !(V2 a)
72 , cubicC3 :: !(V2 a)
73 } deriving (Show, Eq)
74
75 -- | A quadratic bezier curve.
76 data QuadBezier a = QuadBezier
77 { quadC0 :: !(V2 a)
78 , quadC1 :: !(V2 a)
79 , quadC2 :: !(V2 a)
80 } deriving (Show, Eq)
81
82 -- | Open cubicbezier path.
83 data OpenPath a = OpenPath [(V2 a, PathJoin a)] (V2 a)
84 deriving (Show, Eq)
85
86 -- | Closed cubicbezier path.
87 data ClosedPath a = ClosedPath [(V2 a, PathJoin a)]
88 deriving (Show, Eq)
89
90 -- | Join two points with either a straight line or a bezier
91 -- curve with two control points.
92 data PathJoin a
93 = JoinLine
94 | JoinCurve (V2 a) (V2 a)
95 deriving (Show, Eq)
96
97 -- | Closed meta path.
98 data ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)]
99 deriving (Show, Eq)
100
101 -- | Open meta path
102 data OpenMetaPath a = OpenMetaPath [(V2 a, MetaJoin a)] (V2 a)
103 deriving (Show, Eq)
104
105 -- | The tension value specifies how /tense/ the curve is.
106 -- A higher value means the curve approaches a line segment,
107 -- while a lower value means the curve is more round. Metafont
108 -- doesn't allow values below 3/4.
109 data Tension a
110 = Tension
111 { tensionValue :: a }
112 | TensionAtLeast -- ^ Like Tension, but keep the segment inside the
113 -- bounding triangle defined by the control points,
114 -- if there is one.
115 { tensionValue :: a }
116 deriving (Functor, Foldable, Traversable, Eq, Show)
117
118 -- | Join two meta points with either a bezier curve or tension
119 -- contraints.
120 data MetaJoin a
121 = MetaJoin
122 { metaTypeL :: MetaNodeType a
123 , tensionL :: Tension a
124 , tensionR :: Tension a
125 , metaTypeR :: MetaNodeType a
126 }
127 | Controls (V2 a) (V2 a)
128 deriving (Show, Eq)
129
130 -- | Node constraint type.
131 data MetaNodeType a
132 = Open
133 | Curl { curlgamma :: a }
134 | Direction { nodedir :: V2 a }
135 deriving (Show, Eq)
136
137 ------------------------------------------------------------
138 -- Methods
139
140 -- | Convert a quadratic bezier to a cubic bezier.
141 quadToCubic :: Fractional a => QuadBezier a -> CubicBezier a
142 quadToCubic = upCast . C.quadToCubic . downCast
143
144 -- | @arcLength c t tol@ finds the arclength of the bezier @c@ at @t@,
145 -- within given tolerance @tol@.
146 arcLength :: CubicBezier Double -> Double -> Double -> Double
147 arcLength bezier t tol = C.arcLength (downCast bezier) t tol
148
149 -- | @arcLengthParam c len tol@ finds the parameter where the curve @c@
150 -- has the arclength @len@, within tolerance @tol@.
151 arcLengthParam :: CubicBezier Double -> Double -> Double -> Double
152 arcLengthParam bezier t tol = C.arcLengthParam (downCast bezier) t tol
153
154 -- | Return @False@ if some points fall outside a line with a thickness of the given tolerance.
155 colinear :: CubicBezier Double -> Double -> Bool
156 colinear bezier tol = C.colinear (downCast bezier) tol
157
158 -- | Calculate a value on the bezier curve.
159 evalBezier :: (C.GenericBezier b, V.Unbox a, Fractional a) => b a -> a -> V2 a
160 evalBezier c p = upCast $ C.evalBezier c p
161
162 -- | Calculate a value and the first derivative on the curve.
163 evalBezierDeriv :: (V.Unbox a, Fractional a,C.GenericBezier b) => b a -> a -> (V2 a, V2 a)
164 evalBezierDeriv c p = upCast $ C.evalBezierDeriv c p
165
166 -- | Find the parameter where the bezier curve is horizontal.
167 bezierHoriz :: CubicBezier Double -> [Double]
168 bezierHoriz = C.bezierHoriz . downCast
169
170 -- | Find the parameter where the bezier curve is vertical.
171 bezierVert :: CubicBezier Double -> [Double]
172 bezierVert = C.bezierVert . downCast
173
174 -- | Create a normal path from a metapath.
175 unmetaOpen :: OpenMetaPath Double -> OpenPath Double
176 unmetaOpen = upCast . C.unmetaOpen . downCast
177
178 -- | Create a normal path from a metapath.
179 unmetaClosed :: ClosedMetaPath Double -> ClosedPath Double
180 unmetaClosed = upCast . C.unmetaClosed . downCast
181
182 -- | `O((n+m)*log(n+m))`, for n segments and m intersections.
183 -- Union of paths, removing overlap and rounding to the given tolerance.
184 union :: [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
185 union p fill tol = upCast (C.union (downCast p) (downCast fill) tol)
186
187 -- | Find the intersections between two Bezier curves, using the Bezier Clip algorithm.
188 -- Returns the parameters for both curves.
189 bezierIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)]
190 bezierIntersection a b t = C.bezierIntersection (downCast a) (downCast b) t
191
192 -- | Find the closest value on the bezier to the given point, within tolerance.
193 -- Return the first value found.
194 closest :: CubicBezier Double -> V2 Double -> Double -> Double
195 closest c p t = C.closest (downCast c) (downCast p) t
196
197 -- | Return the closed path as a list of curves.
198 closedPathCurves :: Fractional a => ClosedPath a -> [CubicBezier a]
199 closedPathCurves = upCast . C.closedPathCurves . downCast
200
201 -- | Return the open path as a list of curves.
202 openPathCurves :: Fractional a => OpenPath a -> [CubicBezier a]
203 openPathCurves = upCast . C.openPathCurves . downCast
204
205 -- | Make an open path from a list of curves. The last control point of each curve is ignored.
206 curvesToClosed :: [CubicBezier a] -> ClosedPath a
207 curvesToClosed = upCast . C.curvesToClosed . downCast
208
209 -- | Interpolate between two vectors.
210 interpolateVector :: Num a => V2 a -> V2 a -> a -> V2 a
211 interpolateVector a b p = upCast $ C.interpolateVector (downCast a) (downCast b) p
212
213 -- | Distance between two vectors.
214 vectorDistance :: Floating a => V2 a -> V2 a -> a
215 vectorDistance a b = C.vectorDistance (downCast a) (downCast b)
216
217 -- | Find inflection points on the curve.
218 findBezierInflection :: CubicBezier Double -> [Double]
219 findBezierInflection = C.findBezierInflection . downCast
220
221 -- | Find the cusps of a bezier.
222 findBezierCusp :: CubicBezier Double -> [Double]
223 findBezierCusp = C.findBezierCusp . downCast
224
225 ------------------------------------------------------------
226 -- Instances
227
228 instance C.GenericBezier QuadBezier where
229 degree = C.degree . downCast
230 toVector = C.toVector . downCast
231 unsafeFromVector = upCast . C.unsafeFromVector
232
233 instance C.GenericBezier CubicBezier where
234 degree = C.degree . downCast
235 toVector = C.toVector . downCast
236 unsafeFromVector = upCast . C.unsafeFromVector
237
238 instance C.GenericBezier AnyBezier where
239 degree = C.degree . downCast
240 toVector = C.toVector . downCast
241 unsafeFromVector = upCast . C.unsafeFromVector
242
243 ------------------------------------------------------------
244 -- Casting
245
246 class Cast a b | a -> b, b -> a where
247 downCast :: a -> b
248 upCast :: b -> a
249
250 instance Cast a b => Cast [a] [b] where
251 downCast = map downCast
252 upCast = map upCast
253
254 instance (Cast a a', Cast b b') => Cast (a,b) (a',b') where
255 downCast (a, b) = (downCast a, downCast b)
256 upCast (a, b) = (upCast a, upCast b)
257
258 instance Cast (V2 a) (C.Point a) where
259 downCast (V2 a b) = C.Point a b
260 upCast (C.Point a b) = V2 a b
261
262 instance Cast FillRule C.FillRule where
263 downCast FillEvenOdd = C.EvenOdd
264 downCast FillNonZero = C.NonZero
265 upCast C.EvenOdd = FillEvenOdd
266 upCast C.NonZero = FillNonZero
267
268 instance Cast (CubicBezier a) (C.CubicBezier a) where
269 downCast (CubicBezier a b c d) = C.CubicBezier
270 (downCast a) (downCast b) (downCast c) (downCast d)
271 upCast (C.CubicBezier a b c d) = CubicBezier
272 (upCast a) (upCast b) (upCast c) (upCast d)
273
274 instance Cast (QuadBezier a) (C.QuadBezier a) where
275 downCast (QuadBezier a b c) = C.QuadBezier
276 (downCast a) (downCast b) (downCast c)
277 upCast (C.QuadBezier a b c)= QuadBezier
278 (upCast a) (upCast b) (upCast c)
279
280 instance V.Unbox a => Cast (AnyBezier a) (C.AnyBezier a) where
281 downCast (AnyBezier arr) = C.AnyBezier $
282 V.map (\(V2 a b) -> (a,b)) arr
283 upCast (C.AnyBezier arr) = AnyBezier $
284 V.map (\(a, b) -> V2 a b) arr
285
286 instance Cast (MetaNodeType a) (C.MetaNodeType a) where
287 downCast Open = C.Open
288 downCast (Curl gamma) = C.Curl gamma
289 downCast (Direction dir) = C.Direction (downCast dir)
290 upCast C.Open = Open
291 upCast (C.Curl gamma) = Curl gamma
292 upCast (C.Direction dir) = Direction (upCast dir)
293
294 instance Cast (Tension a) (C.Tension a) where
295 downCast (Tension v) = C.Tension v
296 downCast (TensionAtLeast v) = C.TensionAtLeast v
297 upCast (C.Tension v) = Tension v
298 upCast (C.TensionAtLeast v) = TensionAtLeast v
299
300 instance Cast (MetaJoin a) (C.MetaJoin a) where
301 downCast (MetaJoin tyL tL tR tyR) =
302 C.MetaJoin (downCast tyL) (downCast tL) (downCast tR) (downCast tyR)
303 downCast (Controls p1 p2) = C.Controls (downCast p1) (downCast p2)
304 upCast (C.MetaJoin tyL tL tR tyR) =
305 MetaJoin (upCast tyL) (upCast tL) (upCast tR) (upCast tyR)
306 upCast (C.Controls p1 p2) = Controls (upCast p1) (upCast p2)
307
308 instance Cast (PathJoin a) (C.PathJoin a) where
309 downCast JoinLine = C.JoinLine
310 downCast (JoinCurve a b) = C.JoinCurve (downCast a) (downCast b)
311 upCast C.JoinLine = JoinLine
312 upCast (C.JoinCurve a b) = JoinCurve (upCast a) (upCast b)
313
314 instance Cast (OpenMetaPath a) (C.OpenMetaPath a) where
315 downCast (OpenMetaPath lst end) = C.OpenMetaPath
316 [ (downCast p, downCast j)
317 | (p, j) <- lst ] (downCast end)
318 upCast (C.OpenMetaPath lst end) = OpenMetaPath
319 [ (upCast p, upCast j)
320 | (p, j) <- lst ] (upCast end)
321
322 instance Cast (ClosedMetaPath a) (C.ClosedMetaPath a) where
323 downCast (ClosedMetaPath lst) = C.ClosedMetaPath
324 [ (downCast p, downCast j)
325 | (p, j) <- lst ]
326 upCast (C.ClosedMetaPath lst) = ClosedMetaPath
327 [ (upCast p, upCast j)
328 | (p, j) <- lst ]
329
330 instance Cast (OpenPath a) (C.OpenPath a) where
331 downCast (OpenPath lst end) = C.OpenPath
332 [ (downCast p, downCast j)
333 | (p, j) <- lst ] (downCast end)
334 upCast (C.OpenPath lst end) = OpenPath
335 [ (upCast p, upCast j)
336 | (p, j) <- lst ] (upCast end)
337
338 instance Cast (ClosedPath a) (C.ClosedPath a) where
339 downCast (ClosedPath lst) = C.ClosedPath
340 [ (downCast p, downCast j)
341 | (p, j) <- lst ]
342 upCast (C.ClosedPath lst) = ClosedPath
343 [ (upCast p, upCast j)
344 | (p, j) <- lst ]