never executed always true always false
1 {-# LANGUAGE RecordWildCards #-}
2 {-# LANGUAGE TupleSections #-}
3 {-# LANGUAGE UnicodeSyntax #-}
4 {-|
5 Copyright : Written by David Himmelstrup
6 License : Unlicense
7 Maintainer : lemmih@gmail.com
8 Stability : experimental
9 Portability : POSIX
10 -}
11 module Reanimate.Morph.Common
12 ( PointCorrespondence
13 , Trajectory
14 , ObjectCorrespondence
15 , Morph(..)
16 , morph
17 , splitObjectCorrespondence
18 , dupObjectCorrespondence
19 , genesisObjectCorrespondence
20 , toShapes
21 , normalizePolygons
22 , annotatePolygons
23 , unsafeSVGToPolygon
24 ) where
25
26 import Control.Lens
27 import qualified Data.Vector as V
28 import Graphics.SvgTree (DrawAttributes, Texture (..),
29 drawAttributes, fillColor,
30 fillOpacity, groupOpacity,
31 strokeColor, strokeOpacity)
32 import Linear.V2
33 import Reanimate.Animation
34 import Reanimate.ColorComponents
35 import Reanimate.Ease
36 import Reanimate.Math.Polygon (APolygon, Epsilon, Polygon,
37 mkPolygon, pAddPoints, pCentroid,
38 pCutEqual, pSize, polygonPoints)
39 import Reanimate.PolyShape
40 import Reanimate.Svg
41
42 -- import Debug.Trace
43
44 -- Correspondence
45 -- Trajectory
46 -- Color interpolation
47 -- Polygon holes
48 -- Polygon splitting
49
50 -- Graphical polygon? FIXME: Come up with a better name.
51 type GPolygon = (DrawAttributes, Polygon)
52
53 -- | Method determining how points in the source polygon align with
54 -- points in the target polygon.
55 type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon)
56
57 -- | Method for interpolating between two aligned polygons.
58 type Trajectory = (Polygon, Polygon) → (Double → Polygon)
59
60 -- | Method for pairing sets of polygons.
61 type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)]
62
63 -- | Morphing strategy
64 data Morph = Morph
65 { morphTolerance :: Double
66 -- ^ Morphing curves is not always possible and
67 -- sometimes shapes are reduced to polygons or meta-curves.
68 -- This parameter determined the accuracy of this transformation.
69 , morphColorComponents :: ColorComponents
70 -- ^ Color components used for color interpolation. LAB is usually
71 -- the best option here.
72 , morphPointCorrespondence :: PointCorrespondence
73 -- ^ Desired point-correspondence algorithm.
74 , morphTrajectory :: Trajectory
75 -- ^ Desired interpolation algorithm.
76 , morphObjectCorrespondence :: ObjectCorrespondence
77 -- ^ Desired object-correspondence algorithm.
78 }
79
80 {-# INLINE morph #-}
81 -- | Apply morphing strategy to interpolate between two SVG images.
82 morph :: Morph -> SVG -> SVG -> Double -> SVG
83 morph Morph{..} src dst = \t ->
84 case t of
85 0 -> lowerTransformations src
86 1 -> lowerTransformations dst
87 _ -> mkGroup
88 [ render (genPoints t)
89 & drawAttributes .~ genAttrs t
90 | (genAttrs, genPoints) <- gens
91 ]
92 where
93 render p = mkLinePathClosed
94 [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ]
95 srcShapes = toShapes morphTolerance src
96 dstShapes = toShapes morphTolerance dst
97 pairs = morphObjectCorrespondence srcShapes dstShapes
98 gens =
99 [ (interpolateAttrs morphColorComponents srcAttr dstAttr, morphTrajectory arranged)
100 | ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs
101 , let arranged = morphPointCorrespondence srcPoly' dstPoly'
102 ]
103
104 -- | Add points to each polygon such that they end up with same size.
105 normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
106 normalizePolygons src dst =
107 (pAddPoints (max 0 $ dstN-srcN) src
108 ,pAddPoints (max 0 $ srcN-dstN) dst)
109 where
110 srcN = pSize src
111 dstN = pSize dst
112
113 interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes
114 interpolateAttrs colorComps src dst t =
115 src & fillColor .~ (interpColor <$> src^.fillColor <*> dst^.fillColor)
116 & strokeColor .~ (interpColor <$> src^.strokeColor <*> dst^.strokeColor)
117 & fillOpacity .~ (interpOpacity <$> src^.fillOpacity <*> dst^.fillOpacity)
118 & groupOpacity .~ (interpOpacity <$> src^.groupOpacity <*> dst^.groupOpacity)
119 & strokeOpacity .~ (interpOpacity <$> src^.strokeOpacity <*> dst^.strokeOpacity)
120 where
121 interpColor (ColorRef a) (ColorRef b) =
122 ColorRef $ interpolateRGBA8 colorComps a b t
123 -- interpolateColor (ColorRef a) FillNone = ColorRef a
124 interpColor a _ = a
125 interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t)
126
127 -- | Object-correspondence algorithm that spawn objects as necessary.
128 genesisObjectCorrespondence :: ObjectCorrespondence
129 genesisObjectCorrespondence left right =
130 case (left, right) of
131 ([] , []) -> []
132 ([], (y1,y2):ys) ->
133 ((y1,y2), (y1, emptyFrom y2 y2)) : genesisObjectCorrespondence [] ys
134 ((x1,x2):xs, []) ->
135 ((x1,x2), (x1, emptyFrom x2 x2)) : genesisObjectCorrespondence xs []
136 (x:xs, y:ys) ->
137 (x,y) : genesisObjectCorrespondence xs ys
138 where
139 emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b)
140
141 -- | Object-correspondence algorithm that duplicate objects as necessary.
142 dupObjectCorrespondence :: ObjectCorrespondence
143 dupObjectCorrespondence left right =
144 case (left, right) of
145 (_, []) -> []
146 ([], _) -> []
147 ([x], [y]) ->
148 [(x,y)]
149 ([(x1,x2)], yShapes) ->
150 let x2s = replicate (length yShapes) x2
151 in dupObjectCorrespondence (map (x1,) x2s) yShapes
152 (xShapes, [(y1,y2)]) ->
153 let y2s = replicate (length xShapes) y2
154 in dupObjectCorrespondence xShapes (map (y1,) y2s)
155 (x:xs, y:ys) ->
156 (x, y) : dupObjectCorrespondence xs ys
157
158 -- | Object-correspondence algorithm that splits objects in smaller pieces
159 -- as necessary.
160 splitObjectCorrespondence :: ObjectCorrespondence
161 -- splitObjectCorrespondence = dupObjectCorrespondence
162 splitObjectCorrespondence left right =
163 case (left, right) of
164 (_, []) -> []
165 ([], _) -> []
166 ([x], [y]) ->
167 [(x,y)]
168 ([(x1,x2)], yShapes) ->
169 let x2s = splitPolygon (length yShapes) x2
170 in splitObjectCorrespondence (map (x1,) x2s) yShapes
171 (xShapes, [(y1,y2)]) ->
172 let y2s = splitPolygon (length xShapes) y2
173 in splitObjectCorrespondence xShapes (map (y1,) y2s)
174 (x:xs, y:ys) ->
175 (x,y) : splitObjectCorrespondence xs ys
176
177 splitPolygon :: Int -> Polygon -> [Polygon]
178 splitPolygon 1 p = [p]
179 splitPolygon n p =
180 let (a,b) = pCutEqual p
181 in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b
182
183 -- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)]
184 -- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])]
185 -- joinPairs _ _ [] = []
186 -- joinPairs _ [] _ = []
187 -- joinPairs corr [(x1,x2)] [(y1,y2)] =
188 -- [(x1,y1, corr x2 y2)]
189 -- joinPairs corr [(x1,x2)] yShapes =
190 -- let x2s = splitPolyShape 0.001 (length yShapes) x2
191 -- in joinPairs corr (map (x1,) x2s) yShapes
192 -- joinPairs corr xShapes [(y1,y2)] =
193 -- let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2
194 -- in joinPairs corr xShapes (map (y1,) y2s)
195 -- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) =
196 -- (x1,y1, corr x2 y2) : joinPairs corr xs ys
197 -- joinPairs _ _ _ = []
198
199 -- FIXME: sort by size, smallest to largest
200 -- | Extract shapes and their graphical attributes from an SVG node.
201 toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)]
202 toShapes tol src =
203 [ (attrs, plToPolygon tol shape)
204 | (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src
205 , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph
206 ]
207
208 -- | Extract the first polygon in an SVG node. Will fail if there
209 -- are no acceptable shapes.
210 unsafeSVGToPolygon :: Double -> SVG -> Polygon
211 unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src
212
213 -- | Map over each polygon in an SVG node.
214 annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG
215 annotatePolygons fn svg = mkGroup
216 [ fn poly & drawAttributes .~ attr
217 | (attr, poly) <- toShapes 0.001 svg
218 ]