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