{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
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 -> 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
{ :: !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
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
-> 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
-> 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 ()
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
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
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
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
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
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" #-}