{-
 *  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
    { Drawing -> IOVector (IOVector Image)
drawingData    :: V.IOVector (V.IOVector Image)
    , Drawing -> Int
drawingWidth   :: Int
    , Drawing -> Int
drawingHeight  :: Int
    , Drawing -> Attribute Color
drawingFgColor :: Attribute Color
    , Drawing -> Attribute Color
drawingBgColor :: Attribute Color
    , Drawing -> Attribute DrawStyle
drawingStyle   :: Attribute DrawStyle
    }

data DrawStyle = DrawStyleNormal
               | DrawStyleBold
               deriving DrawStyle -> DrawStyle -> Bool
(DrawStyle -> DrawStyle -> Bool)
-> (DrawStyle -> DrawStyle -> Bool) -> Eq DrawStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DrawStyle -> DrawStyle -> Bool
$c/= :: DrawStyle -> DrawStyle -> Bool
== :: DrawStyle -> DrawStyle -> Bool
$c== :: DrawStyle -> DrawStyle -> Bool
Eq

drawingStyleNew :: Color -> Color -> DrawStyle -> Attr
drawingStyleNew :: Color -> Color -> DrawStyle -> Attr
drawingStyleNew Color
fg Color
bg DrawStyle
style =
    if DrawStyle
style DrawStyle -> DrawStyle -> Bool
forall a. Eq a => a -> a -> Bool
== DrawStyle
DrawStyleBold
        then Attr
defAttr Attr -> Color -> Attr
`withForeColor` Color
fg Attr -> Color -> Attr
`withBackColor` Color
bg Attr -> Style -> Attr
`withStyle` Style
bold
        else Attr
defAttr Attr -> Color -> Attr
`withForeColor` Color
fg Attr -> Color -> Attr
`withBackColor` Color
bg

drawingNew :: MonadIO m => Int -> Int -> m Drawing
drawingNew :: Int -> Int -> m Drawing
drawingNew Int
width Int
height = do
    IOVector (IOVector Image)
dta <- IO (IOVector (IOVector Image)) -> m (IOVector (IOVector Image))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IOVector (IOVector Image)) -> m (IOVector (IOVector Image)))
-> IO (IOVector (IOVector Image)) -> m (IOVector (IOVector Image))
forall a b. (a -> b) -> a -> b
$ Int
-> IO (IOVector Image)
-> IO (MVector (PrimState IO) (IOVector Image))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m a -> m (MVector (PrimState m) a)
V.replicateM Int
height (IO (IOVector Image)
 -> IO (MVector (PrimState IO) (IOVector Image)))
-> IO (IOVector Image)
-> IO (MVector (PrimState IO) (IOVector Image))
forall a b. (a -> b) -> a -> b
$ Int -> IO Image -> IO (MVector (PrimState IO) Image)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m a -> m (MVector (PrimState m) a)
V.replicateM Int
width (Image -> IO Image
forall (m :: * -> *) a. Monad m => a -> m a
return (Image -> IO Image) -> Image -> IO Image
forall a b. (a -> b) -> a -> b
$ Attr -> Char -> Image
char Attr
defaultStyle Char
' ')
    Attribute Color
fg <- Color -> m (Attribute Color)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Color
white
    Attribute Color
bg <- Color -> m (Attribute Color)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Color
black
    Attribute DrawStyle
style <- DrawStyle -> m (Attribute DrawStyle)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew DrawStyle
DrawStyleNormal
    Drawing -> m Drawing
forall (m :: * -> *) a. Monad m => a -> m a
return Drawing :: IOVector (IOVector Image)
-> Int
-> Int
-> Attribute Color
-> Attribute Color
-> Attribute DrawStyle
-> Drawing
Drawing
        { drawingData :: IOVector (IOVector Image)
drawingData = IOVector (IOVector Image)
dta
        , drawingWidth :: Int
drawingWidth = Int
width
        , drawingHeight :: Int
drawingHeight = Int
height
        , drawingFgColor :: Attribute Color
drawingFgColor = Attribute Color
fg
        , drawingBgColor :: Attribute Color
drawingBgColor = Attribute Color
bg
        , drawingStyle :: Attribute DrawStyle
drawingStyle = Attribute DrawStyle
style
        }
  where
    defaultStyle :: Attr
defaultStyle = Color -> Color -> DrawStyle -> Attr
drawingStyleNew Color
white Color
black DrawStyle
DrawStyleNormal

drawingToImage :: MonadIO m => Drawing -> m Image
drawingToImage :: Drawing -> m Image
drawingToImage Drawing
drawing = do
    [Image]
rows <- IO [Image] -> m [Image]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Image] -> m [Image]) -> IO [Image] -> m [Image]
forall a b. (a -> b) -> a -> b
$ [Int] -> (Int -> IO Image) -> IO [Image]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO Image) -> IO [Image])
-> (Int -> IO Image) -> IO [Image]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
        IOVector Image
row <- MVector (PrimState IO) (IOVector Image)
-> Int -> IO (IOVector Image)
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
V.read (Drawing -> IOVector (IOVector Image)
drawingData Drawing
drawing) Int
i
        IOVector Image -> IO Image
mergeLine IOVector Image
row
    IO Image -> m Image
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Image -> m Image) -> IO Image -> m Image
forall a b. (a -> b) -> a -> b
$ [Image] -> IO Image
forall (t :: * -> *). Foldable t => t Image -> IO Image
mergeRows [Image]
rows
  where
    height :: Int
height = IOVector (IOVector Image) -> Int
forall s a. MVector s a -> Int
V.length (IOVector (IOVector Image) -> Int)
-> IOVector (IOVector Image) -> Int
forall a b. (a -> b) -> a -> b
$ Drawing -> IOVector (IOVector Image)
drawingData Drawing
drawing

    mergeLine :: IOVector Image -> IO Image
mergeLine IOVector Image
row = do
        let width :: Int
width = IOVector Image -> Int
forall s a. MVector s a -> Int
V.length IOVector Image
row
        IORef Image
image <- Image -> IO (IORef Image)
forall a. a -> IO (IORef a)
newIORef Image
emptyImage
        [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
            Image
c <- MVector (PrimState IO) Image -> Int -> IO Image
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
V.read IOVector Image
MVector (PrimState IO) Image
row Int
i
            IORef Image -> (Image -> Image) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Image
image (Image -> Image -> Image
<|> Image
c)
        IORef Image -> IO Image
forall a. IORef a -> IO a
readIORef IORef Image
image

    mergeRows :: t Image -> IO Image
mergeRows t Image
images = do
        IORef Image
image <- Image -> IO (IORef Image)
forall a. a -> IO (IORef a)
newIORef Image
emptyImage
        t Image -> (Image -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t Image
images ((Image -> IO ()) -> IO ()) -> (Image -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Image
i ->
            IORef Image -> (Image -> Image) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Image
image (Image -> Image -> Image
<-> Image
i)
        IORef Image -> IO Image
forall a. IORef a -> IO a
readIORef IORef Image
image

drawingToPicture :: MonadIO m => Drawing -> m Picture
drawingToPicture :: Drawing -> m Picture
drawingToPicture Drawing
drawing = (Image -> Picture) -> m Image -> m Picture
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Image -> Picture
picForImage (Drawing -> m Image
forall (m :: * -> *). MonadIO m => Drawing -> m Image
drawingToImage Drawing
drawing)

--

drawingRun :: MonadIO m => Drawing -> DrawingBuilder a -> m a
drawingRun :: Drawing -> DrawingBuilder a -> m a
drawingRun Drawing
drawing DrawingBuilder a
builder = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ DrawingBuilder a -> Drawing -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT DrawingBuilder a
builder Drawing
drawing

drawingGetWidth :: DrawingBuilder Int
drawingGetWidth :: DrawingBuilder Int
drawingGetWidth = (Drawing -> Int) -> DrawingBuilder Int
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Drawing -> Int
drawingWidth

drawingGetHeight :: DrawingBuilder Int
drawingGetHeight :: DrawingBuilder Int
drawingGetHeight = (Drawing -> Int) -> DrawingBuilder Int
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Drawing -> Int
drawingHeight

drawingGetSize :: DrawingBuilder (Int, Int)
drawingGetSize :: DrawingBuilder (Int, Int)
drawingGetSize = do
    Int
width <- DrawingBuilder Int
drawingGetWidth
    Int
height <- DrawingBuilder Int
drawingGetHeight
    (Int, Int) -> DrawingBuilder (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
width, Int
height)

drawingPutChar :: Int -> Int -> Char -> DrawingBuilder ()
drawingPutChar :: Int -> Int -> Char -> DrawingBuilder ()
drawingPutChar Int
x Int
y Char
c = do
    Drawing
drawing <- ReaderT Drawing IO Drawing
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Color
fg <- Drawing -> (Drawing -> Attribute Color) -> ReaderT Drawing IO Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Drawing
drawing Drawing -> Attribute Color
drawingFgColor
    Color
bg <- Drawing -> (Drawing -> Attribute Color) -> ReaderT Drawing IO Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Drawing
drawing Drawing -> Attribute Color
drawingBgColor
    DrawStyle
style <- Drawing
-> (Drawing -> Attribute DrawStyle) -> ReaderT Drawing IO DrawStyle
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Drawing
drawing Drawing -> Attribute DrawStyle
drawingStyle
    Color
-> Color -> DrawStyle -> Int -> Int -> Char -> DrawingBuilder ()
drawingPutCharWithAttr Color
fg Color
bg DrawStyle
style Int
x Int
y Char
c

drawingPutCharWithAttr :: Color -> Color -> DrawStyle -> Int -> Int -> Char -> DrawingBuilder ()
drawingPutCharWithAttr :: Color
-> Color -> DrawStyle -> Int -> Int -> Char -> DrawingBuilder ()
drawingPutCharWithAttr Color
fg Color
bg DrawStyle
style Int
x Int
y Char
c =
    Bool -> DrawingBuilder () -> DrawingBuilder ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (DrawingBuilder () -> DrawingBuilder ())
-> DrawingBuilder () -> DrawingBuilder ()
forall a b. (a -> b) -> a -> b
$ do
        Int
width <- DrawingBuilder Int
drawingGetWidth
        Int
height <- DrawingBuilder Int
drawingGetHeight
        Bool -> DrawingBuilder () -> DrawingBuilder ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
width Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
height) (DrawingBuilder () -> DrawingBuilder ())
-> DrawingBuilder () -> DrawingBuilder ()
forall a b. (a -> b) -> a -> b
$ do
            Drawing
drawing <- ReaderT Drawing IO Drawing
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
            IOVector Image
line <- MVector (PrimState (ReaderT Drawing IO)) (IOVector Image)
-> Int -> ReaderT Drawing IO (IOVector Image)
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
V.read (Drawing -> IOVector (IOVector Image)
drawingData Drawing
drawing) Int
y
            MVector (PrimState (ReaderT Drawing IO)) Image
-> Int -> Image -> DrawingBuilder ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
V.write IOVector Image
MVector (PrimState (ReaderT Drawing IO)) Image
line Int
x (Attr -> Char -> Image
char Attr
attr Char
c)
  where
    attr :: Attr
attr = Color -> Color -> DrawStyle -> Attr
drawingStyleNew Color
fg Color
bg DrawStyle
style

drawingPutString :: Int -> Int -> String -> DrawingBuilder ()
drawingPutString :: Int -> Int -> String -> DrawingBuilder ()
drawingPutString Int
x Int
y String
cs = do
    Drawing
drawing <- ReaderT Drawing IO Drawing
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Color
fg <- Drawing -> (Drawing -> Attribute Color) -> ReaderT Drawing IO Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Drawing
drawing Drawing -> Attribute Color
drawingFgColor
    Color
bg <- Drawing -> (Drawing -> Attribute Color) -> ReaderT Drawing IO Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Drawing
drawing Drawing -> Attribute Color
drawingBgColor
    DrawStyle
style <- Drawing
-> (Drawing -> Attribute DrawStyle) -> ReaderT Drawing IO DrawStyle
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Drawing
drawing Drawing -> Attribute DrawStyle
drawingStyle
    Color
-> Color -> DrawStyle -> Int -> Int -> String -> DrawingBuilder ()
drawingPutStringWithAttr Color
fg Color
bg DrawStyle
style Int
x Int
y String
cs

drawingPutStringWithAttr :: Color -> Color -> DrawStyle -> Int -> Int -> String -> DrawingBuilder ()
drawingPutStringWithAttr :: Color
-> Color -> DrawStyle -> Int -> Int -> String -> DrawingBuilder ()
drawingPutStringWithAttr Color
_ Color
_ DrawStyle
_ Int
_ Int
_ [] = () -> DrawingBuilder ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawingPutStringWithAttr Color
fg Color
bg DrawStyle
style Int
x Int
y (Char
c:String
cs) = do
    Color
-> Color -> DrawStyle -> Int -> Int -> Char -> DrawingBuilder ()
drawingPutCharWithAttr Color
fg Color
bg DrawStyle
style Int
x Int
y Char
c
    Color
-> Color -> DrawStyle -> Int -> Int -> String -> DrawingBuilder ()
drawingPutStringWithAttr Color
fg Color
bg DrawStyle
style (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
y String
cs

drawingSetAttrs :: Color -> Color -> DrawStyle -> DrawingBuilder ()
drawingSetAttrs :: Color -> Color -> DrawStyle -> DrawingBuilder ()
drawingSetAttrs Color
fg Color
bg DrawStyle
style = do
    Drawing
drawing <- ReaderT Drawing IO Drawing
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Drawing
-> (Drawing -> Attribute Color) -> Color -> DrawingBuilder ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> a -> m ()
set Drawing
drawing Drawing -> Attribute Color
drawingFgColor Color
fg
    Drawing
-> (Drawing -> Attribute Color) -> Color -> DrawingBuilder ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> a -> m ()
set Drawing
drawing Drawing -> Attribute Color
drawingBgColor Color
bg
    Drawing
-> (Drawing -> Attribute DrawStyle)
-> DrawStyle
-> DrawingBuilder ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> a -> m ()
set Drawing
drawing Drawing -> Attribute DrawStyle
drawingStyle DrawStyle
style

drawingClear :: DrawingBuilder ()
drawingClear :: DrawingBuilder ()
drawingClear = do
    Drawing
drawing <- ReaderT Drawing IO Drawing
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Color
fg <- Drawing -> (Drawing -> Attribute Color) -> ReaderT Drawing IO Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Drawing
drawing Drawing -> Attribute Color
drawingFgColor
    Color
bg <- Drawing -> (Drawing -> Attribute Color) -> ReaderT Drawing IO Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Drawing
drawing Drawing -> Attribute Color
drawingBgColor
    DrawStyle
style <- Drawing
-> (Drawing -> Attribute DrawStyle) -> ReaderT Drawing IO DrawStyle
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Drawing
drawing Drawing -> Attribute DrawStyle
drawingStyle
    Color -> Color -> DrawStyle -> DrawingBuilder ()
drawingClearWithAttr Color
fg Color
bg DrawStyle
style

drawingClearWithAttr :: Color -> Color -> DrawStyle -> DrawingBuilder ()
drawingClearWithAttr :: Color -> Color -> DrawStyle -> DrawingBuilder ()
drawingClearWithAttr Color
fg Color
bg DrawStyle
style = do
    Int
width  <- DrawingBuilder Int
drawingGetWidth
    Int
height <- DrawingBuilder Int
drawingGetHeight
    [Int] -> (Int -> DrawingBuilder ()) -> DrawingBuilder ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> DrawingBuilder ()) -> DrawingBuilder ())
-> (Int -> DrawingBuilder ()) -> DrawingBuilder ()
forall a b. (a -> b) -> a -> b
$ \Int
y ->
        [Int] -> (Int -> DrawingBuilder ()) -> DrawingBuilder ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> DrawingBuilder ()) -> DrawingBuilder ())
-> (Int -> DrawingBuilder ()) -> DrawingBuilder ()
forall a b. (a -> b) -> a -> b
$ \Int
x ->
            Color
-> Color -> DrawStyle -> Int -> Int -> Char -> DrawingBuilder ()
drawingPutCharWithAttr Color
fg Color
bg DrawStyle
style Int
x Int
y Char
' '

drawingSlice :: Int -> Int -> Int -> Int -> DrawingBuilder Drawing
drawingSlice :: Int -> Int -> Int -> Int -> ReaderT Drawing IO Drawing
drawingSlice Int
x Int
y Int
width Int
height = do
    let x' :: Int
x' = if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Int
0 else Int
x
    let y' :: Int
y' = if Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Int
0 else Int
y

    Int
origWidth  <- (Drawing -> Int) -> DrawingBuilder Int
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Drawing -> Int
drawingWidth
    Int
origHeight <- (Drawing -> Int) -> DrawingBuilder Int
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Drawing -> Int
drawingHeight
    IOVector (IOVector Image)
origDrawing <- (Drawing -> IOVector (IOVector Image))
-> ReaderT Drawing IO (IOVector (IOVector Image))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Drawing -> IOVector (IOVector Image)
drawingData

    let width' :: Int
width' = if Int
x' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
origWidth then Int
origWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x' else Int
width
    let height' :: Int
height' = if Int
y' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
origHeight then Int
origHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y' else Int
height

    IORef Int
h <- IO (IORef Int) -> ReaderT Drawing IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> ReaderT Drawing IO (IORef Int))
-> IO (IORef Int) -> ReaderT Drawing IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
y'
    IOVector (IOVector Image)
drawing <- IO (IOVector (IOVector Image))
-> ReaderT Drawing IO (IOVector (IOVector Image))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IOVector (IOVector Image))
 -> ReaderT Drawing IO (IOVector (IOVector Image)))
-> IO (IOVector (IOVector Image))
-> ReaderT Drawing IO (IOVector (IOVector Image))
forall a b. (a -> b) -> a -> b
$ Int
-> IO (IOVector Image)
-> IO (MVector (PrimState IO) (IOVector Image))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m a -> m (MVector (PrimState m) a)
V.replicateM Int
height' (IO (IOVector Image)
 -> IO (MVector (PrimState IO) (IOVector Image)))
-> IO (IOVector Image)
-> IO (MVector (PrimState IO) (IOVector Image))
forall a b. (a -> b) -> a -> b
$ do
        Int
h' <- IORef Int -> IO Int
forall b. Num b => IORef b -> IO b
increment IORef Int
h
        IOVector Image
line <- MVector (PrimState IO) (IOVector Image)
-> Int -> IO (IOVector Image)
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
V.read IOVector (IOVector Image)
MVector (PrimState IO) (IOVector Image)
origDrawing Int
h'
        IOVector Image -> IO (IOVector Image)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> IOVector Image -> IOVector Image
forall s a. Int -> Int -> MVector s a -> MVector s a
V.slice Int
x' Int
width' IOVector Image
line)

    Attribute Color
fg <- Color -> ReaderT Drawing IO (Attribute Color)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Color
white
    Attribute Color
bg <- Color -> ReaderT Drawing IO (Attribute Color)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Color
black
    Attribute DrawStyle
style <- DrawStyle -> ReaderT Drawing IO (Attribute DrawStyle)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew DrawStyle
DrawStyleNormal
    Drawing -> ReaderT Drawing IO Drawing
forall (m :: * -> *) a. Monad m => a -> m a
return Drawing :: IOVector (IOVector Image)
-> Int
-> Int
-> Attribute Color
-> Attribute Color
-> Attribute DrawStyle
-> Drawing
Drawing
        { drawingData :: IOVector (IOVector Image)
drawingData = IOVector (IOVector Image)
drawing
        , drawingWidth :: Int
drawingWidth = Int
width'
        , drawingHeight :: Int
drawingHeight = Int
height'
        , drawingFgColor :: Attribute Color
drawingFgColor = Attribute Color
fg
        , drawingBgColor :: Attribute Color
drawingBgColor = Attribute Color
bg
        , drawingStyle :: Attribute DrawStyle
drawingStyle = Attribute DrawStyle
style
        }
  where
    increment :: IORef b -> IO b
increment IORef b
ref = do
        b
i <- IORef b -> IO b
forall a. IORef a -> IO a
readIORef IORef b
ref
        IORef b -> (b -> b) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef b
ref (b -> b -> b
forall a. Num a => a -> a -> a
+b
1)
        b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
i

drawingSliceNew :: MonadIO m => Drawing -> Int -> Int -> Int -> Int -> m Drawing
drawingSliceNew :: Drawing -> Int -> Int -> Int -> Int -> m Drawing
drawingSliceNew Drawing
drawing Int
x Int
y Int
width Int
height = Drawing -> ReaderT Drawing IO Drawing -> m Drawing
forall (m :: * -> *) a.
MonadIO m =>
Drawing -> DrawingBuilder a -> m a
drawingRun Drawing
drawing (ReaderT Drawing IO Drawing -> m Drawing)
-> ReaderT Drawing IO Drawing -> m Drawing
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> ReaderT Drawing IO Drawing
drawingSlice Int
x Int
y Int
width Int
height