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

-- |This type represents the visible cursor state.
data Cursor = NoCursor -- ^ Hide the cursor.
            | Cursor Int Int -- ^ Display the cursor at the given XY position.

-- Gah. GHC can't unbox bitfields itself :(

-- | Opaque data type representing character attributes.
newtype Attr = Attr Int deriving (Eq)

-- | Set the foreground color of an `Attr'.
setFG :: Color -> Attr -> Attr
setFG (Color c) (Attr a) = Attr ((a .&. 0xFFFFFF00) .|. c)

-- | Set the background color of an `Attr'.
setBG :: Color -> Attr -> Attr
setBG (Color c) (Attr a) = Attr ((a .&. 0xFFFF00FF) .|. (c `shiftL` 8))

-- | Set bold attribute of an `Attr'.
setBold :: Attr -> Attr
setBold (Attr a) = Attr (a .|. 0x10000)

-- | Set blink attribute of an `Attr'.
setBlink :: Attr -> Attr
setBlink (Attr a) = Attr (a .|. 0x20000)

-- | Set reverse-video attribute of an `Attr'.
setRV :: Attr -> Attr
setRV (Attr a) = Attr (a .|. 0x40000)

-- | Set half-bright attribute of an `Attr'.
setHalfBright :: Attr -> Attr
setHalfBright (Attr a) = Attr (a .|. 0x80000)

-- | Set underline attribute of an `Attr'.
setUnderline :: Attr -> Attr
setUnderline (Attr a) = Attr (a .|. 0x100000)

-- |'Attr' with all default values.
attr :: Attr
attr = Attr 0x909

-- |Abstract data type representing a color.
newtype Color = Color Int deriving(Eq)

-- FIXME: this assumes a 8-color terminal.
-- |Basic color definitions.
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

-- This uses a somewhat tricky implementation, for efficiency.

-- |A two-dimensional array of (Char,Attr) pairs.
data Image = Image (Int -> Ptr Int -> IO ()) !Int !Int

-- | Access the width of an Image.
imgWidth :: Image -> Int
imgWidth (Image _ w _) = w

-- | Access the height of an Image.
imgHeight :: Image -> Int
imgHeight (Image _ _ h) = h

-- | The empty image.
empty :: Image
empty = Image (\_ _ -> return ()) 0 0

-- | Compose two images side by side.  The images must of the same height,
-- or one must be empty.
(<|>) :: 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"

-- | Compose two images vertically.  The images must of the same width,
-- or one must be empty.
(<->) :: 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"

-- | Helper - fill a buffer segment with a char\/attr.
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)

-- | Compose any number of images horizontally.
horzcat :: [Image] -> Image
horzcat = foldr (<|>) empty

-- | Compose any number of images vertically.
vertcat :: [Image] -> Image
vertcat = foldr (<->) empty

-- | Create an `Image' from a `B.ByteString' with a single uniform `Attr'.
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))

-- | Create a 1x1 image.  Warning, this is likely to be inefficient.
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

-- | Create an image by repeating a single character and attribute horizontally.
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

-- | Create an image by repeating a single character and attribute.
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

-- |The type of images to be displayed using 'update'.  You probably shouldn't
-- create this directly if you care about compatibility with future versions of
-- vty; instead use 'pic' and record update syntax.
data Picture = Pic { -- |The position and visibility status of the virtual
                     -- cursor.
                     pCursor :: Cursor,
                     -- |A 2d array of (character,attribute) pairs, representing
                     -- the screen image.
                     pImage :: Image }

-- |Create a 'Picture' object with all default values.  By using this and record
-- update, rather than directly using the Pic constructor, your code will be
-- compatible with additions to the Picture object. You must specify at least
-- 'pImage'.
pic :: Picture
pic = Pic { pCursor = NoCursor, pImage = error "Pic.pImage not initialized" }