{-# LANGUAGE TemplateHaskell, TypeFamilies, ExistentialQuantification, TypeOperators, ScopedTypeVariables, TupleSections #-}

module Data.Bitmap.StringRGB24A4VR.Internal
    ( BitmapImageString(..)
    , BitmapStringRGB24A4VR(..), bmps_dimensions, bmps_data
    , bytesPerRow
    , bitmapStringBytesPerRow
    , widthPadding
    , encodeIBF_RGB24A4VR'
    , tryIBF_RGB24A4VR'
    , padByte
    , imageSize
    ) where

import Control.Applicative
import Control.Arrow
import Control.Monad.Record                hiding (get)
import Data.Binary
import Data.Bitmap.Class
import Data.Bitmap.Pixel
import Data.Bitmap.Reflectable
import Data.Bitmap.Searchable
import Data.Bitmap.Types
import Data.Bitmap.Util                    hiding (padByte)
import Data.Bits
import qualified Data.ByteString      as B
import qualified Data.Serialize       as S
import qualified Data.String.Class    as S
import Data.Tagged
import Text.Printf

-- | Container for a string that represents a sequence of raw pixels lacking the alpha component and that is stored upside down
data BitmapImageString = forall s. (S.StringCells s) => BitmapImageString {_polyval_bitmapImageString :: s}

instance Eq BitmapImageString where
    a == b = case (a, b) of
        ((BitmapImageString sa), (BitmapImageString sb)) -> S.toStrictByteString sa == S.toStrictByteString sb
    a /= b = case (a, b) of
        ((BitmapImageString sa), (BitmapImageString sb)) -> S.toStrictByteString sa /= S.toStrictByteString sb

-- | A bitmap represented as a string
--
-- This is essentially the format of pixels
-- in the BMP format in which each row is aligned to
-- a four-byte boundry and each row contains a series of
-- RGB pixels.
--
-- This type is most efficient for programs interacting heavily with BMP files.
data BitmapStringRGB24A4VR = BitmapStringRGB24A4VR
    { _bmps_dimensions     :: (Int, Int)         -- ^ Width and height of the bitmap
    , _bmps_data           :: BitmapImageString  -- ^ Data stored in a string
    }

mkLabels [''BitmapStringRGB24A4VR]

instance Binary BitmapStringRGB24A4VR where
    get   = pure BitmapStringRGB24A4VR <*> get <*> (BitmapImageString <$> (get :: Get B.ByteString))
    put b = put (bmps_dimensions <: b) >> put (case bmps_data <: b of (BitmapImageString s) -> S.toLazyByteString s)

instance S.Serialize BitmapStringRGB24A4VR where
    get   = pure BitmapStringRGB24A4VR <*> S.get <*> (BitmapImageString <$> (S.get :: S.Get B.ByteString))
    put b = S.put (bmps_dimensions <: b) >> S.put (case bmps_data <: b of (BitmapImageString s) -> S.toLazyByteString s)

instance Bitmap BitmapStringRGB24A4VR where
    type BIndexType BitmapStringRGB24A4VR = Int
    type BPixelType BitmapStringRGB24A4VR = PixelRGB

    depth = const Depth24RGB

    dimensions = (bmps_dimensions <:)

    getPixel b (row, column) =
        let bytesPixel = 3
            bytesRow   = fst $ bitmapStringBytesPerRow b
            maxRow     = abs . pred . snd . dimensions $ b
            offset     = bytesRow * (maxRow - row) + bytesPixel * column
        in  case bmps_data <: b of
                (BitmapImageString s) ->
                    PixelRGB $ ((fromIntegral . S.toWord8 $ s `S.index` (offset    )) `shiftL` 16) .|.
                               ((fromIntegral . S.toWord8 $ s `S.index` (offset + 1)) `shiftL` 8)  .|.
                               ((fromIntegral . S.toWord8 $ s `S.index` (offset + 2)))

    constructPixels f dms@(width, height) = BitmapStringRGB24A4VR dms . (BitmapImageString :: B.ByteString -> BitmapImageString) $
        S.unfoldrN (imageSize dms) getComponent (0 :: Int, 0 :: Int, 0 :: Int, 0 :: Int)
        where getComponent (row, column, orgb, paddingLeft)
                  | paddingLeft > 0    =
                      Just (padCell, (row, column, orgb, pred paddingLeft))
                  | orgb   > 2         =
                      getComponent (row, succ column, 0, 0)
                  | column > maxColumn =
                      getComponent (succ row, 0, 0, paddingSize)
                  | row    > maxRow    =
                      Nothing
                  | otherwise =
                      let pixel = f (row, column)
                          componentGetter =
                              case orgb of
                                  0 -> untag' . S.toMainChar . (red   <:)
                                  1 -> untag' . S.toMainChar . (green <:)
                                  2 -> untag' . S.toMainChar . (blue  <:)
                                  _ -> undefined
                      in  Just (componentGetter pixel, (row, column, succ orgb, 0))
              maxRow      = abs . pred $ height
              maxColumn   = abs . pred $ width
              paddingSize = snd $ bytesPerRow width 3 4
              padCell     = untag' . S.toMainChar $ padByte
              untag' = untag :: Tagged B.ByteString a -> a

    imageEncoders = updateIdentifiableElements (map (second unwrapGenericBitmapSerializer) defaultImageEncoders) $
        [ (IBF_RGB24A4VR, ImageEncoder $ encodeIBF_RGB24A4VR')
        ]

    imageDecoders = updateIdentifiableElements (map (second unwrapGenericBitmapSerializer) defaultImageDecoders) $
        [ (IBF_RGB24A4VR, ImageDecoder $ tryIBF_RGB24A4VR')
        ]

encodeIBF_RGB24A4VR' :: (S.StringCells s) => BitmapStringRGB24A4VR -> s
encodeIBF_RGB24A4VR' b = case (bmps_data <: b) of (BitmapImageString s) -> S.fromStringCells s

tryIBF_RGB24A4VR' :: (S.StringCells s) => BitmapStringRGB24A4VR -> s -> Either String BitmapStringRGB24A4VR
tryIBF_RGB24A4VR' bmp s
    | S.length s < minLength = Left $ printf "Data.Bitmap.StringRGB24A4VR.Internal.tryIBF_RGB24A4VR': string is too small to contain the pixels of a bitmap with the dimensions of the passed bitmap, which are (%d, %d); the string is %d bytes long, but needs to be at least %d bytes long" (fromIntegral width  :: Integer) (fromIntegral height  :: Integer) (S.length s) minLength
    | otherwise              = Right $
        (bmps_data =: BitmapImageString s) bmp
    where (width, height) = bmps_dimensions <: bmp
          minLength       = imageSize (bmps_dimensions <: bmp)

bitmapStringBytesPerRow :: BitmapStringRGB24A4VR -> (Int, Int)
bitmapStringBytesPerRow b = bytesPerRow (fst $ bmps_dimensions <: b) 3 4

widthPadding :: Int -> String
widthPadding w = replicate (snd $ bytesPerRow w 3 4) $ S.toChar padByte

-- | Return (rowSize, paddingSize) based on width, bytes per pixel, and alignment
bytesPerRow :: Int -> Int -> Int -> (Int, Int)
bytesPerRow width bytes_per_pixel alignment =
    (rawRowSize + off', off')
    where rawRowSize = bytes_per_pixel * width
          off        = rawRowSize `mod` alignment
          off'
              | off == 0  = 0
              | otherwise = alignment - off

padByte :: Word8
padByte = 0x00

imageSize :: Dimensions Int -> Int
imageSize (width, height) = (fst $ bytesPerRow width 3 4) * height

instance BitmapSearchable BitmapStringRGB24A4VR where
    findSubBitmapEqual super sub = case (bmps_data <: super, bmps_data <: sub) of
        ((BitmapImageString dataSuper), (BitmapImageString dataSub)) ->
            let (widthSuper, heightSuper) = bmps_dimensions <: super
                (widthSub,   heightSub)   = bmps_dimensions <: sub
                superBytesPerRow = fst $ bitmapStringBytesPerRow super
                subBytesPerRow   = fst $ bitmapStringBytesPerRow sub
                maxSuperRow      = heightSuper - heightSub
                maxSuperColumn   = widthSuper  - widthSub
                maxOffRow        = abs . pred $ heightSub
                offRowSize       = subBytesPerRow - (snd $ bitmapStringBytesPerRow sub)

                r' (row, column)
                    | column > maxSuperColumn =
                        r' (succ row, 0)
                    | row    > maxSuperRow    =
                        Nothing
                    | matches 0               =
                        Just (maxSuperRow - row, column)
                    | otherwise               =
                        r' (row, succ column)
                    where superBaseIndex = row * superBytesPerRow + 3 * column
                          matches offRow
                              | offRow > maxOffRow
                                  = True
                              | (S.toStringCells :: S.StringCells s => s -> B.ByteString) (subStr (superBaseIndex + offRow * superBytesPerRow) offRowSize dataSuper) /=
                                (S.toStringCells :: S.StringCells s => s -> B.ByteString) (subStr (offRow * subBytesPerRow) offRowSize dataSub)
                                  = False
                              | otherwise
                                  = matches (succ offRow)
            in r'

instance BitmapReflectable BitmapStringRGB24A4VR