{-# 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
{ adam7StartingRow :: [Int]
adam7StartingRow = [Int
0, Int
0, Int
4, Int
0, Int
2, Int
0, Int
1]
, adam7StartingCol :: [Int]
adam7StartingCol = [Int
0, Int
4, Int
0, Int
2, Int
0, Int
1, Int
0]
, adam7RowIncrement :: [Int]
adam7RowIncrement = [Int
8, Int
8, Int
8, Int
4, Int
4, Int
2, Int
2]
, adam7ColIncrement :: [Int]
adam7ColIncrement = [Int
8, Int
8, Int
4, Int
4, Int
2, Int
2, Int
1]
, adam7BlockHeight :: [Int]
adam7BlockHeight = [Int
8, Int
8, Int
4, Int
4, Int
2, Int
2, Int
1]
, adam7BlockWidth :: [Int]
adam7BlockWidth = [Int
8, Int
4, Int
4, Int
2, Int
2, Int
1, Int
1]
}
unparsePngFilter :: Word8 -> Either String PngFilter
{-# INLINE unparsePngFilter #-}
unparsePngFilter :: Pixel8 -> Either String PngFilter
unparsePngFilter Pixel8
0 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterNone
unparsePngFilter Pixel8
1 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterSub
unparsePngFilter Pixel8
2 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterUp
unparsePngFilter Pixel8
3 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterAverage
unparsePngFilter Pixel8
4 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterPaeth
unparsePngFilter Pixel8
_ = String -> Either String PngFilter
forall a b. a -> Either a b
Left String
"Invalid scanline filter"
getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int)
{-# INLINE getBounds #-}
getBounds :: forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds STVector s a
v = (Int, Int) -> m (Int, Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
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
- Int
1)
pngFiltering :: LineUnpacker s -> Int -> (Int, Int)
-> B.ByteString -> Int
-> ST s Int
pngFiltering :: forall s.
LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
pngFiltering LineUnpacker s
_ Int
_ (Int
imgWidth, Int
imgHeight) ByteString
_str Int
initialIdx
| Int
imgWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
imgHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
initialIdx
pngFiltering LineUnpacker s
unpacker Int
beginZeroes (Int
imgWidth, Int
imgHeight) ByteString
str Int
initialIdx = do
PngLine s
thisLine <- Int -> Pixel8 -> ST s (MVector (PrimState (ST s)) Pixel8)
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) Pixel8
0
PngLine s
otherLine <- Int -> Pixel8 -> ST s (MVector (PrimState (ST s)) Pixel8)
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) Pixel8
0
let folder :: PngLine s -> PngLine s -> Int -> Int -> ST s Int
folder PngLine s
_ PngLine s
_ Int
lineIndex !Int
idx | Int
lineIndex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
imgHeight = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
idx
folder PngLine s
previousLine PngLine s
currentLine Int
lineIndex !Int
idx = do
let byte :: Pixel8
byte = ByteString
str ByteString -> Int -> Pixel8
`BU.unsafeIndex` Int
idx
let lineFilter :: PngLine s -> PngLine s -> Int -> ST s Int
lineFilter = case Pixel8 -> Either String PngFilter
unparsePngFilter Pixel8
byte of
Right PngFilter
FilterNone -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterNone
Right PngFilter
FilterSub -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterSub
Right PngFilter
FilterAverage -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterAverage
Right PngFilter
FilterUp -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterUp
Right PngFilter
FilterPaeth -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterPaeth
Either String PngFilter
_ -> 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
+ Int
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
+ Int
1) Int
idx'
PngLine s -> PngLine s -> Int -> Int -> ST s Int
folder PngLine s
thisLine PngLine s
otherLine (Int
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
- Int
1
filterNone, filterSub, filterUp, filterPaeth,
filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int
filterNone :: forall s. 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 Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Pixel8
byte = ByteString
str ByteString -> Int -> Pixel8
`BU.unsafeIndex` Int
readIdx
(PngLine s
MVector (PrimState (ST s)) Pixel8
thisLine MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Pixel8
byte
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
+ Int
1
filterSub :: forall s. 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 Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Pixel8
byte = ByteString
str ByteString -> Int -> Pixel8
`BU.unsafeIndex` Int
readIdx
Pixel8
val <- PngLine s
MVector (PrimState (ST s)) Pixel8
thisLine MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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)) Pixel8
thisLine MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Pixel8
byte Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
+ Pixel8
val
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
+ Int
1
filterUp :: forall s. 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 Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Pixel8
byte = ByteString
str ByteString -> Int -> Pixel8
`BU.unsafeIndex` Int
readIdx
Pixel8
val <- PngLine s
MVector (PrimState (ST s)) Pixel8
previousLine MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
(PngLine s
MVector (PrimState (ST s)) Pixel8
thisLine MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Pixel8
val Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
+ Pixel8
byte
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
+ Int
1
filterAverage :: forall s. 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 Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Pixel8
byte = ByteString
str ByteString -> Int -> Pixel8
`BU.unsafeIndex` Int
readIdx
Pixel8
valA <- PngLine s
MVector (PrimState (ST s)) Pixel8
thisLine MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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)
Pixel8
valB <- PngLine s
MVector (PrimState (ST s)) Pixel8
previousLine MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
let a' :: Word16
a' = Pixel8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
valA
b' :: Word16
b' = Pixel8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
valB
average :: Pixel8
average = Word16 -> Pixel8
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` (Word16
2 :: Word16))
writeVal :: Pixel8
writeVal = Pixel8
byte Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
+ Pixel8
average
(PngLine s
MVector (PrimState (ST s)) Pixel8
thisLine MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Pixel8
writeVal
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
+ Int
1
filterPaeth :: forall s. 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 Int
idx !Int
readIdx
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
| Bool
otherwise = do let byte :: Pixel8
byte = ByteString
str ByteString -> Int -> Pixel8
`BU.unsafeIndex` Int
readIdx
Pixel8
valA <- PngLine s
MVector (PrimState (ST s)) Pixel8
thisLine MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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)
Pixel8
valC <- PngLine s
MVector (PrimState (ST s)) Pixel8
previousLine MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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)
Pixel8
valB <- PngLine s
MVector (PrimState (ST s)) Pixel8
previousLine MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
(PngLine s
MVector (PrimState (ST s)) Pixel8
thisLine MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Pixel8
byte Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
+ Pixel8 -> Pixel8 -> Pixel8 -> Pixel8
forall {a}. Integral a => a -> a -> a -> a
paeth Pixel8
valA Pixel8
valB Pixel8
valC
Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
+ Int
1
paeth :: a -> a -> a -> a
paeth a
a a
b a
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 = a
a
| Int
pb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pc = a
b
| Bool
otherwise = a
c
where a' :: Int
a' = a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a :: Int
b' :: Int
b' = a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b
c' :: Int
c' = a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
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 :: forall s.
Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
byteUnpacker 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 Pixel8)
arr })
(Int
strideWidth, Int
strideHeight) (Int
beginLeft, Int
beginTop) Int
h (Int
beginIdx, PngLine s
line) = do
(Int
_, 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
- Int
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 Int
pixelIndex | Int
pixelIndex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pixelToRead = () -> ST s ()
forall a. a -> ST s a
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 Int
sample | Int
sample Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sampleCount = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
Pixel8
val <- PngLine s
MVector (PrimState (ST s)) Pixel8
line MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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 Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Pixel8
val
Int -> ST s ()
perPixel (Int
sample Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Int -> ST s ()
perPixel Int
0
Int -> ST s ()
inner (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Int -> ST s ()
inner Int
0
bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
bitUnpacker :: forall s.
Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
bitUnpacker Int
_ (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 Pixel8)
arr })
(Int
strideWidth, Int
strideHeight) (Int
beginLeft, Int
beginTop) Int
h (Int
beginIdx, PngLine s
line) = do
(Int
_, 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
(Int
lineWidth, 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
> Int
0 = Int
1
| Bool
otherwise = Int
0
(Int
pixelToRead, 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` Int
8
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
pixelIndex -> do
Pixel8
val <- PngLine s
MVector (PrimState (ST s)) Pixel8
line MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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 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
* Int
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_ [Int
0 .. Int
7] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
bit -> (STVector s (PixelBaseComponent Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bit)) ((Pixel8
val Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
bit) Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
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
/= Int
0)
(do Pixel8
val <- PngLine s
MVector (PrimState (ST s)) Pixel8
line MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
endLine
let writeIdx :: Int -> Int
writeIdx 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
* Int
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_ [Int
0 .. Int
lineRest Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
bit ->
(STVector s (PixelBaseComponent Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
bit) ((Pixel8
val Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bit)) Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
0x1))
twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
twoBitsUnpacker :: forall s.
Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
twoBitsUnpacker Int
_ (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 Pixel8)
arr })
(Int
strideWidth, Int
strideHeight) (Int
beginLeft, Int
beginTop) Int
h (Int
beginIdx, PngLine s
line) = do
(Int
_, 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
(Int
lineWidth, 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
> Int
0 = Int
1
| Bool
otherwise = Int
0
(Int
pixelToRead, 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` Int
4
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
pixelIndex -> do
Pixel8
val <- PngLine s
MVector (PrimState (ST s)) Pixel8
line MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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 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
* Int
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 Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
0) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Pixel8
val Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
6) Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
0x3
(STVector s (PixelBaseComponent Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
1) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Pixel8
val Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
0x3
(STVector s (PixelBaseComponent Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
2) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Pixel8
val Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2) Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
0x3
(STVector s (PixelBaseComponent Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
3) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Pixel8
val Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
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
/= Int
0)
(do Pixel8
val <- PngLine s
MVector (PrimState (ST s)) Pixel8
line MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
endLine
let writeIdx :: Int -> Int
writeIdx 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
* Int
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_ [Int
0 .. Int
lineRest Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
bit ->
(STVector s (PixelBaseComponent Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
bit) ((Pixel8
val Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` (Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bit)) Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
0x3))
halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
halfByteUnpacker :: forall s.
Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
halfByteUnpacker Int
_ (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 Pixel8)
arr })
(Int
strideWidth, Int
strideHeight) (Int
beginLeft, Int
beginTop) Int
h (Int
beginIdx, PngLine s
line) = do
(Int
_, 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
(Int
lineWidth, 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
> Int
0 = Int
1
| Bool
otherwise = Int
0
(Int
pixelToRead, 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` Int
2
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
pixelIndex -> do
Pixel8
val <- PngLine s
MVector (PrimState (ST s)) Pixel8
line MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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 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
* Int
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 Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
0) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Pixel8
val Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
0xF
(STVector s (PixelBaseComponent Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int -> Int
writeIdx Int
1) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Pixel8
val Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
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
/= Int
0)
(do Pixel8
val <- PngLine s
MVector (PrimState (ST s)) Pixel8
line MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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
* Int
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 Pixel8)
MVector (PrimState (ST s)) Pixel8
arr MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) (Pixel8 -> ST s ()) -> Pixel8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Pixel8
val Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
0xF)
shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s
shortUnpacker :: forall s.
Int
-> MutableImage s Word16
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
shortUnpacker 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 })
(Int
strideWidth, Int
strideHeight) (Int
beginLeft, Int
beginTop) Int
h (Int
beginIdx, PngLine s
line) = do
(Int
_, 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
- Int
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
* Int
2)
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
pixelToRead] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \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
* Int
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_ [Int
0 .. Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
sample -> do
Pixel8
highBits <- PngLine s
MVector (PrimState (ST s)) Pixel8
line MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0)
Pixel8
lowBits <- PngLine s
MVector (PrimState (ST s)) Pixel8
line MVector (PrimState (ST s)) Pixel8 -> Int -> ST s Pixel8
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
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
let fullValue :: Word16
fullValue = Pixel8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
lowBits Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. (Pixel8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
highBits Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
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 :: forall s.
Int
-> Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
scanlineUnpacker8 Int
1 = Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
bitUnpacker
scanlineUnpacker8 Int
2 = Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
twoBitsUnpacker
scanlineUnpacker8 Int
4 = Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
halfByteUnpacker
scanlineUnpacker8 Int
8 = Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
byteUnpacker
scanlineUnpacker8 Int
_ = String
-> Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall a. HasCallStack => String -> a
error String
"Impossible bit depth"
byteSizeOfBitLength :: Int -> Int -> Int -> Int
byteSizeOfBitLength :: Int -> Int -> Int -> Int
byteSizeOfBitLength Int
pixelBitDepth Int
sampleCount 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
/= Int
0 then Int
1 else Int
0)
where (Int
size, 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` Int
8
scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
-> B.ByteString
-> ST s ()
scanLineInterleaving :: forall s.
Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
scanLineInterleaving Int
depth Int
sampleCount (Int
imgWidth, Int
imgHeight) (Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker 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 (Int
1,Int
1) (Int
0, Int
0)) Int
strideInfo (Int
byteWidth, Int
imgHeight) ByteString
str Int
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
< Int
8 = Int
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` Int
8)
adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
-> B.ByteString -> ST s ()
adam7Unpack :: forall s.
Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
adam7Unpack Int
depth Int
sampleCount (Int
imgWidth, Int
imgHeight) (Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker 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_ (\Int
i Int -> ST s Int
f -> Int -> ST s Int
f Int
i) Int
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
| (Int
beginW, Int
incrW, Int
beginH, 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 {a}. Integral a => a -> a -> a -> a
sizer Int
imgWidth Int
beginW Int
incrW
passHeight :: Int
passHeight = Int -> Int -> Int -> Int
forall {a}. Integral a => a -> a -> a -> a
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
< Int
8 = Int
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` Int
8)
sizer :: a -> a -> a -> a
sizer a
dimension a
begin a
increment
| a
dimension a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
begin = a
0
| Bool
otherwise = a
outDim a -> a -> a
forall a. Num a => a -> a -> a
+ (if a
restDim a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 then a
1 else a
0)
where (a
outDim, a
restDim) = (a
dimension a -> a -> a
forall a. Num a => a -> a -> a
- a
begin) a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
`quotRem` a
increment
deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16))
deinterlacer :: forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (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 -> Pixel8
bitDepth = Pixel8
depth }) ByteString
str = do
let compCount :: Int
compCount = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngImageType -> Word32
sampleCountOfImageType PngImageType
imgKind
arraySize :: Int
arraySize = (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
compCount
deinterlaceFunction :: Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
deinterlaceFunction = case PngInterlaceMethod
method of
PngInterlaceMethod
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
PngInterlaceMethod
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 = Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
depth
if Int
iBitDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8
then do
MVector s Pixel8
imgArray <- Int -> ST s (MVector (PrimState (ST s)) Pixel8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
arraySize
let mutableImage :: MutableImage s Pixel8
mutableImage = Int
-> Int
-> STVector s (PixelBaseComponent Pixel8)
-> MutableImage s Pixel8
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 Pixel8
STVector s (PixelBaseComponent Pixel8)
imgArray
Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
deinterlaceFunction Int
iBitDepth
Int
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 Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> Int
-> MutableImage s Pixel8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
scanlineUnpacker8 Int
iBitDepth Int
compCount MutableImage s Pixel8
mutableImage)
ByteString
str
Vector Pixel8 -> Either (Vector Pixel8) (Vector Word16)
forall a b. a -> Either a b
Left (Vector Pixel8 -> Either (Vector Pixel8) (Vector Word16))
-> ST s (Vector Pixel8)
-> ST s (Either (Vector Pixel8) (Vector Word16))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ST s)) Pixel8 -> ST s (Vector Pixel8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector s Pixel8
MVector (PrimState (ST s)) Pixel8
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
Int
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 Int
compCount MutableImage s Word16
mutableImage)
ByteString
str
Vector Word16 -> Either (Vector Pixel8) (Vector Word16)
forall a b. b -> Either a b
Right (Vector Word16 -> Either (Vector Pixel8) (Vector Word16))
-> ST s (Vector Word16)
-> ST s (Either (Vector Pixel8) (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 :: Pixel8 -> PngPalette
generateGreyscalePalette Pixel8
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
+Int
1) Vector Pixel8
Vector (PixelBaseComponent PixelRGB8)
vec
where maxValue :: Int
maxValue = Int
2 Int -> Pixel8 -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Pixel8
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
vec :: Vector Pixel8
vec = Int -> [Pixel8] -> Vector Pixel8
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
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) ([Pixel8] -> Vector Pixel8) -> [Pixel8] -> Vector Pixel8
forall a b. (a -> b) -> a -> b
$ [[Pixel8]] -> [Pixel8]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Pixel8]]
pixels
pixels :: [[Pixel8]]
pixels = [[Pixel8
i, Pixel8
i, Pixel8
i] | Int
n <- [Int
0 .. Int
maxValue]
, let i :: Pixel8
i = Int -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Pixel8) -> Int -> Pixel8
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
255 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
maxValue)]
sampleCountOfImageType :: PngImageType -> Word32
sampleCountOfImageType :: PngImageType -> Word32
sampleCountOfImageType PngImageType
PngGreyscale = Word32
1
sampleCountOfImageType PngImageType
PngTrueColour = Word32
3
sampleCountOfImageType PngImageType
PngIndexedColor = Word32
1
sampleCountOfImageType PngImageType
PngGreyscaleWithAlpha = Word32
2
sampleCountOfImageType PngImageType
PngTrueColourWithAlpha = Word32
4
paletteRGB1, paletteRGB2, paletteRGB4 :: PngPalette
paletteRGB1 :: PngPalette
paletteRGB1 = Pixel8 -> PngPalette
generateGreyscalePalette Pixel8
1
paletteRGB2 :: PngPalette
paletteRGB2 = Pixel8 -> PngPalette
generateGreyscalePalette Pixel8
2
paletteRGB4 :: PngPalette
paletteRGB4 = Pixel8 -> PngPalette
generateGreyscalePalette Pixel8
4
addTransparencyToPalette :: PngPalette -> Lb.ByteString -> Palette' PixelRGBA8
addTransparencyToPalette :: PngPalette -> ChunkSignature -> Palette' PixelRGBA8
addTransparencyToPalette PngPalette
pal ChunkSignature
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 Pixel8 -> Palette' PixelRGBA8)
-> (Image PixelRGB8 -> Vector Pixel8)
-> Image PixelRGB8
-> Palette' PixelRGBA8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> Vector Pixel8
Image PixelRGBA8 -> Vector (PixelBaseComponent PixelRGBA8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData (Image PixelRGBA8 -> Vector Pixel8)
-> (Image PixelRGB8 -> Image PixelRGBA8)
-> Image PixelRGB8
-> Vector Pixel8
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
$ ChunkSignature -> Int64
Lb.length ChunkSignature
transpBuffer
addOpacity :: Int -> Int -> PixelRGB8 -> PixelRGBA8
addOpacity Int
ix Int
_ (PixelRGB8 Pixel8
r Pixel8
g Pixel8
b) | Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxi =
Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b (Pixel8 -> PixelRGBA8) -> Pixel8 -> PixelRGBA8
forall a b. (a -> b) -> a -> b
$ HasCallStack => ChunkSignature -> Int64 -> Pixel8
ChunkSignature -> Int64 -> Pixel8
Lb.index ChunkSignature
transpBuffer (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix)
addOpacity Int
_ Int
_ (PixelRGB8 Pixel8
r Pixel8
g Pixel8
b) = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b Pixel8
255
unparse :: PngIHdr -> Maybe PngPalette -> [Lb.ByteString] -> PngImageType
-> B.ByteString -> Either String PalettedImage
unparse :: PngIHdr
-> Maybe PngPalette
-> [ChunkSignature]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr Maybe PngPalette
_ [ChunkSignature]
t PngImageType
PngGreyscale ByteString
bytes
| PngIHdr -> Pixel8
bitDepth PngIHdr
ihdr Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel8
1 = PngIHdr
-> Maybe PngPalette
-> [ChunkSignature]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr (PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
Just PngPalette
paletteRGB1) [ChunkSignature]
t PngImageType
PngIndexedColor ByteString
bytes
| PngIHdr -> Pixel8
bitDepth PngIHdr
ihdr Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel8
2 = PngIHdr
-> Maybe PngPalette
-> [ChunkSignature]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr (PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
Just PngPalette
paletteRGB2) [ChunkSignature]
t PngImageType
PngIndexedColor ByteString
bytes
| PngIHdr -> Pixel8
bitDepth PngIHdr
ihdr Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel8
4 = PngIHdr
-> Maybe PngPalette
-> [ChunkSignature]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr (PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
Just PngPalette
paletteRGB4) [ChunkSignature]
t PngImageType
PngIndexedColor ByteString
bytes
| Bool
otherwise =
(DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Pixel8) (Vector Word16)
-> Either String DynamicImage)
-> Either (Vector Pixel8) (Vector Word16)
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngIHdr
-> (Image Pixel8 -> DynamicImage)
-> (Image Word16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent Pixel8))
(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 Pixel8 -> DynamicImage
ImageY8 Image Word16 -> DynamicImage
ImageY16 (Either (Vector Pixel8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Pixel8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16))
-> (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse PngIHdr
_ Maybe PngPalette
Nothing [ChunkSignature]
_ PngImageType
PngIndexedColor ByteString
_ = String -> Either String PalettedImage
forall a b. a -> Either a b
Left String
"no valid palette found"
unparse PngIHdr
ihdr Maybe PngPalette
_ [ChunkSignature]
_ PngImageType
PngTrueColour ByteString
bytes =
(DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Pixel8) (Vector Word16)
-> Either String DynamicImage)
-> Either (Vector Pixel8) (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 Pixel8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Pixel8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16))
-> (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse PngIHdr
ihdr Maybe PngPalette
_ [ChunkSignature]
_ PngImageType
PngGreyscaleWithAlpha ByteString
bytes =
(DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Pixel8) (Vector Word16)
-> Either String DynamicImage)
-> Either (Vector Pixel8) (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 Pixel8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Pixel8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16))
-> (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse PngIHdr
ihdr Maybe PngPalette
_ [ChunkSignature]
_ PngImageType
PngTrueColourWithAlpha ByteString
bytes =
(DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Pixel8) (Vector Word16)
-> Either String DynamicImage)
-> Either (Vector Pixel8) (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 Pixel8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Pixel8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16))
-> (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse PngIHdr
ihdr (Just PngPalette
plte) [ChunkSignature]
transparency PngImageType
PngIndexedColor ByteString
bytes =
PngIHdr
-> PngPalette
-> [ChunkSignature]
-> Either (Vector Pixel8) (Vector Word16)
-> Either String PalettedImage
forall t.
PngIHdr
-> PngPalette
-> [ChunkSignature]
-> Either (Vector Pixel8) t
-> Either String PalettedImage
palette8 PngIHdr
ihdr PngPalette
plte [ChunkSignature]
transparency (Either (Vector Pixel8) (Vector Word16)
-> Either String PalettedImage)
-> Either (Vector Pixel8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16))
-> (forall s. ST s (Either (Vector Pixel8) (Vector Word16)))
-> Either (Vector Pixel8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Pixel8) (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 :: forall a pxWord8 pxWord16.
PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
(Vector (PixelBaseComponent pxWord8))
(Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage PngIHdr
hdr Image pxWord8 -> DynamicImage
const1 Image pxWord16 -> DynamicImage
const2 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 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 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 :: forall t.
PngIHdr
-> PngPalette
-> [ChunkSignature]
-> Either (Vector Pixel8) t
-> Either String PalettedImage
palette8 PngIHdr
hdr PngPalette
palette [ChunkSignature]
transparency Either (Vector Pixel8) t
eimg = case ([ChunkSignature]
transparency, Either (Vector Pixel8) t
eimg) of
([ChunkSignature
c], Left Vector Pixel8
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 Pixel8 -> Palette' PixelRGBA8 -> PalettedImage
PalettedRGBA8 (Int -> Int -> Vector (PixelBaseComponent Pixel8) -> Image Pixel8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Pixel8
Vector (PixelBaseComponent Pixel8)
img) (Palette' PixelRGBA8 -> Either String PalettedImage)
-> Palette' PixelRGBA8 -> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ PngPalette -> ChunkSignature -> Palette' PixelRGBA8
addTransparencyToPalette PngPalette
palette ChunkSignature
c
([ChunkSignature]
_, Left Vector Pixel8
img) ->
PalettedImage -> Either String PalettedImage
forall a. a -> Either String a
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 Pixel8 -> PngPalette -> PalettedImage
PalettedRGB8 (Int -> Int -> Vector (PixelBaseComponent Pixel8) -> Image Pixel8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Pixel8
Vector (PixelBaseComponent Pixel8)
img) PngPalette
palette
([ChunkSignature]
_, Right t
_) ->
String -> Either String PalettedImage
forall a b. a -> Either a b
Left String
"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 a b. (a -> b) -> Either String a -> Either String b
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 ByteString
b = (PalettedImage -> DynamicImage)
-> (PalettedImage, Metadatas) -> (DynamicImage, Metadatas)
forall b c d. (b -> c) -> (b, d) -> (c, d)
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 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 :: ChunkSignature
compressedImageData =
[ChunkSignature] -> ChunkSignature
Lb.concat [PngRawChunk -> ChunkSignature
chunkData PngRawChunk
chunk | PngRawChunk
chunk <- PngRawImage -> [PngRawChunk]
chunks PngRawImage
rawImg
, PngRawChunk -> ChunkSignature
chunkType PngRawChunk
chunk ChunkSignature -> ChunkSignature -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkSignature
iDATSignature]
zlibHeaderSize :: Int64
zlibHeaderSize = Int64
1
Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1
Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4
transparencyColor :: [ChunkSignature]
transparencyColor =
[ PngRawChunk -> ChunkSignature
chunkData PngRawChunk
chunk | PngRawChunk
chunk <- PngRawImage -> [PngRawChunk]
chunks PngRawImage
rawImg
, PngRawChunk -> ChunkSignature
chunkType PngRawChunk
chunk ChunkSignature -> ChunkSignature -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkSignature
tRNSSignature ]
if ChunkSignature -> Int64
Lb.length ChunkSignature
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 String
"Invalid data size"
else
let imgData :: ChunkSignature
imgData = ChunkSignature -> ChunkSignature
Z.decompress ChunkSignature
compressedImageData
parseableData :: ByteString
parseableData = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ChunkSignature -> [ByteString]
Lb.toChunks ChunkSignature
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 (\PngRawChunk
c -> ChunkSignature
pLTESignature ChunkSignature -> ChunkSignature -> Bool
forall a. Eq a => a -> a -> Bool
== PngRawChunk -> ChunkSignature
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 String
_ -> Maybe PngPalette
forall a. Maybe a
Nothing
Right PngPalette
plte -> PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
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
-> [ChunkSignature]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr Maybe PngPalette
palette [ChunkSignature]
transparencyColor (PngIHdr -> PngImageType
colourType PngIHdr
ihdr) ByteString
parseableData
{-# ANN module "HLint: ignore Reduce duplication" #-}