{-# LANGUAGE CPP #-}
module Graphics.Rasterific.Svg.RenderContext
    ( RenderContext( .. )
    , LoadedElements( .. )
    , loadedFonts
    , loadedImages
    , IODraw
    , ViewBox
    , toRadian
    , capOfSvg
    , joinOfSvg 
    , stripUnits
    , boundingBoxLength
    , lineariseXLength
    , lineariseYLength
    , linearisePoint
    , lineariseLength
    , prepareTexture
    , documentOfPattern
    , fillAlphaCombine
    , fillMethodOfSvg
    , emTransform
    )
    where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( (<$>) )
import Data.Monoid( Monoid( .. ) )
#endif

import Control.Monad.Trans.State.Strict( StateT )
import Codec.Picture( PixelRGBA8( .. ) )
import qualified Codec.Picture as CP
import qualified Data.Foldable as F
import qualified Data.Map as M
import Data.Monoid( Last( .. ) )
import Control.Lens( Lens', lens )

import Graphics.Rasterific.Linear( (^-^) )
import qualified Graphics.Rasterific as R
import qualified Graphics.Rasterific.Texture as RT
import Graphics.Text.TrueType
import Graphics.Svg.Types

toRadian :: Floating a => a -> a
toRadian v = v / 180 * pi

data RenderContext = RenderContext
    { _initialViewBox     :: (R.Point, R.Point)
    , _renderViewBox      :: (R.Point, R.Point)
    , _renderDpi          :: Int
    , _contextDefinitions :: M.Map String Element
    , _fontCache          :: FontCache
    , _subRender          :: Document -> IODraw (R.Drawing PixelRGBA8 ())
    , _basePath           :: FilePath
    }

data LoadedElements = LoadedElements
    { _loadedFonts  :: M.Map FilePath Font
    , _loadedImages :: M.Map FilePath (CP.Image PixelRGBA8)
    }

instance Monoid LoadedElements where
  mempty = LoadedElements mempty mempty
  mappend (LoadedElements a b) (LoadedElements a' b') =
      LoadedElements (a `mappend` a') (b `mappend` b')

loadedFonts :: Lens' LoadedElements (M.Map FilePath Font)
loadedFonts = lens _loadedFonts (\a b -> a { _loadedFonts = b })

loadedImages :: Lens' LoadedElements (M.Map FilePath (CP.Image PixelRGBA8))
loadedImages = lens _loadedImages (\a b -> a { _loadedImages = b })

type IODraw = StateT LoadedElements IO

type ViewBox = (R.Point, R.Point)

capOfSvg :: DrawAttributes -> (R.Cap, R.Cap)
capOfSvg attrs =
  case getLast $ _strokeLineCap attrs of
    Nothing -> (R.CapStraight 1, R.CapStraight 1)
    Just CapSquare -> (R.CapStraight 1, R.CapStraight 1)
    Just CapButt -> (R.CapStraight 0, R.CapStraight 0)
    Just CapRound -> (R.CapRound, R.CapRound)


joinOfSvg :: DrawAttributes -> R.Join
joinOfSvg attrs =
  case (getLast $ _strokeLineJoin attrs, getLast $ _strokeMiterLimit attrs) of
    (Nothing, _) -> R.JoinRound
    (Just JoinMiter, Just _) -> R.JoinMiter 0
    (Just JoinMiter, Nothing) -> R.JoinMiter 0
    (Just JoinBevel, _) -> R.JoinMiter 5
    (Just JoinRound, _) -> R.JoinRound

stripUnits :: RenderContext -> Number -> Number
stripUnits ctxt = toUserUnit (_renderDpi ctxt)

boundingBoxLength :: RenderContext -> DrawAttributes -> R.PlaneBound -> Number
                  -> Float
boundingBoxLength ctxt attr (R.PlaneBound mini maxi) = go where
  R.V2 actualWidth actualHeight =
             abs <$> (maxi ^-^ mini)
  two = 2 :: Int
  coeff = sqrt (actualWidth ^^ two + actualHeight ^^ two)
        / sqrt 2 :: Float
  go num = case num of
    Num n -> realToFrac n
    Em n -> emTransform attr $ realToFrac n
    Percent p -> realToFrac p * coeff
    _ -> go $ stripUnits ctxt num

boundbingBoxLinearise :: RenderContext -> DrawAttributes -> R.PlaneBound -> Point
                      -> R.Point
boundbingBoxLinearise
    ctxt attr (R.PlaneBound mini@(R.V2 xi yi) maxi) (xp, yp) = R.V2 (finalX xp) (finalY yp)
  where
    R.V2 w h = abs <$> (maxi ^-^ mini)
    finalX nu = case nu of
      Num n -> realToFrac n
      Em n -> emTransform attr $ realToFrac n
      Percent p -> realToFrac p * w + xi
      _ -> finalX $ stripUnits ctxt nu

    finalY nu = case nu of
      Num n -> realToFrac n
      Em n -> emTransform attr $ realToFrac n
      Percent p -> realToFrac p * h + yi
      _ -> finalY $ stripUnits ctxt nu

lineariseXLength :: RenderContext -> DrawAttributes -> Number
                 -> Float
lineariseXLength _ _ (Num i) = realToFrac i
lineariseXLength _ attr (Em i) = emTransform attr $ realToFrac i
lineariseXLength ctxt _ (Percent p) = abs (xe - xs) * realToFrac p
  where
    (R.V2 xs _, R.V2 xe _) = _renderViewBox ctxt
lineariseXLength ctxt attr num =
    lineariseXLength ctxt attr $ stripUnits ctxt num

lineariseYLength :: RenderContext -> DrawAttributes -> Number
                 -> Float
lineariseYLength _ _ (Num i) = realToFrac i
lineariseYLength _ attr (Em n) = emTransform attr $ realToFrac n
lineariseYLength ctxt _ (Percent p) = abs (ye - ys) * (realToFrac p)
  where
    (R.V2 _ ys, R.V2 _ ye) = _renderViewBox ctxt
lineariseYLength ctxt attr num =
    lineariseYLength ctxt attr $ stripUnits ctxt num


linearisePoint :: RenderContext -> DrawAttributes -> Point
               -> R.Point
linearisePoint ctxt attr (p1, p2) =
  R.V2 (xs + lineariseXLength ctxt attr p1)
       (ys + lineariseYLength ctxt attr p2)
  where (R.V2 xs ys, _) = _renderViewBox ctxt

emTransform :: DrawAttributes -> Float -> Float
emTransform attr n = case getLast $ _fontSize attr of
    Nothing -> 16 * realToFrac n
    Just (Num v) -> realToFrac v * n
    Just _ -> 16 * n

lineariseLength :: RenderContext -> DrawAttributes -> Number
                -> Float
lineariseLength _ _ (Num i) = realToFrac i
lineariseLength _ attr (Em i) = emTransform attr $ realToFrac i
lineariseLength ctxt _ (Percent v) = realToFrac v * coeff
  where
    (R.V2 x1 y1, R.V2 x2 y2) = _renderViewBox ctxt
    actualWidth = abs $ x2 - x1
    actualHeight = abs $ y2 - y1
    two = 2 :: Int
    coeff = sqrt (actualWidth ^^ two + actualHeight ^^ two)
          / sqrt 2
lineariseLength ctxt attr num =
    lineariseLength ctxt attr $ stripUnits ctxt num

prepareLinearGradientTexture
    :: RenderContext -> DrawAttributes
    -> LinearGradient -> Float -> [R.Primitive]
    -> R.Texture PixelRGBA8
prepareLinearGradientTexture ctxt attr grad opa prims =
  let bounds = F.foldMap R.planeBounds prims
      lineariser = case _linearGradientUnits grad of
        CoordUserSpace -> linearisePoint ctxt attr
        CoordBoundingBox -> boundbingBoxLinearise ctxt attr bounds
      gradient =
        [(offset, fillAlphaCombine opa color)
            | GradientStop offset color <- _linearGradientStops grad]
      startPoint = lineariser $ _linearGradientStart grad
      stopPoint = lineariser $ _linearGradientStop grad
  in
  RT.linearGradientTexture gradient startPoint stopPoint

prepareRadialGradientTexture
    :: RenderContext -> DrawAttributes
    -> RadialGradient -> Float -> [R.Primitive]
    -> R.Texture PixelRGBA8
prepareRadialGradientTexture ctxt attr grad opa prims =
  let bounds = F.foldMap R.planeBounds prims
      (lineariser, lengthLinearise) = case _radialGradientUnits grad of
        CoordUserSpace ->
          (linearisePoint ctxt attr, lineariseLength ctxt attr)
        CoordBoundingBox ->
          (boundbingBoxLinearise ctxt attr bounds,
           boundingBoxLength ctxt attr bounds)
      gradient =
        [(offset, fillAlphaCombine opa color)
            | GradientStop offset color <- _radialGradientStops grad]
      center = lineariser $ _radialGradientCenter grad
      radius = lengthLinearise $ _radialGradientRadius grad
  in
  case (_radialGradientFocusX grad,
            _radialGradientFocusY grad) of
    (Nothing, Nothing) ->
      RT.radialGradientTexture gradient center radius
    (Just fx, Nothing) ->
      RT.radialGradientWithFocusTexture gradient center radius
        $ lineariser (fx, snd $ _radialGradientCenter grad)
    (Nothing, Just fy) ->
      RT.radialGradientWithFocusTexture gradient center radius
        $ lineariser (fst $ _radialGradientCenter grad, fy)
    (Just fx, Just fy) ->
      RT.radialGradientWithFocusTexture gradient center radius
        $ lineariser (fx, fy)

fillMethodOfSvg :: DrawAttributes -> R.FillMethod
fillMethodOfSvg attr = case getLast $ _fillRule attr of
    Nothing -> R.FillWinding
    Just FillNonZero -> R.FillWinding
    Just FillEvenOdd -> R.FillEvenOdd

fillAlphaCombine :: Float -> PixelRGBA8 -> PixelRGBA8
fillAlphaCombine opacity (PixelRGBA8 r g b a) =
    PixelRGBA8 r g b alpha
  where
    a' = fromIntegral a / 255.0
    alpha = floor . max 0 . min 255 $ opacity * a' * 255

documentOfPattern :: Pattern -> String -> Document
documentOfPattern pat loc = Document
    { _viewBox     = _patternViewBox pat
    , _width       = return $ _patternWidth pat
    , _height      = return $ _patternHeight pat
    , _elements    = _patternElements pat
    , _definitions = M.empty
    , _styleRules  = []
    , _description = ""
    , _documentLocation = loc
    }

prepareTexture :: RenderContext -> DrawAttributes
               -> Texture -> Float
               -> [R.Primitive]
               -> IODraw (Maybe (R.Texture PixelRGBA8))
prepareTexture _ _ FillNone _opacity _ = return Nothing
prepareTexture _ _ (ColorRef color) opacity _ =
  return . Just . RT.uniformTexture $ fillAlphaCombine opacity color
prepareTexture ctxt attr (TextureRef ref) opacity prims =
    maybe (return Nothing) prepare $
        M.lookup ref (_contextDefinitions ctxt)
  where
    prepare (ElementGeometry _) = return Nothing
    prepare (ElementMarker _) = return Nothing
    prepare (ElementMask _) = return Nothing
    prepare (ElementClipPath _) = return Nothing
    prepare (ElementLinearGradient grad) =
      return . Just $ prepareLinearGradientTexture ctxt 
                        attr grad opacity prims
    prepare (ElementRadialGradient grad) =
      return . Just $ prepareRadialGradientTexture ctxt
                        attr grad opacity prims
    prepare (ElementPattern pat) = do
      let doc = documentOfPattern pat (_basePath ctxt)
          dpi = _renderDpi ctxt
          w = floor . lineariseXLength ctxt attr $ _patternWidth pat
          h = floor . lineariseYLength ctxt attr $ _patternHeight pat
      patDrawing <- _subRender ctxt doc
      return . Just $ RT.patternTexture w h dpi (PixelRGBA8 0 0 0 0) patDrawing