module Window.Graphics.Renderer
    ( module Window.Graphics.Renderer.Types
    , mkRenderer
    , freeRenderer
    , beginRenderer
    , endRenderer
    , rendererDestRect
    ) where

import Control.Monad          (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IORef             (newIORef, readIORef)
import Data.StateVar          (($=))
import Foreign.C.Types        (CInt)
import qualified SDL

import Configs.All.Settings.Render
import Id
import Window.Graphics.Renderer.Types
import Window.Graphics.Texture.Types

sdTargetTextureWidth   = 1920 :: Int
sdTargetTextureHeight  = 1080 :: Int
sdTargetTextureRawSize = 2048 :: CInt

hdTargetTextureWidth   = 3840 :: Int
hdTargetTextureHeight  = 2160 :: Int
hdTargetTextureRawSize = 4096 :: CInt

mkTargetTexture :: MonadIO m => SDL.Renderer -> RenderMode -> m Texture
mkTargetTexture sdlRenderer renderMode =
    Texture <$>
    pure NullId <*>
    SDL.createTexture sdlRenderer SDL.RGBA8888 SDL.TextureAccessTarget size <*>
    pure width <*>
    pure height
    where
        rawWidthHeight = case renderMode of
            RenderSD -> sdTargetTextureRawSize
            RenderHD -> hdTargetTextureRawSize
        size           = SDL.V2 rawWidthHeight rawWidthHeight

        (width, height) = case renderMode of
            RenderSD -> (sdTargetTextureWidth, sdTargetTextureHeight)
            RenderHD -> (hdTargetTextureWidth, hdTargetTextureHeight)

mkRenderer :: MonadIO m => SDL.Window -> Int -> Int -> RenderConfig -> m Renderer
mkRenderer window winWidth winHeight renderCfg =
    let
        sdlRendererConfig = SDL.RendererConfig
            { SDL.rendererType          = if
                | _vsync renderCfg -> SDL.AcceleratedVSyncRenderer
                | otherwise        -> SDL.AcceleratedRenderer
            , SDL.rendererTargetTexture = True
            }

        renderMode
            | winWidth > sdTargetTextureWidth && winHeight > sdTargetTextureHeight = RenderHD
            | otherwise                                                            = RenderSD
    in do
        when (_hintOpenGL renderCfg) $
            SDL.HintRenderDriver $= SDL.OpenGL
        SDL.HintRenderScaleQuality $= SDL.ScaleLinear

        sdlRenderer      <- SDL.createRenderer window (-1) sdlRendererConfig
        targetTexture    <- mkTargetTexture sdlRenderer renderMode
        targetTextureRef <- liftIO $ newIORef targetTexture

        SDL.rendererDrawBlendMode sdlRenderer $= SDL.BlendAlphaBlend
        case renderMode of
            RenderSD -> return ()
            RenderHD -> SDL.rendererScale sdlRenderer $= SDL.V2 2.0 2.0

        return $ Renderer
            { _sdlRenderer      = sdlRenderer
            , _targetTextureRef = targetTextureRef
            , _renderMode       = renderMode
            }

freeRenderer :: MonadIO m => Renderer -> m ()
freeRenderer renderer = SDL.destroyRenderer $ _sdlRenderer renderer

clearSdlRenderer :: MonadIO m => SDL.Renderer -> m ()
clearSdlRenderer sdlRenderer = do
    SDL.rendererDrawColor sdlRenderer $= SDL.V4 0 0 0 255
    SDL.clear sdlRenderer

beginRenderer :: MonadIO m => Renderer -> m ()
beginRenderer renderer = do
    let targetTextureRef = _targetTextureRef renderer
    targetTexture       <- liftIO $ readIORef targetTextureRef
    let
        targetSdlTexture = _sdlTexture targetTexture
        sdlRenderer      = _sdlRenderer renderer

    SDL.rendererRenderTarget sdlRenderer $= Just targetSdlTexture
    clearSdlRenderer sdlRenderer

endRenderer :: MonadIO m => Int -> Int -> Renderer -> m ()
endRenderer winWidth winHeight renderer = do
    targetTexture  <- liftIO $ readIORef (_targetTextureRef renderer)
    let sdlRenderer = _sdlRenderer renderer

    SDL.rendererRenderTarget sdlRenderer $= Nothing
    clearSdlRenderer sdlRenderer

    let
        srcPoint         = SDL.P $ SDL.V2 0 0
        renderWidth      = _width (targetTexture :: Texture)
        renderHeight     = _height (targetTexture :: Texture)
        srcSize          = SDL.V2 (fromIntegral renderWidth) (fromIntegral renderHeight)
        srcRect          = Just $ SDL.Rectangle srcPoint srcSize
        targetSdlTexture = _sdlTexture targetTexture

    destRect <- Just <$> rendererDestRect winWidth winHeight renderer
    SDL.copyEx sdlRenderer targetSdlTexture srcRect destRect 0 Nothing (SDL.V2 False False)
    SDL.present sdlRenderer

rendererDestRect :: MonadIO m => Int -> Int -> Renderer -> m (SDL.Rectangle CInt)
rendererDestRect winWidth winHeight renderer = do
    targetTexture <- liftIO $ readIORef (_targetTextureRef renderer)

    let
        renderWidth   = _width (targetTexture :: Texture)
        renderHeight  = _height (targetTexture :: Texture)
        winWidthCInt  = fromIntegral winWidth
        winHeightCInt = fromIntegral winHeight

        (destPoint, destSize) =
            let
                h = round $ fromIntegral renderHeight / fromIntegral renderWidth * fromIntegral winWidth
                y = (winHeightCInt - h) `quot` 2
                w = round $ fromIntegral renderWidth / fromIntegral renderHeight * fromIntegral winHeight
                x = (winWidthCInt - w) `quot` 2
            in if
                | h <= winHeightCInt ->
                    ( SDL.P $ SDL.V2 0 y
                    , SDL.V2 winWidthCInt h
                    )
                | otherwise          ->
                    ( SDL.P $ SDL.V2 x 0
                    , SDL.V2 w winHeightCInt
                    )

    return $ SDL.Rectangle destPoint destSize

module Window.Graphics.Renderer
    ( module Window.Graphics.Renderer.Types
    , mkRenderer
    , freeRenderer
    , beginRenderer
    , endRenderer
    , rendererDestRect
    ) where

import Control.Monad          (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IORef             (newIORef, readIORef)
import Data.StateVar          (($=))
import Foreign.C.Types        (CInt)
import qualified SDL

import Configs.All.Settings.Render
import Id
import Window.Graphics.Renderer.Types
import Window.Graphics.Texture.Types

sdTargetTextureWidth   = 1920 :: Int
sdTargetTextureHeight  = 1080 :: Int
sdTargetTextureRawSize = 2048 :: CInt

hdTargetTextureWidth   = 3840 :: Int
hdTargetTextureHeight  = 2160 :: Int
hdTargetTextureRawSize = 4096 :: CInt

mkTargetTexture :: MonadIO m => SDL.Renderer -> RenderMode -> m Texture
mkTargetTexture sdlRenderer renderMode =
    Texture <$>
    pure NullId <*>
    SDL.createTexture sdlRenderer SDL.RGBA8888 SDL.TextureAccessTarget size <*>
    pure width <*>
    pure height
    where
        rawWidthHeight = case renderMode of
            RenderSD -> sdTargetTextureRawSize
            RenderHD -> hdTargetTextureRawSize
        size           = SDL.V2 rawWidthHeight rawWidthHeight

        (width, height) = case renderMode of
            RenderSD -> (sdTargetTextureWidth, sdTargetTextureHeight)
            RenderHD -> (hdTargetTextureWidth, hdTargetTextureHeight)

mkRenderer :: MonadIO m => SDL.Window -> Int -> Int -> RenderConfig -> m Renderer
mkRenderer window winWidth winHeight renderCfg =
    let
        sdlRendererConfig = SDL.RendererConfig
            { SDL.rendererType          = if
                | _vsync renderCfg -> SDL.AcceleratedVSyncRenderer
                | otherwise        -> SDL.AcceleratedRenderer
            , SDL.rendererTargetTexture = True
            }

        renderMode
            | winWidth > sdTargetTextureWidth && winHeight > sdTargetTextureHeight = RenderHD
            | otherwise                                                            = RenderSD
    in do
        when (_hintOpenGL renderCfg) $
            SDL.HintRenderDriver $= SDL.OpenGL
        SDL.HintRenderScaleQuality $= SDL.ScaleLinear

        sdlRenderer      <- SDL.createRenderer window (-1) sdlRendererConfig
        targetTexture    <- mkTargetTexture sdlRenderer renderMode
        targetTextureRef <- liftIO $ newIORef targetTexture

        SDL.rendererDrawBlendMode sdlRenderer $= SDL.BlendAlphaBlend
        case renderMode of
            RenderSD -> return ()
            RenderHD -> SDL.rendererScale sdlRenderer $= SDL.V2 2.0 2.0

        return $ Renderer
            { _sdlRenderer      = sdlRenderer
            , _targetTextureRef = targetTextureRef
            , _renderMode       = renderMode
            }

freeRenderer :: MonadIO m => Renderer -> m ()
freeRenderer renderer = SDL.destroyRenderer $ _sdlRenderer renderer

clearSdlRenderer :: MonadIO m => SDL.Renderer -> m ()
clearSdlRenderer sdlRenderer = do
    SDL.rendererDrawColor sdlRenderer $= SDL.V4 0 0 0 255
    SDL.clear sdlRenderer

beginRenderer :: MonadIO m => Renderer -> m ()
beginRenderer renderer = do
    let targetTextureRef = _targetTextureRef renderer
    targetTexture       <- liftIO $ readIORef targetTextureRef
    let
        targetSdlTexture = _sdlTexture targetTexture
        sdlRenderer      = _sdlRenderer renderer

    SDL.rendererRenderTarget sdlRenderer $= Just targetSdlTexture
    clearSdlRenderer sdlRenderer

endRenderer :: MonadIO m => Int -> Int -> Renderer -> m ()
endRenderer winWidth winHeight renderer = do
    targetTexture  <- liftIO $ readIORef (_targetTextureRef renderer)
    let sdlRenderer = _sdlRenderer renderer

    SDL.rendererRenderTarget sdlRenderer $= Nothing
    clearSdlRenderer sdlRenderer

    let
        srcPoint         = SDL.P $ SDL.V2 0 0
        renderWidth      = _width (targetTexture :: Texture)
        renderHeight     = _height (targetTexture :: Texture)
        srcSize          = SDL.V2 (fromIntegral renderWidth) (fromIntegral renderHeight)
        srcRect          = Just $ SDL.Rectangle srcPoint srcSize
        targetSdlTexture = _sdlTexture targetTexture

    destRect <- Just <$> rendererDestRect winWidth winHeight renderer
    SDL.copyEx sdlRenderer targetSdlTexture srcRect destRect 0 Nothing (SDL.V2 False False)
    SDL.present sdlRenderer

rendererDestRect :: MonadIO m => Int -> Int -> Renderer -> m (SDL.Rectangle CInt)
rendererDestRect winWidth winHeight renderer = do
    targetTexture <- liftIO $ readIORef (_targetTextureRef renderer)

    let
        renderWidth   = _width (targetTexture :: Texture)
        renderHeight  = _height (targetTexture :: Texture)
        winWidthCInt  = fromIntegral winWidth
        winHeightCInt = fromIntegral winHeight

        (destPoint, destSize) =
            let
                h = round $ fromIntegral renderHeight / fromIntegral renderWidth * fromIntegral winWidth
                y = (winHeightCInt - h) `quot` 2
                w = round $ fromIntegral renderWidth / fromIntegral renderHeight * fromIntegral winHeight
                x = (winWidthCInt - w) `quot` 2
            in if
                | h <= winHeightCInt ->
                    ( SDL.P $ SDL.V2 0 y
                    , SDL.V2 winWidthCInt h
                    )
                | otherwise          ->
                    ( SDL.P $ SDL.V2 x 0
                    , SDL.V2 w winHeightCInt
                    )

    return $ SDL.Rectangle destPoint destSize
