{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections   #-}
-- | Module dedicated of Radiance file decompression (.hdr or .pic) file.

-- Radiance file format is used for High dynamic range imaging.

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
-- Transfomers 0.3 compat

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
.<<. :: a -> Int -> a
(.<<.) = a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftL
.>>. :: 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 ()
.<-. :: STVector (PrimState m) a -> Int -> a -> m ()
(.<-.) = STVector (PrimState m) a -> Int -> a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
M.write 
         {-M.unsafeWrite-}

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 (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 (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 (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 (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 (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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure RadianceFormat
FormatXYZE
            | Bool
otherwise = String -> f RadianceFormat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unrecognized Radiance format"

toRGBE :: PixelRGBF -> RGBE
toRGBE :: PixelRGBF -> RGBE
toRGBE (PixelRGBF PixelF
r PixelF
g PixelF
b)
    | PixelF
d PixelF -> PixelF -> Bool
forall a. Ord a => a -> a -> Bool
<= PixelF
1e-32 = Word8 -> Word8 -> Word8 -> Word8 -> RGBE
RGBE Word8
0 Word8
0 Word8
0 Word8
0
    | Bool
otherwise = Word8 -> Word8 -> Word8 -> Word8 -> RGBE
RGBE (PixelF -> Word8
fix PixelF
r) (PixelF -> Word8
fix PixelF
g) (PixelF -> Word8
fix PixelF
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 :: PixelF
d = [PixelF] -> PixelF
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [PixelF
r, PixelF
g, PixelF
b]
        e :: Int
e = PixelF -> Int
forall a. RealFloat a => a -> Int
exponent PixelF
d
        coeff :: PixelF
coeff = PixelF -> PixelF
forall a. RealFloat a => a -> a
significand PixelF
d PixelF -> PixelF -> PixelF
forall a. Num a => a -> a -> a
*  PixelF
255.9999 PixelF -> PixelF -> PixelF
forall a. Fractional a => a -> a -> a
/ PixelF
d
        fix :: PixelF -> Word8
fix PixelF
v = PixelF -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
truncate (PixelF -> Word8) -> PixelF -> Word8
forall a b. (a -> b) -> a -> b
$ PixelF
v PixelF -> PixelF -> PixelF
forall a. Num a => a -> a -> a
* PixelF
coeff


dropUntil :: Word8 -> Get ()
dropUntil :: Word8 -> Get ()
dropUntil Word8
c = Get Word8
getWord8 Get Word8 -> (Word8 -> Get ()) -> Get ()
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
        inner Word8
_ = Get Word8
getWord8 Get Word8 -> (Word8 -> Get ()) -> Get ()
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 (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 (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 (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 = RadianceHeader
  { 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 = 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 :: 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) =>
MVector (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) =>
MVector (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) =>
MVector (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) =>
MVector (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 (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 (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 (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 (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
      -- comment

      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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get [(ByteString, ByteString)]
decodeInfos
      -- end of header, no more information

      Char
'\n' -> [(ByteString, ByteString)] -> Get [(ByteString, ByteString)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      -- Classical parsing

      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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [(ByteString, ByteString)]
decodeInfos


-- | Decode an HDR (radiance) image, the resulting image can be:

--

--  * 'ImageRGBF'

--

decodeHDR :: B.ByteString -> Either String DynamicImage
decodeHDR :: ByteString -> Either String DynamicImage
decodeHDR = ((DynamicImage, Metadatas) -> DynamicImage)
-> Either String (DynamicImage, Metadatas)
-> Either String DynamicImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynamicImage, Metadatas) -> DynamicImage
forall a b. (a, b) -> a
fst (Either String (DynamicImage, Metadatas)
 -> Either String DynamicImage)
-> (ByteString -> Either String (DynamicImage, Metadatas))
-> ByteString
-> Either String DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (DynamicImage, Metadatas)
decodeHDRWithMetadata

-- | Equivalent to decodeHDR but with aditional metadatas.

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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ST s (Image PixelRGBF) -> ExceptT String (ST s) (Image PixelRGBF)
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)
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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Int
acc

    Get Char
getChar8 Get Char -> (Char -> Get Int) -> Get Int
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 :: 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) =>
MVector (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) =>
MVector (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) =>
MVector (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) =>
MVector (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 :: ByteString -> Int -> STVector s Word8 -> HDRReader s Int
oldStyleRLE ByteString
inputData Int
initialIdx STVector s Word8
scanLine = Int -> Int -> Int -> HDRReader 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 -> HDRReader 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 -> HDRReader s Int
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 (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 -> HDRReader 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 (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 -> HDRReader 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 :: ByteString -> Int -> STVector s Word8 -> HDRReader s Int
newStyleRLE ByteString
inputData Int
initialIdx STVector s Word8
scanline = (Int -> Int -> HDRReader s Int) -> Int -> [Int] -> HDRReader s Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Int -> Int -> HDRReader 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 (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
$ 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 -> HDRReader 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 -> HDRReader s Int
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String -> HDRReader s Int) -> String -> HDRReader 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 -> HDRReader s Int
aux Int
destIndex Int
count
            where aux :: Int -> Int -> HDRReader s Int
aux Int
i Int
0 =  Int -> HDRReader s Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
                  aux Int
i Int
c = do
                    ST s () -> ExceptT String (ST s) ()
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) =>
MVector (PrimState m) a -> Int -> a -> m ()
.<-. Int
i) Word8
val
                    Int -> Int -> HDRReader 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 -> HDRReader 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 -> HDRReader 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 -> HDRReader s Int
aux Int
sourceIndex Int
destIndex Int
count
          where aux :: Int -> Int -> Int -> HDRReader s Int
aux Int
_ Int
j Int
0 = Int -> HDRReader s Int
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 (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) =>
MVector (PrimState m) a -> Int -> a -> m ()
.<-. Int
j) Word8
val
                    Int -> Int -> Int -> HDRReader 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 -> HDRReader 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 -> HDRReader s Int
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 -> HDRReader s Int
strideSet Int
repeatCount Int
writeIdx Word8
newVal
              Int -> Int -> HDRReader 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 -> HDRReader s Int
strideCopy (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
iCode Int
writeIdx
              Int -> Int -> HDRReader 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
decodeHeader :: Get RadianceHeader
decodeHeader = 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 (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 (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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
getRemainingBytes
              RadianceHeader -> Get RadianceHeader
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 (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) = PixelF -> PixelF -> PixelF -> PixelRGBF
PixelRGBF PixelF
rf PixelF
gf PixelF
bf
  where f :: PixelF
f = Integer -> Int -> PixelF
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
1 (Int -> PixelF) -> Int -> PixelF
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 :: PixelF
rf = (Word8 -> PixelF
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
r PixelF -> PixelF -> PixelF
forall a. Num a => a -> a -> a
+ PixelF
0.0) PixelF -> PixelF -> PixelF
forall a. Num a => a -> a -> a
* PixelF
f
        gf :: PixelF
gf = (Word8 -> PixelF
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g PixelF -> PixelF -> PixelF
forall a. Num a => a -> a -> a
+ PixelF
0.0) PixelF -> PixelF -> PixelF
forall a. Num a => a -> a -> a
* PixelF
f
        bf :: PixelF
bf = (Word8 -> PixelF
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b PixelF -> PixelF -> PixelF
forall a. Num a => a -> a -> a
+ PixelF
0.0) PixelF -> PixelF -> PixelF
forall a. Num a => a -> a -> a
* PixelF
f

encodeScanlineColor :: M.STVector s Word8
                    -> M.STVector s Word8
                    -> Int
                    -> ST s Int
encodeScanlineColor :: 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) =>
MVector (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) =>
MVector (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 (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) =>
MVector (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) =>
MVector (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 (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

        -- End of scanline, empty the thing

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

        -- full runlength, we must write the packet

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

        -- full copy, we must write the packet

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

-- | Write an High dynamic range image into a radiance

-- image file on disk.

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

-- | Write a RLE encoded High dynamic range image into a radiance

-- image file on disk.

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

-- | Encode an High dynamic range image into a radiance image

-- file format.

-- Alias for encodeRawHDR

encodeHDR :: Image PixelRGBF -> L.ByteString
encodeHDR :: Image PixelRGBF -> ByteString
encodeHDR = Image PixelRGBF -> ByteString
encodeRawHDR

-- | Encode an High dynamic range image into a radiance image

-- file format. without compression

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
    -- we are cheating to death here, the layout we want

    -- correspond to the layout of pixelRGBA8, so we

    -- convert

    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 :: [(ByteString, ByteString)]
-> RadianceFormat -> Int -> Int -> ByteString -> RadianceHeader
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]
        }


-- | Encode an High dynamic range image into a radiance image

-- file format using a light RLE compression. Some problems

-- seem to arise with some image viewer.

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 (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) =>
MVector (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) =>
MVector (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) =>
MVector (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) =>
MVector (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) =>
MVector (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) =>
MVector (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) =>
MVector (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) =>
MVector (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 (f :: * -> *) a. Applicative f => a -> f a
pure RadianceHeader :: [(ByteString, ByteString)]
-> RadianceFormat -> Int -> Int -> ByteString -> RadianceHeader
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 :: 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 (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 PixelF
resultBuffer <- ST s (MVector s PixelF) -> ExceptT String (ST s) (MVector s PixelF)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (MVector s PixelF)
 -> ExceptT String (ST s) (MVector s PixelF))
-> ST s (MVector s PixelF)
-> ExceptT String (ST s) (MVector s PixelF)
forall a b. (a -> b) -> a -> b
$ Int -> ST s (MVector (PrimState (ST s)) PixelF)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector (PrimState (ST s)) PixelF))
-> Int -> ST s (MVector (PrimState (ST s)) PixelF)
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 :: forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
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 :: forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
MutableImage
                   { mutableImageWidth :: Int
mutableImageWidth = Int
width
                   , mutableImageHeight :: Int
mutableImageHeight = Int
height
                   , mutableImageData :: STVector s (PixelBaseComponent PixelRGBF)
mutableImageData = MVector s PixelF
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 (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 (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
              -- mokay, it's a hack, but I don't want to define a

              -- pixel instance of RGBE...

              PixelRGBA8 Word8
r Word8
g Word8
b Word8
e <- ST s PixelRGBA8 -> ExceptT String (ST s) PixelRGBA8
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
readPixel MutableImage s PixelRGBA8
MutableImage (PrimState (ST s)) PixelRGBA8
scanLineImage Int
i Int
0
              ST s () -> ExceptT String (ST s) ()
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 ()
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 (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 (m :: * -> *) a. Monad m => a -> m a
return MutableImage s PixelRGBF
finalImage