{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
module Tart.Canvas
  ( Canvas
  , CanvasData
  , canvasFromData
  , canvasToData
  , newCanvas
  , canvasSize
  , canvasSetPixel
  , canvasSetMany
  , canvasGetPixel
  , resizeFrom
  , prettyPrintCanvas
  , merge
  , clearCanvas
  , canvasFromString
  , canvasFromText
  , canvasLayersToImage
  , normalizeAttr
  )
where

import Control.Monad (forM_, forM, replicateM, when)
import Control.Monad.State
import Data.Bits
import Data.Word (Word64)
import Data.Monoid ((<>))
import Data.Maybe (catMaybes)
import qualified Graphics.Vty as V
import qualified Data.Array.IArray as I
import qualified Data.Array.MArray as A
import qualified Data.Binary as B
import Data.Array.IO (IOUArray)
import Data.Array.Unboxed (UArray)
import Lens.Micro.Platform
import qualified Data.Text as T

data Canvas =
    Canvas { Canvas -> IOUArray (Int, Int) Word64
mut   :: IOUArray (Int, Int) Word64
           , Canvas -> UArray (Int, Int) Word64
immut :: UArray   (Int, Int) Word64
           , Canvas -> (Int, Int)
size  :: (Int, Int)
           }

data CanvasData =
    CanvasData { CanvasData -> (Int, Int)
canvasDataSize :: (Int, Int)
               , CanvasData -> [Word64]
canvasData :: [Word64]
               }

instance B.Binary CanvasData where
    put :: CanvasData -> Put
put CanvasData
cd = do
        (Int, Int) -> Put
forall t. Binary t => t -> Put
B.put ((Int, Int) -> Put) -> (Int, Int) -> Put
forall a b. (a -> b) -> a -> b
$ CanvasData -> (Int, Int)
canvasDataSize CanvasData
cd
        (Word64 -> Put) -> [Word64] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word64 -> Put
forall t. Binary t => t -> Put
B.put ([Word64] -> Put) -> [Word64] -> Put
forall a b. (a -> b) -> a -> b
$ CanvasData -> [Word64]
canvasData CanvasData
cd

    get :: Get CanvasData
get = do
        (Int
w, Int
h) <- Get (Int, Int)
forall t. Binary t => Get t
B.get
        (Int, Int) -> [Word64] -> CanvasData
CanvasData ((Int, Int) -> [Word64] -> CanvasData)
-> Get (Int, Int) -> Get ([Word64] -> CanvasData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, Int) -> Get (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
w, Int
h))
                   Get ([Word64] -> CanvasData) -> Get [Word64] -> Get CanvasData
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Get Word64 -> Get [Word64]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h) Get Word64
forall t. Binary t => Get t
B.get

canvasFromData :: CanvasData -> IO (Either String Canvas)
canvasFromData :: CanvasData -> IO (Either String Canvas)
canvasFromData CanvasData
cd = do
    let (Int
w, Int
h) = CanvasData -> (Int, Int)
canvasDataSize CanvasData
cd
    if Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Word64] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CanvasData -> [Word64]
canvasData CanvasData
cd)
       then Either String Canvas -> IO (Either String Canvas)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Canvas -> IO (Either String Canvas))
-> Either String Canvas -> IO (Either String Canvas)
forall a b. (a -> b) -> a -> b
$ String -> Either String Canvas
forall a b. a -> Either a b
Left String
"Canvas data entries do not match dimensions"
       else do
           Canvas
c <- (Int, Int) -> IO Canvas
newCanvas (Int
w, Int
h)
           let idxs :: [(Int, Int)]
idxs = [(Int
w', Int
h') | Int
w' <- [Int
0..Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
h' <- [Int
0..Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
           [((Int, Int), Word64)] -> (((Int, Int), Word64) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Int, Int)] -> [Word64] -> [((Int, Int), Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int, Int)]
idxs (CanvasData -> [Word64]
canvasData CanvasData
cd)) ((((Int, Int), Word64) -> IO ()) -> IO ())
-> (((Int, Int), Word64) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \((Int, Int)
point, Word64
word) ->
               IOUArray (Int, Int) Word64 -> (Int, Int) -> Word64 -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
A.writeArray (Canvas -> IOUArray (Int, Int) Word64
mut Canvas
c) (Int, Int)
point Word64
word
           UArray (Int, Int) Word64
f <- IOUArray (Int, Int) Word64 -> IO (UArray (Int, Int) Word64)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
A.freeze (IOUArray (Int, Int) Word64 -> IO (UArray (Int, Int) Word64))
-> IOUArray (Int, Int) Word64 -> IO (UArray (Int, Int) Word64)
forall a b. (a -> b) -> a -> b
$ Canvas -> IOUArray (Int, Int) Word64
mut Canvas
c
           Either String Canvas -> IO (Either String Canvas)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Canvas -> IO (Either String Canvas))
-> Either String Canvas -> IO (Either String Canvas)
forall a b. (a -> b) -> a -> b
$ Canvas -> Either String Canvas
forall a b. b -> Either a b
Right (Canvas -> Either String Canvas) -> Canvas -> Either String Canvas
forall a b. (a -> b) -> a -> b
$ Canvas
c { immut :: UArray (Int, Int) Word64
immut = UArray (Int, Int) Word64
f }

canvasToData :: Canvas -> CanvasData
canvasToData :: Canvas -> CanvasData
canvasToData Canvas
c =
    (Int, Int) -> [Word64] -> CanvasData
CanvasData (Int, Int)
sz [Word64]
canvasPixels
    where
        sz :: (Int, Int)
sz@(Int
w, Int
h) = Canvas -> (Int, Int)
canvasSize Canvas
c
        canvasPixels :: [Word64]
canvasPixels =
           [ Canvas -> (Int, Int) -> Word64
canvasGetPixelRaw Canvas
c (Int
w', Int
h')
           | Int
w' <- [Int
0..Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
h' <- [Int
0..Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
           ]

newCanvas :: (Int, Int) -> IO Canvas
newCanvas :: (Int, Int) -> IO Canvas
newCanvas (Int, Int)
sz = do
    let arrayBounds :: ((Int, Int), (Int, Int))
arrayBounds = ((Int
0, Int
0), (Int, Int)
sz (Int, Int) -> ((Int, Int) -> (Int, Int)) -> (Int, Int)
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int)
forall s t a b. Each s t a b => Traversal s t a b
each ((Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int))
-> (Int -> Int) -> (Int, Int) -> (Int, Int)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int
forall a. Enum a => a -> a
pred)
    IOUArray (Int, Int) Word64
draw <- ((Int, Int), (Int, Int))
-> Word64 -> IO (IOUArray (Int, Int) Word64)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
A.newArray ((Int, Int), (Int, Int))
arrayBounds Word64
blankPixel
    UArray (Int, Int) Word64
drawFreeze <- IOUArray (Int, Int) Word64 -> IO (UArray (Int, Int) Word64)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
A.freeze IOUArray (Int, Int) Word64
draw
    Canvas -> IO Canvas
forall (m :: * -> *) a. Monad m => a -> m a
return (Canvas -> IO Canvas) -> Canvas -> IO Canvas
forall a b. (a -> b) -> a -> b
$ IOUArray (Int, Int) Word64
-> UArray (Int, Int) Word64 -> (Int, Int) -> Canvas
Canvas IOUArray (Int, Int) Word64
draw UArray (Int, Int) Word64
drawFreeze (Int, Int)
sz

canvasFromString :: String -> IO Canvas
canvasFromString :: String -> IO Canvas
canvasFromString = Text -> IO Canvas
canvasFromText (Text -> IO Canvas) -> (String -> Text) -> String -> IO Canvas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

canvasFromText :: T.Text -> IO Canvas
canvasFromText :: Text -> IO Canvas
canvasFromText Text
t = do
    let ls :: [Text]
ls = Text -> Text
convertTab (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Text]
T.lines Text
t
        convertTab :: Text -> Text
convertTab = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
convertTabChar
        convertTabChar :: Char -> Text
convertTabChar Char
'\t' = Int -> Text -> Text
T.replicate Int
8 Text
" "
        convertTabChar Char
c = Char -> Text
T.singleton Char
c
        height :: Int
height = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ls
        width :: Int
width = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length (Text -> Int) -> [Text] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
ls
        pixs :: [((Int, Int), Char, Attr)]
pixs = [[((Int, Int), Char, Attr)]] -> [((Int, Int), Char, Attr)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[((Int, Int), Char, Attr)]] -> [((Int, Int), Char, Attr)])
-> [[((Int, Int), Char, Attr)]] -> [((Int, Int), Char, Attr)]
forall a b. (a -> b) -> a -> b
$ (Int, Text) -> [((Int, Int), Char, Attr)]
forall a b. (Num a, Enum a) => (b, Text) -> [((a, b), Char, Attr)]
mkRowPixels ((Int, Text) -> [((Int, Int), Char, Attr)])
-> [(Int, Text)] -> [[((Int, Int), Char, Attr)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Text]
ls
        mkRowPixels :: (b, Text) -> [((a, b), Char, Attr)]
mkRowPixels (b
rowNum, Text
row) =
            b -> (a, Char) -> ((a, b), Char, Attr)
forall b a b. b -> (a, b) -> ((a, b), b, Attr)
mkPixel b
rowNum ((a, Char) -> ((a, b), Char, Attr))
-> [(a, Char)] -> [((a, b), Char, Attr)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> String -> [(a, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a
0..] (Text -> String
T.unpack Text
row)
        mkPixel :: b -> (a, b) -> ((a, b), b, Attr)
mkPixel b
rowNum (a
colNum, b
ch) =
            ((a
colNum, b
rowNum), b
ch, Attr
V.defAttr)

    Canvas
c <- (Int, Int) -> IO Canvas
newCanvas (Int
width, Int
height)
    Canvas -> [((Int, Int), Char, Attr)] -> IO Canvas
canvasSetMany Canvas
c [((Int, Int), Char, Attr)]
pixs

clearCanvas :: Canvas -> IO Canvas
clearCanvas :: Canvas -> IO Canvas
clearCanvas Canvas
c = do
    let (Int
width, Int
height) = Canvas -> (Int, Int)
canvasSize Canvas
c
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
widthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
w ->
        [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
h -> do
            IOUArray (Int, Int) Word64 -> (Int, Int) -> Word64 -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
A.writeArray (Canvas -> IOUArray (Int, Int) Word64
mut Canvas
c) (Int
w, Int
h) Word64
blankPixel
    UArray (Int, Int) Word64
f <- IOUArray (Int, Int) Word64 -> IO (UArray (Int, Int) Word64)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
A.freeze (Canvas -> IOUArray (Int, Int) Word64
mut Canvas
c)
    Canvas -> IO Canvas
forall (m :: * -> *) a. Monad m => a -> m a
return (Canvas -> IO Canvas) -> Canvas -> IO Canvas
forall a b. (a -> b) -> a -> b
$ Canvas
c { immut :: UArray (Int, Int) Word64
immut = UArray (Int, Int) Word64
f }

type RLE a = State RLEState a

data RLEState =
    RLEState { RLEState -> [(Text, Attr)]
content       :: [(T.Text, V.Attr)]
             , RLEState -> Text
currentString :: T.Text
             , RLEState -> Attr
currentAttr   :: V.Attr
             }

runRLE :: RLE () -> [(T.Text, V.Attr)]
runRLE :: RLE () -> [(Text, Attr)]
runRLE RLE ()
act =
    let s :: RLEState
s = RLE () -> RLEState -> RLEState
forall s a. State s a -> s -> s
execState (RLE ()
act RLE () -> RLE () -> RLE ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RLE ()
sealFinalToken) ([(Text, Attr)] -> Text -> Attr -> RLEState
RLEState [] Text
"" Attr
V.defAttr)
    in RLEState -> [(Text, Attr)]
content RLEState
s

rleNext :: (Char, V.Attr) -> RLE ()
rleNext :: (Char, Attr) -> RLE ()
rleNext (Char
ch, Attr
attr) = do
    -- If the attribute matches the current attribute, just append the
    -- character.
    Attr
cur <- (RLEState -> Attr) -> StateT RLEState Identity Attr
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RLEState -> Attr
currentAttr
    case Attr
cur Attr -> Attr -> Bool
forall a. Eq a => a -> a -> Bool
== Attr
attr of
        Bool
True -> Char -> RLE ()
appendCharacter Char
ch
        Bool
False -> Char -> Attr -> RLE ()
newToken Char
ch Attr
attr

appendCharacter :: Char -> RLE ()
appendCharacter :: Char -> RLE ()
appendCharacter Char
c =
    (RLEState -> RLEState) -> RLE ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RLEState -> RLEState) -> RLE ())
-> (RLEState -> RLEState) -> RLE ()
forall a b. (a -> b) -> a -> b
$ \RLEState
s -> RLEState
s { currentString :: Text
currentString = RLEState -> Text
currentString RLEState
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
c
                     }

sealFinalToken :: RLE ()
sealFinalToken :: RLE ()
sealFinalToken =
    (RLEState -> RLEState) -> RLE ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RLEState -> RLEState) -> RLE ())
-> (RLEState -> RLEState) -> RLE ()
forall a b. (a -> b) -> a -> b
$ \RLEState
s -> RLEState
s { content :: [(Text, Attr)]
content = if Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ RLEState -> Text
currentString RLEState
s
                                 then RLEState -> [(Text, Attr)]
content RLEState
s
                                 else RLEState -> [(Text, Attr)]
content RLEState
s [(Text, Attr)] -> [(Text, Attr)] -> [(Text, Attr)]
forall a. Semigroup a => a -> a -> a
<> [(RLEState -> Text
currentString RLEState
s, RLEState -> Attr
currentAttr RLEState
s)]
                     }

newToken :: Char -> V.Attr -> RLE ()
newToken :: Char -> Attr -> RLE ()
newToken Char
c Attr
a =
    (RLEState -> RLEState) -> RLE ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RLEState -> RLEState) -> RLE ())
-> (RLEState -> RLEState) -> RLE ()
forall a b. (a -> b) -> a -> b
$ \RLEState
s -> RLEState
s { currentString :: Text
currentString = Char -> Text
T.singleton Char
c
                     , currentAttr :: Attr
currentAttr = Attr
a
                     , content :: [(Text, Attr)]
content = if Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ RLEState -> Text
currentString RLEState
s
                                 then RLEState -> [(Text, Attr)]
content RLEState
s
                                 else RLEState -> [(Text, Attr)]
content RLEState
s [(Text, Attr)] -> [(Text, Attr)] -> [(Text, Attr)]
forall a. Semigroup a => a -> a -> a
<> [(RLEState -> Text
currentString RLEState
s, RLEState -> Attr
currentAttr RLEState
s)]
                     }

prettyPrintCanvas :: Bool -> [Canvas] -> T.Text
prettyPrintCanvas :: Bool -> [Canvas] -> Text
prettyPrintCanvas Bool
emitSequences [Canvas]
cs =
    let pairs :: [(Text, Attr)]
pairs = RLE () -> [(Text, Attr)]
runRLE ([Canvas] -> RLE ()
mkRLE [Canvas]
cs)
        mkOutput :: (Text, Attr) -> Text
mkOutput (Text
s, Attr
attr) =
            if Bool
emitSequences
            then Attr -> Text
ctrlSequence Attr
attr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
            else Text
s
        ctrlSequence :: Attr -> Text
ctrlSequence Attr
a =
            Text
"\ESC[0m" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Attr -> Text
attrSequence Attr
a
    in [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text, Attr) -> Text
mkOutput ((Text, Attr) -> Text) -> [(Text, Attr)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Attr)]
pairs

mkRLE :: [Canvas] -> RLE ()
mkRLE :: [Canvas] -> RLE ()
mkRLE [] = () -> RLE ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkRLE cs :: [Canvas]
cs@(Canvas
c:[Canvas]
_) = do
    let (Int
w, Int
h) = Canvas -> (Int, Int)
canvasSize Canvas
c
    [Int] -> (Int -> RLE ()) -> RLE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> RLE ()) -> RLE ()) -> (Int -> RLE ()) -> RLE ()
forall a b. (a -> b) -> a -> b
$ \Int
row -> do
        [Int] -> (Int -> RLE ()) -> RLE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> RLE ()) -> RLE ()) -> (Int -> RLE ()) -> RLE ()
forall a b. (a -> b) -> a -> b
$ \Int
col ->
            (Char, Attr) -> RLE ()
rleNext ((Char, Attr) -> RLE ()) -> (Char, Attr) -> RLE ()
forall a b. (a -> b) -> a -> b
$ [Canvas] -> (Int, Int) -> (Char, Attr)
findPixel [Canvas]
cs (Int
col, Int
row)
        (Char, Attr) -> RLE ()
rleNext (Char
'\n', Attr
V.defAttr)

attrSequence :: V.Attr -> T.Text
attrSequence :: Attr -> Text
attrSequence Attr
a =
    let fg :: Text
fg = Bool -> MaybeDefault Color -> Text
colorCode Bool
True (Attr -> MaybeDefault Color
V.attrForeColor Attr
a)
        bg :: Text
bg = Bool -> MaybeDefault Color -> Text
colorCode Bool
False (Attr -> MaybeDefault Color
V.attrBackColor Attr
a)
        sty :: Text
sty = MaybeDefault Style -> Text
styleCode (Attr -> MaybeDefault Style
V.attrStyle Attr
a)
    in Text
fg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sty

styleCode :: V.MaybeDefault V.Style -> T.Text
styleCode :: MaybeDefault Style -> Text
styleCode MaybeDefault Style
V.KeepCurrent = Text
""
styleCode MaybeDefault Style
V.Default = Text
""
styleCode (V.SetTo Style
s) = Style -> Text
styleCode' Style
s

styles :: [V.Style]
styles :: [Style]
styles =
    [ Style
V.bold
    , Style
V.underline
    , Style
V.blink
    , Style
V.reverseVideo
    ]

styleCode' :: V.Style -> T.Text
styleCode' :: Style -> Text
styleCode' Style
s =
    let present :: [Style]
present = (Style -> Bool) -> [Style] -> [Style]
forall a. (a -> Bool) -> [a] -> [a]
filter (Style -> Style -> Bool
V.hasStyle Style
s) [Style]
styles
    in if [Style] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Style]
present
       then Text
""
       else Text
"\ESC[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
";" (Style -> Text
styleToCode (Style -> Text) -> [Style] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Style]
present) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"m"

styleToCode :: V.Style -> T.Text
styleToCode :: Style -> Text
styleToCode Style
s =
    let mapping :: [(Style, Text)]
mapping = [ (Style
V.bold,         Text
"1")
                  , (Style
V.underline,    Text
"4")
                  , (Style
V.blink,        Text
"5")
                  , (Style
V.reverseVideo, Text
"7")
                  ]
    in Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Text -> Text
forall a. a -> a
id (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Style -> [(Style, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Style
s [(Style, Text)]
mapping

colorCode :: Bool -> V.MaybeDefault V.Color -> T.Text
colorCode :: Bool -> MaybeDefault Color -> Text
colorCode Bool
_ MaybeDefault Color
V.KeepCurrent = Text
""
colorCode Bool
_ MaybeDefault Color
V.Default = Text
""
colorCode Bool
f (V.SetTo Color
c) = Bool -> Color -> Text
colorCode' Bool
f Color
c

colorCode' :: Bool -> V.Color -> T.Text
colorCode' :: Bool -> Color -> Text
colorCode' Bool
f (V.Color240 Style
w) =
    Text
"\ESC[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool
f then Text
"38" else Text
"48" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";5;" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Style -> String
forall a. Show a => a -> String
show Style
w) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"m"
colorCode' Bool
f (V.ISOColor Style
w) =
    let c :: Text
c = if Bool
f then Text
"38" else Text
"48"
        valid :: a -> Bool
valid a
v = a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0 Bool -> Bool -> Bool
&& a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
15
    in if Style -> Bool
forall a. (Ord a, Num a) => a -> Bool
valid Style
w
       then Text
"\ESC[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";5;" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Style -> String
forall a. Show a => a -> String
show Style
w) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"m"
       else Text
""

canvasSize :: Canvas -> (Int, Int)
canvasSize :: Canvas -> (Int, Int)
canvasSize = Canvas -> (Int, Int)
size

canvasGetPixel :: Canvas -> (Int, Int) -> (Char, V.Attr)
canvasGetPixel :: Canvas -> (Int, Int) -> (Char, Attr)
canvasGetPixel Canvas
c (Int, Int)
p = Word64 -> (Char, Attr)
decodePixel (Word64 -> (Char, Attr)) -> Word64 -> (Char, Attr)
forall a b. (a -> b) -> a -> b
$ Canvas -> (Int, Int) -> Word64
canvasGetPixelRaw Canvas
c (Int, Int)
p

canvasGetPixelRaw :: Canvas -> (Int, Int) -> Word64
canvasGetPixelRaw :: Canvas -> (Int, Int) -> Word64
canvasGetPixelRaw Canvas
c (Int, Int)
point = (Canvas -> UArray (Int, Int) Word64
immut Canvas
c) UArray (Int, Int) Word64 -> (Int, Int) -> Word64
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
I.! (Int, Int)
point

canvasSetMany :: Canvas -> [((Int, Int), Char, V.Attr)] -> IO Canvas
canvasSetMany :: Canvas -> [((Int, Int), Char, Attr)] -> IO Canvas
canvasSetMany Canvas
c [((Int, Int), Char, Attr)]
pixels = do
    [((Int, Int), Char, Attr)]
-> (((Int, Int), Char, Attr) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((Int, Int), Char, Attr)]
pixels ((((Int, Int), Char, Attr) -> IO ()) -> IO ())
-> (((Int, Int), Char, Attr) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \((Int, Int)
point, Char
ch, Attr
attr) -> do
        Bool
valid <- (Int, Int) -> IOUArray (Int, Int) Word64 -> IO Bool
isValidPoint (Int, Int)
point (Canvas -> IOUArray (Int, Int) Word64
mut Canvas
c)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
valid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOUArray (Int, Int) Word64 -> (Int, Int) -> Word64 -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
A.writeArray (Canvas -> IOUArray (Int, Int) Word64
mut Canvas
c) (Int, Int)
point (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Char -> Attr -> Word64
encodePixel Char
ch Attr
attr

    UArray (Int, Int) Word64
f <- IOUArray (Int, Int) Word64 -> IO (UArray (Int, Int) Word64)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
A.freeze (Canvas -> IOUArray (Int, Int) Word64
mut Canvas
c)
    Canvas -> IO Canvas
forall (m :: * -> *) a. Monad m => a -> m a
return (Canvas -> IO Canvas) -> Canvas -> IO Canvas
forall a b. (a -> b) -> a -> b
$ Canvas
c { immut :: UArray (Int, Int) Word64
immut = UArray (Int, Int) Word64
f
               }

isValidPoint :: (Int, Int) -> IOUArray (Int, Int) Word64 -> IO Bool
isValidPoint :: (Int, Int) -> IOUArray (Int, Int) Word64 -> IO Bool
isValidPoint (Int
c, Int
r) IOUArray (Int, Int) Word64
arr = do
    ((Int
loC, Int
loR), (Int
hiC, Int
hiR)) <- IOUArray (Int, Int) Word64 -> IO ((Int, Int), (Int, Int))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
A.getBounds IOUArray (Int, Int) Word64
arr
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
loR Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
loC Bool -> Bool -> Bool
&&
             Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
hiR Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
hiC

canvasSetPixel :: Canvas -> (Int, Int) -> Char -> V.Attr -> IO Canvas
canvasSetPixel :: Canvas -> (Int, Int) -> Char -> Attr -> IO Canvas
canvasSetPixel Canvas
c (Int, Int)
point Char
ch Attr
attr = Canvas -> [((Int, Int), Char, Attr)] -> IO Canvas
canvasSetMany Canvas
c [((Int, Int)
point, Char
ch, Attr
attr)]

blankPixel :: Word64
blankPixel :: Word64
blankPixel = Char -> Attr -> Word64
encodePixel Char
' ' Attr
V.defAttr

resizeFrom :: Canvas -> (Int, Int) -> IO Canvas
resizeFrom :: Canvas -> (Int, Int) -> IO Canvas
resizeFrom Canvas
old (Int, Int)
newSz = do
    -- If the new bounds are different than the old, create a new array
    -- and copy.
    case (Int, Int)
newSz (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= Canvas -> (Int, Int)
canvasSize Canvas
old of
        Bool
False -> Canvas -> IO Canvas
forall (m :: * -> *) a. Monad m => a -> m a
return Canvas
old
        Bool
True -> do
            Canvas
new <- (Int, Int) -> IO Canvas
newCanvas (Int, Int)
newSz
            (Canvas
c, [((Int, Int), (Char, Attr))]
_) <- Canvas -> Canvas -> IO (Canvas, [((Int, Int), (Char, Attr))])
merge Canvas
new Canvas
old
            Canvas -> IO Canvas
forall (m :: * -> *) a. Monad m => a -> m a
return Canvas
c

encodePixel :: Char -> V.Attr -> Word64
encodePixel :: Char -> Attr -> Word64
encodePixel Char
c Attr
a =
    -- Convert char to word32
    -- Convert attr color slots to 10-bit sequences (set bit, type bit, color bits)
    let low32Mask :: Word64
low32Mask = Word64
2 Word64 -> Integer -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
32::Integer) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1
        c64 :: Word64
c64 = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c
        a' :: Attr
a' = Char -> Attr -> Attr
normalizeAttr Char
c Attr
a
    in (Word64
c64 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
low32Mask) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
       (Attr -> Word64
encodeAttribute Attr
a' Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
32)

decodePixel :: Word64 -> (Char, V.Attr)
decodePixel :: Word64 -> (Char, Attr)
decodePixel Word64
v =
    let chBits :: Word64
chBits = Word64
v Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. (Word64
2 Word64 -> Integer -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
32::Integer) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
        attrBits :: Word64
attrBits = Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32
        attr :: Attr
attr = Word64 -> Attr
decodeAttribute Word64
attrBits
        ch :: Char
ch = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
chBits
    in (Char
ch, Char -> Attr -> Attr
normalizeAttr Char
ch Attr
attr)

normalizeAttr :: Char -> V.Attr -> V.Attr
normalizeAttr :: Char -> Attr -> Attr
normalizeAttr Char
ch Attr
attr =
    if Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ MaybeDefault Style -> Bool
hasForegroundStyle (MaybeDefault Style -> Bool) -> MaybeDefault Style -> Bool
forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Style
V.attrStyle Attr
attr)
    then Attr
attr { attrForeColor :: MaybeDefault Color
V.attrForeColor = MaybeDefault Color
forall v. MaybeDefault v
V.Default
              , attrStyle :: MaybeDefault Style
V.attrStyle = MaybeDefault Style
forall v. MaybeDefault v
V.Default
              }
    else Attr
attr

hasForegroundStyle :: V.MaybeDefault V.Style -> Bool
hasForegroundStyle :: MaybeDefault Style -> Bool
hasForegroundStyle (V.SetTo Style
s) =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Style -> Style -> Bool
V.hasStyle Style
s Style
V.underline
       , Style -> Style -> Bool
V.hasStyle Style
s Style
V.reverseVideo
       ]
hasForegroundStyle MaybeDefault Style
_ = Bool
False

encodeAttribute :: V.Attr -> Word64
encodeAttribute :: Attr -> Word64
encodeAttribute Attr
attr =
    (MaybeDefault Style -> Word64
encodeAttrStyle (Attr -> MaybeDefault Style
V.attrStyle Attr
attr) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
20) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
    (MaybeDefault Color -> Word64
encodeAttrColor (Attr -> MaybeDefault Color
V.attrForeColor Attr
attr) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
10) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
    (MaybeDefault Color -> Word64
encodeAttrColor (Attr -> MaybeDefault Color
V.attrBackColor Attr
attr))

encodeAttrStyle :: V.MaybeDefault V.Style -> Word64
encodeAttrStyle :: MaybeDefault Style -> Word64
encodeAttrStyle MaybeDefault Style
V.Default = Word64
0
encodeAttrStyle MaybeDefault Style
V.KeepCurrent = Word64
0
encodeAttrStyle (V.SetTo Style
s) = Style -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Style
s

decodeAttrStyle :: Word64 -> V.MaybeDefault V.Style
decodeAttrStyle :: Word64 -> MaybeDefault Style
decodeAttrStyle Word64
0 = MaybeDefault Style
forall v. MaybeDefault v
V.Default
decodeAttrStyle Word64
v = Style -> MaybeDefault Style
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
V.SetTo (Style -> MaybeDefault Style) -> Style -> MaybeDefault Style
forall a b. (a -> b) -> a -> b
$ Word64 -> Style
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v

decodeAttribute :: Word64 -> V.Attr
decodeAttribute :: Word64 -> Attr
decodeAttribute Word64
v =
    let attrColorMask :: Word64
attrColorMask = Word64
2 Word64 -> Integer -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
10::Integer) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1
        attrStyleMask :: Word64
attrStyleMask = Word64
2 Word64 -> Integer -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
8::Integer) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1
    in Attr
V.defAttr { attrStyle :: MaybeDefault Style
V.attrStyle     = Word64 -> MaybeDefault Style
decodeAttrStyle (Word64 -> MaybeDefault Style) -> Word64 -> MaybeDefault Style
forall a b. (a -> b) -> a -> b
$ (Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
20) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
attrStyleMask
                 , attrForeColor :: MaybeDefault Color
V.attrForeColor = Word64 -> MaybeDefault Color
decodeAttrColor (Word64 -> MaybeDefault Color) -> Word64 -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ (Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
10) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
attrColorMask
                 , attrBackColor :: MaybeDefault Color
V.attrBackColor = Word64 -> MaybeDefault Color
decodeAttrColor (Word64 -> MaybeDefault Color) -> Word64 -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Word64
v Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
attrColorMask
                 }

encodeAttrColor :: V.MaybeDefault V.Color -> Word64
encodeAttrColor :: MaybeDefault Color -> Word64
encodeAttrColor MaybeDefault Color
V.Default = Word64
0
encodeAttrColor MaybeDefault Color
V.KeepCurrent = Word64
0
encodeAttrColor (V.SetTo Color
c) =
    let (Word64
ty, Word64
color) = case Color
c of
          V.ISOColor Style
w -> (Word64
0, Style -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Style
w)
          V.Color240 Style
w -> (Word64
1, Style -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Style
w)
    in (Word64
1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
9) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
       (Word64
ty Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
       Word64
color

decodeAttrColor :: Word64 -> V.MaybeDefault V.Color
decodeAttrColor :: Word64 -> MaybeDefault Color
decodeAttrColor Word64
0 = MaybeDefault Color
forall v. MaybeDefault v
V.Default
decodeAttrColor Word64
v =
    let ty :: Word64
ty = (Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0b1
        color :: Style
color = Word64 -> Style
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Style) -> Word64 -> Style
forall a b. (a -> b) -> a -> b
$ Word64
v Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0b11111111
    in if Word64
ty Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
1
       then Color -> MaybeDefault Color
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
V.SetTo (Color -> MaybeDefault Color) -> Color -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Style -> Color
V.Color240 Style
color
       else Color -> MaybeDefault Color
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
V.SetTo (Color -> MaybeDefault Color) -> Color -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Style -> Color
V.ISOColor Style
color

merge :: Canvas -> Canvas -> IO (Canvas, [((Int, Int), (Char, V.Attr))])
merge :: Canvas -> Canvas -> IO (Canvas, [((Int, Int), (Char, Attr))])
merge Canvas
dest Canvas
src = do
    let (Int
width, Int
height) = (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
srcW Int
destW, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
srcH Int
destH)
        (Int
srcW, Int
srcH) = Canvas -> (Int, Int)
canvasSize Canvas
src
        (Int
destW, Int
destH) = Canvas -> (Int, Int)
canvasSize Canvas
dest

    [[Maybe ((Int, Int), (Char, Attr))]]
undoBuf <- [Int]
-> (Int -> IO [Maybe ((Int, Int), (Char, Attr))])
-> IO [[Maybe ((Int, Int), (Char, Attr))]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Int
widthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO [Maybe ((Int, Int), (Char, Attr))])
 -> IO [[Maybe ((Int, Int), (Char, Attr))]])
-> (Int -> IO [Maybe ((Int, Int), (Char, Attr))])
-> IO [[Maybe ((Int, Int), (Char, Attr))]]
forall a b. (a -> b) -> a -> b
$ \Int
w ->
        [Int]
-> (Int -> IO (Maybe ((Int, Int), (Char, Attr))))
-> IO [Maybe ((Int, Int), (Char, Attr))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO (Maybe ((Int, Int), (Char, Attr))))
 -> IO [Maybe ((Int, Int), (Char, Attr))])
-> (Int -> IO (Maybe ((Int, Int), (Char, Attr))))
-> IO [Maybe ((Int, Int), (Char, Attr))]
forall a b. (a -> b) -> a -> b
$ \Int
h -> do
            let pix :: Word64
pix = (Canvas -> UArray (Int, Int) Word64
immut Canvas
src) UArray (Int, Int) Word64 -> (Int, Int) -> Word64
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
I.! (Int
w, Int
h)
            case Word64
pix Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
blankPixel of
                Bool
True -> do
                    Word64
old <- IOUArray (Int, Int) Word64 -> (Int, Int) -> IO Word64
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
A.readArray (Canvas -> IOUArray (Int, Int) Word64
mut Canvas
dest) (Int
w, Int
h)
                    IOUArray (Int, Int) Word64 -> (Int, Int) -> Word64 -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
A.writeArray (Canvas -> IOUArray (Int, Int) Word64
mut Canvas
dest) (Int
w, Int
h) Word64
pix
                    Maybe ((Int, Int), (Char, Attr))
-> IO (Maybe ((Int, Int), (Char, Attr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ((Int, Int), (Char, Attr))
 -> IO (Maybe ((Int, Int), (Char, Attr))))
-> Maybe ((Int, Int), (Char, Attr))
-> IO (Maybe ((Int, Int), (Char, Attr)))
forall a b. (a -> b) -> a -> b
$ ((Int, Int), (Char, Attr)) -> Maybe ((Int, Int), (Char, Attr))
forall a. a -> Maybe a
Just ((Int
w, Int
h), Word64 -> (Char, Attr)
decodePixel Word64
old)
                Bool
False ->
                    Maybe ((Int, Int), (Char, Attr))
-> IO (Maybe ((Int, Int), (Char, Attr)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ((Int, Int), (Char, Attr))
forall a. Maybe a
Nothing

    UArray (Int, Int) Word64
f <- IOUArray (Int, Int) Word64 -> IO (UArray (Int, Int) Word64)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
A.freeze (IOUArray (Int, Int) Word64 -> IO (UArray (Int, Int) Word64))
-> IOUArray (Int, Int) Word64 -> IO (UArray (Int, Int) Word64)
forall a b. (a -> b) -> a -> b
$ Canvas -> IOUArray (Int, Int) Word64
mut Canvas
dest
    (Canvas, [((Int, Int), (Char, Attr))])
-> IO (Canvas, [((Int, Int), (Char, Attr))])
forall (m :: * -> *) a. Monad m => a -> m a
return (Canvas
dest { immut :: UArray (Int, Int) Word64
immut = UArray (Int, Int) Word64
f }, [Maybe ((Int, Int), (Char, Attr))] -> [((Int, Int), (Char, Attr))]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ((Int, Int), (Char, Attr))]
 -> [((Int, Int), (Char, Attr))])
-> [Maybe ((Int, Int), (Char, Attr))]
-> [((Int, Int), (Char, Attr))]
forall a b. (a -> b) -> a -> b
$ [[Maybe ((Int, Int), (Char, Attr))]]
-> [Maybe ((Int, Int), (Char, Attr))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Maybe ((Int, Int), (Char, Attr))]]
undoBuf)

-- | Create a Vty image from a list of canvas layers, with the topmost
-- layer being the first canvas in the list. A pixel in the final image
-- is set by looking for the first non-blank pixel in the canvas list,
-- starting at the beginning.
--
-- The result will be as high as the least tall input canvas, and as
-- wide as the least wide input canvas.
canvasLayersToImage :: [Canvas] -> V.Image
canvasLayersToImage :: [Canvas] -> Image
canvasLayersToImage [] = Image
V.emptyImage
canvasLayersToImage [Canvas]
cs =
    let sizes :: [(Int, Int)]
sizes = Canvas -> (Int, Int)
canvasSize (Canvas -> (Int, Int)) -> [Canvas] -> [(Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Canvas]
cs
        smallestSize :: (Int, Int)
smallestSize = ( [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Int)]
sizes
                       , [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Int)]
sizes
                       )
        (Int
lastCol, Int
lastRow) = (Int, Int)
smallestSize (Int, Int) -> ((Int, Int) -> (Int, Int)) -> (Int, Int)
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int)
forall s t a b. Each s t a b => Traversal s t a b
each ((Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int))
-> (Int -> Int) -> (Int, Int) -> (Int, Int)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int
forall a. Enum a => a -> a
pred
        rows :: [Image]
rows = Int -> Image
getRow (Int -> Image) -> [Int] -> [Image]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0..Int
lastRow]
        getRow :: Int -> Image
getRow Int
r = [Image] -> Image
V.horizCat ([Image] -> Image) -> [Image] -> Image
forall a b. (a -> b) -> a -> b
$ ((Char -> Attr -> Image) -> (Char, Attr) -> Image
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Char -> Attr -> Image) -> (Char, Attr) -> Image)
-> (Char -> Attr -> Image) -> (Char, Attr) -> Image
forall a b. (a -> b) -> a -> b
$ (Attr -> Char -> Image) -> Char -> Attr -> Image
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Char -> Image
V.char) ((Char, Attr) -> Image) -> (Int -> (Char, Attr)) -> Int -> Image
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> (Char, Attr)
getCol Int
r (Int -> Image) -> [Int] -> [Image]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0..Int
lastCol]
        getCol :: Int -> Int -> (Char, Attr)
getCol Int
r Int
c = [Canvas] -> (Int, Int) -> (Char, Attr)
findPixel [Canvas]
cs (Int
c, Int
r)
    in [Image] -> Image
V.vertCat [Image]
rows

findPixel :: [Canvas] -> (Int, Int) -> (Char, V.Attr)
findPixel :: [Canvas] -> (Int, Int) -> (Char, Attr)
findPixel [] (Int, Int)
_ = String -> (Char, Attr)
forall a. HasCallStack => String -> a
error String
"BUG: canvasLayersToImage got no layers"
findPixel [Canvas
l] (Int, Int)
point = Canvas -> (Int, Int) -> (Char, Attr)
canvasGetPixel Canvas
l (Int, Int)
point
findPixel (Canvas
l:[Canvas]
ls) (Int, Int)
point =
    let pix :: (Char, Attr)
pix = Canvas -> (Int, Int) -> (Char, Attr)
canvasGetPixel Canvas
l (Int, Int)
point
        blank :: (Char, Attr)
blank = Word64 -> (Char, Attr)
decodePixel Word64
blankPixel
    in if (Char, Attr)
pix (Char, Attr) -> (Char, Attr) -> Bool
forall a. Eq a => a -> a -> Bool
== (Char, Attr)
blank
       then [Canvas] -> (Int, Int) -> (Char, Attr)
findPixel [Canvas]
ls (Int, Int)
point
       else (Char, Attr)
pix