{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
-- | Module used for loading & writing \'Portable Network Graphics\' (PNG)

-- files.

--

-- A high level API is provided. It loads and saves images for you

-- while hiding all the details about PNG chunks.

--

-- Basic functions for PNG handling are 'decodePng', 'encodePng'

-- and 'encodePalettedPng'. Convenience functions are provided

-- for direct file handling and using 'DynamicImage's.

--

-- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html)

module Codec.Picture.Png( -- * High level functions

                          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

-- | Simple structure used to hold information about Adam7 deinterlacing.

-- A structure is used to avoid pollution of the module namespace.

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]
    }

-- | The real info about the matrix.

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)

-- | Apply a filtering method on a reduced image. Apply the filter

-- on each line, using the previous line (the one above it) to perform

-- some prediction on the value.

pngFiltering :: LineUnpacker s -> Int -> (Int, Int)    -- ^ Image size

             -> 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

          -- The filter implementation are... well non-idiomatic

          -- to say the least, but my benchmarks proved me one thing,

          -- they are faster than mapM_, gained something like 5% with

          -- a rewrite from mapM_ to this direct version

          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'
                  
-- | Directly stolen from the definition in the standard (on W3C page),

-- pixel predictor.


type PngLine s = M.STVector s Word8
type LineUnpacker s = Int -> (Int, PngLine s) -> ST s ()

type StrideInfo  = (Int, Int)

type BeginOffset = (Int, Int)


-- | Unpack lines where bit depth is 8

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
             

-- | Unpack lines where bit depth is 1

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))


-- | Unpack lines when bit depth is 2

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

-- | Transform a scanline to a bunch of bytes. Bytes are then packed

-- into pixels at a further step.

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)

-- | Given data and image size, recreate an image with deinterlaced

-- data for PNG's adam 7 method.

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

-- | deinterlace picture in function of the method indicated

-- in the iHDR

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


-- | Transform a raw png image to an image, without modifying the

-- underlying pixel type. If the image is greyscale and < 8 bits,

-- a transformation to RGBA8 is performed. This should change

-- in the future.

-- The resulting image let you manage the pixel types.

--

-- This function can output the following images:

--

--  * 'ImageY8'

--

--  * 'ImageY16'

--

--  * 'ImageYA8'

--

--  * 'ImageYA16'

--

--  * 'ImageRGB8'

--

--  * 'ImageRGB16'

--

--  * 'ImageRGBA8'

--

--  * 'ImageRGBA16'

--

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

-- | Decode a PNG file with, possibly, separated palette.

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

-- | Same as 'decodePng' but also extract meta datas present

-- in the files.

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 {- compression method/flags code -}
                     Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1 {- Additional flags/check bits -}
                     Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4 {-CRC-}

      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" #-}