{-|
  Bounding-boxes can be immensely useful for aligning objects
  but they are not part of the SVG specification and cannot be
  computed for all SVG nodes. In particular, you'll get bad results
  when asking for the bounding boxes of Text nodes (because fonts
  are difficult), clipped nodes, and filtered nodes.
-}
module Reanimate.Svg.BoundingBox
  ( boundingBox
  , svgHeight
  , svgWidth
  ) where

import           Control.Arrow             ((***))
import           Control.Lens              ((^.))
import           Data.List                 (foldl')
import           Data.Maybe                (mapMaybe)
import qualified Data.Vector.Unboxed       as V
import qualified Geom2D.CubicBezier.Linear as Bezier
import           Graphics.SvgTree
import           Linear.V2                 (V2 (V2))
import           Linear.Vector             (Additive (zero))
import           Reanimate.Constants       (defaultDPI)
import           Reanimate.Svg.LineCommand (LineCommand (..), toLineCommands)
import qualified Reanimate.Transform       as Transform

-- | Return bounding box of SVG tree.
--  The four numbers returned are (minimal X-coordinate, minimal Y-coordinate, width, height)
--
--  Note: Bounding boxes are computed on a best-effort basis and will not work
--        in all cases. The only supported SVG nodes are: path, circle, polyline,
--        ellipse, line, rectangle, image and svg. All other nodes return (0,0,0,0).
--        The box for the svg node is based on the document's width and height
--        (if both are present).
boundingBox :: Tree -> (Double, Double, Double, Double)
boundingBox :: Tree -> (Double, Double, Double, Double)
boundingBox Tree
t =
    case Tree -> [RPoint]
svgBoundingPoints Tree
t of
      [] -> (Double
0,Double
0,Double
0,Double
0)
      (V2 Double
x Double
y:[RPoint]
rest) ->
        let (Double
minx, Double
miny, Double
maxx, Double
maxy) = ((Double, Double, Double, Double)
 -> RPoint -> (Double, Double, Double, Double))
-> (Double, Double, Double, Double)
-> [RPoint]
-> (Double, Double, Double, Double)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Double, Double, Double, Double)
-> RPoint -> (Double, Double, Double, Double)
forall d. Ord d => (d, d, d, d) -> V2 d -> (d, d, d, d)
worker (Double
x, Double
y, Double
x, Double
y) [RPoint]
rest
        in (Double
minx, Double
miny, Double
maxxDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
minx, Double
maxyDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
miny)
  where
    worker :: (d, d, d, d) -> V2 d -> (d, d, d, d)
worker (d
minx, d
miny, d
maxx, d
maxy) (V2 d
x d
y) =
      (d -> d -> d
forall a. Ord a => a -> a -> a
min d
minx d
x, d -> d -> d
forall a. Ord a => a -> a -> a
min d
miny d
y, d -> d -> d
forall a. Ord a => a -> a -> a
max d
maxx d
x, d -> d -> d
forall a. Ord a => a -> a -> a
max d
maxy d
y)

-- | Height of SVG node in local units (not pixels). Computed on best-effort basis
--   and will not give accurate results for all SVG nodes.
svgHeight :: Tree -> Double
svgHeight :: Tree -> Double
svgHeight Tree
t = Double
h
  where
    (Double
_x, Double
_y, Double
_w, Double
h) = Tree -> (Double, Double, Double, Double)
boundingBox Tree
t

-- | Width of SVG node in local units (not pixels). Computed on best-effort basis
--   and will not give accurate results for all SVG nodes.
svgWidth :: Tree -> Double
svgWidth :: Tree -> Double
svgWidth Tree
t = Double
w
  where
    (Double
_x, Double
_y, Double
w, Double
_h) = Tree -> (Double, Double, Double, Double)
boundingBox Tree
t

-- | Sampling of points in a line path.
linePoints :: [LineCommand] -> [RPoint]
linePoints :: [LineCommand] -> [RPoint]
linePoints = RPoint -> [LineCommand] -> [RPoint]
worker RPoint
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
  where
    worker :: RPoint -> [LineCommand] -> [RPoint]
worker RPoint
_from [] = []
    worker RPoint
from (LineCommand
x:[LineCommand]
xs) =
      case LineCommand
x of
        LineMove RPoint
to     -> RPoint -> [LineCommand] -> [RPoint]
worker RPoint
to [LineCommand]
xs
        -- LineDraw to     -> from:to:worker to xs
        LineBezier [RPoint
p] ->
          RPoint
p RPoint -> [RPoint] -> [RPoint]
forall a. a -> [a] -> [a]
: RPoint -> [LineCommand] -> [RPoint]
worker RPoint
p [LineCommand]
xs
        LineBezier [RPoint]
ctrl -> -- approximation
          let bezier :: AnyBezier Double
bezier = Vector RPoint -> AnyBezier Double
forall a. Vector (V2 a) -> AnyBezier a
Bezier.AnyBezier ([RPoint] -> Vector RPoint
forall a. Unbox a => [a] -> Vector a
V.fromList (RPoint
fromRPoint -> [RPoint] -> [RPoint]
forall a. a -> [a] -> [a]
:[RPoint]
ctrl))
          in [ AnyBezier Double -> Double -> RPoint
forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> V2 a
Bezier.evalBezier AnyBezier Double
bezier (Double -> Double
forall a. Fractional a => a -> a
recip Double
chunksDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
i) | Double
i <- [Double
0..Double
chunks]] [RPoint] -> [RPoint] -> [RPoint]
forall a. [a] -> [a] -> [a]
++
          RPoint -> [LineCommand] -> [RPoint]
worker ([RPoint] -> RPoint
forall a. [a] -> a
last [RPoint]
ctrl) [LineCommand]
xs
        LineEnd RPoint
p -> RPoint
p RPoint -> [RPoint] -> [RPoint]
forall a. a -> [a] -> [a]
: RPoint -> [LineCommand] -> [RPoint]
worker RPoint
p [LineCommand]
xs
    chunks :: Double
chunks = Double
10

svgBoundingPoints :: Tree -> [RPoint]
svgBoundingPoints :: Tree -> [RPoint]
svgBoundingPoints Tree
t = (RPoint -> RPoint) -> [RPoint] -> [RPoint]
forall a b. (a -> b) -> [a] -> [b]
map (Matrix Double -> RPoint -> RPoint
Transform.transformPoint Matrix Double
m) ([RPoint] -> [RPoint]) -> [RPoint] -> [RPoint]
forall a b. (a -> b) -> a -> b
$
    case Tree
t of
      Tree
None             -> []
      UseTree{}        -> []
      GroupTree Group
g      -> (Tree -> [RPoint]) -> [Tree] -> [RPoint]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree -> [RPoint]
svgBoundingPoints (Group
g Group -> Getting [Tree] Group [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^. Getting [Tree] Group [Tree]
Lens' Group [Tree]
groupChildren)
      SymbolTree Group
g     -> (Tree -> [RPoint]) -> [Tree] -> [RPoint]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree -> [RPoint]
svgBoundingPoints (Group
g Group -> Getting [Tree] Group [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^. Getting [Tree] Group [Tree]
Lens' Group [Tree]
groupChildren)
      FilterTree{}     -> []
      DefinitionTree{} -> []
      PathTree Path
p       -> [LineCommand] -> [RPoint]
linePoints ([LineCommand] -> [RPoint]) -> [LineCommand] -> [RPoint]
forall a b. (a -> b) -> a -> b
$ [PathCommand] -> [LineCommand]
toLineCommands (Path
p Path -> Getting [PathCommand] Path [PathCommand] -> [PathCommand]
forall s a. s -> Getting a s a -> a
^. Getting [PathCommand] Path [PathCommand]
Lens' Path [PathCommand]
pathDefinition)
      CircleTree Circle
c     -> Circle -> [RPoint]
circleBoundingPoints Circle
c
      PolyLineTree PolyLine
pl  -> PolyLine
pl PolyLine -> Getting [RPoint] PolyLine [RPoint] -> [RPoint]
forall s a. s -> Getting a s a -> a
^. Getting [RPoint] PolyLine [RPoint]
Lens' PolyLine [RPoint]
polyLinePoints
      EllipseTree Ellipse
e    -> Ellipse -> [RPoint]
ellipseBoundingPoints Ellipse
e
      LineTree Line
l       -> ((Number, Number) -> RPoint) -> [(Number, Number)] -> [RPoint]
forall a b. (a -> b) -> [a] -> [b]
map (Number, Number) -> RPoint
pointToRPoint [Line
l Line
-> Getting (Number, Number) Line (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Line (Number, Number)
Lens' Line (Number, Number)
linePoint1, Line
l Line
-> Getting (Number, Number) Line (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Line (Number, Number)
Lens' Line (Number, Number)
linePoint2]
      RectangleTree Rectangle
r  ->
        let p :: RPoint
p = (Number, Number) -> RPoint
pointToRPoint (Rectangle
r Rectangle
-> Getting (Number, Number) Rectangle (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Rectangle (Number, Number)
Lens' Rectangle (Number, Number)
rectUpperLeftCorner)
            mDims :: (Maybe Number, Maybe Number)
mDims = (Rectangle
r Rectangle
-> Getting (Maybe Number) Rectangle (Maybe Number) -> Maybe Number
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Number) Rectangle (Maybe Number)
Lens' Rectangle (Maybe Number)
rectWidth, Rectangle
r Rectangle
-> Getting (Maybe Number) Rectangle (Maybe Number) -> Maybe Number
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Number) Rectangle (Maybe Number)
Lens' Rectangle (Maybe Number)
rectHeight)
        in  RPoint -> (Maybe Number, Maybe Number) -> [RPoint]
rectPoints RPoint
p (Maybe Number, Maybe Number)
mDims
      TextTree{}       -> []
      ImageTree Image
img    ->
        let p :: RPoint
p = (Number, Number) -> RPoint
pointToRPoint (Image
img Image
-> Getting (Number, Number) Image (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Image (Number, Number)
Lens' Image (Number, Number)
imageCornerUpperLeft)
            dims :: (Number, Number)
dims = (Image
img Image -> Getting Number Image Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Image Number
Lens' Image Number
imageWidth, Image
img Image -> Getting Number Image Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Image Number
Lens' Image Number
imageHeight)
        in  RPoint -> (Number, Number) -> [RPoint]
rectPoints' RPoint
p (Number, Number)
dims
      MeshGradientTree{} -> []
      SvgTree Document
d        -> let mDims :: (Maybe Number, Maybe Number)
mDims = (Document
d Document
-> Getting (Maybe Number) Document (Maybe Number) -> Maybe Number
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Number) Document (Maybe Number)
Lens' Document (Maybe Number)
documentWidth, Document
d Document
-> Getting (Maybe Number) Document (Maybe Number) -> Maybe Number
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Number) Document (Maybe Number)
Lens' Document (Maybe Number)
documentHeight)
                          in  RPoint -> (Maybe Number, Maybe Number) -> [RPoint]
rectPoints (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
0 Double
0) (Maybe Number, Maybe Number)
mDims
      Tree
_                -> []
  where
    m :: Matrix Double
m = Maybe [Transformation] -> Matrix Double
Transform.mkMatrix (Tree
t Tree
-> Getting (Maybe [Transformation]) Tree (Maybe [Transformation])
-> Maybe [Transformation]
forall s a. s -> Getting a s a -> a
^. Getting (Maybe [Transformation]) Tree (Maybe [Transformation])
forall c. HasDrawAttributes c => Lens' c (Maybe [Transformation])
transform)
    mapTuple :: a b' c' -> a (b', b') (c', c')
mapTuple a b' c'
f = a b' c'
f a b' c' -> a b' c' -> a (b', b') (c', c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a b' c'
f
    toUserUnit' :: Number -> Number
toUserUnit' = Dpi -> Number -> Number
toUserUnit Dpi
defaultDPI
    pointToRPoint :: (Number, Number) -> RPoint
pointToRPoint (Number, Number)
p =
      case (Number -> Number) -> (Number, Number) -> (Number, Number)
forall (a :: * -> * -> *) b' c'.
Arrow a =>
a b' c' -> a (b', b') (c', c')
mapTuple Number -> Number
toUserUnit' (Number, Number)
p of
        (Num Double
x, Num Double
y) -> Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
x Double
y
        (Number, Number)
_              -> [Char] -> RPoint
forall a. HasCallStack => [Char] -> a
error [Char]
"Reanimate.Svg.svgBoundingPoints: Unrecognized number format."

    circleBoundingPoints :: Circle -> [RPoint]
circleBoundingPoints Circle
circ =
      let (Number
xnum, Number
ynum) = Circle
circ Circle
-> Getting (Number, Number) Circle (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Circle (Number, Number)
Lens' Circle (Number, Number)
circleCenter
          rnum :: Number
rnum = Circle
circ Circle -> Getting Number Circle Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Circle Number
Lens' Circle Number
circleRadius
      in case (Number -> Maybe Double) -> [Number] -> [Double]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Number -> Maybe Double
unpackNumber [Number
xnum, Number
ynum, Number
rnum] of
        [Double
x, Double
y, Double
r] -> Double -> Double -> Double -> Double -> [RPoint]
forall a. (Floating a, Enum a) => a -> a -> a -> a -> [V2 a]
ellipsePoints Double
x Double
y Double
r Double
r
        [Double]
_         -> []

    ellipseBoundingPoints :: Ellipse -> [RPoint]
ellipseBoundingPoints Ellipse
e =
      let (Number
xnum,Number
ynum) = Ellipse
e Ellipse
-> Getting (Number, Number) Ellipse (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Ellipse (Number, Number)
Lens' Ellipse (Number, Number)
ellipseCenter
          xrnum :: Number
xrnum = Ellipse
e Ellipse -> Getting Number Ellipse Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Ellipse Number
Lens' Ellipse Number
ellipseXRadius
          yrnum :: Number
yrnum = Ellipse
e Ellipse -> Getting Number Ellipse Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Ellipse Number
Lens' Ellipse Number
ellipseYRadius
      in case (Number -> Maybe Double) -> [Number] -> [Double]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Number -> Maybe Double
unpackNumber [Number
xnum, Number
ynum, Number
xrnum, Number
yrnum] of
        [Double
x, Double
y, Double
xr, Double
yr] -> Double -> Double -> Double -> Double -> [RPoint]
forall a. (Floating a, Enum a) => a -> a -> a -> a -> [V2 a]
ellipsePoints Double
x Double
y Double
xr Double
yr
        [Double]
_              -> []

    ellipsePoints :: a -> a -> a -> a -> [V2 a]
ellipsePoints a
x a
y a
xr a
yr = [ a -> a -> V2 a
forall a. a -> a -> V2 a
V2 (a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
xr a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. Floating a => a -> a
cos a
angle) (a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
yr a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. Floating a => a -> a
sin a
angle)
                              | a
angle <- [a
0, a
forall a. Floating a => a
pia -> a -> a
forall a. Fractional a => a -> a -> a
/a
10 .. a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
forall a. Floating a => a
pi] ]

    rectPoints :: RPoint -> (Maybe Number, Maybe Number) -> [RPoint]
rectPoints RPoint
p (Maybe Number, Maybe Number)
mDims = case (Maybe Number, Maybe Number)
mDims of
                           (Just Number
w, Just Number
h) -> RPoint -> (Number, Number) -> [RPoint]
rectPoints' RPoint
p (Number
w, Number
h)
                           (Maybe Number, Maybe Number)
_ -> [RPoint
p]

    rectPoints' :: RPoint -> (Number, Number) -> [RPoint]
rectPoints' p :: RPoint
p@(V2 Double
x Double
y) (Number, Number)
dims =
      RPoint
p RPoint -> [RPoint] -> [RPoint]
forall a. a -> [a] -> [a]
: case (Number -> Number) -> (Number, Number) -> (Number, Number)
forall (a :: * -> * -> *) b' c'.
Arrow a =>
a b' c' -> a (b', b') (c', c')
mapTuple Number -> Number
toUserUnit' (Number, Number)
dims of
            ((Num Double
w), (Num Double
h)) -> let (Double
x', Double
y') = (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w, Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
h)
                                  in  [Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
x' Double
y, Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
x' Double
y', Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
x Double
y']
            (Number, Number)
_ -> []

    unpackNumber :: Number -> Maybe Double
unpackNumber Number
n =
      case Number -> Number
toUserUnit' Number
n of
        Num Double
d -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
d
        Number
_     -> Maybe Double
forall a. Maybe a
Nothing