{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
-- | This module implements drawing primitives to draw directly into

-- the output texture, without generating an intermediate scene

-- representation.

--

-- If you need to draw complex scenes or plot an important set of

-- data, this is the module you should use. The downside is that

-- you must specify everything you need at each draw call, there

-- is no API to help you propagate constants.

--

-- The "stroking" must be done using the functions of the

-- `Graphics.Rasterific.Outline` module.

module Graphics.Rasterific.Immediate
    ( DrawContext
    , DrawOrder( .. )
    , orderToDrawing

    , runDrawContext
    , fillWithTextureAndMask
    , fillWithTexture
    , fillWithTextureNoAA
    , fillOrder

    , textToDrawOrders
    , transformOrder

    , meshToImage
    ) where


import Control.Monad.ST( ST, runST )
import Data.Maybe( fromMaybe )
import qualified Data.Foldable as F
import Control.Monad.Free( liftF )
import Control.Monad.State( evalStateT, execStateT, lift )
import Control.Monad.Trans.State( get )
import Codec.Picture.Types( Image( .. )
                          , Pixel( .. )
                          , MutableImage( .. )
                          , unsafeFreezeImage
                          , fillImageWith )

import Control.Monad.Primitive( PrimMonad, primToPrim )
import qualified Data.Vector.Storable.Mutable as M
import Graphics.Rasterific.Compositor
import Graphics.Rasterific.Linear( V2( .. ) )
import Graphics.Rasterific.Rasterize
import Graphics.Rasterific.Shading
import Graphics.Rasterific.QuadraticBezier
import Graphics.Rasterific.Types
import Graphics.Rasterific.PatchTypes
import Graphics.Rasterific.CubicBezier.FastForwardDifference
import Graphics.Rasterific.Transformations
import Graphics.Rasterific.MeshPatch
import Graphics.Rasterific.ComplexPrimitive
import Graphics.Rasterific.Command
import Graphics.Rasterific.PlaneBoundable

import qualified Data.Vector.Unboxed as VU
import Graphics.Text.TrueType( Dpi, getStringCurveAtPoint )

-- | Reify a filling function call, to be able to manipulate

-- them in a simpler fashion.

data DrawOrder px = DrawOrder
    { -- | Primitives to be filled.

      _orderPrimitives :: ![[Primitive]]
      -- | Texture for the filled primitives.

    , _orderTexture    :: !(Texture px)
      -- | How to fill the primitives.

    , _orderFillMethod :: !FillMethod
      -- | Optional mask used for clipping.

    , _orderMask       :: !(Maybe (Texture (PixelBaseComponent px)))
      -- | Function to perform direct drawing

    , _orderDirect     :: !(forall s. DrawContext (ST s) px ())
    }

instance PlaneBoundable (DrawOrder px) where
  planeBounds =
    foldMap (foldMap planeBounds) . _orderPrimitives

transformOrder :: (Point -> Point) -> DrawOrder px -> DrawOrder px
transformOrder f order =
  order { _orderPrimitives = transform f $ _orderPrimitives order }

transformOrderM :: Monad m => (Point -> m Point) -> DrawOrder px -> m (DrawOrder px)
transformOrderM f order = do
  v <- transformM f $ _orderPrimitives order
  return $ order { _orderPrimitives = v}

instance Transformable (DrawOrder px) where
  transform = transformOrder
  transformM = transformOrderM

-- | Transform back a low level drawing order to a more

-- high level Drawing

orderToDrawing :: DrawOrder px -> Drawing px ()
orderToDrawing order =
  usingTexture . mapM_ filler $ _orderPrimitives order
    where
      usingTexture sub =
          liftF $ SetTexture (_orderTexture order) sub ()
      filler prims =
          liftF $ Fill (_orderFillMethod order) prims ()

-- | Render the drawing orders on the canvas.

fillOrder :: (PrimMonad m, RenderablePixel px)
          => DrawOrder px -> DrawContext m px ()
fillOrder o@DrawOrder { _orderMask = Nothing } = do
  F.forM_ (_orderPrimitives o) $
    fillWithTexture (_orderFillMethod o) (_orderTexture o)
  img <- get
  lift $ primToPrim $ flip evalStateT img $ _orderDirect o

fillOrder o@DrawOrder { _orderMask = Just mask } = do
  F.forM_ (_orderPrimitives o) $
    fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask
  img <- get
  lift $ primToPrim $ flip evalStateT img $ _orderDirect o

-- | Start an image rendering. See `fillWithTexture` for

-- an usage example. This function can work with either

-- `IO` or `ST`.

runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px)
               => Int   -- ^ Rendering width

               -> Int   -- ^ Rendering height

               -> px    -- ^ Background color

               -> DrawContext m px () -- ^ Actual drawing computation

               -> m (Image px)
runDrawContext width height background drawing = do
  buff <- M.new (width * height * componentCount background)
  let mutable = MutableImage width height buff
  fillImageWith mutable background
  img <- execStateT drawing mutable
  unsafeFreezeImage img

mapExec :: Monad m => (a -> m ()) -> [a] -> m ()
mapExec f = foldr ((>>) . f) (return ())

isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool
isCoverageDrawable img coverage =
    _coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight
  where
    !imgWidth = fromIntegral $ mutableImageWidth img
    !imgHeight = fromIntegral $ mutableImageHeight img
    x = _coverageX coverage
    y = _coverageY coverage

-- | Fill some geometry.

--

-- > immediateDrawExample :: Image PixelRGBA8

-- > immediateDrawExample = runST $

-- >   runDrawContext 200 200 (PixelRGBA8 0 0 0 0) $

-- >     fillWithTexture FillWinding texture geometry

-- >   where

-- >     circlePrimitives = circle (V2 100 100) 50

-- >     geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives

-- >     texture = uniformTexture (PixelRGBA8 255 255 255 255)

--

-- <<docimages/immediate_fill.png>>

--

fillWithTexture :: (PrimMonad m, RenderablePixel px)
                => FillMethod
                -> Texture px  -- ^ Color/Texture used for the filling

                -> [Primitive] -- ^ Primitives to fill

                -> DrawContext m px ()
fillWithTexture fillMethod texture els = do
    img@(MutableImage width height _) <- get
    let !mini = V2 0 0
        !maxi = V2 (fromIntegral width) (fromIntegral height)
        !filler = primToPrim . transformTextureToFiller meshToImage texture img
        clipped = foldMap (clip mini maxi) els
        spans = rasterize fillMethod clipped
    lift . mapExec filler $ filter (isCoverageDrawable img) spans

-- | Function identical to 'fillWithTexture' but with anti-aliasing

-- (and transparency) disabled.

fillWithTextureNoAA :: (PrimMonad m, RenderablePixel px)
                => FillMethod
                -> Texture px  -- ^ Color/Texture used for the filling

                -> [Primitive] -- ^ Primitives to fill

                -> DrawContext m px ()
fillWithTextureNoAA fillMethod texture els = do
    img@(MutableImage width height _) <- get
    let !mini = V2 0 0
        !maxi = V2 (fromIntegral width) (fromIntegral height)
        !filler = primToPrim . transformTextureToFiller meshToImage texture img
        clipped = foldMap (clip mini maxi) els
        spans = rasterize fillMethod clipped
    lift . mapExec (filler . toOpaqueCoverage) $ filter (isCoverageDrawable img) spans

-- | Fill some geometry using a composition mask for visibility.

--

-- > immediateDrawMaskExample :: Image PixelRGBA8

-- > immediateDrawMaskExample = runST $

-- >   runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $

-- >     forM_ [1 .. 10] $ \ix ->

-- >        fillWithTextureAndMask FillWinding texture mask $

-- >            rectangle (V2 10 (ix * 18 - 5)) 180 13

-- >   where

-- >     texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255

-- >     mask = sampledImageTexture

-- >          $ runST

-- >          $ runDrawContext 200 200 0

-- >          $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry

-- > 

-- >     maskGeometry = strokize 15 JoinRound (CapRound, CapRound)

-- >                  $ circle (V2 100 100) 80

--

-- <<docimages/immediate_mask.png>>

--

fillWithTextureAndMask
    :: (PrimMonad m, RenderablePixel px)
    => FillMethod
    -> Texture px  -- ^ Color/Texture used for the filling of the geometry

    -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask.

    -> [Primitive]                     -- ^ Primitives to fill

    -> DrawContext m px ()
fillWithTextureAndMask fillMethod texture mask els = do
    img@(MutableImage width height _) <- get
    let !mini = V2 0 0
        !maxi = V2 (fromIntegral width) (fromIntegral height)
        spans = rasterize fillMethod $ foldMap (clip mini maxi) els
        !shader = primToPrim
                . transformTextureToFiller meshToImage (ModulateTexture texture mask) img
    lift . mapM_ shader $ filter (isCoverageDrawable img) spans

-- | Helper function transforming text range to draw order.

textToDrawOrders :: Dpi             -- ^ Current output device resolution

                 -> Texture px      -- ^ Texture to use if no texture is defined in the range

                 -> Point           -- ^ Baseline position

                 -> [TextRange px]  -- ^ Text description.

                 -> [DrawOrder px]
textToDrawOrders dpi defaultTexture (V2 x y) descriptions =
    toOrder <$> zip floatCurves linearDescriptions where

  toOrder (curve, d) = DrawOrder
    { _orderPrimitives = [beziersOfChar curve]
    , _orderFillMethod = FillWinding
    , _orderMask = Nothing
    , _orderTexture = fromMaybe defaultTexture $ _textTexture d
    , _orderDirect = return ()
    }

  floatCurves =
    getStringCurveAtPoint dpi (x, y)
      [(_textFont d, _textSize d, _text d) | d <- descriptions]

  linearDescriptions =
    concat [map (const d) $ _text d | d <- descriptions]

  beziersOfChar curves = concat
    [fmap BezierPrim . bezierFromPath . fmap (uncurry V2) $ VU.toList c | c <- curves]


meshToImage :: forall px. (RenderablePixel px)
            => Maybe Transformation -> Int-> Int
            -> PatchInterpolation -> MeshPatch px
            -> Image px
meshToImage mayTrans width height i baseMesh
  | not hasTransparency = rendering
  | otherwise = runST $ runDrawContext width height background $ fillOrder order
  where
    mesh = case mayTrans >>= inverseTransformation of
      Nothing -> baseMesh
      Just trans ->
        transform (applyTransformation trans) baseMesh

    background = emptyPx :: px
    clipBackground = emptyValue :: PixelBaseComponent px

    rendering = runST $ runDrawContext width height background $ case i of
      PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf opaqueMesh
      PatchBicubic ->
          mapM_ rasterizeCoonPatch
              . cubicCoonPatchesOf
              $ calculateMeshColorDerivative opaqueMesh

    hasTransparency =
        F.any ((/= fullValue) . pixelOpacity) $ _meshColors mesh

    opacifier px = mixWithAlpha (\_ _ a -> a) (\_ _ -> fullValue) px px

    opaqueMesh = opacifier <$> mesh
    transparencyMesh = pixelOpacity <$> mesh

    clipPath =
      runST $ runDrawContext width height clipBackground $ case i of
        PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf transparencyMesh
        PatchBicubic ->
            mapM_ rasterizeCoonPatch
                . cubicCoonPatchesOf
                $ calculateMeshColorDerivative transparencyMesh

    order = DrawOrder
          { _orderPrimitives = [rectangle (V2 0 0) (fromIntegral width) (fromIntegral height)]
          , _orderTexture    = AlphaModulateTexture (RawTexture rendering) (RawTexture clipPath)
          , _orderFillMethod = FillWinding
          , _orderMask       = Nothing
          , _orderDirect     = return ()
          }