{-|
Copyright   : Written by David Himmelstrup
License     : Unlicense
Maintainer  : lemmih@gmail.com
Stability   : experimental
Portability : POSIX
-}
module Reanimate.Svg.Unuse
  ( replaceUses
  , unbox
  , unboxFit
  , embedDocument
  ) where

import           Control.Lens               ((%~), (&), (.~), (?~), (^.))
import qualified Data.Map                   as Map
import           Data.Maybe                 (fromMaybe)
import           Graphics.SvgTree
import           Reanimate.Constants        (defaultDPI, screenHeight, screenWidth)
import           Reanimate.Svg.Constructors (flipYAxis, mkGroup, scaleXY, translate,
                                             withFillOpacity, withStrokeWidth)

-- | Replace all @<use>@ nodes with their definition.
replaceUses :: Document -> Document
replaceUses :: Document -> Document
replaceUses Document
doc = Document
doc Document -> (Document -> Document) -> Document
forall a b. a -> (a -> b) -> b
& ([Tree] -> Identity [Tree]) -> Document -> Identity Document
Lens' Document [Tree]
documentElements (([Tree] -> Identity [Tree]) -> Document -> Identity Document)
-> ([Tree] -> [Tree]) -> Document -> Document
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Tree -> Tree) -> [Tree] -> [Tree]
forall a b. (a -> b) -> [a] -> [b]
map ((Tree -> Tree) -> Tree -> Tree
mapTree Tree -> Tree
replace)
  where
    replaceDefinition :: Tree -> Tree
replaceDefinition PathTree{}   = Tree
None
    replaceDefinition SymbolTree{} = Tree
None
    replaceDefinition Tree
t            = Tree
t

    replace :: Tree -> Tree
replace t :: Tree
t@DefinitionTree{} = (Tree -> Tree) -> Tree -> Tree
mapTree Tree -> Tree
replaceDefinition Tree
t
    replace (UseTree Use
_ Just{}) = [Char] -> Tree
forall a. HasCallStack => [Char] -> a
error [Char]
"replaceUses: subtree in use?"
    replace (UseTree Use
use Maybe Tree
Nothing) =
      case [Char] -> Map [Char] Tree -> Maybe Tree
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Use
useUse -> Getting [Char] Use [Char] -> [Char]
forall s a. s -> Getting a s a -> a
^.Getting [Char] Use [Char]
Lens' Use [Char]
useName) Map [Char] Tree
idMap of
        Maybe Tree
Nothing -> [Char] -> Tree
forall a. HasCallStack => [Char] -> a
error ([Char] -> Tree) -> [Char] -> Tree
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown id: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Use
useUse -> Getting [Char] Use [Char] -> [Char]
forall s a. s -> Getting a s a -> a
^.Getting [Char] Use [Char]
Lens' Use [Char]
useName)
        Just (SymbolTree Group
children) -> (Tree -> Tree) -> Tree -> Tree
mapTree Tree -> Tree
replace (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$
          Group -> Tree
GroupTree Group
children
          Tree -> (Tree -> Tree) -> Tree
forall a b. a -> (a -> b) -> b
& (Maybe [Transformation] -> Identity (Maybe [Transformation]))
-> Tree -> Identity Tree
forall c. HasDrawAttributes c => Lens' c (Maybe [Transformation])
transform ((Maybe [Transformation] -> Identity (Maybe [Transformation]))
 -> Tree -> Identity Tree)
-> [Transformation] -> Tree -> Tree
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~
              [Transformation] -> Maybe [Transformation] -> [Transformation]
forall a. a -> Maybe a -> a
fromMaybe [] (Use
useUse
-> Getting (Maybe [Transformation]) Use (Maybe [Transformation])
-> Maybe [Transformation]
forall s a. s -> Getting a s a -> a
^.Getting (Maybe [Transformation]) Use (Maybe [Transformation])
forall c. HasDrawAttributes c => Lens' c (Maybe [Transformation])
transform) [Transformation] -> [Transformation] -> [Transformation]
forall a. [a] -> [a] -> [a]
++
              [(Number, Number) -> Transformation
baseToTransformation (Use
useUse
-> Getting (Number, Number) Use (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^.Getting (Number, Number) Use (Number, Number)
Lens' Use (Number, Number)
useBase)]
        Just Tree
tree -> (Tree -> Tree) -> Tree -> Tree
mapTree Tree -> Tree
replace (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$
          Group -> Tree
GroupTree (Group
forall a. WithDefaultSvg a => a
defaultSvg Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([Tree] -> Identity [Tree]) -> Group -> Identity Group
Lens' Group [Tree]
groupChildren (([Tree] -> Identity [Tree]) -> Group -> Identity Group)
-> [Tree] -> Group -> Group
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Tree
tree])
          Tree -> (Tree -> Tree) -> Tree
forall a b. a -> (a -> b) -> b
& (Maybe [Transformation] -> Identity (Maybe [Transformation]))
-> Tree -> Identity Tree
forall c. HasDrawAttributes c => Lens' c (Maybe [Transformation])
transform ((Maybe [Transformation] -> Identity (Maybe [Transformation]))
 -> Tree -> Identity Tree)
-> [Transformation] -> Tree -> Tree
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~
              [Transformation] -> Maybe [Transformation] -> [Transformation]
forall a. a -> Maybe a -> a
fromMaybe [] (Use
useUse
-> Getting (Maybe [Transformation]) Use (Maybe [Transformation])
-> Maybe [Transformation]
forall s a. s -> Getting a s a -> a
^.Getting (Maybe [Transformation]) Use (Maybe [Transformation])
forall c. HasDrawAttributes c => Lens' c (Maybe [Transformation])
transform) [Transformation] -> [Transformation] -> [Transformation]
forall a. [a] -> [a] -> [a]
++
              [(Number, Number) -> Transformation
baseToTransformation (Use
useUse
-> Getting (Number, Number) Use (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^.Getting (Number, Number) Use (Number, Number)
Lens' Use (Number, Number)
useBase)]
    replace Tree
x = Tree
x
    baseToTransformation :: (Number, Number) -> Transformation
baseToTransformation (Number
x,Number
y) =
      case (Dpi -> Number -> Number
toUserUnit Dpi
defaultDPI Number
x, Dpi -> Number -> Number
toUserUnit Dpi
defaultDPI Number
y) of
        (Num Double
a, Num Double
b) -> Double -> Double -> Transformation
Translate Double
a Double
b
        (Number, Number)
_              -> Transformation
TransformUnknown
    docTree :: Tree
docTree = [Tree] -> Tree
mkGroup (Document
docDocument -> Getting [Tree] Document [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^.Getting [Tree] Document [Tree]
Lens' Document [Tree]
documentElements)
    idMap :: Map [Char] Tree
idMap = (Map [Char] Tree -> Tree -> Map [Char] Tree)
-> Map [Char] Tree -> Tree -> Map [Char] Tree
forall a. (a -> Tree -> a) -> a -> Tree -> a
foldTree Map [Char] Tree -> Tree -> Map [Char] Tree
forall a. HasDrawAttributes a => Map [Char] a -> a -> Map [Char] a
updMap Map [Char] Tree
forall k a. Map k a
Map.empty Tree
docTree
    updMap :: Map [Char] a -> a -> Map [Char] a
updMap Map [Char] a
m a
tree =
      case a
treea -> Getting (Maybe [Char]) a (Maybe [Char]) -> Maybe [Char]
forall s a. s -> Getting a s a -> a
^.Getting (Maybe [Char]) a (Maybe [Char])
forall c. HasDrawAttributes c => Lens' c (Maybe [Char])
attrId of
        Maybe [Char]
Nothing  -> Map [Char] a
m
        Just [Char]
tid -> [Char] -> a -> Map [Char] a -> Map [Char] a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
tid a
tree Map [Char] a
m

-- FIXME: the viewbox is ignored. Can we use the viewbox as a mask?
-- | Transform out viewbox. Definitions and CSS rules are discarded.
unbox :: Document -> Tree
unbox :: Document -> Tree
unbox doc :: Document
doc@Document{_documentViewBox :: Document -> Maybe (Double, Double, Double, Double)
_documentViewBox = Just (Double
_minx, Double
_miny, Double
_width, Double
_height)} =
  Group -> Tree
groupTree (Group -> Tree) -> Group -> Tree
forall a b. (a -> b) -> a -> b
$ Group
forall a. WithDefaultSvg a => a
defaultSvg
          Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([Tree] -> Identity [Tree]) -> Group -> Identity Group
Lens' Group [Tree]
groupChildren (([Tree] -> Identity [Tree]) -> Group -> Identity Group)
-> [Tree] -> Group -> Group
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Document
docDocument -> Getting [Tree] Document [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^.Getting [Tree] Document [Tree]
Lens' Document [Tree]
documentElements
unbox Document
doc =
  Group -> Tree
groupTree (Group -> Tree) -> Group -> Tree
forall a b. (a -> b) -> a -> b
$ Group
forall a. WithDefaultSvg a => a
defaultSvg
    Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([Tree] -> Identity [Tree]) -> Group -> Identity Group
Lens' Group [Tree]
groupChildren (([Tree] -> Identity [Tree]) -> Group -> Identity Group)
-> [Tree] -> Group -> Group
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Document
docDocument -> Getting [Tree] Document [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^.Getting [Tree] Document [Tree]
Lens' Document [Tree]
documentElements

-- | Transform out viewbox and fit image to screen size.
unboxFit :: Document -> Tree
unboxFit :: Document -> Tree
unboxFit doc :: Document
doc@Document{_documentViewBox :: Document -> Maybe (Double, Double, Double, Double)
_documentViewBox = Just (Double
minx, Double
miny, Double
width, Double
height)} =
  let widthScale :: Double
widthScale = Double
forall a. Fractional a => a
screenWidthDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
width
      heightScale :: Double
heightScale = Double
forall a. Fractional a => a
screenHeightDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
height
      scaler :: Double
scaler = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
widthScale Double
heightScale
  in
    Double -> Double -> Tree -> Tree
scaleXY Double
scaler (-Double
scaler) (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$
    Double -> Double -> Tree -> Tree
translate (-Double
minxDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
widthDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (-Double
minyDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
heightDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$
    Group -> Tree
groupTree (Group -> Tree) -> Group -> Tree
forall a b. (a -> b) -> a -> b
$ Group
forall a. WithDefaultSvg a => a
defaultSvg
      Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([Tree] -> Identity [Tree]) -> Group -> Identity Group
Lens' Group [Tree]
groupChildren (([Tree] -> Identity [Tree]) -> Group -> Identity Group)
-> [Tree] -> Group -> Group
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Document
docDocument -> Getting [Tree] Document [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^.Getting [Tree] Document [Tree]
Lens' Document [Tree]
documentElements
unboxFit Document
doc =
  Group -> Tree
groupTree (Group -> Tree) -> Group -> Tree
forall a b. (a -> b) -> a -> b
$ Group
forall a. WithDefaultSvg a => a
defaultSvg
    Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([Tree] -> Identity [Tree]) -> Group -> Identity Group
Lens' Group [Tree]
groupChildren (([Tree] -> Identity [Tree]) -> Group -> Identity Group)
-> [Tree] -> Group -> Group
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Document
docDocument -> Getting [Tree] Document [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^.Getting [Tree] Document [Tree]
Lens' Document [Tree]
documentElements


-- | Embed 'Document'. This keeps the entire document intact but makes
--   it more difficult to use, say, `Reanimate.Svg.pathify` on it.
embedDocument :: Document -> Tree
embedDocument :: Document -> Tree
embedDocument Document
doc =
  Double -> Double -> Tree -> Tree
translate (-Double
forall a. Fractional a => a
screenWidthDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Double
forall a. Fractional a => a
screenHeightDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$
  Double -> Tree -> Tree
withFillOpacity Double
1 (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$
  Double -> Tree -> Tree
withStrokeWidth Double
0 (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$
  Tree -> Tree
flipYAxis (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$
  Document -> Tree
svgTree (Document -> Tree) -> Document -> Tree
forall a b. (a -> b) -> a -> b
$ Document
doc Document -> (Document -> Document) -> Document
forall a b. a -> (a -> b) -> b
& (Maybe Number -> Identity (Maybe Number))
-> Document -> Identity Document
Lens' Document (Maybe Number)
documentWidth ((Maybe Number -> Identity (Maybe Number))
 -> Document -> Identity Document)
-> Maybe Number -> Document -> Document
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Number
forall a. Maybe a
Nothing
                Document -> (Document -> Document) -> Document
forall a b. a -> (a -> b) -> b
& (Maybe Number -> Identity (Maybe Number))
-> Document -> Identity Document
Lens' Document (Maybe Number)
documentHeight ((Maybe Number -> Identity (Maybe Number))
 -> Document -> Identity Document)
-> Maybe Number -> Document -> Document
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Number
forall a. Maybe a
Nothing