{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
-- | Module implementing function to read and write

-- Targa (*.tga) files.

module Codec.Picture.Tga( decodeTga
                        , decodeTgaWithMetadata
                        , decodeTgaWithPaletteAndMetadata
                        , TgaSaveable
                        , encodeTga
                        , writeTga
                        )  where

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid( mempty )
import Control.Applicative( (<*>), pure, (<$>) )
#endif

import Control.Arrow( first )
import Control.Monad.ST( ST, runST )
import Data.Bits( (.&.)
                , (.|.)
                , bit
                , testBit
                , setBit
                , unsafeShiftL
                , unsafeShiftR )
import Data.Word( Word8, Word16 )
import Data.Binary( Binary( .. ), encode )
import Data.Binary.Get( Get
                      , getByteString 
                      , getWord8
                      , getWord16le
                      )
import Data.Binary.Put( putWord8
                      , putWord16le
                      , putByteString
                      )

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as Lb
import qualified Data.ByteString.Unsafe as U
import qualified Data.Vector.Storable.Mutable as M

import Codec.Picture.Types
import Codec.Picture.InternalHelper
import Codec.Picture.Metadata( Metadatas
                             , SourceFormat( SourceTGA )
                             , basicMetadata )
import Codec.Picture.VectorByteConversion

data TgaColorMapType
  = ColorMapWithoutTable
  | ColorMapWithTable
  | ColorMapUnknown Word8

instance Binary TgaColorMapType where
  get :: Get TgaColorMapType
get = do
    Word8
v <- Get Word8
getWord8
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Word8
v of
      Word8
0 -> TgaColorMapType
ColorMapWithoutTable
      Word8
1 -> TgaColorMapType
ColorMapWithTable
      Word8
n -> Word8 -> TgaColorMapType
ColorMapUnknown Word8
n

  put :: TgaColorMapType -> Put
put TgaColorMapType
v = case TgaColorMapType
v of
    TgaColorMapType
ColorMapWithoutTable -> Word8 -> Put
putWord8 Word8
0
    TgaColorMapType
ColorMapWithTable -> Word8 -> Put
putWord8 Word8
1
    (ColorMapUnknown Word8
vv) -> Word8 -> Put
putWord8 Word8
vv

data TgaImageType
  = ImageTypeNoData Bool
  | ImageTypeColorMapped Bool
  | ImageTypeTrueColor Bool
  | ImageTypeMonochrome Bool

isRleEncoded :: TgaImageType -> Bool
isRleEncoded :: TgaImageType -> Bool
isRleEncoded TgaImageType
v = case TgaImageType
v of
  ImageTypeNoData      Bool
yn -> Bool
yn
  ImageTypeColorMapped Bool
yn -> Bool
yn
  ImageTypeTrueColor   Bool
yn -> Bool
yn
  ImageTypeMonochrome  Bool
yn -> Bool
yn

imageTypeOfCode :: Word8 -> Get TgaImageType
imageTypeOfCode :: Word8 -> Get TgaImageType
imageTypeOfCode Word8
v = case Word8
v forall a. Bits a => a -> a -> a
.&. Word8
3 of
    Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> TgaImageType
ImageTypeNoData Bool
isEncoded
    Word8
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> TgaImageType
ImageTypeColorMapped Bool
isEncoded
    Word8
2 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> TgaImageType
ImageTypeTrueColor Bool
isEncoded
    Word8
3 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> TgaImageType
ImageTypeMonochrome Bool
isEncoded
    Word8
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unknown TGA image type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
v
  where
    isEncoded :: Bool
isEncoded = forall a. Bits a => a -> Int -> Bool
testBit Word8
v Int
3

codeOfImageType :: TgaImageType -> Word8
codeOfImageType :: TgaImageType -> Word8
codeOfImageType TgaImageType
v = case TgaImageType
v of
    ImageTypeNoData Bool
encoded -> forall {a}. Bits a => a -> Bool -> a
setVal Word8
0 Bool
encoded
    ImageTypeColorMapped Bool
encoded -> forall {a}. Bits a => a -> Bool -> a
setVal Word8
1 Bool
encoded
    ImageTypeTrueColor Bool
encoded -> forall {a}. Bits a => a -> Bool -> a
setVal Word8
2 Bool
encoded
    ImageTypeMonochrome Bool
encoded -> forall {a}. Bits a => a -> Bool -> a
setVal Word8
3 Bool
encoded
    where
      setVal :: a -> Bool -> a
setVal a
vv Bool
True = forall a. Bits a => a -> Int -> a
setBit a
vv Int
3
      setVal a
vv Bool
False = a
vv

instance Binary TgaImageType where
  get :: Get TgaImageType
get = Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get TgaImageType
imageTypeOfCode
  put :: TgaImageType -> Put
put = Word8 -> Put
putWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. TgaImageType -> Word8
codeOfImageType
    
data TgaImageDescription = TgaImageDescription
  { TgaImageDescription -> Bool
_tgaIdXOrigin       :: Bool
  , TgaImageDescription -> Bool
_tgaIdYOrigin       :: Bool
  , TgaImageDescription -> Word8
_tgaIdAttributeBits :: Word8
  }

instance Binary TgaImageDescription where
  put :: TgaImageDescription -> Put
put TgaImageDescription
desc = Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ Word8
xOrig forall a. Bits a => a -> a -> a
.|. Word8
yOrig forall a. Bits a => a -> a -> a
.|. Word8
attr
    where
      xOrig :: Word8
xOrig | TgaImageDescription -> Bool
_tgaIdXOrigin TgaImageDescription
desc = forall a. Bits a => Int -> a
bit Int
4
            | Bool
otherwise = Word8
0

      yOrig :: Word8
yOrig | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ TgaImageDescription -> Bool
_tgaIdYOrigin TgaImageDescription
desc = forall a. Bits a => Int -> a
bit Int
5
            | Bool
otherwise = Word8
0
      
      attr :: Word8
attr = TgaImageDescription -> Word8
_tgaIdAttributeBits TgaImageDescription
desc forall a. Bits a => a -> a -> a
.&. Word8
0xF

  get :: Get TgaImageDescription
get = Word8 -> TgaImageDescription
toDescr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8 where
    toDescr :: Word8 -> TgaImageDescription
toDescr Word8
v = TgaImageDescription
      { _tgaIdXOrigin :: Bool
_tgaIdXOrigin       = forall a. Bits a => a -> Int -> Bool
testBit Word8
v Int
4
      , _tgaIdYOrigin :: Bool
_tgaIdYOrigin       = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> Int -> Bool
testBit Word8
v Int
5
      , _tgaIdAttributeBits :: Word8
_tgaIdAttributeBits = Word8
v forall a. Bits a => a -> a -> a
.&. Word8
0xF
      }

data TgaHeader = TgaHeader
  { TgaHeader -> Word8
_tgaHdrIdLength         :: {-# UNPACK #-} !Word8
  , TgaHeader -> TgaColorMapType
_tgaHdrColorMapType     :: !TgaColorMapType
  , TgaHeader -> TgaImageType
_tgaHdrImageType        :: !TgaImageType
  , TgaHeader -> Word16
_tgaHdrMapStart         :: {-# UNPACK #-} !Word16
  , TgaHeader -> Word16
_tgaHdrMapLength        :: {-# UNPACK #-} !Word16
  , TgaHeader -> Word8
_tgaHdrMapDepth         :: {-# UNPACK #-} !Word8
  , TgaHeader -> Word16
_tgaHdrXOffset          :: {-# UNPACK #-} !Word16
  , TgaHeader -> Word16
_tgaHdrYOffset          :: {-# UNPACK #-} !Word16
  , TgaHeader -> Word16
_tgaHdrWidth            :: {-# UNPACK #-} !Word16
  , TgaHeader -> Word16
_tgaHdrHeight           :: {-# UNPACK #-} !Word16
  , TgaHeader -> Word8
_tgaHdrPixelDepth       :: {-# UNPACK #-} !Word8
  , TgaHeader -> TgaImageDescription
_tgaHdrImageDescription :: {-# UNPACK #-} !TgaImageDescription
  }

instance Binary TgaHeader where
  get :: Get TgaHeader
get = Word8
-> TgaColorMapType
-> TgaImageType
-> Word16
-> Word16
-> Word8
-> Word16
-> Word16
-> Word16
-> Word16
-> Word8
-> TgaImageDescription
-> TgaHeader
TgaHeader
     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
g8 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
g16 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
g16 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
g8
     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
g16 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
g16 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
g16 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
g16 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
g8 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get
   where g16 :: Get Word16
g16 = Get Word16
getWord16le
         g8 :: Get Word8
g8 = Get Word8
getWord8

  put :: TgaHeader -> Put
put TgaHeader
v = do
    let p8 :: Word8 -> Put
p8 = Word8 -> Put
putWord8
        p16 :: Word16 -> Put
p16 = Word16 -> Put
putWord16le
    Word8 -> Put
p8  forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word8
_tgaHdrIdLength TgaHeader
v
    forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ TgaHeader -> TgaColorMapType
_tgaHdrColorMapType TgaHeader
v
    forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ TgaHeader -> TgaImageType
_tgaHdrImageType TgaHeader
v

    Word16 -> Put
p16 forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrMapStart TgaHeader
v
    Word16 -> Put
p16 forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrMapLength TgaHeader
v
    Word8 -> Put
p8  forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word8
_tgaHdrMapDepth TgaHeader
v
    Word16 -> Put
p16 forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrXOffset TgaHeader
v
    Word16 -> Put
p16 forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrYOffset TgaHeader
v
    Word16 -> Put
p16 forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrWidth TgaHeader
v
    Word16 -> Put
p16 forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrHeight TgaHeader
v
    Word8 -> Put
p8  forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word8
_tgaHdrPixelDepth TgaHeader
v
    forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ TgaHeader -> TgaImageDescription
_tgaHdrImageDescription TgaHeader
v


data TgaFile = TgaFile
  { TgaFile -> TgaHeader
_tgaFileHeader :: !TgaHeader
  , TgaFile -> ByteString
_tgaFileId     :: !B.ByteString
  , TgaFile -> ByteString
_tgaPalette    :: !B.ByteString
  , TgaFile -> ByteString
_tgaFileRest   :: !B.ByteString
  }

getPalette :: TgaHeader -> Get B.ByteString
getPalette :: TgaHeader -> Get ByteString
getPalette TgaHeader
hdr | TgaHeader -> Word16
_tgaHdrMapLength TgaHeader
hdr forall a. Ord a => a -> a -> Bool
<= Word16
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
getPalette TgaHeader
hdr = Int -> Get ByteString
getByteString forall a b. (a -> b) -> a -> b
$ Int
bytePerPixel forall a. Num a => a -> a -> a
* Int
pixelCount
  where
    bytePerPixel :: Int
bytePerPixel = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word8
_tgaHdrMapDepth TgaHeader
hdr forall a. Integral a => a -> a -> a
`div` Word8
8
    pixelCount :: Int
pixelCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrMapLength TgaHeader
hdr

instance Binary TgaFile where
  get :: Get TgaFile
get = do
    TgaHeader
hdr <- forall t. Binary t => Get t
get
    TgaHeader -> Get ()
validateTga TgaHeader
hdr
    ByteString
fileId <- Int -> Get ByteString
getByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word8
_tgaHdrIdLength TgaHeader
hdr
    ByteString
palette <- TgaHeader -> Get ByteString
getPalette TgaHeader
hdr
    ByteString
rest <- Get ByteString
getRemainingBytes

    forall (m :: * -> *) a. Monad m => a -> m a
return TgaFile {
        _tgaFileHeader :: TgaHeader
_tgaFileHeader = TgaHeader
hdr
      , _tgaFileId :: ByteString
_tgaFileId = ByteString
fileId
      , _tgaPalette :: ByteString
_tgaPalette = ByteString
palette
      , _tgaFileRest :: ByteString
_tgaFileRest = ByteString
rest
      }

  put :: TgaFile -> Put
put TgaFile
file = do
    forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ TgaFile -> TgaHeader
_tgaFileHeader TgaFile
file
    ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ TgaFile -> ByteString
_tgaFileId TgaFile
file
    ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ TgaFile -> ByteString
_tgaPalette TgaFile
file
    ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ TgaFile -> ByteString
_tgaFileRest TgaFile
file

data Depth8 = Depth8
data Depth15 = Depth15
data Depth24 = Depth24
data Depth32 = Depth32

class (Pixel (Unpacked a)) => TGAPixel a where
   type Unpacked a
   packedByteSize :: a -> Int
   tgaUnpack      :: a -> B.ByteString -> Int -> Unpacked a

instance TGAPixel Depth8 where
   type Unpacked Depth8 = Pixel8
   packedByteSize :: Depth8 -> Int
packedByteSize Depth8
_ = Int
1
   tgaUnpack :: Depth8 -> ByteString -> Int -> Unpacked Depth8
tgaUnpack Depth8
_ = ByteString -> Int -> Word8
U.unsafeIndex

instance TGAPixel Depth15 where
   type Unpacked Depth15 = PixelRGBA8
   packedByteSize :: Depth15 -> Int
packedByteSize Depth15
_ = Int
2
   tgaUnpack :: Depth15 -> ByteString -> Int -> Unpacked Depth15
tgaUnpack Depth15
_ ByteString
str Int
ix = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b Word8
a
      where
        v0 :: Word8
v0 = ByteString -> Int -> Word8
U.unsafeIndex ByteString
str Int
ix
        v1 :: Word8
v1 = ByteString -> Int -> Word8
U.unsafeIndex ByteString
str forall a b. (a -> b) -> a -> b
$ Int
ix forall a. Num a => a -> a -> a
+ Int
1
        r :: Word8
r = (Word8
v1 forall a. Bits a => a -> a -> a
.&. Word8
0x7c) forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1;
        g :: Word8
g = ((Word8
v1 forall a. Bits a => a -> a -> a
.&. Word8
0x03) forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
6) forall a. Bits a => a -> a -> a
.|. ((Word8
v0 forall a. Bits a => a -> a -> a
.&. Word8
0xe0) forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2);
        b :: Word8
b = (Word8
v0 forall a. Bits a => a -> a -> a
.&. Word8
0x1f) forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
3
        a :: Word8
a = Word8
255 -- v1 .&. 0x80


instance TGAPixel Depth24 where
   type Unpacked Depth24 = PixelRGB8
   packedByteSize :: Depth24 -> Int
packedByteSize Depth24
_ = Int
3
   tgaUnpack :: Depth24 -> ByteString -> Int -> Unpacked Depth24
tgaUnpack Depth24
_ ByteString
str Int
ix = Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 Word8
r Word8
g Word8
b
     where
       b :: Word8
b = ByteString -> Int -> Word8
U.unsafeIndex ByteString
str Int
ix
       g :: Word8
g = ByteString -> Int -> Word8
U.unsafeIndex ByteString
str (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
       r :: Word8
r = ByteString -> Int -> Word8
U.unsafeIndex ByteString
str (Int
ix forall a. Num a => a -> a -> a
+ Int
2)

instance TGAPixel Depth32 where
   type Unpacked Depth32 = PixelRGBA8
   packedByteSize :: Depth32 -> Int
packedByteSize Depth32
_ = Int
4
   tgaUnpack :: Depth32 -> ByteString -> Int -> Unpacked Depth32
tgaUnpack Depth32
_ ByteString
str Int
ix = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b Word8
a
     where
       b :: Word8
b = ByteString -> Int -> Word8
U.unsafeIndex ByteString
str Int
ix
       g :: Word8
g = ByteString -> Int -> Word8
U.unsafeIndex ByteString
str (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
       r :: Word8
r = ByteString -> Int -> Word8
U.unsafeIndex ByteString
str (Int
ix forall a. Num a => a -> a -> a
+ Int
2)
       a :: Word8
a = ByteString -> Int -> Word8
U.unsafeIndex ByteString
str (Int
ix forall a. Num a => a -> a -> a
+ Int
3)

prepareUnpacker :: TgaFile
                -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx))
                -> Either String DynamicImage
prepareUnpacker :: TgaFile
-> (forall tgapx.
    TGAPixel tgapx =>
    tgapx -> TgaFile -> Image (Unpacked tgapx))
-> Either String DynamicImage
prepareUnpacker TgaFile
file forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
f =
  let hdr :: TgaHeader
hdr = TgaFile -> TgaHeader
_tgaFileHeader TgaFile
file
      flipper :: (Pixel px) => Image px -> Image px
      flipper :: forall px. Pixel px => Image px -> Image px
flipper = forall px. Pixel px => TgaImageDescription -> Image px -> Image px
flipImage forall a b. (a -> b) -> a -> b
$ TgaHeader -> TgaImageDescription
_tgaHdrImageDescription TgaHeader
hdr
  in
  case TgaHeader -> Word8
_tgaHdrPixelDepth TgaHeader
hdr of
    Word8
8  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Word8 -> DynamicImage
ImageY8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall px. Pixel px => Image px -> Image px
flipper forall a b. (a -> b) -> a -> b
$ forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
f Depth8
Depth8 TgaFile
file
    Word8
16 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> DynamicImage
ImageRGBA8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall px. Pixel px => Image px -> Image px
flipper forall a b. (a -> b) -> a -> b
$ forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
f Depth15
Depth15 TgaFile
file
    Word8
24 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall px. Pixel px => Image px -> Image px
flipper forall a b. (a -> b) -> a -> b
$ forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
f Depth24
Depth24 TgaFile
file
    Word8
32 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> DynamicImage
ImageRGBA8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall px. Pixel px => Image px -> Image px
flipper forall a b. (a -> b) -> a -> b
$ forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
f Depth32
Depth32 TgaFile
file
    Word8
n  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Invalid bit depth (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
n forall a. [a] -> [a] -> [a]
++ String
")"

toPaletted :: (Pixel px)
           => (Image Pixel8 -> Palette' px -> PalettedImage) -> Image px
           -> DynamicImage
           -> Either String PalettedImage
toPaletted :: forall px.
Pixel px =>
(Image Word8 -> Palette' px -> PalettedImage)
-> Image px -> DynamicImage -> Either String PalettedImage
toPaletted Image Word8 -> Palette' px -> PalettedImage
f Image px
palette (ImageY8 Image Word8
img) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Image Word8 -> Palette' px -> PalettedImage
f Image Word8
img Palette' px
pal where
  pal :: Palette' px
pal = Palette' 
    { _paletteSize :: Int
_paletteSize = forall a. Image a -> Int
imageWidth Image px
palette
    , _paletteData :: Vector (PixelBaseComponent px)
_paletteData = forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image px
palette
    }
toPaletted Image Word8 -> Palette' px -> PalettedImage
_ Image px
_ DynamicImage
_ = forall a b. a -> Either a b
Left String
"Bad colorspace for image"

unparse :: TgaFile -> Either String (PalettedImage, Metadatas)
unparse :: TgaFile -> Either String (PalettedImage, Metadatas)
unparse TgaFile
file =
  let hdr :: TgaHeader
hdr = TgaFile -> TgaHeader
_tgaFileHeader TgaFile
file
      imageType :: TgaImageType
imageType = TgaHeader -> TgaImageType
_tgaHdrImageType TgaHeader
hdr

      unpacker :: forall tgapx. (TGAPixel tgapx)
               => tgapx -> TgaFile -> Image (Unpacked tgapx)
      unpacker :: forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpacker | TgaImageType -> Bool
isRleEncoded TgaImageType
imageType = forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpackRLETga
               | Bool
otherwise = forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpackUncompressedTga

      metas :: Metadatas
metas = forall nSize.
Integral nSize =>
SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
SourceTGA (TgaHeader -> Word16
_tgaHdrWidth TgaHeader
hdr) (TgaHeader -> Word16
_tgaHdrHeight TgaHeader
hdr)
      decodedPalette :: Either String (PalettedImage, Metadatas)
decodedPalette = TgaFile -> Either String (PalettedImage, Metadatas)
unparse TgaFile
file
        { _tgaFileHeader :: TgaHeader
_tgaFileHeader = TgaHeader
hdr
            { _tgaHdrHeight :: Word16
_tgaHdrHeight = Word16
1
            , _tgaHdrWidth :: Word16
_tgaHdrWidth = TgaHeader -> Word16
_tgaHdrMapLength TgaHeader
hdr
            , _tgaHdrPixelDepth :: Word8
_tgaHdrPixelDepth = TgaHeader -> Word8
_tgaHdrMapDepth TgaHeader
hdr
            , _tgaHdrImageType :: TgaImageType
_tgaHdrImageType = Bool -> TgaImageType
ImageTypeTrueColor Bool
False
            }
        , _tgaFileRest :: ByteString
_tgaFileRest = TgaFile -> ByteString
_tgaPalette TgaFile
file
        }
  in
  case TgaImageType
imageType of
    ImageTypeNoData Bool
_ -> forall a b. a -> Either a b
Left String
"No data detected in TGA file"
    ImageTypeTrueColor Bool
_ ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((, Metadatas
metas) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage) forall a b. (a -> b) -> a -> b
$ TgaFile
-> (forall tgapx.
    TGAPixel tgapx =>
    tgapx -> TgaFile -> Image (Unpacked tgapx))
-> Either String DynamicImage
prepareUnpacker TgaFile
file forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpacker
    ImageTypeMonochrome Bool
_ ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((, Metadatas
metas) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage) forall a b. (a -> b) -> a -> b
$ TgaFile
-> (forall tgapx.
    TGAPixel tgapx =>
    tgapx -> TgaFile -> Image (Unpacked tgapx))
-> Either String DynamicImage
prepareUnpacker TgaFile
file forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpacker
    ImageTypeColorMapped Bool
_ ->
      case Either String (PalettedImage, Metadatas)
decodedPalette of
        Left String
str -> forall a b. a -> Either a b
Left String
str
        Right (TrueColorImage (ImageY8 Image Word8
img), Metadatas
_) ->
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Metadatas
metas) forall a b. (a -> b) -> a -> b
$ TgaFile
-> (forall tgapx.
    TGAPixel tgapx =>
    tgapx -> TgaFile -> Image (Unpacked tgapx))
-> Either String DynamicImage
prepareUnpacker TgaFile
file forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpacker forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall px.
Pixel px =>
(Image Word8 -> Palette' px -> PalettedImage)
-> Image px -> DynamicImage -> Either String PalettedImage
toPaletted Image Word8 -> Palette' Word8 -> PalettedImage
PalettedY8 Image Word8
img
        Right (TrueColorImage (ImageRGB8 Image PixelRGB8
img), Metadatas
_) ->
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Metadatas
metas) forall a b. (a -> b) -> a -> b
$ TgaFile
-> (forall tgapx.
    TGAPixel tgapx =>
    tgapx -> TgaFile -> Image (Unpacked tgapx))
-> Either String DynamicImage
prepareUnpacker TgaFile
file forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpacker forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall px.
Pixel px =>
(Image Word8 -> Palette' px -> PalettedImage)
-> Image px -> DynamicImage -> Either String PalettedImage
toPaletted Image Word8 -> Palette' PixelRGB8 -> PalettedImage
PalettedRGB8 Image PixelRGB8
img
        Right (TrueColorImage (ImageRGBA8 Image PixelRGBA8
img), Metadatas
_) ->
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Metadatas
metas) forall a b. (a -> b) -> a -> b
$ TgaFile
-> (forall tgapx.
    TGAPixel tgapx =>
    tgapx -> TgaFile -> Image (Unpacked tgapx))
-> Either String DynamicImage
prepareUnpacker TgaFile
file forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpacker forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall px.
Pixel px =>
(Image Word8 -> Palette' px -> PalettedImage)
-> Image px -> DynamicImage -> Either String PalettedImage
toPaletted Image Word8 -> Palette' PixelRGBA8 -> PalettedImage
PalettedRGBA8 Image PixelRGBA8
img
        Right (PalettedImage, Metadatas)
_ -> forall a b. a -> Either a b
Left String
"Unknown pixel type"

writeRun :: (Pixel px)
         => M.STVector s (PixelBaseComponent px) -> Int -> px -> Int
         -> ST s Int
writeRun :: forall px s.
Pixel px =>
STVector s (PixelBaseComponent px) -> Int -> px -> Int -> ST s Int
writeRun STVector s (PixelBaseComponent px)
imgData Int
localMaxi px
px = Int -> ST s Int
run
  where
    writeDelta :: Int
writeDelta = forall a. Pixel a => a -> Int
componentCount px
px
    run :: Int -> ST s Int
run Int
writeIndex 
      | Int
writeIndex forall a. Ord a => a -> a -> Bool
>= Int
localMaxi = forall (m :: * -> *) a. Monad m => a -> m a
return Int
writeIndex
    run Int
writeIndex = do
      forall a (m :: * -> *).
(Pixel a, PrimMonad m) =>
STVector (PrimState m) (PixelBaseComponent a) -> Int -> a -> m ()
unsafeWritePixel STVector s (PixelBaseComponent px)
imgData Int
writeIndex px
px
      Int -> ST s Int
run forall a b. (a -> b) -> a -> b
$ Int
writeIndex forall a. Num a => a -> a -> a
+ Int
writeDelta

copyData :: forall tgapx s
          . (TGAPixel tgapx)
         => tgapx
         -> M.STVector s (PixelBaseComponent (Unpacked tgapx))
         -> B.ByteString
         -> Int -> Int
         -> Int -> Int
         -> ST s (Int, Int)
copyData :: forall tgapx s.
TGAPixel tgapx =>
tgapx
-> STVector s (PixelBaseComponent (Unpacked tgapx))
-> ByteString
-> Int
-> Int
-> Int
-> Int
-> ST s (Int, Int)
copyData tgapx
tgapx STVector s (PixelBaseComponent (Unpacked tgapx))
imgData ByteString
readData Int
maxi Int
maxRead = Int -> Int -> ST s (Int, Int)
go
  where
    readDelta :: Int
readDelta = forall a. TGAPixel a => a -> Int
packedByteSize tgapx
tgapx
    writeDelta :: Int
writeDelta = forall a. Pixel a => a -> Int
componentCount (forall a. HasCallStack => a
undefined :: Unpacked tgapx)

    go :: Int -> Int -> ST s (Int, Int)
go Int
writeIndex Int
readIndex
      | Int
writeIndex forall a. Ord a => a -> a -> Bool
>= Int
maxi Bool -> Bool -> Bool
||
        Int
readIndex forall a. Ord a => a -> a -> Bool
>= Int
maxRead = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
writeIndex, Int
readIndex)
    go Int
writeIndex Int
readIndex = do
      let px :: Unpacked tgapx
px = forall a. TGAPixel a => a -> ByteString -> Int -> Unpacked a
tgaUnpack tgapx
tgapx ByteString
readData Int
readIndex :: Unpacked tgapx
      forall a (m :: * -> *).
(Pixel a, PrimMonad m) =>
STVector (PrimState m) (PixelBaseComponent a) -> Int -> a -> m ()
unsafeWritePixel STVector s (PixelBaseComponent (Unpacked tgapx))
imgData Int
writeIndex Unpacked tgapx
px
      Int -> Int -> ST s (Int, Int)
go (Int
writeIndex forall a. Num a => a -> a -> a
+ Int
writeDelta) (Int
readIndex forall a. Num a => a -> a -> a
+ Int
readDelta)

unpackUncompressedTga :: forall tgapx
                       . (TGAPixel tgapx)
                      => tgapx -- ^ Type witness

                      -> TgaFile
                      -> Image (Unpacked tgapx)
unpackUncompressedTga :: forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpackUncompressedTga tgapx
tga TgaFile
file = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    MutableImage s (Unpacked tgapx)
img <- forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
MutableImage Int
width Int
height forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
maxi
    let imgData :: STVector s (PixelBaseComponent (Unpacked tgapx))
imgData = forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData MutableImage s (Unpacked tgapx)
img
    (Int, Int)
_ <- forall tgapx s.
TGAPixel tgapx =>
tgapx
-> STVector s (PixelBaseComponent (Unpacked tgapx))
-> ByteString
-> Int
-> Int
-> Int
-> Int
-> ST s (Int, Int)
copyData tgapx
tga STVector s (PixelBaseComponent (Unpacked tgapx))
imgData ByteString
readData Int
maxi Int
maxRead Int
0 Int
0
    forall a (m :: * -> *).
(Storable (PixelBaseComponent a), PrimMonad m) =>
MutableImage (PrimState m) a -> m (Image a)
unsafeFreezeImage MutableImage s (Unpacked tgapx)
img

  where
    hdr :: TgaHeader
hdr = TgaFile -> TgaHeader
_tgaFileHeader TgaFile
file
    width :: Int
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrWidth TgaHeader
hdr
    height :: Int
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrHeight TgaHeader
hdr
    readData :: ByteString
readData = TgaFile -> ByteString
_tgaFileRest TgaFile
file
    compCount :: Int
compCount = forall a. Pixel a => a -> Int
componentCount (forall a. HasCallStack => a
undefined :: Unpacked tgapx)
    maxi :: Int
maxi = Int
width forall a. Num a => a -> a -> a
* Int
height forall a. Num a => a -> a -> a
* Int
compCount
    maxRead :: Int
maxRead = ByteString -> Int
B.length ByteString
readData

isRleChunk :: Word8 -> Bool
isRleChunk :: Word8 -> Bool
isRleChunk Word8
v = forall a. Bits a => a -> Int -> Bool
testBit Word8
v Int
7

runLength :: Word8 -> Int
runLength :: Word8 -> Int
runLength Word8
v = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
v forall a. Bits a => a -> a -> a
.&. Word8
0x7F) forall a. Num a => a -> a -> a
+ Int
1

unpackRLETga :: forall tgapx
              . (TGAPixel tgapx)
             => tgapx -- ^ Type witness

             -> TgaFile
             -> Image (Unpacked tgapx)
unpackRLETga :: forall tgapx.
TGAPixel tgapx =>
tgapx -> TgaFile -> Image (Unpacked tgapx)
unpackRLETga tgapx
tga TgaFile
file = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    MutableImage s (Unpacked tgapx)
img <- forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
MutableImage Int
width Int
height forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
maxi
    let imgData :: STVector s (PixelBaseComponent (Unpacked tgapx))
imgData = forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData MutableImage s (Unpacked tgapx)
img

        go :: Int -> Int -> ST s ()
go Int
writeIndex Int
readIndex
            | Int
writeIndex forall a. Ord a => a -> a -> Bool
>= Int
maxi = forall (m :: * -> *) a. Monad m => a -> m a
return () 
            | Int
readIndex forall a. Ord a => a -> a -> Bool
>= Int
maxRead = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go Int
writeIndex Int
readIndex = do
          let code :: Word8
code = ByteString -> Int -> Word8
U.unsafeIndex ByteString
readData Int
readIndex
              copyMax :: Int
copyMax = forall a. Ord a => a -> a -> a
min Int
maxi forall a b. (a -> b) -> a -> b
$ Int
writeIndex forall a. Num a => a -> a -> a
+ Word8 -> Int
runLength Word8
code forall a. Num a => a -> a -> a
* Int
compCount
          
          if Word8 -> Bool
isRleChunk Word8
code then do
            let px :: Unpacked tgapx
px = forall a. TGAPixel a => a -> ByteString -> Int -> Unpacked a
tgaUnpack tgapx
tga ByteString
readData (Int
readIndex forall a. Num a => a -> a -> a
+ Int
1) :: Unpacked tgapx
            Int
lastWriteIndex <- forall px s.
Pixel px =>
STVector s (PixelBaseComponent px) -> Int -> px -> Int -> ST s Int
writeRun STVector s (PixelBaseComponent (Unpacked tgapx))
imgData Int
copyMax Unpacked tgapx
px Int
writeIndex
            Int -> Int -> ST s ()
go Int
lastWriteIndex forall a b. (a -> b) -> a -> b
$ Int
readIndex forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ Int
readDelta

          else do
            (Int
newWrite, Int
newRead) <-
                forall tgapx s.
TGAPixel tgapx =>
tgapx
-> STVector s (PixelBaseComponent (Unpacked tgapx))
-> ByteString
-> Int
-> Int
-> Int
-> Int
-> ST s (Int, Int)
copyData tgapx
tga STVector s (PixelBaseComponent (Unpacked tgapx))
imgData ByteString
readData Int
copyMax Int
maxRead
                    Int
writeIndex (Int
readIndex forall a. Num a => a -> a -> a
+ Int
1)
            Int -> Int -> ST s ()
go Int
newWrite Int
newRead

    Int -> Int -> ST s ()
go Int
0 Int
0
    forall a (m :: * -> *).
(Storable (PixelBaseComponent a), PrimMonad m) =>
MutableImage (PrimState m) a -> m (Image a)
unsafeFreezeImage MutableImage s (Unpacked tgapx)
img

  where
    hdr :: TgaHeader
hdr = TgaFile -> TgaHeader
_tgaFileHeader TgaFile
file
    width :: Int
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrWidth TgaHeader
hdr
    height :: Int
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TgaHeader -> Word16
_tgaHdrHeight TgaHeader
hdr
    readData :: ByteString
readData = TgaFile -> ByteString
_tgaFileRest TgaFile
file
    compCount :: Int
compCount = forall a. Pixel a => a -> Int
componentCount (forall a. HasCallStack => a
undefined :: Unpacked tgapx)
    maxi :: Int
maxi = Int
width forall a. Num a => a -> a -> a
* Int
height forall a. Num a => a -> a -> a
* Int
compCount
    maxRead :: Int
maxRead = ByteString -> Int
B.length ByteString
readData
    readDelta :: Int
readDelta = forall a. TGAPixel a => a -> Int
packedByteSize tgapx
tga

flipImage :: (Pixel px)
          => TgaImageDescription -> Image px -> Image px
flipImage :: forall px. Pixel px => TgaImageDescription -> Image px -> Image px
flipImage TgaImageDescription
desc Image px
img
    | Bool
xFlip Bool -> Bool -> Bool
&& Bool
yFlip =
        forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (\Int
x Int
y -> forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image px
img (Int
wMax forall a. Num a => a -> a -> a
- Int
x) (Int
hMax forall a. Num a => a -> a -> a
- Int
y)) Int
w Int
h
    | Bool
xFlip =
        forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (\Int
x Int
y -> forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image px
img (Int
wMax forall a. Num a => a -> a -> a
- Int
x) Int
y) Int
w Int
h
    | Bool
yFlip =
        forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (\Int
x Int
y -> forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image px
img Int
x (Int
hMax forall a. Num a => a -> a -> a
- Int
y)) Int
w Int
h
    | Bool
otherwise = Image px
img
  where
    xFlip :: Bool
xFlip = TgaImageDescription -> Bool
_tgaIdXOrigin TgaImageDescription
desc
    yFlip :: Bool
yFlip = TgaImageDescription -> Bool
_tgaIdYOrigin TgaImageDescription
desc
    w :: Int
w = forall a. Image a -> Int
imageWidth Image px
img
    h :: Int
h = forall a. Image a -> Int
imageHeight Image px
img

    !wMax :: Int
wMax = Int
w forall a. Num a => a -> a -> a
- Int
1
    !hMax :: Int
hMax = Int
h forall a. Num a => a -> a -> a
- Int
1

validateTga :: TgaHeader -> Get ()
validateTga :: TgaHeader -> Get ()
validateTga TgaHeader
hdr
    | TgaHeader -> Word16
_tgaHdrWidth TgaHeader
hdr forall a. Ord a => a -> a -> Bool
<= Word16
0 = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Width is null or negative"
    | TgaHeader -> Word16
_tgaHdrHeight TgaHeader
hdr forall a. Ord a => a -> a -> Bool
<= Word16
0 = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Height is null or negative"
validateTga TgaHeader
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Transform a raw tga image to an image, without modifying

-- the underlying pixel type.

--

-- This function can output the following images:

--

--  * 'ImageY8'

--

--  * 'ImageRGB8'

--

--  * 'ImageRGBA8'

--

decodeTga :: B.ByteString -> Either String DynamicImage
decodeTga :: ByteString -> Either String DynamicImage
decodeTga ByteString
byte = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String (DynamicImage, Metadatas)
decodeTgaWithMetadata ByteString
byte

-- | Equivalent to decodeTga but also provide metadata

decodeTgaWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
decodeTgaWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
decodeTgaWithMetadata ByteString
byte = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first PalettedImage -> DynamicImage
palettedToTrueColor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String (PalettedImage, Metadatas)
decodeTgaWithPaletteAndMetadata ByteString
byte

-- | Equivalent to decodeTga but with metdata and palette if any

decodeTgaWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
decodeTgaWithPaletteAndMetadata :: ByteString -> Either String (PalettedImage, Metadatas)
decodeTgaWithPaletteAndMetadata ByteString
byte = forall a. Get a -> ByteString -> Either String a
runGetStrict forall t. Binary t => Get t
get ByteString
byte forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TgaFile -> Either String (PalettedImage, Metadatas)
unparse

-- | This typeclass determine if a pixel can be saved in the

-- TGA format.

class TgaSaveable a where
    tgaDataOfImage :: Image a -> B.ByteString
    tgaPixelDepthOfImage :: Image a -> Word8
    tgaTypeOfImage :: Image a -> TgaImageType

instance TgaSaveable Pixel8 where
    tgaDataOfImage :: Image Word8 -> ByteString
tgaDataOfImage = forall a. Storable a => Vector a -> ByteString
toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Image a -> Vector (PixelBaseComponent a)
imageData
    tgaPixelDepthOfImage :: Image Word8 -> Word8
tgaPixelDepthOfImage Image Word8
_ = Word8
8
    tgaTypeOfImage :: Image Word8 -> TgaImageType
tgaTypeOfImage Image Word8
_ = Bool -> TgaImageType
ImageTypeMonochrome Bool
False

instance TgaSaveable PixelRGB8 where
    tgaPixelDepthOfImage :: Image PixelRGB8 -> Word8
tgaPixelDepthOfImage Image PixelRGB8
_ = Word8
24
    tgaTypeOfImage :: Image PixelRGB8 -> TgaImageType
tgaTypeOfImage Image PixelRGB8
_ = Bool -> TgaImageType
ImageTypeTrueColor Bool
False
    tgaDataOfImage :: Image PixelRGB8 -> ByteString
tgaDataOfImage = forall a. Storable a => Vector a -> ByteString
toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Image a -> Vector (PixelBaseComponent a)
imageData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGB8 -> PixelRGB8
flipRgb
      where
        flipRgb :: PixelRGB8 -> PixelRGB8
flipRgb (PixelRGB8 Word8
r Word8
g Word8
b) = Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 Word8
b Word8
g Word8
r

instance TgaSaveable PixelRGBA8 where
    tgaPixelDepthOfImage :: Image PixelRGBA8 -> Word8
tgaPixelDepthOfImage Image PixelRGBA8
_ = Word8
32
    tgaTypeOfImage :: Image PixelRGBA8 -> TgaImageType
tgaTypeOfImage Image PixelRGBA8
_ = Bool -> TgaImageType
ImageTypeTrueColor Bool
False
    tgaDataOfImage :: Image PixelRGBA8 -> ByteString
tgaDataOfImage = forall a. Storable a => Vector a -> ByteString
toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Image a -> Vector (PixelBaseComponent a)
imageData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGBA8 -> PixelRGBA8
flipRgba
      where
        flipRgba :: PixelRGBA8 -> PixelRGBA8
flipRgba (PixelRGBA8 Word8
r Word8
g Word8
b Word8
a) = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
b Word8
g Word8
r Word8
a

-- | Helper function to directly write an image a tga on disk.

writeTga :: (TgaSaveable pixel) => FilePath -> Image pixel -> IO ()
writeTga :: forall pixel. TgaSaveable pixel => String -> Image pixel -> IO ()
writeTga String
path Image pixel
img = String -> ByteString -> IO ()
Lb.writeFile String
path forall a b. (a -> b) -> a -> b
$ forall px. TgaSaveable px => Image px -> ByteString
encodeTga Image pixel
img

-- | Transform a compatible image to a raw bytestring

-- representing a Targa file.

encodeTga :: (TgaSaveable px) => Image px -> Lb.ByteString
encodeTga :: forall px. TgaSaveable px => Image px -> ByteString
encodeTga Image px
img = forall a. Binary a => a -> ByteString
encode TgaFile
file
  where
    file :: TgaFile
file = TgaFile
      { _tgaFileHeader :: TgaHeader
_tgaFileHeader = TgaHeader
            { _tgaHdrIdLength :: Word8
_tgaHdrIdLength         = Word8
0
            , _tgaHdrColorMapType :: TgaColorMapType
_tgaHdrColorMapType     = TgaColorMapType
ColorMapWithoutTable
            , _tgaHdrImageType :: TgaImageType
_tgaHdrImageType        = forall a. TgaSaveable a => Image a -> TgaImageType
tgaTypeOfImage Image px
img
            , _tgaHdrMapStart :: Word16
_tgaHdrMapStart         = Word16
0
            , _tgaHdrMapLength :: Word16
_tgaHdrMapLength        = Word16
0
            , _tgaHdrMapDepth :: Word8
_tgaHdrMapDepth         = Word8
0
            , _tgaHdrXOffset :: Word16
_tgaHdrXOffset          = Word16
0
            , _tgaHdrYOffset :: Word16
_tgaHdrYOffset          = Word16
0
            , _tgaHdrWidth :: Word16
_tgaHdrWidth            = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
imageWidth Image px
img
            , _tgaHdrHeight :: Word16
_tgaHdrHeight           = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
imageHeight Image px
img
            , _tgaHdrPixelDepth :: Word8
_tgaHdrPixelDepth       = forall a. TgaSaveable a => Image a -> Word8
tgaPixelDepthOfImage Image px
img
            , _tgaHdrImageDescription :: TgaImageDescription
_tgaHdrImageDescription = TgaImageDescription
                    { _tgaIdXOrigin :: Bool
_tgaIdXOrigin       = Bool
False
                    , _tgaIdYOrigin :: Bool
_tgaIdYOrigin       = Bool
False
                    , _tgaIdAttributeBits :: Word8
_tgaIdAttributeBits = Word8
0
                    }
            }
      , _tgaFileId :: ByteString
_tgaFileId     = forall a. Monoid a => a
mempty
      , _tgaPalette :: ByteString
_tgaPalette    = forall a. Monoid a => a
mempty
      , _tgaFileRest :: ByteString
_tgaFileRest   = forall a. TgaSaveable a => Image a -> ByteString
tgaDataOfImage Image px
img
      }

{-# ANN module "HLint: ignore Reduce duplication" #-}