{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2017 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

module Simple.UI.Core.Draw (
    Drawing,
    DrawingBuilder,
    DrawStyle (..),
    drawingNew,
    drawingToImage,
    drawingToPicture,
    drawingRun,
    drawingGetWidth,
    drawingGetHeight,
    drawingGetSize,
    drawingPutChar,
    drawingPutCharWithAttr,
    drawingPutString,
    drawingPutStringWithAttr,
    drawingSetAttrs,
    drawingClear,
    drawingClearWithAttr,
    drawingSlice,
    drawingSliceNew
) where

import qualified Data.Vector.Mutable        as V

import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Reader
import           Data.IORef
import           Graphics.Vty

import           Simple.UI.Core.Attribute

type DrawingBuilder = ReaderT Drawing IO

data Drawing = Drawing
    { drawingData    :: V.IOVector (V.IOVector Image)
    , drawingWidth   :: Int
    , drawingHeight  :: Int
    , drawingFgColor :: Attribute Color
    , drawingBgColor :: Attribute Color
    , drawingStyle   :: Attribute DrawStyle
    }

data DrawStyle = DrawStyleNormal
               | DrawStyleBold
               deriving Eq

drawingStyleNew :: Color -> Color -> DrawStyle -> Attr
drawingStyleNew fg bg style =
    if style == DrawStyleBold
        then defAttr `withForeColor` fg `withBackColor` bg `withStyle` bold
        else defAttr `withForeColor` fg `withBackColor` bg

drawingNew :: MonadIO m => Int -> Int -> m Drawing
drawingNew width height = do
    dta <- liftIO $ V.replicateM height $ V.replicateM width (return $ char defaultStyle ' ')
    fg <- attributeNew white
    bg <- attributeNew black
    style <- attributeNew DrawStyleNormal
    return Drawing
        { drawingData = dta
        , drawingWidth = width
        , drawingHeight = height
        , drawingFgColor = fg
        , drawingBgColor = bg
        , drawingStyle = style
        }
  where
    defaultStyle = drawingStyleNew white black DrawStyleNormal

drawingToImage :: MonadIO m => Drawing -> m Image
drawingToImage drawing = do
    rows <- liftIO $ forM [0 .. height - 1] $ \i -> do
        row <- V.read (drawingData drawing) i
        mergeLine row
    liftIO $ mergeRows rows
  where
    height = V.length $ drawingData drawing

    mergeLine row = do
        let width = V.length row
        image <- newIORef emptyImage
        forM_ [0 .. width - 1] $ \i -> do
            c <- V.read row i
            modifyIORef' image (<|> c)
        readIORef image

    mergeRows images = do
        image <- newIORef emptyImage
        forM_ images $ \i ->
            modifyIORef' image (<-> i)
        readIORef image

drawingToPicture :: MonadIO m => Drawing -> m Picture
drawingToPicture drawing = fmap picForImage (drawingToImage drawing)

--

drawingRun :: MonadIO m => Drawing -> DrawingBuilder a -> m a
drawingRun drawing builder = liftIO $ runReaderT builder drawing

drawingGetWidth :: DrawingBuilder Int
drawingGetWidth = asks drawingWidth

drawingGetHeight :: DrawingBuilder Int
drawingGetHeight = asks drawingHeight

drawingGetSize :: DrawingBuilder (Int, Int)
drawingGetSize = do
    width <- drawingGetWidth
    height <- drawingGetHeight
    return (width, height)

drawingPutChar :: Int -> Int -> Char -> DrawingBuilder ()
drawingPutChar x y c = do
    drawing <- ask
    fg <- get drawing drawingFgColor
    bg <- get drawing drawingBgColor
    style <- get drawing drawingStyle
    drawingPutCharWithAttr fg bg style x y c

drawingPutCharWithAttr :: Color -> Color -> DrawStyle -> Int -> Int -> Char -> DrawingBuilder ()
drawingPutCharWithAttr fg bg style x y c =
    when (x >= 0 && y >= 0) $ do
        width <- drawingGetWidth
        height <- drawingGetHeight
        when (x < width && y < height) $ do
            drawing <- ask
            line <- V.read (drawingData drawing) y
            V.write line x (char attr c)
  where
    attr = drawingStyleNew fg bg style

drawingPutString :: Int -> Int -> String -> DrawingBuilder ()
drawingPutString x y cs = do
    drawing <- ask
    fg <- get drawing drawingFgColor
    bg <- get drawing drawingBgColor
    style <- get drawing drawingStyle
    drawingPutStringWithAttr fg bg style x y cs

drawingPutStringWithAttr :: Color -> Color -> DrawStyle -> Int -> Int -> String -> DrawingBuilder ()
drawingPutStringWithAttr _ _ _ _ _ [] = return ()
drawingPutStringWithAttr fg bg style x y (c:cs) = do
    drawingPutCharWithAttr fg bg style x y c
    drawingPutStringWithAttr fg bg style (x + 1) y cs

drawingSetAttrs :: Color -> Color -> DrawStyle -> DrawingBuilder ()
drawingSetAttrs fg bg style = do
    drawing <- ask
    set drawing drawingFgColor fg
    set drawing drawingBgColor bg
    set drawing drawingStyle style

drawingClear :: DrawingBuilder ()
drawingClear = do
    drawing <- ask
    fg <- get drawing drawingFgColor
    bg <- get drawing drawingBgColor
    style <- get drawing drawingStyle
    drawingClearWithAttr fg bg style

drawingClearWithAttr :: Color -> Color -> DrawStyle -> DrawingBuilder ()
drawingClearWithAttr fg bg style = do
    width  <- drawingGetWidth
    height <- drawingGetHeight
    forM_ [0 .. height - 1] $ \y ->
        forM_ [0 .. width - 1] $ \x ->
            drawingPutCharWithAttr fg bg style x y ' '

drawingSlice :: Int -> Int -> Int -> Int -> DrawingBuilder Drawing
drawingSlice x y width height = do
    let x' = if x < 0 then 0 else x
    let y' = if y < 0 then 0 else y

    origWidth  <- asks drawingWidth
    origHeight <- asks drawingHeight
    origDrawing <- asks drawingData

    let width' = if x' + width > origWidth then origWidth - x' else width
    let height' = if y' + height > origHeight then origHeight - y' else height

    h <- liftIO $ newIORef y'
    drawing <- liftIO $ V.replicateM height' $ do
        h' <- increment h
        line <- V.read origDrawing h'
        return (V.slice x' width' line)

    fg <- attributeNew white
    bg <- attributeNew black
    style <- attributeNew DrawStyleNormal
    return Drawing
        { drawingData = drawing
        , drawingWidth = width'
        , drawingHeight = height'
        , drawingFgColor = fg
        , drawingBgColor = bg
        , drawingStyle = style
        }
  where
    increment ref = do
        i <- readIORef ref
        modifyIORef' ref (+1)
        return i

drawingSliceNew :: MonadIO m => Drawing -> Int -> Int -> Int -> Int -> m Drawing
drawingSliceNew drawing x y width height = drawingRun drawing $ drawingSlice x y width height