{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
module Codec.Picture.Png(
PngSavable( .. ),
PngPaletteSaveable( .. )
, decodePng
, decodePngWithMetadata
, decodePngWithPaletteAndMetadata
, writePng
, encodeDynamicPng
, writeDynamicPng
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( (<$>) )
#endif
import Control.Arrow( first )
import Control.Monad( forM_, foldM_, when, void )
import Control.Monad.ST( ST, runST )
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
#endif
import Data.Binary( Binary( get) )
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as M
import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )
import Data.List( find, zip4 )
import Data.Word( Word8, Word16, Word32 )
import qualified Codec.Compression.Zlib as Z
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as BU
import qualified Data.ByteString.Lazy as Lb
import Foreign.Storable ( Storable )
import Codec.Picture.Types
import Codec.Picture.Metadata
import Codec.Picture.Png.Internal.Type
import Codec.Picture.Png.Internal.Export
import Codec.Picture.Png.Internal.Metadata
import Codec.Picture.InternalHelper
data Adam7MatrixInfo = Adam7MatrixInfo
{ Adam7MatrixInfo -> [Int]
adam7StartingRow :: [Int]
, Adam7MatrixInfo -> [Int]
adam7StartingCol :: [Int]
, Adam7MatrixInfo -> [Int]
adam7RowIncrement :: [Int]
, Adam7MatrixInfo -> [Int]
adam7ColIncrement :: [Int]
, Adam7MatrixInfo -> [Int]
adam7BlockHeight :: [Int]
, Adam7MatrixInfo -> [Int]
adam7BlockWidth :: [Int]
}
adam7MatrixInfo :: Adam7MatrixInfo
adam7MatrixInfo :: Adam7MatrixInfo
adam7MatrixInfo = Adam7MatrixInfo :: [Int]
-> [Int] -> [Int] -> [Int] -> [Int] -> [Int] -> Adam7MatrixInfo
Adam7MatrixInfo
{ adam7StartingRow :: [Int]
adam7StartingRow = [0, 0, 4, 0, 2, 0, 1]
, adam7StartingCol :: [Int]
adam7StartingCol = [0, 4, 0, 2, 0, 1, 0]
, adam7RowIncrement :: [Int]
adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2]
, adam7ColIncrement :: [Int]
adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1]
, adam7BlockHeight :: [Int]
adam7BlockHeight = [8, 8, 4, 4, 2, 2, 1]
, adam7BlockWidth :: [Int]
adam7BlockWidth = [8, 4, 4, 2, 2, 1, 1]
}
unparsePngFilter :: Word8 -> Either String PngFilter
{-# INLINE unparsePngFilter #-}
unparsePngFilter :: Word8 -> Either String PngFilter
unparsePngFilter 0 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterNone
unparsePngFilter 1 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterSub
unparsePngFilter 2 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterUp
unparsePngFilter 3 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterAverage
unparsePngFilter 4 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterPaeth
unparsePngFilter _ = String -> Either String PngFilter
forall a b. a -> Either a b
Left "Invalid scanline filter"
getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int)
{-# INLINE getBounds #-}
getBounds :: STVector s a -> m (Int, Int)
getBounds v :: STVector s a
v = (Int, Int) -> m (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (0, STVector s a -> Int
forall a s. Storable a => MVector s a -> Int
M.length STVector s a
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
pngFiltering :: LineUnpacker s -> Int -> (Int, Int)
-> B.ByteString -> Int
-> ST s Int
pngFiltering :: LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
pngFiltering _ _ (imgWidth :: Int
imgWidth, imgHeight :: Int
imgHeight) _str :: ByteString
_str initialIdx :: Int
initialIdx
| Int
imgWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 Bool -> Bool -> Bool
|| Int
imgHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
initialIdx
pngFiltering unpacker :: LineUnpacker s
unpacker beginZeroes :: Int
beginZeroes (imgWidth :: Int
imgWidth, imgHeight :: Int
imgHeight) str :: ByteString
str initialIdx :: Int
initialIdx = do
PngLine s
thisLine <- Int -> Word8 -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate (Int
beginZeroes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
imgWidth) 0
PngLine s
otherLine <- Int -> Word8 -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate (Int
beginZeroes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
imgWidth) 0
let folder :: PngLine s -> PngLine s -> Int -> Int -> ST s Int
folder _ _ lineIndex :: Int
lineIndex !Int
idx | Int
lineIndex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
imgHeight = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
idx
folder previousLine :: PngLine s
previousLine currentLine :: PngLine s
currentLine lineIndex :: Int
lineIndex !Int
idx = do
let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
idx
let lineFilter :: PngLine s -> PngLine s -> Int -> ST s Int
lineFilter = case Word8 -> Either String PngFilter
unparsePngFilter Word8
byte of
Right FilterNone -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterNone
Right FilterSub -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterSub
Right FilterAverage -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterAverage
Right FilterUp -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterUp
Right FilterPaeth -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterPaeth
_ -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterNone
Int
idx' <- PngLine s -> PngLine s -> Int -> ST s Int
lineFilter PngLine s
previousLine PngLine s
currentLine (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
LineUnpacker s
unpacker Int
lineIndex (Int
stride, PngLine s
currentLine)
PngLine s -> PngLine s -> Int -> Int -> ST s Int
folder PngLine s
currentLine PngLine s
previousLine (Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int
idx'
PngLine s -> PngLine s -> Int -> Int -> ST s Int
folder PngLine s
thisLine PngLine s
otherLine (0 :: Int) Int
initialIdx
where stride :: Int
stride = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
beginZeroes
lastIdx :: Int
lastIdx = Int
beginZeroes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
filterNone, filterSub, filterUp, filterPaeth,
filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int
filterNone :: PngLine s -> PngLine s -> Int -> ST s Int
filterNone !PngLine s
_previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
(PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Word8
byte
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
filterSub :: PngLine s -> PngLine s -> Int -> ST s Int
filterSub !PngLine s
_previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stride)
(PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
byte Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
val
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
filterUp :: PngLine s -> PngLine s -> Int -> ST s Int
filterUp !PngLine s
previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
previousLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
(PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
val Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
byte
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int
filterAverage !PngLine s
previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
Word8
valA <- PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stride)
Word8
valB <- PngLine s
MVector (PrimState (ST s)) Word8
previousLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
let a' :: Word16
a' = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
valA
b' :: Word16
b' = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
valB
average :: Word8
average = Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word16
a' Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
b') Word16 -> Word16 -> Word16
forall a. Integral a => a -> a -> a
`div` (2 :: Word16))
writeVal :: Word8
writeVal = Word8
byte Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
average
(PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Word8
writeVal
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
filterPaeth :: PngLine s -> PngLine s -> Int -> ST s Int
filterPaeth !PngLine s
previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
Word8
valA <- PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stride)
Word8
valC <- PngLine s
MVector (PrimState (ST s)) Word8
previousLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stride)
Word8
valB <- PngLine s
MVector (PrimState (ST s)) Word8
previousLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
(PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
byte Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8 -> Word8 -> Word8 -> Word8
forall p. Integral p => p -> p -> p -> p
paeth Word8
valA Word8
valB Word8
valC
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
paeth :: p -> p -> p -> p
paeth a :: p
a b :: p
b c :: p
c
| Int
pa Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pb Bool -> Bool -> Bool
&& Int
pa Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pc = p
a
| Int
pb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pc = p
b
| Bool
otherwise = p
c
where a' :: Int
a' = p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
a :: Int
b' :: Int
b' = p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
b
c' :: Int
c' = p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
c
p :: Int
p = Int
a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c'
pa :: Int
pa = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a'
pb :: Int
pb = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b'
pc :: Int
pc = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c'
type PngLine s = M.STVector s Word8
type LineUnpacker s = Int -> (Int, PngLine s) -> ST s ()
type StrideInfo = (Int, Int)
type BeginOffset = (Int, Int)
byteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
byteUnpacker :: Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
byteUnpacker sampleCount :: Int
sampleCount (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word8)
arr })
(strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
(_, maxIdx :: Int
maxIdx) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
pixelToRead :: Int
pixelToRead = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
maxIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginIdx) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
sampleCount
inner :: Int -> ST s ()
inner pixelIndex :: Int
pixelIndex | Int
pixelIndex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pixelToRead = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
let destPixelIndex :: Int
destPixelIndex = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
destSampleIndex :: Int
destSampleIndex = Int
destPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount
srcPixelIndex :: Int
srcPixelIndex = Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx
perPixel :: Int -> ST s ()
perPixel sample :: Int
sample | Int
sample Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sampleCount = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
srcPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample)
let writeIdx :: Int
writeIdx = Int
destSampleIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Word8
val
Int -> ST s ()
perPixel (Int
sample Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
Int -> ST s ()
perPixel 0
Int -> ST s ()
inner (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
Int -> ST s ()
inner 0
bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
bitUnpacker :: Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
bitUnpacker _ (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word8)
arr })
(strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
(_, endLine :: Int
endLine) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
(lineWidth :: Int
lineWidth, subImageRest :: Int
subImageRest) = (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginLeft) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
strideWidth
subPadd :: Int
subPadd | Int
subImageRest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = 1
| Bool
otherwise = 0
(pixelToRead :: Int
pixelToRead, lineRest :: Int
lineRest) = (Int
lineWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
subPadd) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 8
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \pixelIndex :: Int
pixelIndex -> do
Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx)
let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. 7] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \bit :: Int
bit -> (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx (7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bit)) ((Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
bit) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 1)
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lineRest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)
(do Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
endLine
let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
lineRest Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \bit :: Int
bit ->
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
bit) ((Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` (7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bit)) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x1))
twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
twoBitsUnpacker :: Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
twoBitsUnpacker _ (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word8)
arr })
(strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
(_, endLine :: Int
endLine) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
(lineWidth :: Int
lineWidth, subImageRest :: Int
subImageRest) = (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginLeft) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
strideWidth
subPadd :: Int
subPadd | Int
subImageRest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = 1
| Bool
otherwise = 0
(pixelToRead :: Int
pixelToRead, lineRest :: Int
lineRest) = (Int
lineWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
subPadd) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 4
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \pixelIndex :: Int
pixelIndex -> do
Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx)
let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx 0) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 6) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx 1) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx 2) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 2) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx 3) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
val Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lineRest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)
(do Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
endLine
let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
lineRest Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \bit :: Int
bit ->
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
bit) ((Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` (6 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bit)) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3))
halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
halfByteUnpacker :: Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
halfByteUnpacker _ (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word8)
arr })
(strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
(_, endLine :: Int
endLine) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
(lineWidth :: Int
lineWidth, subImageRest :: Int
subImageRest) = (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginLeft) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
strideWidth
subPadd :: Int
subPadd | Int
subImageRest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = 1
| Bool
otherwise = 0
(pixelToRead :: Int
pixelToRead, lineRest :: Int
lineRest) = (Int
lineWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
subPadd) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 2
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \pixelIndex :: Int
pixelIndex -> do
Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx)
let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx 0) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xF
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx 1) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
val Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xF
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lineRest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)
(do Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
endLine
let writeIdx :: Int
writeIdx = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
(STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xF)
shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s
shortUnpacker :: Int
-> MutableImage s Word16
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
shortUnpacker sampleCount :: Int
sampleCount (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word16)
arr })
(strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
(_, maxIdx :: Int
maxIdx) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
pixelToRead :: Int
pixelToRead = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
maxIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginIdx) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2)
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
pixelToRead] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \pixelIndex :: Int
pixelIndex -> do
let destPixelIndex :: Int
destPixelIndex = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
destSampleIndex :: Int
destSampleIndex = Int
destPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount
srcPixelIndex :: Int
srcPixelIndex = Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \sample :: Int
sample -> do
Word8
highBits <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
srcPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 0)
Word8
lowBits <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
srcPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
let fullValue :: Word16
fullValue = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lowBits Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
highBits Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 8)
writeIdx :: Int
writeIdx = Int
destSampleIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample
(STVector s (PixelBaseComponent Word16)
MVector (PrimState (ST s)) Word16
arr MVector (PrimState (ST s)) Word16 -> Int -> Word16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Word16
fullValue
scanlineUnpacker8 :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset
-> LineUnpacker s
scanlineUnpacker8 :: Int
-> Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
scanlineUnpacker8 1 = Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
bitUnpacker
scanlineUnpacker8 2 = Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
twoBitsUnpacker
scanlineUnpacker8 4 = Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
halfByteUnpacker
scanlineUnpacker8 8 = Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
byteUnpacker
scanlineUnpacker8 _ = String
-> Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall a. HasCallStack => String -> a
error "Impossible bit depth"
byteSizeOfBitLength :: Int -> Int -> Int -> Int
byteSizeOfBitLength :: Int -> Int -> Int -> Int
byteSizeOfBitLength pixelBitDepth :: Int
pixelBitDepth sampleCount :: Int
sampleCount dimension :: Int
dimension = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Int
rest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then 1 else 0)
where (size :: Int
size, rest :: Int
rest) = (Int
pixelBitDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dimension Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 8
scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
-> B.ByteString
-> ST s ()
scanLineInterleaving :: Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
scanLineInterleaving depth :: Int
depth sampleCount :: Int
sampleCount (imgWidth :: Int
imgWidth, imgHeight :: Int
imgHeight) unpacker :: (Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker str :: ByteString
str =
ST s Int -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s Int -> ST s ()) -> ST s Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
forall s.
LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
pngFiltering ((Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker (1,1) (0, 0)) Int
strideInfo (Int
byteWidth, Int
imgHeight) ByteString
str 0
where byteWidth :: Int
byteWidth = Int -> Int -> Int -> Int
byteSizeOfBitLength Int
depth Int
sampleCount Int
imgWidth
strideInfo :: Int
strideInfo | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 8 = 1
| Bool
otherwise = Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
depth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8)
adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
-> B.ByteString -> ST s ()
adam7Unpack :: Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
adam7Unpack depth :: Int
depth sampleCount :: Int
sampleCount (imgWidth :: Int
imgWidth, imgHeight :: Int
imgHeight) unpacker :: (Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker str :: ByteString
str =
ST s () -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Int -> (Int -> ST s Int) -> ST s Int)
-> Int -> [Int -> ST s Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (\i :: Int
i f :: Int -> ST s Int
f -> Int -> ST s Int
f Int
i) 0 [Int -> ST s Int]
subImages
where Adam7MatrixInfo { adam7StartingRow :: Adam7MatrixInfo -> [Int]
adam7StartingRow = [Int]
startRows
, adam7RowIncrement :: Adam7MatrixInfo -> [Int]
adam7RowIncrement = [Int]
rowIncrement
, adam7StartingCol :: Adam7MatrixInfo -> [Int]
adam7StartingCol = [Int]
startCols
, adam7ColIncrement :: Adam7MatrixInfo -> [Int]
adam7ColIncrement = [Int]
colIncrement } = Adam7MatrixInfo
adam7MatrixInfo
subImages :: [Int -> ST s Int]
subImages =
[LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
forall s.
LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
pngFiltering ((Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker (Int
incrW, Int
incrH) (Int
beginW, Int
beginH)) Int
strideInfo (Int
byteWidth, Int
passHeight) ByteString
str
| (beginW :: Int
beginW, incrW :: Int
incrW, beginH :: Int
beginH, incrH :: Int
incrH) <- [Int] -> [Int] -> [Int] -> [Int] -> [(Int, Int, Int, Int)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Int]
startCols [Int]
colIncrement [Int]
startRows [Int]
rowIncrement
, let passWidth :: Int
passWidth = Int -> Int -> Int -> Int
forall p. Integral p => p -> p -> p -> p
sizer Int
imgWidth Int
beginW Int
incrW
passHeight :: Int
passHeight = Int -> Int -> Int -> Int
forall p. Integral p => p -> p -> p -> p
sizer Int
imgHeight Int
beginH Int
incrH
byteWidth :: Int
byteWidth = Int -> Int -> Int -> Int
byteSizeOfBitLength Int
depth Int
sampleCount Int
passWidth
]
strideInfo :: Int
strideInfo | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 8 = 1
| Bool
otherwise = Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
depth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8)
sizer :: p -> p -> p -> p
sizer dimension :: p
dimension begin :: p
begin increment :: p
increment
| p
dimension p -> p -> Bool
forall a. Ord a => a -> a -> Bool
<= p
begin = 0
| Bool
otherwise = p
outDim p -> p -> p
forall a. Num a => a -> a -> a
+ (if p
restDim p -> p -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then 1 else 0)
where (outDim :: p
outDim, restDim :: p
restDim) = (p
dimension p -> p -> p
forall a. Num a => a -> a -> a
- p
begin) p -> p -> (p, p)
forall a. Integral a => a -> a -> (a, a)
`quotRem` p
increment
deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16))
deinterlacer :: PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer (PngIHdr { width :: PngIHdr -> Word32
width = Word32
w, height :: PngIHdr -> Word32
height = Word32
h, colourType :: PngIHdr -> PngImageType
colourType = PngImageType
imgKind
, interlaceMethod :: PngIHdr -> PngInterlaceMethod
interlaceMethod = PngInterlaceMethod
method, bitDepth :: PngIHdr -> Word8
bitDepth = Word8
depth }) str :: ByteString
str = do
let compCount :: Word32
compCount = PngImageType -> Word32
sampleCountOfImageType PngImageType
imgKind
arraySize :: Int
arraySize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
h Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
compCount
deinterlaceFunction :: Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
deinterlaceFunction = case PngInterlaceMethod
method of
PngNoInterlace -> Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
forall s.
Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
scanLineInterleaving
PngInterlaceAdam7 -> Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
forall s.
Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
adam7Unpack
iBitDepth :: Int
iBitDepth = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
depth
if Int
iBitDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 8
then do
MVector s Word8
imgArray <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
arraySize
let mutableImage :: MutableImage s Word8
mutableImage = Int
-> Int
-> STVector s (PixelBaseComponent Word8)
-> MutableImage s Word8
forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
MutableImage (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h) MVector s Word8
STVector s (PixelBaseComponent Word8)
imgArray
Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
deinterlaceFunction Int
iBitDepth
(Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
compCount)
(Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w, Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h)
(Int
-> Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
scanlineUnpacker8 Int
iBitDepth (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
compCount)
MutableImage s Word8
mutableImage)
ByteString
str
Vector Word8 -> Either (Vector Word8) (Vector Word16)
forall a b. a -> Either a b
Left (Vector Word8 -> Either (Vector Word8) (Vector Word16))
-> ST s (Vector Word8)
-> ST s (Either (Vector Word8) (Vector Word16))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector s Word8
MVector (PrimState (ST s)) Word8
imgArray
else do
MVector s Word16
imgArray <- Int -> ST s (MVector (PrimState (ST s)) Word16)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
arraySize
let mutableImage :: MutableImage s Word16
mutableImage = Int
-> Int
-> STVector s (PixelBaseComponent Word16)
-> MutableImage s Word16
forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
MutableImage (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h) MVector s Word16
STVector s (PixelBaseComponent Word16)
imgArray
Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
deinterlaceFunction Int
iBitDepth
(Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
compCount)
(Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w, Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h)
(Int
-> MutableImage s Word16
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word16
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
shortUnpacker (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
compCount) MutableImage s Word16
mutableImage)
ByteString
str
Vector Word16 -> Either (Vector Word8) (Vector Word16)
forall a b. b -> Either a b
Right (Vector Word16 -> Either (Vector Word8) (Vector Word16))
-> ST s (Vector Word16)
-> ST s (Either (Vector Word8) (Vector Word16))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ST s)) Word16 -> ST s (Vector Word16)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector s Word16
MVector (PrimState (ST s)) Word16
imgArray
generateGreyscalePalette :: Word8 -> PngPalette
generateGreyscalePalette :: Word8 -> PngPalette
generateGreyscalePalette bits :: Word8
bits = Int -> Vector (PixelBaseComponent PixelRGB8) -> PngPalette
forall px. Int -> Vector (PixelBaseComponent px) -> Palette' px
Palette' (Int
maxValueInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Vector Word8
Vector (PixelBaseComponent PixelRGB8)
vec
where maxValue :: Int
maxValue = 2 Int -> Word8 -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Word8
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
vec :: Vector Word8
vec = Int -> [Word8] -> Vector Word8
forall a. Storable a => Int -> [a] -> Vector a
V.fromListN ((Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxValue Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3) ([Word8] -> Vector Word8) -> [Word8] -> Vector Word8
forall a b. (a -> b) -> a -> b
$ [[Word8]] -> [Word8]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Word8]]
pixels
pixels :: [[Word8]]
pixels = [[Word8
i, Word8
i, Word8
i] | Int
n <- [0 .. Int
maxValue]
, let i :: Word8
i = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* (255 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
maxValue)]
sampleCountOfImageType :: PngImageType -> Word32
sampleCountOfImageType :: PngImageType -> Word32
sampleCountOfImageType PngGreyscale = 1
sampleCountOfImageType PngTrueColour = 3
sampleCountOfImageType PngIndexedColor = 1
sampleCountOfImageType PngGreyscaleWithAlpha = 2
sampleCountOfImageType PngTrueColourWithAlpha = 4
paletteRGB1, paletteRGB2, paletteRGB4 :: PngPalette
paletteRGB1 :: PngPalette
paletteRGB1 = Word8 -> PngPalette
generateGreyscalePalette 1
paletteRGB2 :: PngPalette
paletteRGB2 = Word8 -> PngPalette
generateGreyscalePalette 2
paletteRGB4 :: PngPalette
paletteRGB4 = Word8 -> PngPalette
generateGreyscalePalette 4
addTransparencyToPalette :: PngPalette -> Lb.ByteString -> Palette' PixelRGBA8
addTransparencyToPalette :: PngPalette -> ByteString -> Palette' PixelRGBA8
addTransparencyToPalette pal :: PngPalette
pal transpBuffer :: ByteString
transpBuffer =
Int
-> Vector (PixelBaseComponent PixelRGBA8) -> Palette' PixelRGBA8
forall px. Int -> Vector (PixelBaseComponent px) -> Palette' px
Palette' (PngPalette -> Int
forall px. Palette' px -> Int
_paletteSize PngPalette
pal) (Vector Word8 -> Palette' PixelRGBA8)
-> (Image PixelRGB8 -> Vector Word8)
-> Image PixelRGB8
-> Palette' PixelRGBA8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> Vector Word8
forall a. Image a -> Vector (PixelBaseComponent a)
imageData (Image PixelRGBA8 -> Vector Word8)
-> (Image PixelRGB8 -> Image PixelRGBA8)
-> Image PixelRGB8
-> Vector Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> PixelRGB8 -> PixelRGBA8)
-> Image PixelRGB8 -> Image PixelRGBA8
forall a b.
(Pixel a, Pixel b) =>
(Int -> Int -> a -> b) -> Image a -> Image b
pixelMapXY Int -> Int -> PixelRGB8 -> PixelRGBA8
addOpacity (Image PixelRGB8 -> Palette' PixelRGBA8)
-> Image PixelRGB8 -> Palette' PixelRGBA8
forall a b. (a -> b) -> a -> b
$ PngPalette -> Image PixelRGB8
forall px. Palette' px -> Image px
palettedAsImage PngPalette
pal
where
maxi :: Int
maxi = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
Lb.length ByteString
transpBuffer
addOpacity :: Int -> Int -> PixelRGB8 -> PixelRGBA8
addOpacity ix :: Int
ix _ (PixelRGB8 r :: Word8
r g :: Word8
g b :: Word8
b) | Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxi =
Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b (Word8 -> PixelRGBA8) -> Word8 -> PixelRGBA8
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64 -> Word8
Lb.index ByteString
transpBuffer (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix)
addOpacity _ _ (PixelRGB8 r :: Word8
r g :: Word8
g b :: Word8
b) = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b 255
unparse :: PngIHdr -> Maybe PngPalette -> [Lb.ByteString] -> PngImageType
-> B.ByteString -> Either String PalettedImage
unparse :: PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse ihdr :: PngIHdr
ihdr _ t :: [ByteString]
t PngGreyscale bytes :: ByteString
bytes
| PngIHdr -> Word8
bitDepth PngIHdr
ihdr Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr (PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
Just PngPalette
paletteRGB1) [ByteString]
t PngImageType
PngIndexedColor ByteString
bytes
| PngIHdr -> Word8
bitDepth PngIHdr
ihdr Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr (PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
Just PngPalette
paletteRGB2) [ByteString]
t PngImageType
PngIndexedColor ByteString
bytes
| PngIHdr -> Word8
bitDepth PngIHdr
ihdr Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 4 = PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr (PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
Just PngPalette
paletteRGB4) [ByteString]
t PngImageType
PngIndexedColor ByteString
bytes
| Bool
otherwise =
(DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Word8) (Vector Word16)
-> Either String DynamicImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngIHdr
-> (Image Word8 -> DynamicImage)
-> (Image Word16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent Word8))
(Vector (PixelBaseComponent Word16))
-> Either String DynamicImage
forall a pxWord8 pxWord16.
PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent pxWord8))
(Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage PngIHdr
ihdr Image Word8 -> DynamicImage
ImageY8 Image Word16 -> DynamicImage
ImageY16 (Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse _ Nothing _ PngIndexedColor _ = String -> Either String PalettedImage
forall a b. a -> Either a b
Left "no valid palette found"
unparse ihdr :: PngIHdr
ihdr _ _ PngTrueColour bytes :: ByteString
bytes =
(DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Word8) (Vector Word16)
-> Either String DynamicImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngIHdr
-> (Image PixelRGB8 -> DynamicImage)
-> (Image PixelRGB16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent PixelRGB8))
(Vector (PixelBaseComponent PixelRGB16))
-> Either String DynamicImage
forall a pxWord8 pxWord16.
PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent pxWord8))
(Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage PngIHdr
ihdr Image PixelRGB8 -> DynamicImage
ImageRGB8 Image PixelRGB16 -> DynamicImage
ImageRGB16 (Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse ihdr :: PngIHdr
ihdr _ _ PngGreyscaleWithAlpha bytes :: ByteString
bytes =
(DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Word8) (Vector Word16)
-> Either String DynamicImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngIHdr
-> (Image PixelYA8 -> DynamicImage)
-> (Image PixelYA16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent PixelYA8))
(Vector (PixelBaseComponent PixelYA16))
-> Either String DynamicImage
forall a pxWord8 pxWord16.
PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent pxWord8))
(Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage PngIHdr
ihdr Image PixelYA8 -> DynamicImage
ImageYA8 Image PixelYA16 -> DynamicImage
ImageYA16 (Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse ihdr :: PngIHdr
ihdr _ _ PngTrueColourWithAlpha bytes :: ByteString
bytes =
(DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Word8) (Vector Word16)
-> Either String DynamicImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngIHdr
-> (Image PixelRGBA8 -> DynamicImage)
-> (Image PixelRGBA16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent PixelRGBA8))
(Vector (PixelBaseComponent PixelRGBA16))
-> Either String DynamicImage
forall a pxWord8 pxWord16.
PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent pxWord8))
(Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage PngIHdr
ihdr Image PixelRGBA8 -> DynamicImage
ImageRGBA8 Image PixelRGBA16 -> DynamicImage
ImageRGBA16 (Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse ihdr :: PngIHdr
ihdr (Just plte :: PngPalette
plte) transparency :: [ByteString]
transparency PngIndexedColor bytes :: ByteString
bytes =
PngIHdr
-> PngPalette
-> [ByteString]
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall t.
PngIHdr
-> PngPalette
-> [ByteString]
-> Either (Vector Word8) t
-> Either String PalettedImage
palette8 PngIHdr
ihdr PngPalette
plte [ByteString]
transparency (Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
toImage :: forall a pxWord8 pxWord16
. PngIHdr
-> (Image pxWord8 -> DynamicImage) -> (Image pxWord16 -> DynamicImage)
-> Either (V.Vector (PixelBaseComponent pxWord8))
(V.Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage :: PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent pxWord8))
(Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage hdr :: PngIHdr
hdr const1 :: Image pxWord8 -> DynamicImage
const1 const2 :: Image pxWord16 -> DynamicImage
const2 lr :: Either
(Vector (PixelBaseComponent pxWord8))
(Vector (PixelBaseComponent pxWord16))
lr = DynamicImage -> Either a DynamicImage
forall a b. b -> Either a b
Right (DynamicImage -> Either a DynamicImage)
-> DynamicImage -> Either a DynamicImage
forall a b. (a -> b) -> a -> b
$ case Either
(Vector (PixelBaseComponent pxWord8))
(Vector (PixelBaseComponent pxWord16))
lr of
Left a :: Vector (PixelBaseComponent pxWord8)
a -> Image pxWord8 -> DynamicImage
const1 (Image pxWord8 -> DynamicImage) -> Image pxWord8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector (PixelBaseComponent pxWord8) -> Image pxWord8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector (PixelBaseComponent pxWord8)
a
Right a :: Vector (PixelBaseComponent pxWord16)
a -> Image pxWord16 -> DynamicImage
const2 (Image pxWord16 -> DynamicImage) -> Image pxWord16 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> Vector (PixelBaseComponent pxWord16) -> Image pxWord16
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector (PixelBaseComponent pxWord16)
a
where
w :: Int
w = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
width PngIHdr
hdr
h :: Int
h = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
height PngIHdr
hdr
palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t
-> Either String PalettedImage
palette8 :: PngIHdr
-> PngPalette
-> [ByteString]
-> Either (Vector Word8) t
-> Either String PalettedImage
palette8 hdr :: PngIHdr
hdr palette :: PngPalette
palette transparency :: [ByteString]
transparency eimg :: Either (Vector Word8) t
eimg = case ([ByteString]
transparency, Either (Vector Word8) t
eimg) of
([c :: ByteString
c], Left img :: Vector Word8
img) ->
PalettedImage -> Either String PalettedImage
forall a b. b -> Either a b
Right (PalettedImage -> Either String PalettedImage)
-> (Palette' PixelRGBA8 -> PalettedImage)
-> Palette' PixelRGBA8
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Word8 -> Palette' PixelRGBA8 -> PalettedImage
PalettedRGBA8 (Int -> Int -> Vector (PixelBaseComponent Word8) -> Image Word8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent Word8)
img) (Palette' PixelRGBA8 -> Either String PalettedImage)
-> Palette' PixelRGBA8 -> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ PngPalette -> ByteString -> Palette' PixelRGBA8
addTransparencyToPalette PngPalette
palette ByteString
c
(_, Left img :: Vector Word8
img) ->
PalettedImage -> Either String PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Either String PalettedImage)
-> PalettedImage -> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ Image Word8 -> PngPalette -> PalettedImage
PalettedRGB8 (Int -> Int -> Vector (PixelBaseComponent Word8) -> Image Word8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent Word8)
img) PngPalette
palette
(_, Right _) ->
String -> Either String PalettedImage
forall a b. a -> Either a b
Left "Invalid bit depth for paleted image"
where
w :: Int
w = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
width PngIHdr
hdr
h :: Int
h = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
height PngIHdr
hdr
decodePng :: B.ByteString -> Either String DynamicImage
decodePng :: ByteString -> Either String DynamicImage
decodePng = ((DynamicImage, Metadatas) -> DynamicImage)
-> Either String (DynamicImage, Metadatas)
-> Either String DynamicImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynamicImage, Metadatas) -> DynamicImage
forall a b. (a, b) -> a
fst (Either String (DynamicImage, Metadatas)
-> Either String DynamicImage)
-> (ByteString -> Either String (DynamicImage, Metadatas))
-> ByteString
-> Either String DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (DynamicImage, Metadatas)
decodePngWithMetadata
decodePngWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
decodePngWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
decodePngWithMetadata b :: ByteString
b = (PalettedImage -> DynamicImage)
-> (PalettedImage, Metadatas) -> (DynamicImage, Metadatas)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first PalettedImage -> DynamicImage
palettedToTrueColor ((PalettedImage, Metadatas) -> (DynamicImage, Metadatas))
-> Either String (PalettedImage, Metadatas)
-> Either String (DynamicImage, Metadatas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String (PalettedImage, Metadatas)
decodePngWithPaletteAndMetadata ByteString
b
decodePngWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
decodePngWithPaletteAndMetadata :: ByteString -> Either String (PalettedImage, Metadatas)
decodePngWithPaletteAndMetadata byte :: ByteString
byte = do
PngRawImage
rawImg <- Get PngRawImage -> ByteString -> Either String PngRawImage
forall a. Get a -> ByteString -> Either String a
runGetStrict Get PngRawImage
forall t. Binary t => Get t
get ByteString
byte
let ihdr :: PngIHdr
ihdr = PngRawImage -> PngIHdr
header PngRawImage
rawImg
metadatas :: Metadatas
metadatas =
SourceFormat -> Word32 -> Word32 -> Metadatas
forall nSize.
Integral nSize =>
SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
SourcePng (PngIHdr -> Word32
width PngIHdr
ihdr) (PngIHdr -> Word32
height PngIHdr
ihdr) Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> PngRawImage -> Metadatas
extractMetadatas PngRawImage
rawImg
compressedImageData :: ByteString
compressedImageData =
[ByteString] -> ByteString
Lb.concat [PngRawChunk -> ByteString
chunkData PngRawChunk
chunk | PngRawChunk
chunk <- PngRawImage -> [PngRawChunk]
chunks PngRawImage
rawImg
, PngRawChunk -> ByteString
chunkType PngRawChunk
chunk ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
iDATSignature]
zlibHeaderSize :: Int64
zlibHeaderSize = 1
Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ 1
Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ 4
transparencyColor :: [ByteString]
transparencyColor =
[ PngRawChunk -> ByteString
chunkData PngRawChunk
chunk | PngRawChunk
chunk <- PngRawImage -> [PngRawChunk]
chunks PngRawImage
rawImg
, PngRawChunk -> ByteString
chunkType PngRawChunk
chunk ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
tRNSSignature ]
if ByteString -> Int64
Lb.length ByteString
compressedImageData Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
zlibHeaderSize then
String -> Either String (PalettedImage, Metadatas)
forall a b. a -> Either a b
Left "Invalid data size"
else
let imgData :: ByteString
imgData = ByteString -> ByteString
Z.decompress ByteString
compressedImageData
parseableData :: ByteString
parseableData = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
Lb.toChunks ByteString
imgData
palette :: Maybe PngPalette
palette = do
PngRawChunk
p <- (PngRawChunk -> Bool) -> [PngRawChunk] -> Maybe PngRawChunk
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\c :: PngRawChunk
c -> ByteString
pLTESignature ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== PngRawChunk -> ByteString
chunkType PngRawChunk
c) ([PngRawChunk] -> Maybe PngRawChunk)
-> [PngRawChunk] -> Maybe PngRawChunk
forall a b. (a -> b) -> a -> b
$ PngRawImage -> [PngRawChunk]
chunks PngRawImage
rawImg
case PngRawChunk -> Either String PngPalette
parsePalette PngRawChunk
p of
Left _ -> Maybe PngPalette
forall a. Maybe a
Nothing
Right plte :: PngPalette
plte -> PngPalette -> Maybe PngPalette
forall (m :: * -> *) a. Monad m => a -> m a
return PngPalette
plte
in
(, Metadatas
metadatas) (PalettedImage -> (PalettedImage, Metadatas))
-> Either String PalettedImage
-> Either String (PalettedImage, Metadatas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr Maybe PngPalette
palette [ByteString]
transparencyColor (PngIHdr -> PngImageType
colourType PngIHdr
ihdr) ByteString
parseableData
{-# ANN module "HLint: ignore Reduce duplication" #-}