hashirama/reanimate
Watch
1
0
Fork
You've already forked reanimate
 0
mirror of https://github.com/reanimate/reanimate.git synced 2026-09-16 18:42:21 +00:00
Code Issues Projects Releases Wiki Activity

Deploying to gh-pages from @ ce1059b8b0 🚀

Browse source
This commit is contained in:
Lemmih 2020-08-26 12:49:33 +00:00
commit 4417f2cf54
7 changed files with 1617 additions and 1552 deletions
Download patch file Download diff file Expand all files Collapse all files

301
reanimate-0.4.1.0-inplace/Reanimate.Morph.Common.hs.html
View file

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