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