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