never executed always true always false
1 {-# LANGUAGE FunctionalDependencies #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 module Reanimate.Internal.CubicBezier
5 ( AnyBezier(..)
6 , CubicBezier(..)
7 , QuadBezier(..)
8 , OpenPath(..)
9 , ClosedPath(..)
10 , PathJoin(..)
11 , ClosedMetaPath(..)
12 , OpenMetaPath(..)
13 , MetaJoin(..)
14 , MetaNodeType(..)
15 , C.GenericBezier(..)
16 , C.FillRule(..)
17 , C.Tension(..)
18 , quadToCubic
19 , arcLength
20 , arcLengthParam
21 , C.splitBezier
22 , colinear
23 , evalBezier
24 , evalBezierDeriv
25 , bezierHoriz
26 , bezierVert
27 , C.bezierSubsegment
28 , C.reorient
29 , closedPathCurves
30 , openPathCurves
31 , curvesToClosed
32 , closest
33 , unmetaOpen
34 , unmetaClosed
35 , union
36 , bezierIntersection
37 , interpolateVector
38 , vectorDistance
39 , findBezierInflection
40 , findBezierCusp
41 ) where
42
43 import qualified Data.Vector.Unboxed as V
44 import qualified Geom2D.CubicBezier as C
45 import Linear.V2
46
47 ------------------------------------------------------------
48 -- Data types
49
50 newtype AnyBezier a = AnyBezier (V.Vector (V2 a))
51
52 data CubicBezier a = CubicBezier
53 { cubicC0 :: !(V2 a)
54 , cubicC1 :: !(V2 a)
55 , cubicC2 :: !(V2 a)
56 , cubicC3 :: !(V2 a)
57 } deriving (Show, Eq)
58
59 data QuadBezier a = QuadBezier
60 { quadC0 :: !(V2 a)
61 , quadC1 :: !(V2 a)
62 , quadC2 :: !(V2 a)
63 } deriving (Show, Eq)
64
65 data OpenPath a = OpenPath [(V2 a, PathJoin a)] (V2 a)
66 deriving (Show, Eq)
67 data ClosedPath a = ClosedPath [(V2 a, PathJoin a)]
68 deriving (Show, Eq)
69
70 data PathJoin a
71 = JoinLine
72 | JoinCurve (V2 a) (V2 a)
73 deriving (Show, Eq)
74
75 data ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)]
76 deriving (Show, Eq)
77 data OpenMetaPath a = OpenMetaPath [(V2 a, MetaJoin a)] (V2 a)
78 deriving (Show, Eq)
79
80 data MetaJoin a
81 = MetaJoin
82 { metaTypeL :: MetaNodeType a
83 , tensionL :: C.Tension a
84 , tensionR :: C.Tension a
85 , metaTypeR :: MetaNodeType a
86 }
87 | Controls (V2 a) (V2 a)
88 deriving (Show, Eq)
89
90 data MetaNodeType a
91 = Open
92 | Curl { curlgamma :: a }
93 | Direction { nodedir :: V2 a }
94 deriving (Show, Eq)
95
96 ------------------------------------------------------------
97 -- Methods
98
99 quadToCubic :: Fractional a => QuadBezier a -> CubicBezier a
100 quadToCubic = upCast . C.quadToCubic . downCast
101
102 arcLength :: CubicBezier Double -> Double -> Double -> Double
103 arcLength bezier t tol = C.arcLength (downCast bezier) t tol
104
105 arcLengthParam :: CubicBezier Double -> Double -> Double -> Double
106 arcLengthParam bezier t tol = C.arcLengthParam (downCast bezier) t tol
107
108 colinear :: CubicBezier Double -> Double -> Bool
109 colinear bezier tol = C.colinear (downCast bezier) tol
110
111 evalBezier :: (C.GenericBezier b, V.Unbox a, Fractional a) => b a -> a -> V2 a
112 evalBezier c p = upCast $ C.evalBezier c p
113
114 evalBezierDeriv :: (V.Unbox a, Fractional a,C.GenericBezier b) => b a -> a -> (V2 a, V2 a)
115 evalBezierDeriv c p = upCast $ C.evalBezierDeriv c p
116
117 bezierHoriz :: CubicBezier Double -> [Double]
118 bezierHoriz = C.bezierHoriz . downCast
119
120 bezierVert :: CubicBezier Double -> [Double]
121 bezierVert = C.bezierVert . downCast
122
123 unmetaOpen :: OpenMetaPath Double -> OpenPath Double
124 unmetaOpen = upCast . C.unmetaOpen . downCast
125
126 unmetaClosed :: ClosedMetaPath Double -> ClosedPath Double
127 unmetaClosed = upCast . C.unmetaClosed . downCast
128
129 union :: [ClosedPath Double] -> C.FillRule -> Double -> [ClosedPath Double]
130 union p fill tol = upCast (C.union (downCast p) fill tol)
131
132 bezierIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)]
133 bezierIntersection a b t = C.bezierIntersection (downCast a) (downCast b) t
134
135 closest :: CubicBezier Double -> V2 Double -> Double -> Double
136 closest c p t = C.closest (downCast c) (downCast p) t
137
138 closedPathCurves :: Fractional a => ClosedPath a -> [CubicBezier a]
139 closedPathCurves = upCast . C.closedPathCurves . downCast
140
141 openPathCurves :: Fractional a => OpenPath a -> [CubicBezier a]
142 openPathCurves = upCast . C.openPathCurves . downCast
143
144 curvesToClosed :: [CubicBezier a] -> ClosedPath a
145 curvesToClosed = upCast . C.curvesToClosed . downCast
146
147 interpolateVector :: Num a => V2 a -> V2 a -> a -> V2 a
148 interpolateVector a b p = upCast $ C.interpolateVector (downCast a) (downCast b) p
149
150 vectorDistance :: Floating a => V2 a -> V2 a -> a
151 vectorDistance a b = C.vectorDistance (downCast a) (downCast b)
152
153 findBezierInflection :: CubicBezier Double -> [Double]
154 findBezierInflection = C.findBezierInflection . downCast
155
156 findBezierCusp :: CubicBezier Double -> [Double]
157 findBezierCusp = C.findBezierCusp . downCast
158
159 ------------------------------------------------------------
160 -- Instances
161
162 instance C.GenericBezier QuadBezier where
163 degree = C.degree . downCast
164 toVector = C.toVector . downCast
165 unsafeFromVector = upCast . C.unsafeFromVector
166
167 instance C.GenericBezier CubicBezier where
168 degree = C.degree . downCast
169 toVector = C.toVector . downCast
170 unsafeFromVector = upCast . C.unsafeFromVector
171
172 instance C.GenericBezier AnyBezier where
173 degree = C.degree . downCast
174 toVector = C.toVector . downCast
175 unsafeFromVector = upCast . C.unsafeFromVector
176
177 ------------------------------------------------------------
178 -- Casting
179
180 class Cast a b | a -> b, b -> a where
181 downCast :: a -> b
182 upCast :: b -> a
183
184 instance Cast a b => Cast [a] [b] where
185 downCast = map downCast
186 upCast = map upCast
187
188 instance (Cast a a', Cast b b') => Cast (a,b) (a',b') where
189 downCast (a, b) = (downCast a, downCast b)
190 upCast (a, b) = (upCast a, upCast b)
191
192 instance Cast (V2 a) (C.Point a) where
193 downCast (V2 a b) = C.Point a b
194 upCast (C.Point a b) = V2 a b
195
196 instance Cast (CubicBezier a) (C.CubicBezier a) where
197 downCast (CubicBezier a b c d) = C.CubicBezier
198 (downCast a) (downCast b) (downCast c) (downCast d)
199 upCast (C.CubicBezier a b c d) = CubicBezier
200 (upCast a) (upCast b) (upCast c) (upCast d)
201
202 instance Cast (QuadBezier a) (C.QuadBezier a) where
203 downCast (QuadBezier a b c) = C.QuadBezier
204 (downCast a) (downCast b) (downCast c)
205 upCast (C.QuadBezier a b c)= QuadBezier
206 (upCast a) (upCast b) (upCast c)
207
208 instance V.Unbox a => Cast (AnyBezier a) (C.AnyBezier a) where
209 downCast (AnyBezier arr) = C.AnyBezier $
210 V.map (\(V2 a b) -> (a,b)) arr
211 upCast (C.AnyBezier arr) = AnyBezier $
212 V.map (\(a, b) -> V2 a b) arr
213
214 instance Cast (MetaNodeType a) (C.MetaNodeType a) where
215 downCast Open = C.Open
216 downCast (Curl gamma) = C.Curl gamma
217 downCast (Direction dir) = C.Direction (downCast dir)
218 upCast C.Open = Open
219 upCast (C.Curl gamma) = Curl gamma
220 upCast (C.Direction dir) = Direction (upCast dir)
221
222 instance Cast (MetaJoin a) (C.MetaJoin a) where
223 downCast (MetaJoin tyL tL tR tyR) = C.MetaJoin (downCast tyL) tL tR (downCast tyR)
224 downCast (Controls p1 p2) = C.Controls (downCast p1) (downCast p2)
225 upCast (C.MetaJoin tyL tL tR tyR) = MetaJoin (upCast tyL) tL tR (upCast tyR)
226 upCast (C.Controls p1 p2) = Controls (upCast p1) (upCast p2)
227
228 instance Cast (PathJoin a) (C.PathJoin a) where
229 downCast JoinLine = C.JoinLine
230 downCast (JoinCurve a b) = C.JoinCurve (downCast a) (downCast b)
231 upCast C.JoinLine = JoinLine
232 upCast (C.JoinCurve a b) = JoinCurve (upCast a) (upCast b)
233
234 instance Cast (OpenMetaPath a) (C.OpenMetaPath a) where
235 downCast (OpenMetaPath lst end) = C.OpenMetaPath
236 [ (downCast p, downCast j)
237 | (p, j) <- lst ] (downCast end)
238 upCast (C.OpenMetaPath lst end) = OpenMetaPath
239 [ (upCast p, upCast j)
240 | (p, j) <- lst ] (upCast end)
241
242 instance Cast (ClosedMetaPath a) (C.ClosedMetaPath a) where
243 downCast (ClosedMetaPath lst) = C.ClosedMetaPath
244 [ (downCast p, downCast j)
245 | (p, j) <- lst ]
246 upCast (C.ClosedMetaPath lst) = ClosedMetaPath
247 [ (upCast p, upCast j)
248 | (p, j) <- lst ]
249
250 instance Cast (OpenPath a) (C.OpenPath a) where
251 downCast (OpenPath lst end) = C.OpenPath
252 [ (downCast p, downCast j)
253 | (p, j) <- lst ] (downCast end)
254 upCast (C.OpenPath lst end) = OpenPath
255 [ (upCast p, upCast j)
256 | (p, j) <- lst ] (upCast end)
257
258 instance Cast (ClosedPath a) (C.ClosedPath a) where
259 downCast (ClosedPath lst) = C.ClosedPath
260 [ (downCast p, downCast j)
261 | (p, j) <- lst ]
262 upCast (C.ClosedPath lst) = ClosedPath
263 [ (upCast p, upCast j)
264 | (p, j) <- lst ]