diff --git a/reanimate-svg.cabal b/reanimate-svg.cabal --- a/reanimate-svg.cabal +++ b/reanimate-svg.cabal @@ -1,5 +1,5 @@ name: reanimate-svg -version: 0.9.8.0 +version: 0.10.0.0 synopsis: SVG file loader and serializer description: reanimate-svg provides types representing a SVG document, diff --git a/src/Graphics/SvgTree/Types.hs b/src/Graphics/SvgTree/Types.hs --- a/src/Graphics/SvgTree/Types.hs +++ b/src/Graphics/SvgTree/Types.hs @@ -63,6 +63,13 @@ , EdgeMode(..) , HasGaussianBlur(..) , GaussianBlur(..) + , HasTurbulence(..) + , Turbulence(..) + , TurbulenceType(..) + , StitchTiles(..) + , HasDisplacementMap(..) + , DisplacementMap(..) + , ChannelSelector(..) -- * SVG drawing primitives -- ** Rectangle @@ -1633,14 +1640,14 @@ data FilterElement = FEBlend | FEColorMatrix ColorMatrix - | FEComponentTransfer + | FEComponentTransfer -- Need | FEComposite Composite | FEConvolveMatrix | FEDiffuseLighting - | FEDisplacementMap + | FEDisplacementMap DisplacementMap | FEDropShadow | FEFlood - | FEFuncA + | FEFuncA -- Need | FEFuncB | FEFuncG | FEFuncR @@ -1652,13 +1659,61 @@ | FEOffset | FESpecularLighting | FETile - | FETurbulence + | FETurbulence Turbulence | FENone deriving (Eq,Show) instance WithDefaultSvg FilterElement where defaultSvg = FENone +data TransferFunctionType + = TFIdentity + | TFTable + | TFDiscrete + | TFLinear + | TFGamma + deriving (Eq, Show) + +data TransferFunction = TransferFunction + { _transferFunctionDrawAttributes :: !DrawAttributes + , _transferFunctionFilterAttr :: !FilterAttributes + , _transferFunctionType :: TransferFunctionType + , _transferFunctionTableValues :: [Double] + , _transferFunctionSlope :: Double + , _transferFunctionIntercept :: Double + , _transferFunctionAmplitude :: Double + , _transferFunctionExponent :: Double + , _transferFunctionOffset :: Double + } deriving (Eq, Show) + +data ChannelSelector + = ChannelR + | ChannelG + | ChannelB + | ChannelA + deriving (Eq, Show) + +data DisplacementMap = DisplacementMap + { _displacementMapDrawAttributes :: !DrawAttributes + , _displacementMapFilterAttr :: !FilterAttributes + , _displacementMapIn :: !(Last FilterSource) + , _displacementMapIn2 :: !(Last FilterSource) + , _displacementMapScale :: !(Last Double) + , _displacementMapXChannelSelector :: ChannelSelector + , _displacementMapYChannelSelector :: ChannelSelector + } deriving (Eq, Show) + +instance WithDefaultSvg DisplacementMap where + defaultSvg = DisplacementMap + { _displacementMapDrawAttributes = defaultSvg + , _displacementMapFilterAttr = defaultSvg + , _displacementMapIn = Last Nothing + , _displacementMapIn2 = Last Nothing + , _displacementMapScale = Last Nothing + , _displacementMapXChannelSelector = ChannelA + , _displacementMapYChannelSelector = ChannelA + } + data ColorMatrixType = Matrix | Saturate @@ -1717,6 +1772,37 @@ , _compositeK4 = Num 0 } +data Turbulence = Turbulence + { _turbulenceDrawAttributes :: !DrawAttributes + , _turbulenceFilterAttr :: !FilterAttributes + , _turbulenceBaseFrequency :: !(Double, Last Double) -- Not negative + , _turbulenceNumOctaves :: Int -- Not negative + , _turbulenceSeed :: Double + , _turbulenceStitchTiles :: StitchTiles + , _turbulenceType :: TurbulenceType + } deriving (Eq, Show) + +data StitchTiles + = NoStitch + | Stitch + deriving (Eq, Show) + +data TurbulenceType + = FractalNoiseType + | TurbulenceType + deriving (Eq, Show) + +instance WithDefaultSvg Turbulence where + defaultSvg = Turbulence + { _turbulenceDrawAttributes = defaultSvg + , _turbulenceFilterAttr = defaultSvg + , _turbulenceBaseFrequency = (0, Last Nothing) + , _turbulenceNumOctaves = 1 + , _turbulenceSeed = 0 + , _turbulenceStitchTiles = NoStitch + , _turbulenceType = TurbulenceType + } + data EdgeMode = EdgeDuplicate | EdgeWrap @@ -2784,6 +2870,8 @@ makeClassy ''Composite makeClassy ''ColorMatrix makeClassy ''GaussianBlur +makeClassy ''Turbulence +makeClassy ''DisplacementMap instance HasDrawAttributes Composite where drawAttributes = compositeDrawAttributes @@ -2795,6 +2883,12 @@ instance HasDrawAttributes GaussianBlur where drawAttributes = gaussianBlurDrawAttributes +instance HasDrawAttributes Turbulence where + drawAttributes = turbulenceDrawAttributes + +instance HasDrawAttributes DisplacementMap where + drawAttributes = displacementMapDrawAttributes + instance HasFilterAttributes Composite where filterAttributes = compositeFilterAttr @@ -2804,6 +2898,12 @@ instance HasFilterAttributes GaussianBlur where filterAttributes = gaussianBlurFilterAttr +instance HasFilterAttributes Turbulence where + filterAttributes = turbulenceFilterAttr + +instance HasFilterAttributes DisplacementMap where + filterAttributes = displacementMapFilterAttr + instance HasFilterAttributes FilterElement where filterAttributes = lens getter setter where @@ -2814,7 +2914,7 @@ FEComposite c -> c ^. filterAttributes FEConvolveMatrix -> defaultSvg FEDiffuseLighting -> defaultSvg - FEDisplacementMap -> defaultSvg + FEDisplacementMap d -> d ^. filterAttributes FEDropShadow -> defaultSvg FEFlood -> defaultSvg FEFuncA -> defaultSvg @@ -2829,7 +2929,7 @@ FEOffset -> defaultSvg FESpecularLighting -> defaultSvg FETile -> defaultSvg - FETurbulence -> defaultSvg + FETurbulence t -> t ^. filterAttributes FENone -> defaultSvg setter fe attr = case fe of FEBlend -> fe @@ -2838,7 +2938,7 @@ FEComposite c -> FEComposite $ c & filterAttributes .~ attr FEConvolveMatrix -> fe FEDiffuseLighting -> fe - FEDisplacementMap -> fe + FEDisplacementMap d -> FEDisplacementMap $ d & filterAttributes .~ attr FEDropShadow -> fe FEFlood -> fe FEFuncA -> fe @@ -2853,5 +2953,5 @@ FEOffset -> fe FESpecularLighting -> fe FETile -> fe - FETurbulence -> fe + FETurbulence t -> FETurbulence $ t & filterAttributes .~ attr FENone -> fe diff --git a/src/Graphics/SvgTree/XmlParser.hs b/src/Graphics/SvgTree/XmlParser.hs --- a/src/Graphics/SvgTree/XmlParser.hs +++ b/src/Graphics/SvgTree/XmlParser.hs @@ -93,6 +93,10 @@ aparse = parse dashArray aserialize = Just . serializeDashArray +instance ParseableAttribute [Double] where + aparse = parse numberList + aserialize = Just . serializeDashArray . map Num + instance ParseableAttribute PixelRGBA8 where aparse = parse colorParser aserialize = Just . colorSerializer @@ -113,6 +117,10 @@ aparse = parseMayStartDot num aserialize v = Just $ printf "%s" (ppD v) +instance ParseableAttribute Int where + aparse = fmap (round :: Double -> Int) . aparse + aserialize v = Just $ printf "%d" v + instance ParseableAttribute Texture where aparse = parse textureParser aserialize = Just . textureSerializer @@ -390,6 +398,40 @@ HueRotate -> "hueRotate" LuminanceToAlpha -> "luminanceToAlpha" +instance ParseableAttribute StitchTiles where + aparse s = case s of + "noStitch" -> Just NoStitch + "stitch" -> Just Stitch + _ -> Nothing + + aserialize v = Just $ case v of + NoStitch -> "noStitch" + Stitch -> "stitch" + +instance ParseableAttribute TurbulenceType where + aparse s = case s of + "fractalNoise" -> Just FractalNoiseType + "turbulence" -> Just TurbulenceType + _ -> Nothing + + aserialize v = Just $ case v of + FractalNoiseType -> "fractalNoise" + TurbulenceType -> "turbulence" + +instance ParseableAttribute ChannelSelector where + aparse s = case s of + "R" -> Just ChannelR + "G" -> Just ChannelG + "B" -> Just ChannelB + "A" -> Just ChannelA + _ -> Nothing + + aserialize v = Just $ case v of + ChannelR -> "R" + ChannelG -> "G" + ChannelB -> "B" + ChannelA -> "A" + instance ParseableAttribute EdgeMode where aparse s = case s of "duplicate" -> Just EdgeDuplicate @@ -411,6 +453,15 @@ aserialize (x, Last Nothing) = aserialize [x] aserialize (x, Last (Just y)) = aserialize [x, y] +instance ParseableAttribute (Double, Last Double) where + aparse s = case aparse s of + Just [x] -> Just (x, Last Nothing) + Just [x,y] -> Just (x, Last (Just y)) + _ -> Nothing + + aserialize (x, Last Nothing) = aserialize [x] + aserialize (x, Last (Just y)) = aserialize [x, y] + parse :: Parser a -> String -> Maybe a parse p str = case parseOnly p (T.pack str) of Left _ -> Nothing @@ -900,10 +951,12 @@ xmlTagName _ = "FilterElement" serializeTreeNode fe = flip mergeAttributes <$> (genericSerializeNode fe) <*> case fe of - FEColorMatrix m -> serializeTreeNode m - FEComposite c -> serializeTreeNode c - FEGaussianBlur b -> serializeTreeNode b - _ -> error $ + FEColorMatrix m -> serializeTreeNode m + FEComposite c -> serializeTreeNode c + FEGaussianBlur b -> serializeTreeNode b + FETurbulence t -> serializeTreeNode t + FEDisplacementMap d -> serializeTreeNode d + _ -> error $ "Unsupported element: " ++ show fe ++ ". Please submit bug on github." attributes = [ "result" `parseIn` (filterAttributes . filterResult)] @@ -935,6 +988,26 @@ [ "in" `parseIn` gaussianBlurIn , "stdDeviation" `parseIn` lensProduct gaussianBlurStdDeviationX gaussianBlurStdDeviationY , "edgeMode" `parseIn` gaussianBlurEdgeMode ] + +instance XMLUpdatable DisplacementMap where + xmlTagName _ = "feDisplacementMap" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + [ "in" `parseIn` displacementMapIn + , "in2" `parseIn` displacementMapIn2 + , "scale" `parseIn` displacementMapScale + , "xChannelSelector" `parseIn` displacementMapXChannelSelector + , "yChannelSelector" `parseIn` displacementMapYChannelSelector ] + +instance XMLUpdatable Turbulence where + xmlTagName _ = "feTurbulence" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + [ "baseFrequency" `parseIn` turbulenceBaseFrequency + , "numOctaves" `parseIn` turbulenceNumOctaves + , "seed" `parseIn` turbulenceSeed + , "stitchTiles" `parseIn` turbulenceStitchTiles + , "type" `parseIn` turbulenceType ] instance XMLUpdatable RadialGradient where xmlTagName _ = "radialGradient"