{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
-- | 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
    , fillOrder

    , textToDrawOrders
    , transformOrder
    ) where

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

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

import Control.Monad.Primitive( PrimState, 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.Command
import Graphics.Rasterific.PlaneBoundable

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

-- | Monad used to describe the drawing context.
type DrawContext m px =
    StateT (MutableImage (PrimState m) px) m

-- | 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)))
    }

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 }

instance Transformable (DrawOrder px) where
  transform = transformOrder

-- | 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 } =
  F.forM_ (_orderPrimitives o) $
    fillWithTexture (_orderFillMethod o) (_orderTexture o)
fillOrder o@DrawOrder { _orderMask = Just mask } =
  F.forM_ (_orderPrimitives o) $
    fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask

-- | 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,
                    MonadState (MutableImage (PrimState m) px)
                               (DrawContext m 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 texture img
        clipped = foldMap (clip mini maxi) els
        spans = rasterize fillMethod clipped
    lift . mapExec filler $ 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
       , MonadState (MutableImage (PrimState m) px)
                    (DrawContext m 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 (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
    }

  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]