-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Transforms an image into rows of operations.
module Graphics.Vty.PictureToSpans where

import Graphics.Vty.Attributes (Attr, currentAttr)
import Graphics.Vty.Image
import Graphics.Vty.Image.Internal
import Graphics.Vty.Picture
import Graphics.Vty.Span

import Lens.Micro
import Lens.Micro.Mtl
import Lens.Micro.TH
import Control.Monad.Reader
import Control.Monad.State.Strict hiding ( state )
import Control.Monad.ST.Strict

import qualified Data.Vector as Vector hiding ( take, replicate )
import Data.Vector.Mutable ( MVector(..))
import qualified Data.Vector.Mutable as MVector

import qualified Data.Text.Lazy as TL

type MRowOps s = MVector s SpanOps

type MSpanOps s = MVector s SpanOp

-- transform plus clip. More or less.
data BlitState = BlitState
    -- we always snoc to the operation vectors. Thus the columnOffset =
    -- length of row at rowOffset although, one possibility is to merge
    -- layers right in snocOp (naming it something else, of course). In
    -- which case columnnOffset would be applicable. Right now we need
    -- it to exist.
    { BlitState -> Int
_columnOffset :: Int
    , BlitState -> Int
_rowOffset :: Int
    -- clip coordinate space is in image space. Which means it's >= 0
    -- and < imageWidth.
    , BlitState -> Int
_skipColumns :: Int
    -- >= 0 and < imageHeight
    , BlitState -> Int
_skipRows :: Int
    -- includes consideration of skipColumns. In display space. The
    -- number of columns from the next column to be defined to the end
    -- of the display for the row.
    , BlitState -> Int
_remainingColumns :: Int
    -- includes consideration of skipRows. In display space.
    , BlitState -> Int
_remainingRows :: Int
    }

makeLenses ''BlitState

data BlitEnv s = BlitEnv
    { forall s. BlitEnv s -> DisplayRegion
_region :: DisplayRegion
    , forall s. BlitEnv s -> MRowOps s
_mrowOps :: MRowOps s
    }

makeLenses ''BlitEnv

type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a

-- | Produces the span ops that will render the given picture, possibly
-- cropped or padded, into the specified region.
displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps
displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps
displayOpsForPic Picture
pic DisplayRegion
r = forall a. (forall s. ST s (MVector s a)) -> Vector a
Vector.create (forall s. Picture -> DisplayRegion -> ST s (MRowOps s)
combinedOpsForLayers Picture
pic DisplayRegion
r)

-- | Returns the DisplayOps for an image rendered to a window the size
-- of the image.
--
-- largely used only for debugging.
displayOpsForImage :: Image -> DisplayOps
displayOpsForImage :: Image -> DisplayOps
displayOpsForImage Image
i = Picture -> DisplayRegion -> DisplayOps
displayOpsForPic (Image -> Picture
picForImage Image
i) (Image -> Int
imageWidth Image
i, Image -> Int
imageHeight Image
i)

-- | Produces the span ops for each layer then combines them.
combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
combinedOpsForLayers :: forall s. Picture -> DisplayRegion -> ST s (MRowOps s)
combinedOpsForLayers Picture
pic DisplayRegion
r
    | DisplayRegion -> Int
regionWidth DisplayRegion
r forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| DisplayRegion -> Int
regionHeight DisplayRegion
r forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MVector.new Int
0
    | Bool
otherwise = do
        [MRowOps s]
layerOps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall s. Image -> DisplayRegion -> ST s (MRowOps s)
`buildSpans` DisplayRegion
r) (Picture -> [Image]
picLayers Picture
pic)
        case [MRowOps s]
layerOps of
            []    -> forall a. HasCallStack => [Char] -> a
error [Char]
"empty picture"
            [MRowOps s
ops] -> forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips (Picture -> Background
picBackground Picture
pic) MRowOps s
ops
            -- instead of merging ops after generation the merging can
            -- be performed as part of snocOp.
            MRowOps s
topOps : [MRowOps s]
lowerOps -> do
                MRowOps s
ops <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall s. MRowOps s -> MRowOps s -> ST s (MRowOps s)
mergeUnder MRowOps s
topOps [MRowOps s]
lowerOps
                forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips (Picture -> Background
picBackground Picture
pic) MRowOps s
ops

substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips :: forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips Background
ClearBackground MRowOps s
ops = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. forall s a. MVector s a -> Int
MVector.length MRowOps s
ops forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
row -> do
        SpanOps
rowOps <- forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
ops Int
row
        -- the image operations assure that background fills are
        -- combined. clipping a background fill does not split the
        -- background fill. merging of image layers can split a skip,
        -- but only by the insertion of a non skip. all this combines to
        -- mean we can check the last operation and remove it if it's a
        -- skip
        let rowOps' :: SpanOps
rowOps' = case forall a. Vector a -> a
Vector.last SpanOps
rowOps of
                        Skip Int
w -> forall a. Vector a -> Vector a
Vector.init SpanOps
rowOps forall a. Vector a -> a -> Vector a
`Vector.snoc` Int -> SpanOp
RowEnd Int
w
                        SpanOp
_      -> SpanOps
rowOps
        -- now all the skips can be replaced by replications of ' ' of
        -- the required width.
        let rowOps'' :: SpanOps
rowOps'' = Char -> Attr -> SpanOps -> SpanOps
swapSkipsForSingleColumnCharSpan Char
' ' Attr
currentAttr SpanOps
rowOps'
        forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
ops Int
row SpanOps
rowOps''
    forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
ops
substituteSkips (Background {Char
backgroundChar :: Background -> Char
backgroundChar :: Char
backgroundChar, Attr
backgroundAttr :: Background -> Attr
backgroundAttr :: Attr
backgroundAttr}) MRowOps s
ops = do
    -- At this point we decide if the background character is single
    -- column or not. obviously, single column is easier.
    case Char -> Int
safeWcwidth Char
backgroundChar of
        Int
w | Int
w forall a. Eq a => a -> a -> Bool
== Int
0 -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"invalid background character " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Char
backgroundChar
          | Int
w forall a. Eq a => a -> a -> Bool
== Int
1 -> do
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. forall s a. MVector s a -> Int
MVector.length MRowOps s
ops forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
row -> do
                    SpanOps
rowOps <- forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
ops Int
row
                    let rowOps' :: SpanOps
rowOps' = Char -> Attr -> SpanOps -> SpanOps
swapSkipsForSingleColumnCharSpan Char
backgroundChar Attr
backgroundAttr SpanOps
rowOps
                    forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
ops Int
row SpanOps
rowOps'
          | Bool
otherwise -> do
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. forall s a. MVector s a -> Int
MVector.length MRowOps s
ops forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
row -> do
                    SpanOps
rowOps <- forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
ops Int
row
                    let rowOps' :: SpanOps
rowOps' = Int -> Char -> Attr -> SpanOps -> SpanOps
swapSkipsForCharSpan Int
w Char
backgroundChar Attr
backgroundAttr SpanOps
rowOps
                    forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
ops Int
row SpanOps
rowOps'
    forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
ops

mergeUnder :: MRowOps s -> MRowOps s -> ST s (MRowOps s)
mergeUnder :: forall s. MRowOps s -> MRowOps s -> ST s (MRowOps s)
mergeUnder MRowOps s
upper MRowOps s
lower = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. forall s a. MVector s a -> Int
MVector.length MRowOps s
upper forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
row -> do
        SpanOps
upperRowOps <- forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
upper Int
row
        SpanOps
lowerRowOps <- forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
lower Int
row
        let rowOps :: SpanOps
rowOps = SpanOps -> SpanOps -> SpanOps
mergeRowUnder SpanOps
upperRowOps SpanOps
lowerRowOps
        forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
upper Int
row SpanOps
rowOps
    forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
upper

mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
mergeRowUnder SpanOps
upperRowOps =
    SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp forall a. Vector a
Vector.empty (forall a. Vector a -> a
Vector.head SpanOps
upperRowOps) (forall a. Vector a -> Vector a
Vector.tail SpanOps
upperRowOps)
    where
        -- H: it will never be the case that we are out of upper ops
        -- before lower ops.
        onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
        onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
outOps op :: SpanOp
op@(TextSpan Attr
_ Int
w Int
_ DisplayText
_) SpanOps
upperOps SpanOps
lowerOps =
            let lowerOps' :: SpanOps
lowerOps' = Int -> SpanOps -> SpanOps
dropOps Int
w SpanOps
lowerOps
                outOps' :: SpanOps
outOps' = forall a. Vector a -> a -> Vector a
Vector.snoc SpanOps
outOps SpanOp
op
            in if forall a. Vector a -> Bool
Vector.null SpanOps
lowerOps'
                then SpanOps
outOps'
                else SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
outOps' (forall a. Vector a -> a
Vector.head SpanOps
upperOps) (forall a. Vector a -> Vector a
Vector.tail SpanOps
upperOps) SpanOps
lowerOps'
        onUpperOp SpanOps
outOps (Skip Int
w) SpanOps
upperOps SpanOps
lowerOps =
            let (SpanOps
ops', SpanOps
lowerOps') = Int -> SpanOps -> (SpanOps, SpanOps)
splitOpsAt Int
w SpanOps
lowerOps
                outOps' :: SpanOps
outOps' = SpanOps
outOps forall a. Monoid a => a -> a -> a
`mappend` SpanOps
ops'
            in if forall a. Vector a -> Bool
Vector.null SpanOps
lowerOps'
                then SpanOps
outOps'
                else SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
outOps' (forall a. Vector a -> a
Vector.head SpanOps
upperOps) (forall a. Vector a -> Vector a
Vector.tail SpanOps
upperOps) SpanOps
lowerOps'
        onUpperOp SpanOps
_ (RowEnd Int
_) SpanOps
_ SpanOps
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot merge rows containing RowEnd ops"


swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps
swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps
swapSkipsForSingleColumnCharSpan Char
c Attr
a = forall a b. (a -> b) -> Vector a -> Vector b
Vector.map SpanOp -> SpanOp
f
    where f :: SpanOp -> SpanOp
f (Skip Int
ow) = let txt :: DisplayText
txt = [Char] -> DisplayText
TL.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
ow Char
c
                        in Attr -> Int -> Int -> DisplayText -> SpanOp
TextSpan Attr
a Int
ow Int
ow DisplayText
txt
          f SpanOp
v = SpanOp
v

swapSkipsForCharSpan :: Int -> Char -> Attr -> SpanOps -> SpanOps
swapSkipsForCharSpan :: Int -> Char -> Attr -> SpanOps -> SpanOps
swapSkipsForCharSpan Int
w Char
c Attr
a = forall a b. (a -> b) -> Vector a -> Vector b
Vector.map SpanOp -> SpanOp
f
    where
        f :: SpanOp -> SpanOp
f (Skip Int
ow) = let txt0Cw :: Int
txt0Cw = Int
ow forall a. Integral a => a -> a -> a
`div` Int
w
                          txt0 :: DisplayText
txt0 = [Char] -> DisplayText
TL.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
txt0Cw Char
c
                          txt1Cw :: Int
txt1Cw = Int
ow forall a. Integral a => a -> a -> a
`mod` Int
w
                          txt1 :: DisplayText
txt1 = [Char] -> DisplayText
TL.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
txt1Cw Char
'…'
                          cw :: Int
cw = Int
txt0Cw forall a. Num a => a -> a -> a
+ Int
txt1Cw
                          txt :: DisplayText
txt = DisplayText
txt0 DisplayText -> DisplayText -> DisplayText
`TL.append` DisplayText
txt1
                      in Attr -> Int -> Int -> DisplayText -> SpanOp
TextSpan Attr
a Int
ow Int
cw DisplayText
txt
        f SpanOp
v = SpanOp
v

-- | Builds a vector of row operations that will output the given
-- picture to the terminal.
--
-- Crops to the given display region.
buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
buildSpans :: forall s. Image -> DisplayRegion -> ST s (MRowOps s)
buildSpans Image
image DisplayRegion
outRegion = do
    -- First we create a mutable vector for each rows output operations.
    MRowOps s
outOps <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MVector.replicate (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion) forall a. Vector a
Vector.empty
    -- It's possible that building the span operations in display order
    -- would provide better performance.
    --
    -- A depth first traversal of the image is performed. ordered
    -- according to the column range defined by the image from least
    -- to greatest. The output row ops will at least have the region
    -- of the image specified. Iterate over all output rows and output
    -- background fills for all unspecified columns.
    --
    -- The images are made into span operations from left to right. It's
    -- possible that this could easily be made to assure top to bottom
    -- output as well.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& DisplayRegion -> Int
regionWidth DisplayRegion
outRegion forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ do
        -- The ops builder recursively descends the image and outputs
        -- span ops that would display that image. The number of columns
        -- remaining in this row before exceeding the bounds is also
        -- provided. This is used to clip the span ops produced to the
        -- display.
        let fullBuild :: ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
fullBuild = do
                forall s. Image -> BlitM s ()
startImageBuild Image
image
                -- Fill in any unspecified columns with a skip.
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion forall a. Num a => a -> a -> a
- Int
1)] (forall s. DisplayRegion -> Int -> BlitM s ()
addRowCompletion DisplayRegion
outRegion)
            initEnv :: BlitEnv s
initEnv   = forall s. DisplayRegion -> MRowOps s -> BlitEnv s
BlitEnv DisplayRegion
outRegion MRowOps s
outOps
            initState :: BlitState
initState = Int -> Int -> Int -> Int -> Int -> Int -> BlitState
BlitState Int
0 Int
0 Int
0 Int
0 (DisplayRegion -> Int
regionWidth DisplayRegion
outRegion) (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion)
        ((), BlitState)
_ <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall {s}. ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
fullBuild BlitEnv s
initEnv) BlitState
initState
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
outOps

-- | Add the operations required to build a given image to the current
-- set of row operations.
startImageBuild :: Image -> BlitM s ()
startImageBuild :: forall s. Image -> BlitM s ()
startImageBuild Image
image = do
    Bool
outOfBounds <- Image -> BlitState -> Bool
isOutOfBounds Image
image forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
outOfBounds) forall a b. (a -> b) -> a -> b
$ forall s. Image -> BlitM s ()
addMaybeClipped Image
image

isOutOfBounds :: Image -> BlitState -> Bool
isOutOfBounds :: Image -> BlitState -> Bool
isOutOfBounds Image
i BlitState
s
    | BlitState
s forall s a. s -> Getting a s a -> a
^. Lens' BlitState Int
remainingColumns forall a. Ord a => a -> a -> Bool
<= Int
0              = Bool
True
    | BlitState
s forall s a. s -> Getting a s a -> a
^. Lens' BlitState Int
remainingRows    forall a. Ord a => a -> a -> Bool
<= Int
0              = Bool
True
    | BlitState
s forall s a. s -> Getting a s a -> a
^. Lens' BlitState Int
skipColumns      forall a. Ord a => a -> a -> Bool
>= Image -> Int
imageWidth Image
i  = Bool
True
    | BlitState
s forall s a. s -> Getting a s a -> a
^. Lens' BlitState Int
skipRows         forall a. Ord a => a -> a -> Bool
>= Image -> Int
imageHeight Image
i = Bool
True
    | Bool
otherwise = Bool
False

-- | This adds an image that might be partially clipped to the output
-- ops.
--
-- This is a very touchy algorithm. Too touchy. For instance, the
-- CropRight and CropBottom implementations are odd. They pass the
-- current tests but something seems terribly wrong about all this.
addMaybeClipped :: forall s . Image -> BlitM s ()
addMaybeClipped :: forall s. Image -> BlitM s ()
addMaybeClipped Image
EmptyImage = forall (m :: * -> *) a. Monad m => a -> m a
return ()
addMaybeClipped (HorizText Attr
a DisplayText
textStr Int
ow Int
_cw) = do
    -- This assumes that text spans are only 1 row high.
    Int
s <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
skipRows
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
s forall a. Ord a => a -> a -> Bool
< Int
1) forall a b. (a -> b) -> a -> b
$ do
        Int
leftClip <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
skipColumns
        Int
rightClip <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
remainingColumns
        let leftClipped :: Bool
leftClipped = Int
leftClip forall a. Ord a => a -> a -> Bool
> Int
0
            rightClipped :: Bool
rightClipped = (Int
ow forall a. Num a => a -> a -> a
- Int
leftClip) forall a. Ord a => a -> a -> Bool
> Int
rightClip
        if Bool
leftClipped Bool -> Bool -> Bool
|| Bool
rightClipped
            then let textStr' :: DisplayText
textStr' = DisplayText -> Int -> Int -> DisplayText
clipText DisplayText
textStr Int
leftClip Int
rightClip
                 in forall s. Attr -> DisplayText -> BlitM s ()
addUnclippedText Attr
a DisplayText
textStr'
            else forall s. Attr -> DisplayText -> BlitM s ()
addUnclippedText Attr
a DisplayText
textStr
addMaybeClipped (VertJoin Image
topImage Image
bottomImage Int
_ow Int
oh) = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Image -> Int
imageHeight Image
topImage forall a. Num a => a -> a -> a
+ Image -> Int
imageHeight Image
bottomImage forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        forall s.
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin [Char]
"vert_join" Lens' BlitState Int
skipRows Lens' BlitState Int
remainingRows Lens' BlitState Int
rowOffset
                            (Image -> Int
imageHeight Image
topImage)
                            Image
topImage
                            Image
bottomImage
                            Int
oh
addMaybeClipped (HorizJoin Image
leftImage Image
rightImage Int
ow Int
_oh) = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Image -> Int
imageWidth Image
leftImage forall a. Num a => a -> a -> a
+ Image -> Int
imageWidth Image
rightImage forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        forall s.
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin [Char]
"horiz_join" Lens' BlitState Int
skipColumns Lens' BlitState Int
remainingColumns Lens' BlitState Int
columnOffset
                            (Image -> Int
imageWidth Image
leftImage)
                            Image
leftImage
                            Image
rightImage
                            Int
ow
addMaybeClipped BGFill {Int
outputWidth :: Image -> Int
outputWidth :: Int
outputWidth, Int
outputHeight :: Image -> Int
outputHeight :: Int
outputHeight} = do
    BlitState
s <- forall s (m :: * -> *). MonadState s m => m s
get
    let outputWidth' :: Int
outputWidth'  = forall a. Ord a => a -> a -> a
min (Int
outputWidth  forall a. Num a => a -> a -> a
- BlitState
sforall s a. s -> Getting a s a -> a
^.Lens' BlitState Int
skipColumns) (BlitState
sforall s a. s -> Getting a s a -> a
^.Lens' BlitState Int
remainingColumns)
        outputHeight' :: Int
outputHeight' = forall a. Ord a => a -> a -> a
min (Int
outputHeight forall a. Num a => a -> a -> a
- BlitState
sforall s a. s -> Getting a s a -> a
^.Lens' BlitState Int
skipRows   ) (BlitState
sforall s a. s -> Getting a s a -> a
^.Lens' BlitState Int
remainingRows)
    Int
y <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
rowOffset
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
y..Int
yforall a. Num a => a -> a -> a
+Int
outputHeight'forall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ forall s. SpanOp -> Int -> BlitM s ()
snocOp (Int -> SpanOp
Skip Int
outputWidth')
addMaybeClipped CropRight {Image
croppedImage :: Image -> Image
croppedImage :: Image
croppedImage, Int
outputWidth :: Int
outputWidth :: Image -> Int
outputWidth} = do
    Int
s <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
skipColumns
    Int
r <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
remainingColumns
    let x :: Int
x = Int
outputWidth forall a. Num a => a -> a -> a
- Int
s
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x forall a. Ord a => a -> a -> Bool
< Int
r) forall a b. (a -> b) -> a -> b
$ Lens' BlitState Int
remainingColumns forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int
x
    forall s. Image -> BlitM s ()
addMaybeClipped Image
croppedImage
addMaybeClipped CropLeft {Image
croppedImage :: Image
croppedImage :: Image -> Image
croppedImage, Int
leftSkip :: Image -> Int
leftSkip :: Int
leftSkip} = do
    Lens' BlitState Int
skipColumns forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
leftSkip
    forall s. Image -> BlitM s ()
addMaybeClipped Image
croppedImage
addMaybeClipped CropBottom {Image
croppedImage :: Image
croppedImage :: Image -> Image
croppedImage, Int
outputHeight :: Int
outputHeight :: Image -> Int
outputHeight} = do
    Int
s <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
skipRows
    Int
r <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
remainingRows
    let x :: Int
x = Int
outputHeight forall a. Num a => a -> a -> a
- Int
s
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x forall a. Ord a => a -> a -> Bool
< Int
r) forall a b. (a -> b) -> a -> b
$ Lens' BlitState Int
remainingRows forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int
x
    forall s. Image -> BlitM s ()
addMaybeClipped Image
croppedImage
addMaybeClipped CropTop {Image
croppedImage :: Image
croppedImage :: Image -> Image
croppedImage, Int
topSkip :: Image -> Int
topSkip :: Int
topSkip} = do
    Lens' BlitState Int
skipRows forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
topSkip
    forall s. Image -> BlitM s ()
addMaybeClipped Image
croppedImage

addMaybeClippedJoin :: forall s . String
                       -> Lens BlitState BlitState Int Int
                       -> Lens BlitState BlitState Int Int
                       -> Lens BlitState BlitState Int Int
                       -> Int
                       -> Image
                       -> Image
                       -> Int
                       -> BlitM s ()
addMaybeClippedJoin :: forall s.
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin [Char]
name Lens' BlitState Int
skip Lens' BlitState Int
remaining Lens' BlitState Int
offset Int
i0Dim Image
i0 Image
i1 Int
size = do
    BlitState
state <- forall s (m :: * -> *). MonadState s m => m s
get
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlitState
stateforall s a. s -> Getting a s a -> a
^.Lens' BlitState Int
remaining forall a. Ord a => a -> a -> Bool
<= Int
0) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" with remaining <= 0"
    case BlitState
stateforall s a. s -> Getting a s a -> a
^.Lens' BlitState Int
skip of
        Int
s | Int
s forall a. Ord a => a -> a -> Bool
> Int
size -> forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ BlitState
state forall a b. a -> (a -> b) -> b
& Lens' BlitState Int
skip forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Num a => a -> a -> a
subtract Int
size
          | Int
s forall a. Eq a => a -> a -> Bool
== Int
0    -> if BlitState
stateforall s a. s -> Getting a s a -> a
^.Lens' BlitState Int
remaining forall a. Ord a => a -> a -> Bool
> Int
i0Dim
                            then do
                                forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
                                forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ BlitState
state forall a b. a -> (a -> b) -> b
& Lens' BlitState Int
offset forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
+ Int
i0Dim) forall a b. a -> (a -> b) -> b
& Lens' BlitState Int
remaining forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Num a => a -> a -> a
subtract Int
i0Dim
                                forall s. Image -> BlitM s ()
addMaybeClipped Image
i1
                            else forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
          | Int
s forall a. Ord a => a -> a -> Bool
< Int
i0Dim  ->
                let i0Dim' :: Int
i0Dim' = Int
i0Dim forall a. Num a => a -> a -> a
- Int
s
                in if BlitState
stateforall s a. s -> Getting a s a -> a
^.Lens' BlitState Int
remaining forall a. Ord a => a -> a -> Bool
<= Int
i0Dim'
                    then forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
                    else do
                        forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
                        forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ BlitState
state forall a b. a -> (a -> b) -> b
& Lens' BlitState Int
offset forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
+ Int
i0Dim') forall a b. a -> (a -> b) -> b
& Lens' BlitState Int
remaining forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Num a => a -> a -> a
subtract Int
i0Dim' forall a b. a -> (a -> b) -> b
& Lens' BlitState Int
skip forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
0
                        forall s. Image -> BlitM s ()
addMaybeClipped Image
i1
          | Int
s forall a. Ord a => a -> a -> Bool
>= Int
i0Dim -> do
                forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ BlitState
state forall a b. a -> (a -> b) -> b
& Lens' BlitState Int
skip forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Num a => a -> a -> a
subtract Int
i0Dim
                forall s. Image -> BlitM s ()
addMaybeClipped Image
i1
        Int
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" has unhandled skip class"

addUnclippedText :: Attr -> DisplayText -> BlitM s ()
addUnclippedText :: forall s. Attr -> DisplayText -> BlitM s ()
addUnclippedText Attr
a DisplayText
txt = do
    let op :: SpanOp
op = Attr -> Int -> Int -> DisplayText -> SpanOp
TextSpan Attr
a Int
usedDisplayColumns
                      (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ DisplayText -> Int64
TL.length DisplayText
txt)
                      DisplayText
txt
        usedDisplayColumns :: Int
usedDisplayColumns = DisplayText -> Int
wctlwidth DisplayText
txt
    forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
rowOffset forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s. SpanOp -> Int -> BlitM s ()
snocOp SpanOp
op

addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
addRowCompletion :: forall s. DisplayRegion -> Int -> BlitM s ()
addRowCompletion DisplayRegion
displayRegion Int
row = do
    MRowOps s
allRowOps <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s s. Lens (BlitEnv s) (BlitEnv s) (MRowOps s) (MRowOps s)
mrowOps
    SpanOps
rowOps <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
allRowOps Int
row
    let endX :: Int
endX = SpanOps -> Int
spanOpsAffectedColumns SpanOps
rowOps
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
endX forall a. Ord a => a -> a -> Bool
< DisplayRegion -> Int
regionWidth DisplayRegion
displayRegion) forall a b. (a -> b) -> a -> b
$ do
        let ow :: Int
ow = DisplayRegion -> Int
regionWidth DisplayRegion
displayRegion forall a. Num a => a -> a -> a
- Int
endX
        forall s. SpanOp -> Int -> BlitM s ()
snocOp (Int -> SpanOp
Skip Int
ow) Int
row

-- | snocs the operation to the operations for the given row.
snocOp :: SpanOp -> Int -> BlitM s ()
snocOp :: forall s. SpanOp -> Int -> BlitM s ()
snocOp !SpanOp
op !Int
row = do
    MRowOps s
theMrowOps <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s s. Lens (BlitEnv s) (BlitEnv s) (MRowOps s) (MRowOps s)
mrowOps
    DisplayRegion
theRegion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. Lens' (BlitEnv s) DisplayRegion
region
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
        SpanOps
ops <- forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
theMrowOps Int
row
        let ops' :: SpanOps
ops' = forall a. Vector a -> a -> Vector a
Vector.snoc SpanOps
ops SpanOp
op
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SpanOps -> Int
spanOpsAffectedColumns SpanOps
ops' forall a. Ord a => a -> a -> Bool
> DisplayRegion -> Int
regionWidth DisplayRegion
theRegion)
             forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"row " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
row forall a. [a] -> [a] -> [a]
++ [Char]
" now exceeds region width"
        forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
theMrowOps Int
row SpanOps
ops'