{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
module Codec.Picture.HDR( decodeHDR
, decodeHDRWithMetadata
, encodeHDR
, encodeRawHDR
, encodeRLENewStyleHDR
, writeHDR
, writeRLENewStyleHDR
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( pure, (<*>), (<$>) )
#endif
import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR )
import Data.Char( ord, chr, isDigit )
import Data.Word( Word8 )
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
#endif
import Control.Monad( when, foldM, foldM_, forM, forM_, unless )
import Control.Monad.Trans.Class( lift )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as BC
import Data.List( partition )
import Data.Binary( Binary( .. ), encode )
import Data.Binary.Get( Get, getByteString, getWord8 )
import Data.Binary.Put( putByteString, putLazyByteString )
import Control.Monad.ST( ST, runST )
import Foreign.Storable ( Storable )
import Control.Monad.Primitive ( PrimState, PrimMonad )
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as M
import Codec.Picture.Metadata( Metadatas
, SourceFormat( SourceHDR )
, basicMetadata )
import Codec.Picture.InternalHelper
import Codec.Picture.Types
import Codec.Picture.VectorByteConversion
#if MIN_VERSION_transformers(0, 4, 0)
import Control.Monad.Trans.Except( ExceptT, throwE, runExceptT )
#else
import Control.Monad.Trans.Error( Error, ErrorT, throwError, runErrorT )
type ExceptT = ErrorT
throwE :: (Monad m, Error e) => e -> ErrorT e m a
throwE = throwError
runExceptT :: ErrorT e m a -> m (Either e a)
runExceptT = runErrorT
#endif
{-# INLINE (.<<.) #-}
(.<<.), (.>>.) :: (Bits a) => a -> Int -> a
.<<. :: forall a. Bits a => a -> Int -> a
(.<<.) = a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftL
.>>. :: forall a. Bits a => a -> Int -> a
(.>>.) = a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftR
{-# INLINE (.<-.) #-}
(.<-.) :: (PrimMonad m, Storable a)
=> M.STVector (PrimState m) a -> Int -> a -> m ()
.<-. :: forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
(.<-.) = MVector (PrimState m) a -> Int -> a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
M.write
type HDRReader s a = ExceptT String (ST s) a
data RGBE = RGBE !Word8 !Word8 !Word8 !Word8
instance Binary RGBE where
put :: RGBE -> Put
put (RGBE Word8
r Word8
g Word8
b Word8
e) = Word8 -> Put
forall t. Binary t => t -> Put
put Word8
r Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
forall t. Binary t => t -> Put
put Word8
g Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
forall t. Binary t => t -> Put
put Word8
b Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
forall t. Binary t => t -> Put
put Word8
e
get :: Get RGBE
get = Word8 -> Word8 -> Word8 -> Word8 -> RGBE
RGBE (Word8 -> Word8 -> Word8 -> Word8 -> RGBE)
-> Get Word8 -> Get (Word8 -> Word8 -> Word8 -> RGBE)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get Get (Word8 -> Word8 -> Word8 -> RGBE)
-> Get Word8 -> Get (Word8 -> Word8 -> RGBE)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
forall t. Binary t => Get t
get Get (Word8 -> Word8 -> RGBE) -> Get Word8 -> Get (Word8 -> RGBE)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
forall t. Binary t => Get t
get Get (Word8 -> RGBE) -> Get Word8 -> Get RGBE
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
forall t. Binary t => Get t
get
checkLineLength :: RGBE -> Int
checkLineLength :: RGBE -> Int
checkLineLength (RGBE Word8
_ Word8
_ Word8
a Word8
b) =
(Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a Int -> Int -> Int
forall a. Bits a => a -> Int -> a
.<<. Int
8) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b
isNewRunLengthMarker :: RGBE -> Bool
isNewRunLengthMarker :: RGBE -> Bool
isNewRunLengthMarker (RGBE Word8
2 Word8
2 Word8
_ Word8
_) = Bool
True
isNewRunLengthMarker RGBE
_ = Bool
False
data RadianceFormat =
FormatRGBE
| FormatXYZE
radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString
radiance32bitRleRGBEFormat :: ByteString
radiance32bitRleRGBEFormat = String -> ByteString
BC.pack String
"32-bit_rle_rgbe"
radiance32bitRleXYZEFromat :: ByteString
radiance32bitRleXYZEFromat = String -> ByteString
BC.pack String
"32-bit_rle_xyze"
instance Binary RadianceFormat where
put :: RadianceFormat -> Put
put RadianceFormat
FormatRGBE = ByteString -> Put
putByteString ByteString
radiance32bitRleRGBEFormat
put RadianceFormat
FormatXYZE = ByteString -> Put
putByteString ByteString
radiance32bitRleXYZEFromat
get :: Get RadianceFormat
get = Int -> Get ByteString
getByteString (ByteString -> Int
B.length ByteString
radiance32bitRleRGBEFormat) Get ByteString
-> (ByteString -> Get RadianceFormat) -> Get RadianceFormat
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Get RadianceFormat
forall {f :: * -> *}. MonadFail f => ByteString -> f RadianceFormat
format
where format :: ByteString -> f RadianceFormat
format ByteString
sig
| ByteString
sig ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
radiance32bitRleRGBEFormat = RadianceFormat -> f RadianceFormat
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RadianceFormat
FormatRGBE
| ByteString
sig ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
radiance32bitRleXYZEFromat = RadianceFormat -> f RadianceFormat
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RadianceFormat
FormatXYZE
| Bool
otherwise = String -> f RadianceFormat
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unrecognized Radiance format"
toRGBE :: PixelRGBF -> RGBE
toRGBE :: PixelRGBF -> RGBE
toRGBE (PixelRGBF Float
r Float
g Float
b)
| Float
d Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
1e-32 = Word8 -> Word8 -> Word8 -> Word8 -> RGBE
RGBE Word8
0 Word8
0 Word8
0 Word8
0
| Bool
otherwise = Word8 -> Word8 -> Word8 -> Word8 -> RGBE
RGBE (Float -> Word8
fix Float
r) (Float -> Word8
fix Float
g) (Float -> Word8
fix Float
b) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
128)
where d :: Float
d = [Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float
r, Float
g, Float
b]
e :: Int
e = Float -> Int
forall a. RealFloat a => a -> Int
exponent Float
d
coeff :: Float
coeff = Float -> Float
forall a. RealFloat a => a -> a
significand Float
d Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
255.9999 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
d
fix :: Float -> Word8
fix Float
v = Float -> Word8
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Float -> Word8) -> Float -> Word8
forall a b. (a -> b) -> a -> b
$ Float
v Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
coeff
dropUntil :: Word8 -> Get ()
dropUntil :: Word8 -> Get ()
dropUntil Word8
c = Get Word8
getWord8 Get Word8 -> (Word8 -> Get ()) -> Get ()
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get ()
inner
where inner :: Word8 -> Get ()
inner Word8
val | Word8
val Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
c = () -> Get ()
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
inner Word8
_ = Get Word8
getWord8 Get Word8 -> (Word8 -> Get ()) -> Get ()
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get ()
inner
getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString
getUntil :: (Word8 -> Bool) -> ByteString -> Get ByteString
getUntil Word8 -> Bool
f ByteString
initialAcc = Get Word8
getWord8 Get Word8 -> (Word8 -> Get ByteString) -> Get ByteString
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Word8 -> Get ByteString
inner ByteString
initialAcc
where inner :: ByteString -> Word8 -> Get ByteString
inner ByteString
acc Word8
c | Word8 -> Bool
f Word8
c = ByteString -> Get ByteString
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
acc
inner ByteString
acc Word8
c = Get Word8
getWord8 Get Word8 -> (Word8 -> Get ByteString) -> Get ByteString
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Word8 -> Get ByteString
inner (ByteString -> Word8 -> ByteString
B.snoc ByteString
acc Word8
c)
data =
{ RadianceHeader -> [(ByteString, ByteString)]
radianceInfos :: [(B.ByteString, B.ByteString)]
, RadianceHeader -> RadianceFormat
radianceFormat :: RadianceFormat
, RadianceHeader -> Int
radianceHeight :: !Int
, RadianceHeader -> Int
radianceWidth :: !Int
, RadianceHeader -> ByteString
radianceData :: L.ByteString
}
radianceFileSignature :: B.ByteString
radianceFileSignature :: ByteString
radianceFileSignature = String -> ByteString
BC.pack String
"#?RADIANCE\n"
unpackColor :: L.ByteString -> Int -> RGBE
unpackColor :: ByteString -> Int -> RGBE
unpackColor ByteString
str Int
idx = Word8 -> Word8 -> Word8 -> Word8 -> RGBE
RGBE (Int -> Word8
at Int
0) (Int -> Word8
at Int
1) (Int -> Word8
at Int
2) (Int -> Word8
at Int
3)
where at :: Int -> Word8
at Int
n = HasCallStack => ByteString -> Int64 -> Word8
ByteString -> Int64 -> Word8
L.index ByteString
str (Int64 -> Word8) -> (Int -> Int64) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s ()
storeColor :: forall s. STVector s Word8 -> Int -> RGBE -> ST s ()
storeColor STVector s Word8
vec Int
idx (RGBE Word8
r Word8
g Word8
b Word8
e) = do
(STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
.<-. (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0)) Word8
r
(STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
.<-. (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Word8
g
(STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
.<-. (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) Word8
b
(STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
.<-. (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)) Word8
e
parsePair :: Char -> Get (B.ByteString, B.ByteString)
parsePair :: Char -> Get (ByteString, ByteString)
parsePair Char
firstChar = do
let eol :: a -> Bool
eol a
c = a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'\n')
ByteString
line <- (Word8 -> Bool) -> ByteString -> Get ByteString
getUntil Word8 -> Bool
forall {a}. (Eq a, Num a) => a -> Bool
eol ByteString
B.empty
case Char -> ByteString -> [ByteString]
BC.split Char
'=' ByteString
line of
[] -> (ByteString, ByteString) -> Get (ByteString, ByteString)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> ByteString
BC.singleton Char
firstChar, ByteString
B.empty)
[ByteString
val] -> (ByteString, ByteString) -> Get (ByteString, ByteString)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> ByteString
BC.singleton Char
firstChar, ByteString
val)
[ByteString
key, ByteString
val] -> (ByteString, ByteString) -> Get (ByteString, ByteString)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> ByteString
BC.singleton Char
firstChar ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
key, ByteString
val)
(ByteString
key : [ByteString]
vals) -> (ByteString, ByteString) -> Get (ByteString, ByteString)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> ByteString
BC.singleton Char
firstChar ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
key, [ByteString] -> ByteString
B.concat [ByteString]
vals)
decodeInfos :: Get [(B.ByteString, B.ByteString)]
decodeInfos :: Get [(ByteString, ByteString)]
decodeInfos = do
Char
char <- Get Char
getChar8
case Char
char of
Char
'#' -> Word8 -> Get ()
dropUntil (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'\n') Get ()
-> Get [(ByteString, ByteString)] -> Get [(ByteString, ByteString)]
forall a b. Get a -> Get b -> Get b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get [(ByteString, ByteString)]
decodeInfos
Char
'\n' -> [(ByteString, ByteString)] -> Get [(ByteString, ByteString)]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Char
c -> (:) ((ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> Get (ByteString, ByteString)
-> Get ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Get (ByteString, ByteString)
parsePair Char
c Get ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> Get [(ByteString, ByteString)] -> Get [(ByteString, ByteString)]
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [(ByteString, ByteString)]
decodeInfos
decodeHDR :: B.ByteString -> Either String DynamicImage
decodeHDR :: ByteString -> Either String DynamicImage
decodeHDR = ((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)
decodeHDRWithMetadata
decodeHDRWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
decodeHDRWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
decodeHDRWithMetadata ByteString
str = (forall s. ST s (Either String (DynamicImage, Metadatas)))
-> Either String (DynamicImage, Metadatas)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either String (DynamicImage, Metadatas)))
-> Either String (DynamicImage, Metadatas))
-> (forall s. ST s (Either String (DynamicImage, Metadatas)))
-> Either String (DynamicImage, Metadatas)
forall a b. (a -> b) -> a -> b
$ ExceptT String (ST s) (DynamicImage, Metadatas)
-> ST s (Either String (DynamicImage, Metadatas))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (ST s) (DynamicImage, Metadatas)
-> ST s (Either String (DynamicImage, Metadatas)))
-> ExceptT String (ST s) (DynamicImage, Metadatas)
-> ST s (Either String (DynamicImage, Metadatas))
forall a b. (a -> b) -> a -> b
$
case Get RadianceHeader -> ByteString -> Either String RadianceHeader
forall a. Get a -> ByteString -> Either String a
runGet Get RadianceHeader
decodeHeader (ByteString -> Either String RadianceHeader)
-> ByteString -> Either String RadianceHeader
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks [ByteString
str] of
Left String
err -> String -> ExceptT String (ST s) (DynamicImage, Metadatas)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
err
Right RadianceHeader
rez ->
let meta :: Metadatas
meta = SourceFormat -> Int -> Int -> Metadatas
forall nSize.
Integral nSize =>
SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
SourceHDR (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ RadianceHeader -> Int
radianceWidth RadianceHeader
rez) (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ RadianceHeader -> Int
radianceHeight RadianceHeader
rez) in
(, Metadatas
meta) (DynamicImage -> (DynamicImage, Metadatas))
-> (Image PixelRGBF -> DynamicImage)
-> Image PixelRGBF
-> (DynamicImage, Metadatas)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBF -> DynamicImage
ImageRGBF (Image PixelRGBF -> (DynamicImage, Metadatas))
-> ExceptT String (ST s) (Image PixelRGBF)
-> ExceptT String (ST s) (DynamicImage, Metadatas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RadianceHeader -> HDRReader s (MutableImage s PixelRGBF)
forall s. RadianceHeader -> HDRReader s (MutableImage s PixelRGBF)
decodeRadiancePicture RadianceHeader
rez HDRReader s (MutableImage s PixelRGBF)
-> (MutableImage s PixelRGBF
-> ExceptT String (ST s) (Image PixelRGBF))
-> ExceptT String (ST s) (Image PixelRGBF)
forall a b.
ExceptT String (ST s) a
-> (a -> ExceptT String (ST s) b) -> ExceptT String (ST s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ST s (Image PixelRGBF) -> ExceptT String (ST s) (Image PixelRGBF)
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (Image PixelRGBF) -> ExceptT String (ST s) (Image PixelRGBF))
-> (MutableImage s PixelRGBF -> ST s (Image PixelRGBF))
-> MutableImage s PixelRGBF
-> ExceptT String (ST s) (Image PixelRGBF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutableImage s PixelRGBF -> ST s (Image PixelRGBF)
MutableImage (PrimState (ST s)) PixelRGBF -> ST s (Image PixelRGBF)
forall a (m :: * -> *).
(Storable (PixelBaseComponent a), PrimMonad m) =>
MutableImage (PrimState m) a -> m (Image a)
unsafeFreezeImage)
getChar8 :: Get Char
getChar8 :: Get Char
getChar8 = Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Char) -> Get Word8 -> Get Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
isSign :: Char -> Bool
isSign :: Char -> Bool
isSign Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
isAxisLetter :: Char -> Bool
isAxisLetter :: Char -> Bool
isAxisLetter Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'X' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'Y'
decodeNum :: Get Int
decodeNum :: Get Int
decodeNum = do
Char
sign <- Get Char
getChar8
Char
letter <- Get Char
getChar8
Char
space <- Get Char
getChar8
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char -> Bool
isSign Char
sign Bool -> Bool -> Bool
&& Char -> Bool
isAxisLetter Char
letter Bool -> Bool -> Bool
&& Char
space Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
(String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid radiance size declaration")
let numDec :: Int -> Char -> Get Int
numDec Int
acc Char
c | Char -> Bool
isDigit Char
c =
Get Char
getChar8 Get Char -> (Char -> Get Int) -> Get Int
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Char -> Get Int
numDec (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0')
numDec Int
acc Char
_
| Char
sign Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' = Int -> Get Int
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Get Int) -> Int -> Get Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
negate Int
acc
| Bool
otherwise = Int -> Get Int
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
acc
Get Char
getChar8 Get Char -> (Char -> Get Int) -> Get Int
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Char -> Get Int
numDec Int
0
copyPrevColor :: M.STVector s Word8 -> Int -> ST s ()
copyPrevColor :: forall s. STVector s Word8 -> Int -> ST s ()
copyPrevColor STVector s Word8
scanLine Int
idx = do
Word8
r <- STVector s Word8
MVector (PrimState (ST s)) Word8
scanLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)
Word8
g <- STVector s Word8
MVector (PrimState (ST s)) Word8
scanLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3)
Word8
b <- STVector s Word8
MVector (PrimState (ST s)) Word8
scanLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
Word8
e <- STVector s Word8
MVector (PrimState (ST s)) Word8
scanLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
(STVector s Word8
MVector (PrimState (ST s)) Word8
scanLine MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0)) Word8
r
(STVector s Word8
MVector (PrimState (ST s)) Word8
scanLine MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Word8
g
(STVector s Word8
MVector (PrimState (ST s)) Word8
scanLine MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) Word8
b
(STVector s Word8
MVector (PrimState (ST s)) Word8
scanLine MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)) Word8
e
oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
-> HDRReader s Int
oldStyleRLE :: forall s. ByteString -> Int -> STVector s Word8 -> HDRReader s Int
oldStyleRLE ByteString
inputData Int
initialIdx STVector s Word8
scanLine = Int -> Int -> Int -> ExceptT String (ST s) Int
inner Int
initialIdx Int
0 Int
0
where maxOutput :: Int
maxOutput = STVector s Word8 -> Int
forall a s. Storable a => MVector s a -> Int
M.length STVector s Word8
scanLine
maxInput :: Int
maxInput = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
inputData
inner :: Int -> Int -> Int -> ExceptT String (ST s) Int
inner Int
readIdx Int
writeIdx Int
_
| Int
readIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxInput Bool -> Bool -> Bool
|| Int
writeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxOutput = Int -> ExceptT String (ST s) Int
forall a. a -> ExceptT String (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
readIdx
inner Int
readIdx Int
writeIdx Int
shift = do
let color :: RGBE
color@(RGBE Word8
r Word8
g Word8
b Word8
e) = ByteString -> Int -> RGBE
unpackColor ByteString
inputData Int
readIdx
isRun :: Bool
isRun = Word8
r Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1 Bool -> Bool -> Bool
&& Word8
g Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1 Bool -> Bool -> Bool
&& Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1
if Bool -> Bool
not Bool
isRun
then do
ST s () -> ExceptT String (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> ExceptT String (ST s) ())
-> ST s () -> ExceptT String (ST s) ()
forall a b. (a -> b) -> a -> b
$ STVector s Word8 -> Int -> RGBE -> ST s ()
forall s. STVector s Word8 -> Int -> RGBE -> ST s ()
storeColor STVector s Word8
scanLine Int
writeIdx RGBE
color
Int -> Int -> Int -> ExceptT String (ST s) Int
inner (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) Int
0
else do
let count :: Int
count = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
e Int -> Int -> Int
forall a. Bits a => a -> Int -> a
.<<. Int
shift
ST s () -> ExceptT String (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> ExceptT String (ST s) ())
-> ST s () -> ExceptT String (ST s) ()
forall a b. (a -> b) -> a -> b
$ [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
count] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> STVector s Word8 -> Int -> ST s ()
forall s. STVector s Word8 -> Int -> ST s ()
copyPrevColor STVector s Word8
scanLine (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i)
Int -> Int -> Int -> ExceptT String (ST s) Int
inner (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
count) (Int
shift Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8)
newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
-> HDRReader s Int
newStyleRLE :: forall s. ByteString -> Int -> STVector s Word8 -> HDRReader s Int
newStyleRLE ByteString
inputData Int
initialIdx STVector s Word8
scanline = (Int -> Int -> ExceptT String (ST s) Int)
-> Int -> [Int] -> ExceptT String (ST s) Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Int -> Int -> ExceptT String (ST s) Int
inner Int
initialIdx [Int
0 .. Int
3]
where dataAt :: Int -> ExceptT String (ST s) Word8
dataAt Int
idx
| Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxInput = String -> ExceptT String (ST s) Word8
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String (ST s) Word8)
-> String -> ExceptT String (ST s) Word8
forall a b. (a -> b) -> a -> b
$ String
"Read index out of bound (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
idx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
| Bool
otherwise = Word8 -> ExceptT String (ST s) Word8
forall a. a -> ExceptT String (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> ExceptT String (ST s) Word8)
-> Word8 -> ExceptT String (ST s) Word8
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int64 -> Word8
ByteString -> Int64 -> Word8
L.index ByteString
inputData (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx)
maxOutput :: Int
maxOutput = STVector s Word8 -> Int
forall a s. Storable a => MVector s a -> Int
M.length STVector s Word8
scanline
maxInput :: Int
maxInput = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
inputData
stride :: Int
stride = Int
4
strideSet :: Int -> Int -> Word8 -> ExceptT String (ST s) Int
strideSet Int
count Int
destIndex Word8
_ | Int
endIndex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxOutput Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stride =
String -> ExceptT String (ST s) Int
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String (ST s) Int)
-> String -> ExceptT String (ST s) Int
forall a b. (a -> b) -> a -> b
$ String
"Out of bound HDR scanline " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
endIndex String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (max " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
maxOutput String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
where endIndex :: Int
endIndex = Int
destIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stride
strideSet Int
count Int
destIndex Word8
val = Int -> Int -> ExceptT String (ST s) Int
aux Int
destIndex Int
count
where aux :: Int -> Int -> ExceptT String (ST s) Int
aux Int
i Int
0 = Int -> ExceptT String (ST s) Int
forall a. a -> ExceptT String (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
aux Int
i Int
c = do
ST s () -> ExceptT String (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> ExceptT String (ST s) ())
-> ST s () -> ExceptT String (ST s) ()
forall a b. (a -> b) -> a -> b
$ (STVector s Word8
MVector (PrimState (ST s)) Word8
scanline MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
.<-. Int
i) Word8
val
Int -> Int -> ExceptT String (ST s) Int
aux (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stride) (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
strideCopy :: Int -> Int -> Int -> ExceptT String (ST s) Int
strideCopy Int
_ Int
count Int
destIndex
| Int
writeEndBound Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxOutput Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stride = String -> ExceptT String (ST s) Int
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Out of bound HDR scanline"
where writeEndBound :: Int
writeEndBound = Int
destIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stride
strideCopy Int
sourceIndex Int
count Int
destIndex = Int -> Int -> Int -> ExceptT String (ST s) Int
aux Int
sourceIndex Int
destIndex Int
count
where aux :: Int -> Int -> Int -> ExceptT String (ST s) Int
aux Int
_ Int
j Int
0 = Int -> ExceptT String (ST s) Int
forall a. a -> ExceptT String (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
j
aux Int
i Int
j Int
c = do
Word8
val <- Int -> ExceptT String (ST s) Word8
dataAt Int
i
ST s () -> ExceptT String (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> ExceptT String (ST s) ())
-> ST s () -> ExceptT String (ST s) ()
forall a b. (a -> b) -> a -> b
$ (STVector s Word8
MVector (PrimState (ST s)) Word8
scanline MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
.<-. Int
j) Word8
val
Int -> Int -> Int -> ExceptT String (ST s) Int
aux (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stride) (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
inner :: Int -> Int -> ExceptT String (ST s) Int
inner Int
readIdx Int
writeIdx
| Int
readIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxInput Bool -> Bool -> Bool
|| Int
writeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxOutput = Int -> ExceptT String (ST s) Int
forall a. a -> ExceptT String (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
readIdx
inner Int
readIdx Int
writeIdx = do
Word8
code <- Int -> ExceptT String (ST s) Word8
dataAt Int
readIdx
if Word8
code Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
128
then do
let repeatCount :: Int
repeatCount = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
code Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7F
Word8
newVal <- Int -> ExceptT String (ST s) Word8
dataAt (Int -> ExceptT String (ST s) Word8)
-> Int -> ExceptT String (ST s) Word8
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
Int
endIndex <- Int -> Int -> Word8 -> ExceptT String (ST s) Int
strideSet Int
repeatCount Int
writeIdx Word8
newVal
Int -> Int -> ExceptT String (ST s) Int
inner (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int
endIndex
else do
let iCode :: Int
iCode = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
code
Int
endIndex <- Int -> Int -> Int -> ExceptT String (ST s) Int
strideCopy (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
iCode Int
writeIdx
Int -> Int -> ExceptT String (ST s) Int
inner (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
iCode Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
endIndex
instance Binary RadianceHeader where
get :: Get RadianceHeader
get = Get RadianceHeader
decodeHeader
put :: RadianceHeader -> Put
put RadianceHeader
hdr = do
ByteString -> Put
putByteString ByteString
radianceFileSignature
ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
"FORMAT="
RadianceFormat -> Put
forall t. Binary t => t -> Put
put (RadianceFormat -> Put) -> RadianceFormat -> Put
forall a b. (a -> b) -> a -> b
$ RadianceHeader -> RadianceFormat
radianceFormat RadianceHeader
hdr
let sizeString :: ByteString
sizeString =
String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"\n\n-Y " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (RadianceHeader -> Int
radianceHeight RadianceHeader
hdr)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" +X " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (RadianceHeader -> Int
radianceWidth RadianceHeader
hdr) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
ByteString -> Put
putByteString ByteString
sizeString
ByteString -> Put
putLazyByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ RadianceHeader -> ByteString
radianceData RadianceHeader
hdr
decodeHeader :: Get RadianceHeader
= do
ByteString
sig <- Int -> Get ByteString
getByteString (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
radianceFileSignature
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
sig ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
radianceFileSignature)
(String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid radiance file signature")
[(ByteString, ByteString)]
infos <- Get [(ByteString, ByteString)]
decodeInfos
let formatKey :: ByteString
formatKey = String -> ByteString
BC.pack String
"FORMAT"
case ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)]
-> ([(ByteString, ByteString)], [(ByteString, ByteString)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(ByteString
k,ByteString
_) -> ByteString
k ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
formatKey) [(ByteString, ByteString)]
infos of
([(ByteString, ByteString)]
_, []) -> String -> Get RadianceHeader
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No radiance format specified"
([(ByteString, ByteString)]
info, [(ByteString
_, ByteString
formatString)]) ->
case Get RadianceFormat -> ByteString -> Either String RadianceFormat
forall a. Get a -> ByteString -> Either String a
runGet Get RadianceFormat
forall t. Binary t => Get t
get (ByteString -> Either String RadianceFormat)
-> ByteString -> Either String RadianceFormat
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks [ByteString
formatString] of
Left String
err -> String -> Get RadianceHeader
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right RadianceFormat
format -> do
(Int
n1, Int
n2, ByteString
b) <- (,,) (Int -> Int -> ByteString -> (Int, Int, ByteString))
-> Get Int -> Get (Int -> ByteString -> (Int, Int, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
decodeNum
Get (Int -> ByteString -> (Int, Int, ByteString))
-> Get Int -> Get (ByteString -> (Int, Int, ByteString))
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
decodeNum
Get (ByteString -> (Int, Int, ByteString))
-> Get ByteString -> Get (Int, Int, ByteString)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
getRemainingBytes
RadianceHeader -> Get RadianceHeader
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (RadianceHeader -> Get RadianceHeader)
-> (ByteString -> RadianceHeader)
-> ByteString
-> Get RadianceHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, ByteString)]
-> RadianceFormat -> Int -> Int -> ByteString -> RadianceHeader
RadianceHeader [(ByteString, ByteString)]
info RadianceFormat
format Int
n1 Int
n2 (ByteString -> Get RadianceHeader)
-> ByteString -> Get RadianceHeader
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks [ByteString
b]
([(ByteString, ByteString)], [(ByteString, ByteString)])
_ -> String -> Get RadianceHeader
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Multiple radiance format specified"
toFloat :: RGBE -> PixelRGBF
toFloat :: RGBE -> PixelRGBF
toFloat (RGBE Word8
r Word8
g Word8
b Word8
e) = Float -> Float -> Float -> PixelRGBF
PixelRGBF Float
rf Float
gf Float
bf
where f :: Float
f = Integer -> Int -> Float
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
1 (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
128 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8)
rf :: Float
rf = (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
r Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.0) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
f
gf :: Float
gf = (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.0) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
f
bf :: Float
bf = (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.0) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
f
encodeScanlineColor :: M.STVector s Word8
-> M.STVector s Word8
-> Int
-> ST s Int
encodeScanlineColor :: forall s. STVector s Word8 -> STVector s Word8 -> Int -> ST s Int
encodeScanlineColor STVector s Word8
vec STVector s Word8
outVec Int
outIdx = do
Word8
val <- STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
0
Int -> Int -> Word8 -> Int -> Int -> ST s Int
runLength Int
1 Int
0 Word8
val Int
1 Int
outIdx
where maxIndex :: Int
maxIndex = STVector s Word8 -> Int
forall a s. Storable a => MVector s a -> Int
M.length STVector s Word8
vec
pushRun :: Int -> Word8 -> Int -> ST s Int
pushRun Int
len Word8
val Int
at = do
(STVector s Word8
MVector (PrimState (ST s)) Word8
outVec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
at) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
len Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
0x80
(STVector s Word8
MVector (PrimState (ST s)) Word8
outVec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
at Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Word8
val
Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
at Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
pushData :: Int -> Int -> Int -> ST s Int
pushData Int
start Int
len Int
at = do
(STVector s Word8
MVector (PrimState (ST s)) Word8
outVec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
at) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
let first :: Int
first = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len
end :: Int
end = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
offset :: Int
offset = Int
at Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
first Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
first .. Int
end] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
Word8
v <- STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
i
(STVector s Word8
MVector (PrimState (ST s)) Word8
outVec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)) Word8
v
Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
at Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
runLength :: Int -> Int -> Word8 -> Int -> Int -> ST s Int
runLength Int
run Int
cpy Word8
prev Int
idx Int
at | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxIndex =
case (Int
run, Int
cpy) of
(Int
0, Int
0) -> Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
at
(Int
0, Int
n) -> Int -> Int -> Int -> ST s Int
pushData Int
idx Int
n Int
at
(Int
n, Int
0) -> Int -> Word8 -> Int -> ST s Int
pushRun Int
n Word8
prev Int
at
(Int
_, Int
_) -> String -> ST s Int
forall a. HasCallStack => String -> a
error String
"HDR - Run length algorithm is wrong"
runLength r :: Int
r@Int
127 Int
_ Word8
prev Int
idx Int
at = do
Word8
val <- STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
Int -> Word8 -> Int -> ST s Int
pushRun Int
r Word8
prev Int
at ST s Int -> (Int -> ST s Int) -> ST s Int
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Int -> Int -> Word8 -> Int -> Int -> ST s Int
runLength Int
1 Int
0 Word8
val (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
runLength Int
_ c :: Int
c@Int
127 Word8
_ Int
idx Int
at = do
Word8
val <- STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
Int -> Int -> Int -> ST s Int
pushData Int
idx Int
c Int
at ST s Int -> (Int -> ST s Int) -> ST s Int
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Int -> Int -> Word8 -> Int -> Int -> ST s Int
runLength Int
1 Int
0 Word8
val (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
runLength Int
n Int
0 Word8
prev Int
idx Int
at = do
Word8
val <- STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
case Word8
val Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
prev of
Bool
True -> Int -> Int -> Word8 -> Int -> Int -> ST s Int
runLength (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0 Word8
prev (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
at
Bool
False | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 -> Int -> Int -> Word8 -> Int -> Int -> ST s Int
runLength Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8
val (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
at
Bool
False ->
Int -> Word8 -> Int -> ST s Int
pushRun Int
n Word8
prev Int
at ST s Int -> (Int -> ST s Int) -> ST s Int
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Int -> Int -> Word8 -> Int -> Int -> ST s Int
runLength Int
1 Int
0 Word8
val (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
runLength Int
0 Int
n Word8
prev Int
idx Int
at = do
Word8
val <- STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
if Word8
val Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
prev
then Int -> Int -> Word8 -> Int -> Int -> ST s Int
runLength Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8
val (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
at
else
Int -> Int -> Int -> ST s Int
pushData (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
at ST s Int -> (Int -> ST s Int) -> ST s Int
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Int -> Int -> Word8 -> Int -> Int -> ST s Int
runLength (Int
2 :: Int) Int
0 Word8
val (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
runLength Int
_ Int
_ Word8
_ Int
_ Int
_ =
String -> ST s Int
forall a. HasCallStack => String -> a
error String
"HDR RLE inconsistent state"
writeHDR :: FilePath -> Image PixelRGBF -> IO ()
writeHDR :: String -> Image PixelRGBF -> IO ()
writeHDR String
filename Image PixelRGBF
img = String -> ByteString -> IO ()
L.writeFile String
filename (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Image PixelRGBF -> ByteString
encodeHDR Image PixelRGBF
img
writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO ()
writeRLENewStyleHDR :: String -> Image PixelRGBF -> IO ()
writeRLENewStyleHDR String
filename Image PixelRGBF
img =
String -> ByteString -> IO ()
L.writeFile String
filename (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Image PixelRGBF -> ByteString
encodeRLENewStyleHDR Image PixelRGBF
img
encodeHDR :: Image PixelRGBF -> L.ByteString
encodeHDR :: Image PixelRGBF -> ByteString
encodeHDR = Image PixelRGBF -> ByteString
encodeRawHDR
encodeRawHDR :: Image PixelRGBF -> L.ByteString
encodeRawHDR :: Image PixelRGBF -> ByteString
encodeRawHDR Image PixelRGBF
pic = RadianceHeader -> ByteString
forall a. Binary a => a -> ByteString
encode RadianceHeader
descriptor
where
newImage :: Image PixelRGBA8
newImage = (PixelRGBF -> PixelRGBA8) -> Image PixelRGBF -> Image PixelRGBA8
forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGBF -> PixelRGBA8
rgbeInRgba Image PixelRGBF
pic
rgbeInRgba :: PixelRGBF -> PixelRGBA8
rgbeInRgba PixelRGBF
pixel = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b Word8
e
where RGBE Word8
r Word8
g Word8
b Word8
e = PixelRGBF -> RGBE
toRGBE PixelRGBF
pixel
descriptor :: RadianceHeader
descriptor = RadianceHeader
{ radianceInfos :: [(ByteString, ByteString)]
radianceInfos = []
, radianceFormat :: RadianceFormat
radianceFormat = RadianceFormat
FormatRGBE
, radianceHeight :: Int
radianceHeight = Image PixelRGBF -> Int
forall a. Image a -> Int
imageHeight Image PixelRGBF
pic
, radianceWidth :: Int
radianceWidth = Image PixelRGBF -> Int
forall a. Image a -> Int
imageWidth Image PixelRGBF
pic
, radianceData :: ByteString
radianceData = [ByteString] -> ByteString
L.fromChunks [Vector Word8 -> ByteString
forall a. Storable a => Vector a -> ByteString
toByteString (Vector Word8 -> ByteString) -> Vector Word8 -> ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> Vector (PixelBaseComponent PixelRGBA8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelRGBA8
newImage]
}
encodeRLENewStyleHDR :: Image PixelRGBF -> L.ByteString
encodeRLENewStyleHDR :: Image PixelRGBF -> ByteString
encodeRLENewStyleHDR Image PixelRGBF
pic = RadianceHeader -> ByteString
forall a. Binary a => a -> ByteString
encode (RadianceHeader -> ByteString) -> RadianceHeader -> ByteString
forall a b. (a -> b) -> a -> b
$ (forall s. ST s RadianceHeader) -> RadianceHeader
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s RadianceHeader) -> RadianceHeader)
-> (forall s. ST s RadianceHeader) -> RadianceHeader
forall a b. (a -> b) -> a -> b
$ do
let w :: Int
w = Image PixelRGBF -> Int
forall a. Image a -> Int
imageWidth Image PixelRGBF
pic
h :: Int
h = Image PixelRGBF -> Int
forall a. Image a -> Int
imageHeight Image PixelRGBF
pic
STVector s Word8
scanLineR <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
w :: ST s (M.STVector s Word8)
STVector s Word8
scanLineG <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
w
STVector s Word8
scanLineB <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
w
STVector s Word8
scanLineE <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
w
[ByteString]
encoded <-
[Int] -> (Int -> ST s ByteString) -> ST s [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ByteString) -> ST s [ByteString])
-> (Int -> ST s ByteString) -> ST s [ByteString]
forall a b. (a -> b) -> a -> b
$ \Int
line -> do
STVector s Word8
buff <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector (PrimState (ST s)) Word8))
-> Int -> ST s (MVector (PrimState (ST s)) Word8)
forall a b. (a -> b) -> a -> b
$ Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
127 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
let columner :: Int -> ST s ()
columner Int
col | Int
col Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
columner Int
col = do
let RGBE Word8
r Word8
g Word8
b Word8
e = PixelRGBF -> RGBE
toRGBE (PixelRGBF -> RGBE) -> PixelRGBF -> RGBE
forall a b. (a -> b) -> a -> b
$ Image PixelRGBF -> Int -> Int -> PixelRGBF
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGBF
pic Int
col Int
line
(STVector s Word8
MVector (PrimState (ST s)) Word8
scanLineR MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
col) Word8
r
(STVector s Word8
MVector (PrimState (ST s)) Word8
scanLineG MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
col) Word8
g
(STVector s Word8
MVector (PrimState (ST s)) Word8
scanLineB MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
col) Word8
b
(STVector s Word8
MVector (PrimState (ST s)) Word8
scanLineE MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
col) Word8
e
Int -> ST s ()
columner (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Int -> ST s ()
columner Int
0
(STVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
0) Word8
2
(STVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
1) Word8
2
(STVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
2) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int
w Int -> Int -> Int
forall a. Bits a => a -> Int -> a
.>>. Int
8) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xFF)
(STVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
STVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
3) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
w Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xFF)
Int
i1 <- STVector s Word8 -> STVector s Word8 -> Int -> ST s Int
forall s. STVector s Word8 -> STVector s Word8 -> Int -> ST s Int
encodeScanlineColor STVector s Word8
scanLineR STVector s Word8
buff Int
4
Int
i2 <- STVector s Word8 -> STVector s Word8 -> Int -> ST s Int
forall s. STVector s Word8 -> STVector s Word8 -> Int -> ST s Int
encodeScanlineColor STVector s Word8
scanLineG STVector s Word8
buff Int
i1
Int
i3 <- STVector s Word8 -> STVector s Word8 -> Int -> ST s Int
forall s. STVector s Word8 -> STVector s Word8 -> Int -> ST s Int
encodeScanlineColor STVector s Word8
scanLineB STVector s Word8
buff Int
i2
Int
endIndex <- STVector s Word8 -> STVector s Word8 -> Int -> ST s Int
forall s. STVector s Word8 -> STVector s Word8 -> Int -> ST s Int
encodeScanlineColor STVector s Word8
scanLineE STVector s Word8
buff Int
i3
(\Vector Word8
v -> Vector Word8 -> Int -> Int -> ByteString
blitVector Vector Word8
v Int
0 Int
endIndex) (Vector Word8 -> ByteString)
-> ST s (Vector Word8) -> ST s ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze STVector s Word8
MVector (PrimState (ST s)) Word8
buff
RadianceHeader -> ST s RadianceHeader
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RadianceHeader
{ radianceInfos :: [(ByteString, ByteString)]
radianceInfos = []
, radianceFormat :: RadianceFormat
radianceFormat = RadianceFormat
FormatRGBE
, radianceHeight :: Int
radianceHeight = Int
h
, radianceWidth :: Int
radianceWidth = Int
w
, radianceData :: ByteString
radianceData = [ByteString] -> ByteString
L.fromChunks [ByteString]
encoded
}
decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF)
decodeRadiancePicture :: forall s. RadianceHeader -> HDRReader s (MutableImage s PixelRGBF)
decodeRadiancePicture RadianceHeader
hdr = do
let width :: Int
width = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ RadianceHeader -> Int
radianceWidth RadianceHeader
hdr
height :: Int
height = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ RadianceHeader -> Int
radianceHeight RadianceHeader
hdr
packedData :: ByteString
packedData = RadianceHeader -> ByteString
radianceData RadianceHeader
hdr
STVector s Word8
scanLine <- ST s (STVector s Word8) -> ExceptT String (ST s) (STVector s Word8)
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (STVector s Word8)
-> ExceptT String (ST s) (STVector s Word8))
-> ST s (STVector s Word8)
-> ExceptT String (ST s) (STVector s Word8)
forall a b. (a -> b) -> a -> b
$ Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector (PrimState (ST s)) Word8))
-> Int -> ST s (MVector (PrimState (ST s)) Word8)
forall a b. (a -> b) -> a -> b
$ Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4
MVector s Float
resultBuffer <- ST s (MVector s Float) -> ExceptT String (ST s) (MVector s Float)
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (MVector s Float) -> ExceptT String (ST s) (MVector s Float))
-> ST s (MVector s Float)
-> ExceptT String (ST s) (MVector s Float)
forall a b. (a -> b) -> a -> b
$ Int -> ST s (MVector (PrimState (ST s)) Float)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector (PrimState (ST s)) Float))
-> Int -> ST s (MVector (PrimState (ST s)) Float)
forall a b. (a -> b) -> a -> b
$ Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3
let scanLineImage :: MutableImage s PixelRGBA8
scanLineImage = MutableImage
{ mutableImageWidth :: Int
mutableImageWidth = Int
width
, mutableImageHeight :: Int
mutableImageHeight = Int
1
, mutableImageData :: STVector s (PixelBaseComponent PixelRGBA8)
mutableImageData = STVector s Word8
STVector s (PixelBaseComponent PixelRGBA8)
scanLine
}
finalImage :: MutableImage s PixelRGBF
finalImage = MutableImage
{ mutableImageWidth :: Int
mutableImageWidth = Int
width
, mutableImageHeight :: Int
mutableImageHeight = Int
height
, mutableImageData :: STVector s (PixelBaseComponent PixelRGBF)
mutableImageData = MVector s Float
STVector s (PixelBaseComponent PixelRGBF)
resultBuffer
}
let scanLineExtractor :: Int -> Int -> ExceptT String (ST s) Int
scanLineExtractor Int
readIdx Int
line = do
let color :: RGBE
color = ByteString -> Int -> RGBE
unpackColor ByteString
packedData Int
readIdx
inner :: ExceptT
String
(ST s)
(Int -> STVector s Word8 -> ExceptT String (ST s) Int)
inner | RGBE -> Bool
isNewRunLengthMarker RGBE
color = do
let calcSize :: Int
calcSize = RGBE -> Int
checkLineLength RGBE
color
Bool -> ExceptT String (ST s) () -> ExceptT String (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
calcSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
width)
(String -> ExceptT String (ST s) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Invalid sanline size")
(Int -> STVector s Word8 -> ExceptT String (ST s) Int)
-> ExceptT
String
(ST s)
(Int -> STVector s Word8 -> ExceptT String (ST s) Int)
forall a. a -> ExceptT String (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int -> STVector s Word8 -> ExceptT String (ST s) Int)
-> ExceptT
String
(ST s)
(Int -> STVector s Word8 -> ExceptT String (ST s) Int))
-> (Int -> STVector s Word8 -> ExceptT String (ST s) Int)
-> ExceptT
String
(ST s)
(Int -> STVector s Word8 -> ExceptT String (ST s) Int)
forall a b. (a -> b) -> a -> b
$ \Int
idx -> ByteString -> Int -> STVector s Word8 -> ExceptT String (ST s) Int
forall s. ByteString -> Int -> STVector s Word8 -> HDRReader s Int
newStyleRLE ByteString
packedData (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
| Bool
otherwise = (Int -> STVector s Word8 -> ExceptT String (ST s) Int)
-> ExceptT
String
(ST s)
(Int -> STVector s Word8 -> ExceptT String (ST s) Int)
forall a. a -> ExceptT String (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int -> STVector s Word8 -> ExceptT String (ST s) Int)
-> ExceptT
String
(ST s)
(Int -> STVector s Word8 -> ExceptT String (ST s) Int))
-> (Int -> STVector s Word8 -> ExceptT String (ST s) Int)
-> ExceptT
String
(ST s)
(Int -> STVector s Word8 -> ExceptT String (ST s) Int)
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> STVector s Word8 -> ExceptT String (ST s) Int
forall s. ByteString -> Int -> STVector s Word8 -> HDRReader s Int
oldStyleRLE ByteString
packedData
Int -> STVector s Word8 -> ExceptT String (ST s) Int
f <- ExceptT
String
(ST s)
(Int -> STVector s Word8 -> ExceptT String (ST s) Int)
inner
Int
newRead <- Int -> STVector s Word8 -> ExceptT String (ST s) Int
f Int
readIdx STVector s Word8
scanLine
[Int]
-> (Int -> ExceptT String (ST s) ()) -> ExceptT String (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ExceptT String (ST s) ()) -> ExceptT String (ST s) ())
-> (Int -> ExceptT String (ST s) ()) -> ExceptT String (ST s) ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
PixelRGBA8 Word8
r Word8
g Word8
b Word8
e <- ST s PixelRGBA8 -> ExceptT String (ST s) PixelRGBA8
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s PixelRGBA8 -> ExceptT String (ST s) PixelRGBA8)
-> ST s PixelRGBA8 -> ExceptT String (ST s) PixelRGBA8
forall a b. (a -> b) -> a -> b
$ MutableImage (PrimState (ST s)) PixelRGBA8
-> Int -> Int -> ST s PixelRGBA8
forall a (m :: * -> *).
(Pixel a, PrimMonad m) =>
MutableImage (PrimState m) a -> Int -> Int -> m a
forall (m :: * -> *).
PrimMonad m =>
MutableImage (PrimState m) PixelRGBA8 -> Int -> Int -> m PixelRGBA8
readPixel MutableImage s PixelRGBA8
MutableImage (PrimState (ST s)) PixelRGBA8
scanLineImage Int
i Int
0
ST s () -> ExceptT String (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> ExceptT String (ST s) ())
-> ST s () -> ExceptT String (ST s) ()
forall a b. (a -> b) -> a -> b
$ MutableImage (PrimState (ST s)) PixelRGBF
-> Int -> Int -> PixelRGBF -> ST s ()
forall a (m :: * -> *).
(Pixel a, PrimMonad m) =>
MutableImage (PrimState m) a -> Int -> Int -> a -> m ()
forall (m :: * -> *).
PrimMonad m =>
MutableImage (PrimState m) PixelRGBF
-> Int -> Int -> PixelRGBF -> m ()
writePixel MutableImage s PixelRGBF
MutableImage (PrimState (ST s)) PixelRGBF
finalImage Int
i Int
line (PixelRGBF -> ST s ()) -> (RGBE -> PixelRGBF) -> RGBE -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RGBE -> PixelRGBF
toFloat (RGBE -> ST s ()) -> RGBE -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Word8 -> RGBE
RGBE Word8
r Word8
g Word8
b Word8
e
Int -> ExceptT String (ST s) Int
forall a. a -> ExceptT String (ST s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
newRead
(Int -> Int -> ExceptT String (ST s) Int)
-> Int -> [Int] -> ExceptT String (ST s) ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ Int -> Int -> ExceptT String (ST s) Int
scanLineExtractor Int
0 [Int
0 .. Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
MutableImage s PixelRGBF -> HDRReader s (MutableImage s PixelRGBF)
forall a. a -> ExceptT String (ST s) a
forall (m :: * -> *) a. Monad m => a -> m a
return MutableImage s PixelRGBF
finalImage