{-|
  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. All other nodes return (0,0,0,0).
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
gGroup -> 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
gGroup -> 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
pPath -> 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
line   -> ((Number, Number) -> RPoint) -> [(Number, Number)] -> [RPoint]
forall a b. (a -> b) -> [a] -> [b]
map (Number, Number) -> RPoint
pointToRPoint [Line
lineLine
-> 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
lineLine
-> 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
rect ->
        case (Number, Number) -> RPoint
pointToRPoint (Rectangle
rectRectangle
-> 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) of
          V2 Double
x Double
y -> Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
x Double
y RPoint -> [RPoint] -> [RPoint]
forall a. a -> [a] -> [a]
:
            case (Maybe Number -> Maybe Number)
-> (Maybe Number, Maybe Number) -> (Maybe Number, Maybe Number)
forall (a :: * -> * -> *) b' c'.
Arrow a =>
a b' c' -> a (b', b') (c', c')
mapTuple ((Number -> Number) -> Maybe Number -> Maybe Number
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Number -> Number) -> Maybe Number -> Maybe Number)
-> (Number -> Number) -> Maybe Number -> Maybe Number
forall a b. (a -> b) -> a -> b
$ Dpi -> Number -> Number
toUserUnit Dpi
defaultDPI) (Rectangle
rectRectangle
-> 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
rectRectangle
-> 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) of
              (Just (Num Double
w), Just (Num Double
h)) -> [Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
w) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
h)]
              (Maybe Number, Maybe Number)
_                            -> []
      TextTree{}      -> []
      ImageTree Image
img   ->
        case (Image
imgImage
-> 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, Image
imgImage -> Getting Number Image Number -> Number
forall s a. s -> Getting a s a -> a
^.Getting Number Image Number
Lens' Image Number
imageWidth, Image
imgImage -> Getting Number Image Number -> Number
forall s a. s -> Getting a s a -> a
^.Getting Number Image Number
Lens' Image Number
imageHeight) of
          ((Num Double
x, Num Double
y), Num Double
w, Num Double
h) ->
            [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
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
w) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
h)]
          ((Number, Number), Number, Number)
_ -> []
      MeshGradientTree{} -> []
      Tree
_ -> []
  where
    m :: Matrix Double
m = Maybe [Transformation] -> Matrix Double
Transform.mkMatrix (Tree
tTree
-> 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
    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 (Dpi -> Number -> Number
toUserUnit Dpi
defaultDPI) (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 -> RPoint
forall a. a -> a -> V2 a
V2 (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
angle) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
angle) | Double
angle <- [Double
0, Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
10 .. Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi]]
        [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 -> RPoint
forall a. a -> a -> V2 a
V2 (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
xr Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
angle) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
yr Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
angle) | Double
angle <- [Double
0, Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
10 .. Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi]]
        [Double]
_ -> []

    unpackNumber :: Number -> Maybe Double
unpackNumber Number
n =
      case Dpi -> Number -> Number
toUserUnit Dpi
defaultDPI 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