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