-- 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
  ( displayOpsForPic
  )
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
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

-- 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)

-- | 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
_ Text
_) 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 :: Text
txt = [Char] -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
ow Char
c
                        in Attr -> Int -> Int -> Text -> SpanOp
TextSpan Attr
a Int
ow Int
ow Text
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 :: Text
txt0 = [Char] -> Text
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 :: Text
txt1 = [Char] -> Text
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 :: Text
txt = Text
txt0 Text -> Text -> Text
`TL.append` Text
txt1
                      in Attr -> Int -> Int -> Text -> SpanOp
TextSpan Attr
a Int
ow Int
cw Text
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
-- Crop implementations is 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 Text
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' :: Text
textStr' = Text -> Int -> Int -> Text
clipText Text
textStr Int
leftClip Int
rightClip
                 in forall s. Attr -> Text -> BlitM s ()
addUnclippedText Attr
a Text
textStr'
            else forall s. Attr -> Text -> BlitM s ()
addUnclippedText Attr
a Text
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 Crop {Image
croppedImage :: Image -> Image
croppedImage :: Image
croppedImage, Int
leftSkip :: Image -> Int
leftSkip :: Int
leftSkip, Int
topSkip :: Image -> Int
topSkip :: Int
topSkip, Int
outputWidth :: Int
outputWidth :: Image -> Int
outputWidth, Int
outputHeight :: Int
outputHeight :: Image -> Int
outputHeight} = do
    Int
sx <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
skipColumns
    Lens' BlitState Int
skipColumns forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
leftSkip
    forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying Lens' BlitState Int
remainingColumns (forall a. Ord a => a -> a -> a
min (Int
outputWidth forall a. Num a => a -> a -> a
- Int
sx))
    Int
sy <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' BlitState Int
skipRows
    Lens' BlitState Int
skipRows forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
topSkip
    forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying Lens' BlitState Int
remainingRows (forall a. Ord a => a -> a -> a
min (Int
outputHeight forall a. Num a => a -> a -> a
- Int
sy))
    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 -> TL.Text -> BlitM s ()
addUnclippedText :: forall s. Attr -> Text -> BlitM s ()
addUnclippedText Attr
a Text
txt = do
    let op :: SpanOp
op = Attr -> Int -> Int -> Text -> SpanOp
TextSpan Attr
a Int
usedDisplayColumns
                      (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> Int64
TL.length Text
txt)
                      Text
txt
        usedDisplayColumns :: Int
usedDisplayColumns = Text -> Int
wctlwidth Text
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'