module Graphics.Vty.Types where
import Data.Bits( (.&.), (.|.), shiftL )
import Foreign.Ptr
import Foreign.Storable
import Foreign.C.Types (CChar)
import Foreign.Marshal.Array
import qualified Data.ByteString as B
infixr 5 <|>
infixr 4 <->
data Cursor = NoCursor
| Cursor Int Int
newtype Attr = Attr Int deriving (Eq)
setFG :: Color -> Attr -> Attr
setFG (Color c) (Attr a) = Attr ((a .&. 0xFFFFFF00) .|. c)
setBG :: Color -> Attr -> Attr
setBG (Color c) (Attr a) = Attr ((a .&. 0xFFFF00FF) .|. (c `shiftL` 8))
setBold :: Attr -> Attr
setBold (Attr a) = Attr (a .|. 0x10000)
setBlink :: Attr -> Attr
setBlink (Attr a) = Attr (a .|. 0x20000)
setRV :: Attr -> Attr
setRV (Attr a) = Attr (a .|. 0x40000)
setHalfBright :: Attr -> Attr
setHalfBright (Attr a) = Attr (a .|. 0x80000)
setUnderline :: Attr -> Attr
setUnderline (Attr a) = Attr (a .|. 0x100000)
attr :: Attr
attr = Attr 0x909
newtype Color = Color Int deriving(Eq)
black, red, green, yellow, blue, magenta, cyan, white, def :: Color
black = Color 0 ; red = Color 1 ; green = Color 2 ; yellow = Color 3
blue = Color 4 ; magenta= Color 5 ; cyan = Color 6 ; white = Color 7
def = Color 9
data Image = Image (Int -> Ptr Int -> IO ()) !Int !Int
imgWidth :: Image -> Int
imgWidth (Image _ w _) = w
imgHeight :: Image -> Int
imgHeight (Image _ _ h) = h
empty :: Image
empty = Image (\_ _ -> return ()) 0 0
(<|>) :: Image -> Image -> Image
Image f1 x1 y1 <|> Image f2 x2 y2 | y1 == y2 || x1 == 0 || x2 == 0 =
Image (\stride ptr -> do f1 stride ptr
f2 stride (ptr `plusPtr` ((sizeOf (undefined :: Int) * 2) * x1)))
(x1+x2) (max y1 y2)
_ <|> _ = error "Graphics.Vty.(<|>) : image heights do not match"
(<->) :: Image -> Image -> Image
Image f1 x1 y1 <-> Image f2 x2 y2 | x1 == x2 || y1 == 0 || y2 == 0 =
Image (\stride ptr -> do f1 stride ptr
f2 stride (ptr `plusPtr` (stride * y1)))
(max x1 x2) (y1+y2)
_ <-> _ = error "Graphics.Vty.(<->) : image widths do not match"
fillSeg :: Attr -> Char -> Ptr Int -> Ptr Int -> IO ()
fillSeg (Attr a) ch p1 pe = a `seq` ch `seq` pe `seq` worker p1
where
worker p | p == pe = return ()
| otherwise = do pokeElemOff p 0 a
pokeElemOff p 1 (fromEnum ch)
worker (p `advancePtr` 2)
horzcat :: [Image] -> Image
horzcat = foldr (<|>) empty
vertcat :: [Image] -> Image
vertcat = foldr (<->) empty
renderBS :: Attr -> B.ByteString -> Image
renderBS (Attr a) bs = a `seq` Image (\ _stride ptr -> B.useAsCStringLen bs (worker ptr)) (B.length bs) 1
where
worker :: Ptr Int -> (Ptr CChar, Int) -> IO ()
worker _op (_ip, 0) = return ()
worker op (ip, ct) = do inp <- peek ip
pokeElemOff op 0 a
pokeElemOff op 1 (fromIntegral inp)
worker (op `advancePtr` 2) ((ip `advancePtr` 1), (ct 1))
renderChar :: Attr -> Char -> Image
renderChar (Attr a) ch = a `seq` ch `seq` Image (\ _stride ptr -> pokeElemOff ptr 0 a >> pokeElemOff ptr 1 (fromEnum ch)) 1 1
renderHFill :: Attr -> Char -> Int -> Image
renderHFill _ _ w | w < 0 || w > 10000 = error "renderHFill: bizarre width"
renderHFill a ch w = a `seq` ch `seq` Image (\ _stride ptr -> fillSeg a ch ptr (ptr `advancePtr` (2*w))) w 1
renderFill :: Attr -> Char -> Int -> Int -> Image
renderFill _ _ w _ | w < 0 || w > 10000 = error "renderFill: bizarre width"
renderFill _ _ _ h | h < 0 || h > 10000 = error "renderFill: bizarre height"
renderFill (Attr a) ch w h = a `seq` ch `seq` Image (worker h) w h
where
worker :: Int -> Int -> Ptr Int -> IO ()
worker 0 _stride _ptr = return ()
worker ct stride ptr = do let ptr2 = ptr `advancePtr` (2 * w)
fillSeg (Attr a) ch ptr ptr2
worker (ct 1) stride ptr2
data Picture = Pic {
pCursor :: Cursor,
pImage :: Image }
pic :: Picture
pic = Pic { pCursor = NoCursor, pImage = error "Pic.pImage not initialized" }