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

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

columnOffset :: Lens' BlitState Int
columnOffset :: Lens' BlitState Int
columnOffset = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_columnOffset (\BlitState
e Int
v -> BlitState
e { _columnOffset = v })

rowOffset :: Lens' BlitState Int
rowOffset :: Lens' BlitState Int
rowOffset = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_rowOffset (\BlitState
e Int
v -> BlitState
e { _rowOffset = v })

skipColumns :: Lens' BlitState Int
skipColumns :: Lens' BlitState Int
skipColumns = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_skipColumns (\BlitState
e Int
v -> BlitState
e { _skipColumns = v })

skipRows :: Lens' BlitState Int
skipRows :: Lens' BlitState Int
skipRows = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_skipRows (\BlitState
e Int
v -> BlitState
e { _skipRows = v })

remainingColumns :: Lens' BlitState Int
remainingColumns :: Lens' BlitState Int
remainingColumns = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_remainingColumns (\BlitState
e Int
v -> BlitState
e { _remainingColumns = v })

remainingRows :: Lens' BlitState Int
remainingRows :: Lens' BlitState Int
remainingRows = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_remainingRows (\BlitState
e Int
v -> BlitState
e { _remainingRows = v })

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

region :: Lens' (BlitEnv s) DisplayRegion
region :: forall s (f :: * -> *).
Functor f =>
(DisplayRegion -> f DisplayRegion) -> BlitEnv s -> f (BlitEnv s)
region = (BlitEnv s -> DisplayRegion)
-> (BlitEnv s -> DisplayRegion -> BlitEnv s)
-> Lens (BlitEnv s) (BlitEnv s) DisplayRegion DisplayRegion
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitEnv s -> DisplayRegion
forall s. BlitEnv s -> DisplayRegion
_region (\BlitEnv s
e DisplayRegion
r -> BlitEnv s
e { _region = r })

mrowOps :: Lens' (BlitEnv s) (MRowOps s)
mrowOps :: forall s (f :: * -> *).
Functor f =>
(MRowOps s -> f (MRowOps s)) -> BlitEnv s -> f (BlitEnv s)
mrowOps = (BlitEnv s -> MRowOps s)
-> (BlitEnv s -> MRowOps s -> BlitEnv s)
-> Lens (BlitEnv s) (BlitEnv s) (MRowOps s) (MRowOps s)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitEnv s -> MRowOps s
forall s. BlitEnv s -> MRowOps s
_mrowOps (\BlitEnv s
e MRowOps s
r -> BlitEnv s
e { _mrowOps = r })

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 s. ST s (MVector s SpanOps)) -> DisplayOps
forall a. (forall s. ST s (MVector s a)) -> Vector a
Vector.create (Picture -> DisplayRegion -> ST s (MRowOps s)
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| DisplayRegion -> Int
regionHeight DisplayRegion
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> ST s (MVector (PrimState (ST s)) SpanOps)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MVector.new Int
0
    | Bool
otherwise = do
        [MVector s SpanOps]
layerOps <- (Image -> ST s (MVector s SpanOps))
-> [Image] -> ST s [MVector s SpanOps]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Image -> DisplayRegion -> ST s (MVector s SpanOps)
forall s. Image -> DisplayRegion -> ST s (MRowOps s)
`buildSpans` DisplayRegion
r) (Picture -> [Image]
picLayers Picture
pic)
        case [MVector s SpanOps]
layerOps of
            []    -> [Char] -> ST s (MVector s SpanOps)
forall a. HasCallStack => [Char] -> a
error [Char]
"empty picture"
            [MVector s SpanOps
ops] -> Background -> MVector s SpanOps -> ST s (MVector s SpanOps)
forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips (Picture -> Background
picBackground Picture
pic) MVector s SpanOps
ops
            -- instead of merging ops after generation the merging can
            -- be performed as part of snocOp.
            MVector s SpanOps
topOps : [MVector s SpanOps]
lowerOps -> do
                MVector s SpanOps
ops <- (MVector s SpanOps
 -> MVector s SpanOps -> ST s (MVector s SpanOps))
-> MVector s SpanOps
-> [MVector s SpanOps]
-> ST s (MVector s SpanOps)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM MVector s SpanOps -> MVector s SpanOps -> ST s (MVector s SpanOps)
forall s. MRowOps s -> MRowOps s -> ST s (MRowOps s)
mergeUnder MVector s SpanOps
topOps [MVector s SpanOps]
lowerOps
                Background -> MVector s SpanOps -> ST s (MVector s SpanOps)
forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips (Picture -> Background
picBackground Picture
pic) MVector s SpanOps
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
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. MRowOps s -> Int
forall s a. MVector s a -> Int
MVector.length MRowOps s
ops Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
row -> do
        SpanOps
rowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
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 SpanOps -> SpanOp
forall a. Vector a -> a
Vector.last SpanOps
rowOps of
                        Skip Int
w -> SpanOps -> SpanOps
forall a. Vector a -> Vector a
Vector.init SpanOps
rowOps SpanOps -> SpanOp -> SpanOps
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'
        MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row SpanOps
rowOps''
    MRowOps s -> ST s (MRowOps s)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
ops
substituteSkips (Background {Char
backgroundChar :: Char
backgroundChar :: Background -> Char
backgroundChar, Attr
backgroundAttr :: Attr
backgroundAttr :: Background -> 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> [Char] -> ST s ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> ST s ()) -> [Char] -> ST s ()
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid background character " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
forall a. Show a => a -> [Char]
show Char
backgroundChar
          | Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> do
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. MRowOps s -> Int
forall s a. MVector s a -> Int
MVector.length MRowOps s
ops Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
row -> do
                    SpanOps
rowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row
                    let rowOps' :: SpanOps
rowOps' = Char -> Attr -> SpanOps -> SpanOps
swapSkipsForSingleColumnCharSpan Char
backgroundChar Attr
backgroundAttr SpanOps
rowOps
                    MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row SpanOps
rowOps'
          | Bool
otherwise -> do
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. MRowOps s -> Int
forall s a. MVector s a -> Int
MVector.length MRowOps s
ops Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
row -> do
                    SpanOps
rowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row
                    let rowOps' :: SpanOps
rowOps' = Int -> Char -> Attr -> SpanOps -> SpanOps
swapSkipsForCharSpan Int
w Char
backgroundChar Attr
backgroundAttr SpanOps
rowOps
                    MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row SpanOps
rowOps'
    MRowOps s -> ST s (MRowOps s)
forall a. a -> ST s a
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
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. MRowOps s -> Int
forall s a. MVector s a -> Int
MVector.length MRowOps s
upper Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
row -> do
        SpanOps
upperRowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
upper Int
row
        SpanOps
lowerRowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
lower Int
row
        let rowOps :: SpanOps
rowOps = SpanOps -> SpanOps -> SpanOps
mergeRowUnder SpanOps
upperRowOps SpanOps
lowerRowOps
        MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
upper Int
row SpanOps
rowOps
    MRowOps s -> ST s (MRowOps s)
forall a. a -> ST s a
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 SpanOps
forall a. Vector a
Vector.empty (SpanOps -> SpanOp
forall a. Vector a -> a
Vector.head SpanOps
upperRowOps) (SpanOps -> SpanOps
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' = SpanOps -> SpanOp -> SpanOps
forall a. Vector a -> a -> Vector a
Vector.snoc SpanOps
outOps SpanOp
op
            in if SpanOps -> Bool
forall a. Vector a -> Bool
Vector.null SpanOps
lowerOps'
                then SpanOps
outOps'
                else SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
outOps' (SpanOps -> SpanOp
forall a. Vector a -> a
Vector.head SpanOps
upperOps) (SpanOps -> SpanOps
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 SpanOps -> SpanOps -> SpanOps
forall a. Monoid a => a -> a -> a
`mappend` SpanOps
ops'
            in if SpanOps -> Bool
forall a. Vector a -> Bool
Vector.null SpanOps
lowerOps'
                then SpanOps
outOps'
                else SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
outOps' (SpanOps -> SpanOp
forall a. Vector a -> a
Vector.head SpanOps
upperOps) (SpanOps -> SpanOps
forall a. Vector a -> Vector a
Vector.tail SpanOps
upperOps) SpanOps
lowerOps'
        onUpperOp SpanOps
_ (RowEnd Int
_) SpanOps
_ SpanOps
_ = [Char] -> 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 = (SpanOp -> SpanOp) -> SpanOps -> SpanOps
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 ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
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 = (SpanOp -> SpanOp) -> SpanOps -> SpanOps
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 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
w
                          txt0 :: Text
txt0 = [Char] -> Text
TL.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
txt0Cw Char
c
                          txt1Cw :: Int
txt1Cw = Int
ow Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
w
                          txt1 :: Text
txt1 = [Char] -> Text
TL.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
txt1Cw Char
'…'
                          cw :: Int
cw = Int
txt0Cw Int -> Int -> Int
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 <- Int -> SpanOps -> ST s (MVector (PrimState (ST s)) SpanOps)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MVector.replicate (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion) SpanOps
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.
    Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& DisplayRegion -> Int
regionWidth DisplayRegion
outRegion Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
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
                Image -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. Image -> BlitM s ()
startImageBuild Image
image
                -- Fill in any unspecified columns with a skip.
                [Int]
-> (Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] (DisplayRegion
-> Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. DisplayRegion -> Int -> BlitM s ()
addRowCompletion DisplayRegion
outRegion)
            initEnv :: BlitEnv s
initEnv   = DisplayRegion -> MRowOps s -> BlitEnv s
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)
_ <- StateT BlitState (ST s) () -> BlitState -> ST s ((), BlitState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> BlitEnv s -> StateT BlitState (ST s) ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall {s}. ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
fullBuild BlitEnv s
initEnv) BlitState
initState
        () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    MRowOps s -> ST s (MRowOps s)
forall a. a -> ST s a
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 (BlitState -> Bool)
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) BlitState
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (BlitEnv s) (StateT BlitState (ST s)) BlitState
forall s (m :: * -> *). MonadState s m => m s
get
    Bool -> BlitM s () -> BlitM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
outOfBounds) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
image

isOutOfBounds :: Image -> BlitState -> Bool
isOutOfBounds :: Image -> BlitState -> Bool
isOutOfBounds Image
i BlitState
s
    | BlitState
s BlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int BlitState Int
Lens' BlitState Int
remainingColumns Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0             = Bool
True
    | BlitState
s BlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int BlitState Int
Lens' BlitState Int
remainingRows    Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0             = Bool
True
    | BlitState
s BlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int BlitState Int
Lens' BlitState Int
skipColumns      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Image -> Int
imageWidth Image
i  = Bool
True
    | BlitState
s BlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int BlitState Int
Lens' BlitState Int
skipRows         Int -> Int -> Bool
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 = () -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a. a -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
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 <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
skipRows
    Bool
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
 -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a b. (a -> b) -> a -> b
$ do
        Int
leftClip <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
skipColumns
        Int
rightClip <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
remainingColumns
        let leftClipped :: Bool
leftClipped = Int
leftClip Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            rightClipped :: Bool
rightClipped = (Int
ow Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftClip) Int -> Int -> Bool
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 Attr -> Text -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. Attr -> Text -> BlitM s ()
addUnclippedText Attr
a Text
textStr'
            else Attr -> Text -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. Attr -> Text -> BlitM s ()
addUnclippedText Attr
a Text
textStr
addMaybeClipped (VertJoin Image
topImage Image
bottomImage Int
_ow Int
oh) = do
    Bool
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Image -> Int
imageHeight Image
topImage Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Image -> Int
imageHeight Image
bottomImage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
 -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a b. (a -> b) -> a -> b
$
        [Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s.
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin [Char]
"vert_join" (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
skipRows (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
remainingRows (Int -> f Int) -> BlitState -> f BlitState
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
    Bool
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Image -> Int
imageWidth Image
leftImage Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Image -> Int
imageWidth Image
rightImage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
 -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a b. (a -> b) -> a -> b
$
        [Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s.
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin [Char]
"horiz_join" (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
skipColumns (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
remainingColumns (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
columnOffset
                            (Image -> Int
imageWidth Image
leftImage)
                            Image
leftImage
                            Image
rightImage
                            Int
ow
addMaybeClipped BGFill {Int
outputWidth :: Int
outputWidth :: Image -> Int
outputWidth, Int
outputHeight :: Int
outputHeight :: Image -> Int
outputHeight} = do
    BlitState
s <- ReaderT (BlitEnv s) (StateT BlitState (ST s)) BlitState
forall s (m :: * -> *). MonadState s m => m s
get
    let outputWidth' :: Int
outputWidth'  = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
outputWidth  Int -> Int -> Int
forall a. Num a => a -> a -> a
- BlitState
sBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
skipColumns) (BlitState
sBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remainingColumns)
        outputHeight' :: Int
outputHeight' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
outputHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- BlitState
sBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
skipRows   ) (BlitState
sBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remainingRows)
    Int
y <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
rowOffset
    [Int]
-> (Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
y..Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
outputHeight'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
 -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> (Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a b. (a -> b) -> a -> b
$ SpanOp -> Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. SpanOp -> Int -> BlitM s ()
snocOp (Int -> SpanOp
Skip Int
outputWidth')
addMaybeClipped Crop {Image
croppedImage :: Image
croppedImage :: Image -> Image
croppedImage, Int
leftSkip :: Int
leftSkip :: Image -> Int
leftSkip, Int
topSkip :: Int
topSkip :: Image -> Int
topSkip, Int
outputWidth :: Image -> Int
outputWidth :: Int
outputWidth, Int
outputHeight :: Image -> Int
outputHeight :: Int
outputHeight} = do
    Int
sx <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
skipColumns
    (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skipColumns ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
leftSkip
    ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remainingColumns (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
outputWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sx))
    Int
sy <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
skipRows
    (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skipRows ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
topSkip
    ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remainingRows (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
outputHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sy))
    Image -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
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 <- ReaderT (BlitEnv s) (StateT BlitState (ST s)) BlitState
forall s (m :: * -> *). MonadState s m => m s
get
    Bool -> BlitM s () -> BlitM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlitState
stateBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ [Char] -> BlitM s ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> BlitM s ()) -> [Char] -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with remaining <= 0"
    case BlitState
stateBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
skip of
        Int
s | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
size -> BlitState -> BlitM s ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BlitState -> BlitM s ()) -> BlitState -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ BlitState
state BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skip ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
size
          | Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    -> if BlitState
stateBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i0Dim
                            then do
                                Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
                                BlitState -> BlitM s ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BlitState -> BlitM s ()) -> BlitState -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ BlitState
state BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
offset ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i0Dim) BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remaining ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
i0Dim
                                Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i1
                            else Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
          | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i0Dim  ->
                let i0Dim' :: Int
i0Dim' = Int
i0Dim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s
                in if BlitState
stateBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i0Dim'
                    then Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
                    else do
                        Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
                        BlitState -> BlitM s ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BlitState -> BlitM s ()) -> BlitState -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ BlitState
state BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
offset ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i0Dim') BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remaining ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
i0Dim' BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skip ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
0
                        Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i1
          | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i0Dim -> do
                BlitState -> BlitM s ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BlitState -> BlitM s ()) -> BlitState -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ BlitState
state BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skip ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
i0Dim
                Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i1
        Int
_ -> [Char] -> BlitM s ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> BlitM s ()) -> [Char] -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> [Char] -> [Char]
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
                      (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Int64
TL.length Text
txt)
                      Text
txt
        usedDisplayColumns :: Int
usedDisplayColumns = Text -> Int
wctlwidth Text
txt
    Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
rowOffset ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
-> (Int -> BlitM s ()) -> BlitM s ()
forall a b.
ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
-> (a -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) b)
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpanOp -> Int -> BlitM s ()
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 <- Getting (MRowOps s) (BlitEnv s) (MRowOps s)
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) (MRowOps s)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MRowOps s) (BlitEnv s) (MRowOps s)
forall s (f :: * -> *).
Functor f =>
(MRowOps s -> f (MRowOps s)) -> BlitEnv s -> f (BlitEnv s)
mrowOps
    SpanOps
rowOps <- StateT BlitState (ST s) SpanOps
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) SpanOps
forall (m :: * -> *) a. Monad m => m a -> ReaderT (BlitEnv s) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BlitState (ST s) SpanOps
 -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) SpanOps)
-> StateT BlitState (ST s) SpanOps
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) SpanOps
forall a b. (a -> b) -> a -> b
$ ST s SpanOps -> StateT BlitState (ST s) SpanOps
forall (m :: * -> *) a. Monad m => m a -> StateT BlitState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s SpanOps -> StateT BlitState (ST s) SpanOps)
-> ST s SpanOps -> StateT BlitState (ST s) SpanOps
forall a b. (a -> b) -> a -> b
$ MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
allRowOps Int
row
    let endX :: Int
endX = SpanOps -> Int
spanOpsAffectedColumns SpanOps
rowOps
    Bool -> BlitM s () -> BlitM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
endX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< DisplayRegion -> Int
regionWidth DisplayRegion
displayRegion) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ do
        let ow :: Int
ow = DisplayRegion -> Int
regionWidth DisplayRegion
displayRegion Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
endX
        SpanOp -> Int -> BlitM s ()
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 <- Getting (MRowOps s) (BlitEnv s) (MRowOps s)
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) (MRowOps s)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MRowOps s) (BlitEnv s) (MRowOps s)
forall s (f :: * -> *).
Functor f =>
(MRowOps s -> f (MRowOps s)) -> BlitEnv s -> f (BlitEnv s)
mrowOps
    DisplayRegion
theRegion <- Getting DisplayRegion (BlitEnv s) DisplayRegion
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) DisplayRegion
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting DisplayRegion (BlitEnv s) DisplayRegion
forall s (f :: * -> *).
Functor f =>
(DisplayRegion -> f DisplayRegion) -> BlitEnv s -> f (BlitEnv s)
region
    StateT BlitState (ST s) () -> BlitM s ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT (BlitEnv s) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BlitState (ST s) () -> BlitM s ())
-> StateT BlitState (ST s) () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ ST s () -> StateT BlitState (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> StateT BlitState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BlitState (ST s) ())
-> ST s () -> StateT BlitState (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
        SpanOps
ops <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
theMrowOps Int
row
        let ops' :: SpanOps
ops' = SpanOps -> SpanOp -> SpanOps
forall a. Vector a -> a -> Vector a
Vector.snoc SpanOps
ops SpanOp
op
        Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SpanOps -> Int
spanOpsAffectedColumns SpanOps
ops' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> DisplayRegion -> Int
regionWidth DisplayRegion
theRegion)
             (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ST s ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> ST s ()) -> [Char] -> ST s ()
forall a b. (a -> b) -> a -> b
$ [Char]
"row " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
row [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" now exceeds region width"
        MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
theMrowOps Int
row SpanOps
ops'