{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
module Graphics.Rasterific.Svg.RasterificTextRendering
        ( renderText ) where

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

import Control.Monad( foldM )
import Control.Monad.IO.Class( liftIO )
import Control.Monad.Identity( Identity )
import Control.Monad.Trans.State.Strict( execState
                                       , StateT
                                       , modify
                                       , gets )
import Control.Applicative( (<|>) )
import Control.Lens( at, (?=) )
import qualified Control.Lens as L
import Codec.Picture( PixelRGBA8( .. ) )
import qualified Data.Foldable as F
import Data.Monoid( (<>), Last( .. ), First( .. ) )
import Data.Maybe( fromMaybe )
import qualified Data.Text as T
import Graphics.Rasterific.Linear( (^+^), (^-^) )
import Graphics.Rasterific hiding ( Path, Line, Texture, transform )
import qualified Graphics.Rasterific as R
import qualified Graphics.Rasterific.Outline as RO
import Graphics.Rasterific.Immediate
import qualified Graphics.Rasterific.Transformations as RT
import Graphics.Rasterific.PathWalker
import Graphics.Text.TrueType
import Graphics.Svg.Types
import Graphics.Rasterific.Svg.RenderContext
import Graphics.Rasterific.Svg.PathConverter
{-import Graphics.Svg.XmlParser-}

{-import Debug.Trace-}
{-import Text.Printf-}

loadFont :: FilePath -> IODraw (Maybe Font)
loadFont fontPath = do
  loaded <- L.use $ loadedFonts . at fontPath
  case loaded of
    Just v -> return $ Just v
    Nothing -> do
      file <- liftIO $ loadFontFile fontPath
      case file of
        Left _ -> return Nothing
        Right f -> do
          loadedFonts . at fontPath ?= f
          return $ Just f

data RenderableString px = RenderableString
    { _renderableAttributes :: !DrawAttributes
    , _renderableSize       :: !Float
    , _renderableFont       :: !Font
    , _renderableString     :: ![(Char, CharInfo px)]
    }

data CharInfo px = CharInfo
  { _charX  :: Maybe Number
  , _charY  :: Maybe Number
  , _charDx :: Maybe Number
  , _charDy :: Maybe Number
  , _charRotate :: Maybe Float
  , _charStroke :: Maybe (Float, R.Texture px, R.Join, (R.Cap, R.Cap))
  }

emptyCharInfo :: CharInfo px
emptyCharInfo = CharInfo
  { _charX      = Nothing
  , _charY      = Nothing
  , _charDx     = Nothing
  , _charDy     = Nothing
  , _charRotate = Nothing
  , _charStroke = Nothing
  }

propagateTextInfo :: TextInfo -> TextInfo -> TextInfo
propagateTextInfo parent current = TextInfo
  { _textInfoX = combine _textInfoX
  , _textInfoY = combine _textInfoY
  , _textInfoDX = combine _textInfoDX
  , _textInfoDY = combine _textInfoDY
  , _textInfoRotate = combine _textInfoRotate
  , _textInfoLength = _textInfoLength current
  }
  where
    combine f = case f current of
      [] -> f parent
      lst -> lst

textInfoRests :: TextInfo -> TextInfo -> TextInfo
              -> TextInfo
textInfoRests this parent sub = TextInfo
    { _textInfoX      = decideWith _textInfoX
    , _textInfoY      = decideWith _textInfoY
    , _textInfoDX     = decideWith _textInfoDX
    , _textInfoDY     = decideWith _textInfoDY
    , _textInfoRotate = decideWith _textInfoRotate
    , _textInfoLength = _textInfoLength parent
    }
  where
    decideWith f = decide (f this) (f parent) (f sub)

    decide []   _ ssub = ssub 
    decide  _ top    _ = top

unconsTextInfo :: RenderContext -> DrawAttributes -> TextInfo
               -> IODraw (CharInfo PixelRGBA8, TextInfo)
unconsTextInfo ctxt attr nfo = do
  texture <- textureOf ctxt attr _strokeColor _strokeOpacity
  return (charInfo texture, restText)
 where
  unconsInf lst = case lst of
     []     -> (Nothing, [])
     (x:xs) -> (Just x, xs)

  (xC, xRest) = unconsInf $ _textInfoX nfo
  (yC, yRest) = unconsInf $ _textInfoY nfo
  (dxC, dxRest) = unconsInf $ _textInfoDX nfo
  (dyC, dyRest) = unconsInf $ _textInfoDY nfo
  (rotateC, rotateRest) = unconsInf $ _textInfoRotate nfo

  restText = TextInfo
    { _textInfoX      = xRest
    , _textInfoY      = yRest
    , _textInfoDX     = dxRest
    , _textInfoDY     = dyRest
    , _textInfoRotate = rotateRest
    , _textInfoLength = _textInfoLength nfo
    }

  sWidth =
     lineariseLength ctxt attr <$> getLast (_strokeWidth attr)

  charInfo tex = CharInfo
    { _charX = xC
    , _charY = yC
    , _charDx = dxC
    , _charDy = dyC
    , _charRotate = realToFrac <$> rotateC
    , _charStroke =
        (,, joinOfSvg attr, capOfSvg attr) <$> sWidth <*> tex
    }

repeatLast :: [a] -> [a]
repeatLast = go where
  go lst = case lst of
    [] -> []
    [x] -> repeat x
    (x:xs) -> x : go xs

infinitizeTextInfo :: TextInfo -> TextInfo
infinitizeTextInfo nfo =
    nfo { _textInfoRotate = repeatLast $ _textInfoRotate nfo }


-- | Monadic version of mapAccumL
mapAccumLM :: Monad m
            => (acc -> x -> m (acc, y)) -- ^ combining funcction
            -> acc                      -- ^ initial state
            -> [x]                      -- ^ inputs
            -> m (acc, [y])             -- ^ final state, outputs
mapAccumLM _ s []     = return (s, [])
mapAccumLM f s (x:xs) = do
    (s1, x')  <- f s x
    (s2, xs') <- mapAccumLM f s1 xs
    return    (s2, x' : xs')

mixWithRenderInfo :: RenderContext -> DrawAttributes
                  -> TextInfo -> String
                  -> IODraw (TextInfo, [(Char, CharInfo PixelRGBA8)])
mixWithRenderInfo ctxt attr = mapAccumLM go where
  go info c = do
    (thisInfo, rest) <- unconsTextInfo ctxt attr info
    return (rest, (c, thisInfo))


data LetterTransformerState = LetterTransformerState 
    { _charactersInfos      :: ![CharInfo PixelRGBA8]
    , _characterCurrent     :: !(CharInfo PixelRGBA8)
    , _currentCharDelta     :: !R.Point
    , _currentAbsoluteDelta :: !R.Point
    , _currentDrawing       :: Drawing PixelRGBA8 ()
    , _stringBounds         :: !PlaneBound
    }

type GlyphPlacer = StateT LetterTransformerState Identity

unconsCurrentLetter :: GlyphPlacer ()
unconsCurrentLetter = modify $ \s ->
  case _charactersInfos s of
    [] -> s
    (x:xs) -> s { _charactersInfos = xs
                , _characterCurrent = x
                }

prepareCharRotation :: CharInfo px -> R.PlaneBound -> RT.Transformation
prepareCharRotation info bounds = case _charRotate info of
  Nothing -> mempty
  Just angle -> RT.rotateCenter (toRadian angle) lowerLeftCorner
      where
        lowerLeftCorner = boundLowerLeftCorner bounds

prepareCharTranslation :: RenderContext -> CharInfo px -> R.PlaneBound
                       -> R.Point -> R.Point
                       -> (R.Point, R.Point, RT.Transformation)
prepareCharTranslation ctxt info bounds prevDelta prevAbsolute = go where
  lowerLeftCorner = boundLowerLeftCorner bounds
  toRPoint a b = linearisePoint ctxt mempty (a, b)
  mzero = Just $ Num 0
  V2 pmx pmy = Just . Num . realToFrac <$> prevAbsolute

  mayForcedPoint = case (_charX info, _charY info) of
    (Nothing, Nothing) -> Nothing
    (mx, my) -> toRPoint <$> (mx <|> pmx) <*> (my <|> pmy)

  delta = fromMaybe 0 $
    toRPoint <$> (_charDx info <|> mzero)
             <*> (_charDy info <|> mzero)

  go = case mayForcedPoint of
    Nothing ->
      let newDelta = prevDelta ^+^ delta
          trans = RT.translate $ newDelta ^+^ prevAbsolute in
      (newDelta, prevAbsolute, trans)

    Just p ->
      let newDelta = prevDelta ^+^ delta
          positionDelta = (realToFrac <$> p) ^-^ lowerLeftCorner
          trans = RT.translate $ positionDelta ^+^ newDelta in
      (newDelta, positionDelta, trans)

transformPlaceGlyph :: RenderContext
                    -> RT.Transformation
                    -> R.PlaneBound
                    -> DrawOrder PixelRGBA8
                    -> GlyphPlacer ()
transformPlaceGlyph ctxt pathTransformation bounds order = do
  unconsCurrentLetter 
  info <- gets _characterCurrent
  delta <- gets _currentCharDelta
  absoluteDelta <- gets _currentAbsoluteDelta
  let rotateTrans = prepareCharRotation info bounds
      (newDelta, newAbsolute, placement) =
        prepareCharTranslation ctxt info bounds delta absoluteDelta
      finalTrans = pathTransformation <> placement <> rotateTrans
      newGeometry =
          R.transform (RT.applyTransformation finalTrans) $ _orderPrimitives order
      newOrder = order { _orderPrimitives = newGeometry }

        
      stroking Nothing = return ()
      stroking (Just (w, texture, rjoin, cap)) =
          orderToDrawing $ newOrder {
            _orderPrimitives = stroker <$> _orderPrimitives newOrder,
            _orderTexture = texture
          }
         where
           stroker = RO.strokize w rjoin cap

  modify $ \s -> s
    { _currentCharDelta = newDelta
    , _currentAbsoluteDelta = newAbsolute
    , _stringBounds = _stringBounds s <> bounds
    , _currentDrawing = do
        _currentDrawing s
        orderToDrawing newOrder
        stroking $ _charStroke info
    }

prepareFontFamilies :: DrawAttributes -> [String]
prepareFontFamilies = (++ defaultFont)
                    . fmap replaceDefault
                    . fromMaybe []
                    . getLast 
                    . _fontFamily
  where
    defaultFont = ["Arial"]
    -- using "safe" web font, hoping they are present on
    -- the system.
    replaceDefault s = case s of
      "monospace" -> "Courier New"
      "sans-serif" -> "Arial"
      "serif" -> "Times New Roman"
      _ -> s

fontOfAttributes :: FontCache -> DrawAttributes -> IODraw (Maybe Font)
fontOfAttributes fontCache attr = case fontFilename of
  Nothing -> return Nothing
  Just fn -> loadFont fn
  where
    fontFilename =
      getFirst . F.foldMap fontFinder $ prepareFontFamilies attr
    noStyle = FontStyle
            { _fontStyleBold = False
            , _fontStyleItalic = False }

    italic = noStyle { _fontStyleItalic = True }

    style = case getLast $ _fontStyle attr of
      Nothing -> noStyle
      Just FontStyleNormal -> noStyle
      Just FontStyleItalic -> italic
      Just FontStyleOblique -> italic

    fontFinder ff =
         First $ findFontInCache fontCache descriptor
      where descriptor = FontDescriptor
                 { _descriptorFamilyName = T.pack ff
                 , _descriptorStyle = style }


prepareRenderableString :: RenderContext -> DrawAttributes -> Text
                        -> IODraw [RenderableString PixelRGBA8]
prepareRenderableString ctxt ini_attr root =
    fst <$> everySpan ini_attr mempty (_textRoot root) where

  everySpan attr originalInfo tspan =
      foldM (everyContent subAttr) (mempty, nfo) $ _spanContent tspan
    where
      subAttr = attr <> _spanDrawAttributes tspan
      nfo = propagateTextInfo originalInfo
          . infinitizeTextInfo
          $ _spanInfo tspan

  everyContent _attr (acc, info) (SpanTextRef _) = return (acc, info)
  everyContent attr (acc, info) (SpanSub thisSpan) = do
      let thisTextInfo = _spanInfo thisSpan
      (drawn, newInfo) <- everySpan attr info thisSpan
      return (acc <> drawn, textInfoRests thisTextInfo info newInfo)
  everyContent attr (acc, info) (SpanText txt) = do
    font <- fontOfAttributes (_fontCache ctxt) attr
    case font of
      Nothing -> return (acc, info)
      Just f -> do
        (info', str) <- mixWithRenderInfo ctxt attr info $ T.unpack txt
        let finalStr = RenderableString attr size f str
        return (acc <> [finalStr], info')
     
     where
       size = case getLast $ _fontSize attr of
          Just v -> lineariseLength ctxt attr v
          Nothing -> 16


anchorStringRendering :: TextAnchor -> LetterTransformerState
                      -> Drawing PixelRGBA8 ()
anchorStringRendering anchor st = case anchor of
    TextAnchorStart -> _currentDrawing st
    TextAnchorMiddle ->
        withTransformation (RT.translate (V2 (negate $ stringWidth / 2) 0)) $
            _currentDrawing st
    TextAnchorEnd ->
        withTransformation (RT.translate (V2 (- stringWidth) 0)) $ _currentDrawing st
  where
    stringWidth = boundWidth $ _stringBounds st

notWhiteSpace :: (Char, a) -> Bool
notWhiteSpace (c, _) = c /= ' ' && c /= '\t'

initialLetterTransformerState :: [RenderableString PixelRGBA8] -> LetterTransformerState
initialLetterTransformerState str = LetterTransformerState 
  { _charactersInfos   =
      fmap snd . filter notWhiteSpace . concat $ _renderableString <$> str
  , _characterCurrent  = emptyCharInfo
  , _currentCharDelta  = V2 0 0
  , _currentAbsoluteDelta = V2 0 0
  , _currentDrawing    = mempty
  , _stringBounds = mempty
  }

executePlacer :: Monad m => PathDrawer m px -> [DrawOrder px] -> m ()
executePlacer placer = F.mapM_ exec where
  exec order | bounds == mempty = return ()
             | otherwise = placer mempty bounds order
    where
      bounds = F.foldMap (F.foldMap planeBounds)
             $ _orderPrimitives order

textureOf :: RenderContext
          -> DrawAttributes
          -> (DrawAttributes -> Last Texture)
          -> (DrawAttributes -> Maybe Float)
          -> IODraw (Maybe (R.Texture PixelRGBA8))
textureOf ctxt attr colorAccessor opacityAccessor =
  case getLast $ colorAccessor attr of
    Nothing -> return Nothing
    Just svgTexture ->
        prepareTexture ctxt attr svgTexture opacity []
      where opacity = fromMaybe 1.0 $ opacityAccessor attr
 
renderString :: RenderContext -> Maybe (Float, R.Path) -> TextAnchor
             -> [RenderableString PixelRGBA8]
             -> IODraw (Drawing PixelRGBA8 ())
renderString ctxt mayPath anchor str = do
  textRanges <- mapM toFillTextRange str

  case mayPath of
    Just (offset, tPath) ->
        return . pathPlacer offset tPath $ fillOrders textRanges
    Nothing -> return . linePlacer $ fillOrders textRanges
  where
    fillOrders =
      drawOrdersOfDrawing swidth sheight (_renderDpi ctxt) background
        . printTextRanges 0

    pixelToPt s = pixelSizeInPointAtDpi s $ _renderDpi ctxt
    (mini, maxi) = _renderViewBox ctxt
    V2 swidth sheight = floor <$> (maxi ^-^ mini)
    background = PixelRGBA8 0 0 0 0

    pathPlacer offset tPath =
        anchorStringRendering anchor
            . flip execState (initialLetterTransformerState str)
            . drawOrdersOnPath (transformPlaceGlyph ctxt) offset 0 tPath

    linePlacer =
        anchorStringRendering anchor
            . flip execState (initialLetterTransformerState str)
            . executePlacer (transformPlaceGlyph ctxt)
      
    toFillTextRange renderable = do
      mayTexture <- textureOf ctxt (_renderableAttributes renderable)
                        _fillColor _fillOpacity 
      return TextRange
        { _textFont = _renderableFont renderable
        , _textSize = pixelToPt $ _renderableSize renderable
        , _text     = fst <$> _renderableString renderable
        , _textTexture = mayTexture
        }

startOffsetOfPath :: RenderContext -> DrawAttributes -> R.Path -> Number
                  -> Float
startOffsetOfPath _ _ _ (Num i) = realToFrac i
startOffsetOfPath _ attr _ (Em i) = emTransform attr $ realToFrac i
startOffsetOfPath _ _ tPath (Percent p) =
    realToFrac p * RO.approximatePathLength tPath
startOffsetOfPath ctxt attr tPath num =
    startOffsetOfPath ctxt attr tPath $ stripUnits ctxt num

renderText :: RenderContext
           -> DrawAttributes
           -> Maybe TextPath
           -> Text
           -> IODraw (Drawing PixelRGBA8 ())
renderText ctxt attr ppath stext =
  prepareRenderableString ctxt attr stext >>= renderString ctxt pathInfo anchor
  where
    renderPath =
      svgPathToRasterificPath False . _textPathData <$> ppath

    offset = do
      rpath <- renderPath
      mayOffset <- _textPathStartOffset <$> ppath
      return $ startOffsetOfPath ctxt attr rpath mayOffset

    pathInfo = (,) <$> (offset <|> return 0) <*> renderPath

    anchor = fromMaybe TextAnchorStart
           . getLast
           . _textAnchor
           . mappend attr
           . _spanDrawAttributes $ _textRoot stext