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