Gif.hs

module Codec.Picture.Gif ( ) where

import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Word
import Data.Maybe( fromMaybe )
import Data.List
import Control.Applicative( (<$>), pure )
import Control.Monad( replicateM )
import Data.Bits( (.&.), shiftR, testBit )
import Data.Word( Word8 )
{-import LZW-}
import qualified Data.ByteString as B
import qualified Data.Vector     as V
import Data.Maybe( fromMaybe )

import Data.Serialize( Serialize(..), Get, Put
                     , getWord8, putWord8
                     , getWord16be, putWord16be
                     , remaining, lookAhead, skip
                     , getBytes, decode
                     , encode, putByteString 
                     )

import Codec.Picture.Types

data GifVersion = GIF87a | GIF89a
  deriving (Show, Eq)

-- | Section 18 of spec-gif89a
data ScreenDescriptor = ScreenDescriptor
  { -- | Stored on 16 bits
    screenWidth           :: !Word16
    -- | Stored on 16 bits
  , screenHeight          :: !Word16
    -- | Stored on 8 bits
  , backgroundIndex       :: !Word8

  -- | Stored on 1 bit
  , hasGlobalMap          :: !Bool
  -- | Stored on 3 bits
  , colorResolution       :: !Word8
  -- | Stored on 1 bit
  , isColorTableSorted    :: !Bool
  -- | Stored on 3 bits
  , colorTableSize        :: !Word8
  }
  deriving (Show, Eq)

-- | Section 20 of spec-gif89a
data GifImageDescriptor = GifImageDescriptor
  { gDescPixelsFromLeft         :: !Int
  , gDescPixelsFromTop          :: !Int
  , gDescImageWidth             :: !Int
  , gDescImageHeight            :: !Int
  , gDescHasLocalMap            :: !Bool
  , gDescIsInterlaced           :: !Bool
  , gDescIsImgDescriptorSorted  :: !Bool
  , gDescLocalColorTableSize    :: !Int
  }
  deriving (Show, Eq)

type Palette = V.Vector PixelRGB8

type GifImageData = (GifImageDescriptor, Maybe Palette, Raster)

-- Stelt 1 pixel waarde voor door een index en de bijbehorende colormap
type GifPixel = (Int, Palette)

type Raster = V.Vector (V.Vector GifPixel)

data GifImage = GifImage
  { gifVersion          :: !GifVersion
  , gifScreenDescriptor :: !ScreenDescriptor
  , gifGlobalMap        :: !Palette
  , images              :: [GifImageData]
  }
  deriving (Eq, Show)

gif87aSignature, gif89aSignature :: B.ByteString
gif87aSignature = B.pack "GIF87a" 
gif89aSignature = B.pack "GIF89a"

instance Serialize GifVersion where
    put GIF87a = put gif87aSignature
    put GIF89a = put gif89aSignature 

    get = do
        sig <- getBytes (B.length gif87aSignature)
        case (sig == gif87aSignature, sig == gif89aSignature) of
            (True, _)  -> pure GIF87a
            (_ , True) -> pure GIF89a
            _          -> fail "Invalid Gif signature"
        
-- Add 2 bytes together
lsbAdd :: Integral a => a -> a -> Int
lsbAdd l r = (fromIntegral l) * 0x100 + (fromIntegral r)

(<++>) = lsbAdd

instance Serialize ScreenDescriptor where
    put _ = undefined
    get = do
        w <- getWord16be
        h <- getWord16be
        packedField  <- getWord8
        backgroundColorIndex  <- getWord8
        aspectRatio  <- getWord8
        return ScreenDescriptor
            { screenWidth           = w
            , screenHeight          = h
            , hasGlobalMap          = packedField `testBit` 7
            , colorResolution       = (packedField `shiftR` 5) .&. 0x7 + 1
            , isColorTableSorted    = packedField `testBit` 3
            , colorTableSize        = (packedField .&. 0x7) + 1
            , backgroundIndex       = backgroundColorIndex
            }

colorMap :: Int -> Get Palette
colorMap bits = fmap V.fromList $ replicateM (2 ^ bits) get

imageSeperator, gifTerminator :: Word8
imageSeperator = 0x2c
gifTerminator  = 0x3b


instance Serialize GifImageDescriptor where
    put _ = undefined
    get = do
        imgSeparator <- getWord8
        imgLeftPos <- getWord16be
        imgTopPos  <- getWord16be
        imgWidth   <- getWord16be
        imgHeight  <- getWord16be
        packedFields <- getWord8
        return GifImageDescriptor
            { gDescPixelsFromLeft = imgLeftPos
            , gDescPixelsFromTop  = imgTopPos
            , gDescImageWidth     = imgWidth
            , gDescImageHeight    = imgHeight
            , gDescHasLocalMap    = packedFields `testBit` 7
            , gDescIsInterlaced     = packedFields `testBit` 6
            , gDescIsImgDescriptorSorted = packedFields `testBit` 5
            , gDescLocalColorTableSize = packedFields .&. 0x7 + 1
            }

-- Takes the global color map as an argument
imageParser :: Palette -> Parser Image
imageParser globalMap = do
  descriptor <- imageDescriptor
  localMap   <- if hasLocalMap descriptor
                then Just <$> colorMap (localColorTableSize descriptor)
                else return $ Nothing

  -- the map the raster should use
  let useMap = fromMaybe globalMap localMap
  codeSize   <- fromIntegral <$> anyWord8
  rasterData <- B.concat <$> imageRasterBlock `A.manyTill` zeroImageRaster
  return (descriptor, localMap, parseRaster descriptor (lzwDecode codeSize rasterData) useMap)


imageRasterBlock :: Parser ByteString
imageRasterBlock = do
  byteCount  <- anyWord8
  rasterData <- A.take (fromIntegral byteCount)
  return rasterData

parseRaster :: GifImageDescriptor -> [Int] -> Palette -> Raster
parseRaster ds list cm
  | interlaced ds = undefined
  | otherwise     =
        V.fromList $ map V.fromList $ groupEach (imageWidth ds) $ map (\x -> (x, cm)) list
      where
        groupEach _ [] = []
        groupEach a l  = let (left, right) = splitAt a l
                         in  [left] ++ groupEach a right

gifParser = do
  signature  <- gifSignature
  descriptor <- screenDescriptor
  globalCM   <- colorMap $ screenBitsPerPixel descriptor
  _          <- anyWord8 `A.manyTill` imageSeperator
  images     <- imageParser globalCM `A.sepBy` imageSeperator
  _          <- gifTerminator
  return GifImage
    { gifVersion = signature
    , gifScreenDescriptor = descriptor
    , gifGlobalMap = globalCM
    , images = images
    }