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 type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon)
47 type Trajectory = (Polygon, Polygon) → (Double → Polygon)
48 type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)]
49
50 data Morph = Morph
51 { morphTolerance :: Double
52 , morphColorComponents :: ColorComponents
53 , morphPointCorrespondence :: PointCorrespondence
54 , morphTrajectory :: Trajectory
55 , morphObjectCorrespondence :: ObjectCorrespondence
56 }
57
58 {-# INLINE morph #-}
59 morph :: Morph -> SVG -> SVG -> Double -> SVG
60 morph Morph{..} src dst = \t ->
61 case t of
62 -- 0 -> lowerTransformations src
63 -- 1 -> lowerTransformations dst
64 _ -> mkGroup
65 [ render (genPoints t)
66 & drawAttributes .~ genAttrs t
67 | (genAttrs, genPoints) <- gens
68 ]
69 where
70 render p = mkLinePathClosed
71 [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ]
72 srcShapes = toShapes morphTolerance src
73 dstShapes = toShapes morphTolerance dst
74 pairs = morphObjectCorrespondence srcShapes dstShapes
75 gens =
76 [ (interpolateAttrs morphColorComponents srcAttr dstAttr, morphTrajectory arranged)
77 | ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs
78 , let arranged = morphPointCorrespondence srcPoly' dstPoly'
79 ]
80
81 normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
82 normalizePolygons src dst =
83 (pAddPoints (max 0 $ dstN-srcN) src
84 ,pAddPoints (max 0 $ srcN-dstN) dst)
85 where
86 srcN = pSize src
87 dstN = pSize dst
88
89 interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes
90 interpolateAttrs colorComps src dst t =
91 src & fillColor .~ (interpColor <$> src^.fillColor <*> dst^.fillColor)
92 & strokeColor .~ (interpColor <$> src^.strokeColor <*> dst^.strokeColor)
93 & fillOpacity .~ (interpOpacity <$> src^.fillOpacity <*> dst^.fillOpacity)
94 & groupOpacity .~ (interpOpacity <$> src^.groupOpacity <*> dst^.groupOpacity)
95 & strokeOpacity .~ (interpOpacity <$> src^.strokeOpacity <*> dst^.strokeOpacity)
96 where
97 interpColor (ColorRef a) (ColorRef b) =
98 ColorRef $ interpolateRGBA8 colorComps a b t
99 -- interpolateColor (ColorRef a) FillNone = ColorRef a
100 interpColor a _ = a
101 interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t)
102
103 genesisObjectCorrespondence :: ObjectCorrespondence
104 genesisObjectCorrespondence left right =
105 case (left, right) of
106 ([] , []) -> []
107 ([], (y1,y2):ys) ->
108 ((y1,y2), (y1, emptyFrom y2 y2)) : genesisObjectCorrespondence [] ys
109 ((x1,x2):xs, []) ->
110 ((x1,x2), (x1, emptyFrom x2 x2)) : genesisObjectCorrespondence xs []
111 (x:xs, y:ys) ->
112 (x,y) : genesisObjectCorrespondence xs ys
113 where
114 emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b)
115
116 dupObjectCorrespondence :: ObjectCorrespondence
117 dupObjectCorrespondence left right =
118 case (left, right) of
119 (_, []) -> []
120 ([], _) -> []
121 ([x], [y]) ->
122 [(x,y)]
123 ([(x1,x2)], yShapes) ->
124 let x2s = replicate (length yShapes) x2
125 in dupObjectCorrespondence (map (x1,) x2s) yShapes
126 (xShapes, [(y1,y2)]) ->
127 let y2s = replicate (length xShapes) y2
128 in dupObjectCorrespondence xShapes (map (y1,) y2s)
129 (x:xs, y:ys) ->
130 (x, y) : dupObjectCorrespondence xs ys
131
132 splitObjectCorrespondence :: ObjectCorrespondence
133 -- splitObjectCorrespondence = dupObjectCorrespondence
134 splitObjectCorrespondence left right =
135 case (left, right) of
136 (_, []) -> []
137 ([], _) -> []
138 ([x], [y]) ->
139 [(x,y)]
140 ([(x1,x2)], yShapes) ->
141 let x2s = splitPolygon (length yShapes) x2
142 in splitObjectCorrespondence (map (x1,) x2s) yShapes
143 (xShapes, [(y1,y2)]) ->
144 let y2s = splitPolygon (length xShapes) y2
145 in splitObjectCorrespondence xShapes (map (y1,) y2s)
146 (x:xs, y:ys) ->
147 (x,y) : splitObjectCorrespondence xs ys
148
149 splitPolygon :: Int -> Polygon -> [Polygon]
150 splitPolygon 1 p = [p]
151 splitPolygon n p =
152 let (a,b) = pCutEqual p
153 in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b
154
155 -- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)]
156 -- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])]
157 -- joinPairs _ _ [] = []
158 -- joinPairs _ [] _ = []
159 -- joinPairs corr [(x1,x2)] [(y1,y2)] =
160 -- [(x1,y1, corr x2 y2)]
161 -- joinPairs corr [(x1,x2)] yShapes =
162 -- let x2s = splitPolyShape 0.001 (length yShapes) x2
163 -- in joinPairs corr (map (x1,) x2s) yShapes
164 -- joinPairs corr xShapes [(y1,y2)] =
165 -- let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2
166 -- in joinPairs corr xShapes (map (y1,) y2s)
167 -- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) =
168 -- (x1,y1, corr x2 y2) : joinPairs corr xs ys
169 -- joinPairs _ _ _ = []
170
171 -- FIXME: sort by size, smallest to largest
172 toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)]
173 toShapes tol src =
174 [ (attrs, plToPolygon tol shape)
175 | (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src
176 , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph
177 ]
178
179 unsafeSVGToPolygon :: Double -> SVG -> Polygon
180 unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src
181
182 annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG
183 annotatePolygons fn svg = mkGroup
184 [ fn poly & drawAttributes .~ attr
185 | (attr, poly) <- toShapes 0.001 svg
186 ]