Hello community,
here is the log from the commit of package ghc-JuicyPixels for openSUSE:Factory
checked in at 2019-06-30 10:21:23
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-JuicyPixels (Old)
and /work/SRC/openSUSE:Factory/.ghc-JuicyPixels.new.4615 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-JuicyPixels"
Sun Jun 30 10:21:23 2019 rev:24 rq:712498 version:3.3.3.1
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-JuicyPixels/ghc-JuicyPixels.changes
2019-06-19 21:11:46.662706206 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-JuicyPixels.new.4615/ghc-JuicyPixels.changes
2019-06-30 10:21:24.515611552 +0200
@@ -1,0 +2,9 @@
+Thu Jun 20 02:03:03 UTC 2019 - [email protected]
+
+- Update JuicyPixels to version 3.3.3.1.
+ Upstream has edited the change log file since the last release in
+ a non-trivial way, i.e. they did more than just add a new entry
+ at the top. You can review the file at:
+ http://hackage.haskell.org/package/JuicyPixels-3.3.3.1/src/changelog
+
+-------------------------------------------------------------------
Old:
----
JuicyPixels-3.3.3.tar.gz
JuicyPixels.cabal
New:
----
JuicyPixels-3.3.3.1.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-JuicyPixels.spec ++++++
--- /var/tmp/diff_new_pack.pVyu0T/_old 2019-06-30 10:21:25.199612615 +0200
+++ /var/tmp/diff_new_pack.pVyu0T/_new 2019-06-30 10:21:25.207612627 +0200
@@ -18,14 +18,13 @@
%global pkg_name JuicyPixels
Name: ghc-%{pkg_name}
-Version: 3.3.3
+Version: 3.3.3.1
Release: 0
Summary: Picture loading/serialization (in png, jpeg, bitmap, gif, tga,
tiff and radiance)
License: BSD-3-Clause
Group: Development/Libraries/Haskell
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
-Source1:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/2.cabal#/%{pkg_name}.cabal
BuildRequires: ghc-Cabal-devel
BuildRequires: ghc-binary-devel
BuildRequires: ghc-bytestring-devel
@@ -55,7 +54,6 @@
%prep
%setup -q -n %{pkg_name}-%{version}
-cp -p %{SOURCE1} %{pkg_name}.cabal
%build
%ghc_lib_build
++++++ JuicyPixels-3.3.3.tar.gz -> JuicyPixels-3.3.3.1.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/JuicyPixels-3.3.3/JuicyPixels.cabal
new/JuicyPixels-3.3.3.1/JuicyPixels.cabal
--- old/JuicyPixels-3.3.3/JuicyPixels.cabal 2018-12-16 22:36:06.000000000
+0100
+++ new/JuicyPixels-3.3.3.1/JuicyPixels.cabal 2019-06-19 21:11:57.000000000
+0200
@@ -1,5 +1,5 @@
Name: JuicyPixels
-Version: 3.3.3
+Version: 3.3.3.1
Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif,
tga, tiff and radiance)
Description:
<<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>>
@@ -28,7 +28,7 @@
Source-Repository this
Type: git
Location: git://github.com/Twinside/Juicy.Pixels.git
- Tag: v3.3.3
+ Tag: v3.3.3.1
Flag Mmap
Description: Enable the file loading via mmap (memory map)
@@ -69,11 +69,11 @@
Build-depends: base >= 4.8 && < 6,
bytestring >= 0.9 && < 0.11,
mtl >= 1.1 && < 2.3,
- binary >= 0.5 && < 0.9,
+ binary >= 0.8.1 && < 0.9,
zlib >= 0.5.3.1 && < 0.7,
transformers >= 0.2,
vector >= 0.10 && < 0.13,
- primitive >= 0.4 && < 0.7,
+ primitive >= 0.4,
deepseq >= 1.1 && < 1.5,
containers >= 0.4.2 && < 0.7
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/JuicyPixels-3.3.3/changelog
new/JuicyPixels-3.3.3.1/changelog
--- old/JuicyPixels-3.3.3/changelog 2018-12-16 22:36:06.000000000 +0100
+++ new/JuicyPixels-3.3.3.1/changelog 2019-06-19 21:11:17.000000000 +0200
@@ -1,6 +1,11 @@
Change log
==========
+v3.3.3.1 June 2019
+------------------
+
+ * New GHC maintenance (thanks to ekmett)
+
v3.3.3 December 2018
--------------------
@@ -9,6 +14,8 @@
* Refactoring: exposing dynamicMap & dynamicPixelMap
through `Codec.Picture` (thnks to LightAndLight)
+ * v3.3.3.1: fixing compilation with older GHC
+
v3.3.2 October 2018
-------------------
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/JuicyPixels-3.3.3/src/Codec/Picture/Bitmap.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/Bitmap.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/Bitmap.hs 2018-12-16
22:36:06.000000000 +0100
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/Bitmap.hs 2019-06-19
21:11:57.000000000 +0200
@@ -12,9 +12,9 @@
, decodeBitmap
, decodeBitmapWithMetadata
, decodeBitmapWithPaletteAndMetadata
- , encodeDynamicBitmap
+ , encodeDynamicBitmap
, encodeBitmapWithPaletteAndMetadata
- , writeDynamicBitmap
+ , writeDynamicBitmap
-- * Accepted format in output
, BmpEncodable( )
) where
@@ -36,12 +36,12 @@
, putInt32le
, putWord16le
, putWord32le
- , putByteString
+ , putByteString
)
import Data.Binary.Get( Get
, getWord8
- , getWord16le
+ , getWord16le
, getWord32le
, getInt32le
, getByteString
@@ -400,7 +400,7 @@
instance BmpEncodable PixelRGBA8 where
hasAlpha _ = True
bitsPerPixel _ = 32
- bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
+ bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l
where
putVector vec = putByteString . blitVector vec 0 $ w * 4
@@ -445,7 +445,7 @@
let r = arr `VS.unsafeIndex` readIdx
g = arr `VS.unsafeIndex` (readIdx + 1)
b = arr `VS.unsafeIndex` (readIdx + 2)
-
+
(buff `M.unsafeWrite` writeIdx) b
(buff `M.unsafeWrite` (writeIdx + 1)) g
(buff `M.unsafeWrite` (writeIdx + 2)) r
@@ -624,7 +624,7 @@
VS.unsafeFreeze arr
padding = linePadding (fromIntegral bpp) wi
-
+
readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
readLine arr readIndex line = case lowBPP of
OneBPP -> inner1 readIndex writeIndex
@@ -678,7 +678,7 @@
inner (0 : 1 : _) _ = return ()
inner (0 : 2 : hOffset : vOffset : rest) (yOffset, _) =
inner rest (yOffset - (wi * fromIntegral vOffset), fromIntegral
hOffset)
- inner (0 : n : rest) writePos =
+ inner (0 : n : rest) writePos =
let isPadded = if is4bpp then (n + 3) .&. 0x3 < 2 else odd n
in copyN isPadded (fromIntegral n) rest writePos
inner (n : b : rest) writePos = writeN (fromIntegral n) b rest writePos
@@ -735,7 +735,7 @@
metadataOfHeader :: BmpV5Header -> Maybe B.ByteString -> Metadatas
metadataOfHeader hdr iccProfile =
- cs <> Met.simpleMetadata Met.SourceBitmap (width hdr) (abs $ height hdr)
dpiX dpiY
+ cs `mappend` Met.simpleMetadata Met.SourceBitmap (width hdr) (abs $ height
hdr) dpiX dpiY
where
dpiX = Met.dotsPerMeterToDotPerInch . fromIntegral $ xResolution hdr
dpiY = Met.dotsPerMeterToDotPerInch . fromIntegral $ yResolution hdr
@@ -847,7 +847,7 @@
decodeImageRGB8 RGB24 hdr rest
(16, 1, 0) -> do
rest <- getData
- return . TrueColorImage . ImageRGB8 $
+ return . TrueColorImage . ImageRGB8 $
decodeImageRGB8 (RGB16 defaultBitfieldsRGB16) hdr rest
(16, 1, 3) -> do
r <- getBitfield . fromIntegral $ 0xFFFF .&. redMask hdr
@@ -884,7 +884,11 @@
a -> fail $ "Can't handle BMP file " ++ show a
-- | Decode a bitfield. Will fail if the bitfield is empty.
+#if MIN_VERSION_base(4,13,0)
+getBitfield :: (FiniteBits t, Integral t, Num t, MonadFail m) => t -> m
(Bitfield t)
+#else
getBitfield :: (FiniteBits t, Integral t, Num t, Monad m) => t -> m (Bitfield
t)
+#endif
getBitfield 0 = fail $
"Codec.Picture.Bitmap.getBitfield: bitfield cannot be 0"
getBitfield w = return (makeBitfield w)
@@ -911,7 +915,7 @@
-- the following metadatas:
--
-- * 'Codec.Picture.Metadata.DpiX'
--- * 'Codec.Picture.Metadata.DpiY'
+-- * 'Codec.Picture.Metadata.DpiY'
--
encodeBitmapWithMetadata :: forall pixel. BmpEncodable pixel
=> Metadatas -> Image pixel -> L.ByteString
@@ -952,7 +956,7 @@
-- the following metadatas:
--
-- * 'Codec.Picture.Metadata.DpiX'
--- * 'Codec.Picture.Metadata.DpiY'
+-- * 'Codec.Picture.Metadata.DpiY'
--
encodeBitmapWithPaletteAndMetadata :: forall pixel. (BmpEncodable pixel)
=> Metadatas -> BmpPalette -> Image pixel
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/JuicyPixels-3.3.3/src/Codec/Picture/ColorQuant.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/ColorQuant.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/ColorQuant.hs 2018-03-14
21:32:58.000000000 +0100
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/ColorQuant.hs 2019-06-19
21:11:57.000000000 +0200
@@ -120,7 +120,7 @@
(bg, br, bb) = bitDiv3 maxCols
(dr, dg, db) = (2^(8-br), 2^(8-bg), 2^(8-bb))
paletteIndex (PixelRGB8 r g b) = fromIntegral $ fromMaybe 0 (elemIndex
- (PixelRGB8 (r .&. (256 - dr)) (g .&. (256 - dg)) (b .&. (256 - db)))
+ (PixelRGB8 (r .&. negate dr) (g .&. negate dg) (b .&. negate db))
paletteList)
isColorCountBelow :: Int -> Image PixelRGB8 -> (Set.Set PixelRGB8, Bool)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/JuicyPixels-3.3.3/src/Codec/Picture/HDR.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/HDR.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/HDR.hs 2016-09-04
14:18:57.000000000 +0200
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/HDR.hs 2019-06-19
21:11:57.000000000 +0200
@@ -1,530 +1,534 @@
-{-# 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 )
-import Data.Monoid( (<>) )
-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
-(.<<.) = unsafeShiftL
-(.>>.) = unsafeShiftR
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a)
- => M.STVector (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 r g b e) = put r >> put g >> put b >> put e
- get = RGBE <$> get <*> get <*> get <*> get
-
-checkLineLength :: RGBE -> Int
-checkLineLength (RGBE _ _ a b) =
- (fromIntegral a .<<. 8) .|. fromIntegral b
-
-isNewRunLengthMarker :: RGBE -> Bool
-isNewRunLengthMarker (RGBE 2 2 _ _) = True
-isNewRunLengthMarker _ = False
-
-data RadianceFormat =
- FormatRGBE
- | FormatXYZE
-
-radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString
-radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe"
-radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze"
-
-instance Binary RadianceFormat where
- put FormatRGBE = putByteString radiance32bitRleRGBEFormat
- put FormatXYZE = putByteString radiance32bitRleXYZEFromat
-
- get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format
- where format sig
- | sig == radiance32bitRleRGBEFormat = pure FormatRGBE
- | sig == radiance32bitRleXYZEFromat = pure FormatXYZE
- | otherwise = fail "Unrecognized Radiance format"
-
-toRGBE :: PixelRGBF -> RGBE
-toRGBE (PixelRGBF r g b)
- | d <= 1e-32 = RGBE 0 0 0 0
- | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128)
- where d = maximum [r, g, b]
- e = exponent d
- coeff = significand d * 255.9999 / d
- fix v = truncate $ v * coeff
-
-
-dropUntil :: Word8 -> Get ()
-dropUntil c = getWord8 >>= inner
- where inner val | val == c = pure ()
- inner _ = getWord8 >>= inner
-
-getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString
-getUntil f initialAcc = getWord8 >>= inner initialAcc
- where inner acc c | f c = pure acc
- inner acc c = getWord8 >>= inner (B.snoc acc c)
-
-data RadianceHeader = RadianceHeader
- { radianceInfos :: [(B.ByteString, B.ByteString)]
- , radianceFormat :: RadianceFormat
- , radianceHeight :: !Int
- , radianceWidth :: !Int
- , radianceData :: L.ByteString
- }
-
-radianceFileSignature :: B.ByteString
-radianceFileSignature = BC.pack "#?RADIANCE\n"
-
-unpackColor :: L.ByteString -> Int -> RGBE
-unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3)
- where at n = L.index str . fromIntegral $ idx + n
-
-storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s ()
-storeColor vec idx (RGBE r g b e) = do
- (vec .<-. (idx + 0)) r
- (vec .<-. (idx + 1)) g
- (vec .<-. (idx + 2)) b
- (vec .<-. (idx + 3)) e
-
-parsePair :: Char -> Get (B.ByteString, B.ByteString)
-parsePair firstChar = do
- let eol c = c == fromIntegral (ord '\n')
- line <- getUntil eol B.empty
- case BC.split '=' line of
- [] -> pure (BC.singleton firstChar, B.empty)
- [val] -> pure (BC.singleton firstChar, val)
- [key, val] -> pure (BC.singleton firstChar <> key, val)
- (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals)
-
-decodeInfos :: Get [(B.ByteString, B.ByteString)]
-decodeInfos = do
- char <- getChar8
- case char of
- -- comment
- '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos
- -- end of header, no more information
- '\n' -> pure []
- -- Classical parsing
- c -> (:) <$> parsePair c <*> decodeInfos
-
-
--- | Decode an HDR (radiance) image, the resulting image can be:
---
--- * 'ImageRGBF'
---
-decodeHDR :: B.ByteString -> Either String DynamicImage
-decodeHDR = fmap fst . decodeHDRWithMetadata
-
--- | Equivalent to decodeHDR but with aditional metadatas.
-decodeHDRWithMetadata :: B.ByteString -> Either String (DynamicImage,
Metadatas)
-decodeHDRWithMetadata str = runST $ runExceptT $
- case runGet decodeHeader $ L.fromChunks [str] of
- Left err -> throwE err
- Right rez ->
- let meta = basicMetadata SourceHDR (abs $ radianceWidth rez) (abs $
radianceHeight rez) in
- (, meta) . ImageRGBF <$> (decodeRadiancePicture rez >>= lift .
unsafeFreezeImage)
-
-getChar8 :: Get Char
-getChar8 = chr . fromIntegral <$> getWord8
-
-isSign :: Char -> Bool
-isSign c = c == '+' || c == '-'
-
-isAxisLetter :: Char -> Bool
-isAxisLetter c = c == 'X' || c == 'Y'
-
-decodeNum :: Get Int
-decodeNum = do
- sign <- getChar8
- letter <- getChar8
- space <- getChar8
-
- unless (isSign sign && isAxisLetter letter && space == ' ')
- (fail "Invalid radiance size declaration")
-
- let numDec acc c | isDigit c =
- getChar8 >>= numDec (acc * 10 + ord c - ord '0')
- numDec acc _
- | sign == '-' = pure $ negate acc
- | otherwise = pure acc
-
- getChar8 >>= numDec 0
-
-copyPrevColor :: M.STVector s Word8 -> Int -> ST s ()
-copyPrevColor scanLine idx = do
- r <- scanLine `M.unsafeRead` (idx - 4)
- g <- scanLine `M.unsafeRead` (idx - 3)
- b <- scanLine `M.unsafeRead` (idx - 2)
- e <- scanLine `M.unsafeRead` (idx - 1)
-
- (scanLine `M.unsafeWrite` (idx + 0)) r
- (scanLine `M.unsafeWrite` (idx + 1)) g
- (scanLine `M.unsafeWrite` (idx + 2)) b
- (scanLine `M.unsafeWrite` (idx + 3)) e
-
-oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
- -> HDRReader s Int
-oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0
- where maxOutput = M.length scanLine
- maxInput = fromIntegral $ L.length inputData
-
- inner readIdx writeIdx _
- | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx
- inner readIdx writeIdx shift = do
- let color@(RGBE r g b e) = unpackColor inputData readIdx
- isRun = r == 1 && g == 1 && b == 1
-
- if not isRun
- then do
- lift $ storeColor scanLine writeIdx color
- inner (readIdx + 4) (writeIdx + 4) 0
-
- else do
- let count = fromIntegral e .<<. shift
- lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine
(writeIdx + 4 * i)
- inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8)
-
-newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
- -> HDRReader s Int
-newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3]
- where dataAt idx
- | fromIntegral idx >= maxInput = throwE $ "Read index out of bound
(" ++ show idx ++ ")"
- | otherwise = pure $ L.index inputData (fromIntegral idx)
-
- maxOutput = M.length scanline
- maxInput = fromIntegral $ L.length inputData
- stride = 4
-
-
- strideSet count destIndex _ | endIndex > maxOutput + stride =
- throwE $ "Out of bound HDR scanline " ++ show endIndex ++ " (max "
++ show maxOutput ++ ")"
- where endIndex = destIndex + count * stride
- strideSet count destIndex val = aux destIndex count
- where aux i 0 = pure i
- aux i c = do
- lift $ (scanline .<-. i) val
- aux (i + stride) (c - 1)
-
-
- strideCopy _ count destIndex
- | writeEndBound > maxOutput + stride = throwE "Out of bound HDR
scanline"
- where writeEndBound = destIndex + count * stride
- strideCopy sourceIndex count destIndex = aux sourceIndex destIndex
count
- where aux _ j 0 = pure j
- aux i j c = do
- val <- dataAt i
- lift $ (scanline .<-. j) val
- aux (i + 1) (j + stride) (c - 1)
-
- inner readIdx writeIdx
- | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx
- inner readIdx writeIdx = do
- code <- dataAt readIdx
- if code > 128
- then do
- let repeatCount = fromIntegral code .&. 0x7F
- newVal <- dataAt $ readIdx + 1
- endIndex <- strideSet repeatCount writeIdx newVal
- inner (readIdx + 2) endIndex
-
- else do
- let iCode = fromIntegral code
- endIndex <- strideCopy (readIdx + 1) iCode writeIdx
- inner (readIdx + iCode + 1) endIndex
-
-instance Binary RadianceHeader where
- get = decodeHeader
- put hdr = do
- putByteString radianceFileSignature
- putByteString $ BC.pack "FORMAT="
- put $ radianceFormat hdr
- let sizeString =
- BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr)
- ++ " +X " ++ show (radianceWidth hdr) ++ "\n"
- putByteString sizeString
- putLazyByteString $ radianceData hdr
-
-
-decodeHeader :: Get RadianceHeader
-decodeHeader = do
- sig <- getByteString $ B.length radianceFileSignature
- when (sig /= radianceFileSignature)
- (fail "Invalid radiance file signature")
-
- infos <- decodeInfos
- let formatKey = BC.pack "FORMAT"
- case partition (\(k,_) -> k /= formatKey) infos of
- (_, []) -> fail "No radiance format specified"
- (info, [(_, formatString)]) ->
- case runGet get $ L.fromChunks [formatString] of
- Left err -> fail err
- Right format -> do
- (n1, n2, b) <- (,,) <$> decodeNum
- <*> decodeNum
- <*> getRemainingBytes
- return . RadianceHeader info format n1 n2 $ L.fromChunks [b]
-
- _ -> fail "Multiple radiance format specified"
-
-toFloat :: RGBE -> PixelRGBF
-toFloat (RGBE r g b e) = PixelRGBF rf gf bf
- where f = encodeFloat 1 $ fromIntegral e - (128 + 8)
- rf = (fromIntegral r + 0.0) * f
- gf = (fromIntegral g + 0.0) * f
- bf = (fromIntegral b + 0.0) * f
-
-encodeScanlineColor :: M.STVector s Word8
- -> M.STVector s Word8
- -> Int
- -> ST s Int
-encodeScanlineColor vec outVec outIdx = do
- val <- vec `M.unsafeRead` 0
- runLength 1 0 val 1 outIdx
- where maxIndex = M.length vec
-
- pushRun len val at = do
- (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80
- (outVec `M.unsafeWrite` (at + 1)) val
- return $ at + 2
-
- pushData start len at = do
- (outVec `M.unsafeWrite` at) $ fromIntegral len
- let first = start - len
- end = start - 1
- offset = at - first + 1
- forM_ [first .. end] $ \i -> do
- v <- vec `M.unsafeRead` i
- (outVec `M.unsafeWrite` (offset + i)) v
-
- return $ at + len + 1
-
- -- End of scanline, empty the thing
- runLength run cpy prev idx at | idx >= maxIndex =
- case (run, cpy) of
- (0, 0) -> pure at
- (0, n) -> pushData idx n at
- (n, 0) -> pushRun n prev at
- (_, _) -> error "HDR - Run length algorithm is wrong"
-
- -- full runlength, we must write the packet
- runLength r@127 _ prev idx at = do
- val <- vec `M.unsafeRead` idx
- pushRun r prev at >>=
- runLength 1 0 val (idx + 1)
-
- -- full copy, we must write the packet
- runLength _ c@127 _ idx at = do
- val <- vec `M.unsafeRead` idx
- pushData idx c at >>=
- runLength 1 0 val (idx + 1)
-
- runLength n 0 prev idx at = do
- val <- vec `M.unsafeRead` idx
- case val == prev of
- True -> runLength (n + 1) 0 prev (idx + 1) at
- False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at
- False ->
- pushRun n prev at >>=
- runLength 1 0 val (idx + 1)
-
- runLength 0 n prev idx at = do
- val <- vec `M.unsafeRead` idx
- if val /= prev
- then runLength 0 (n + 1) val (idx + 1) at
- else
- pushData (idx - 1) (n - 1) at >>=
- runLength (2 :: Int) 0 val (idx + 1)
-
- runLength _ _ _ _ _ =
- error "HDR RLE inconsistent state"
-
--- | Write an High dynamic range image into a radiance
--- image file on disk.
-writeHDR :: FilePath -> Image PixelRGBF -> IO ()
-writeHDR filename img = L.writeFile filename $ encodeHDR img
-
--- | Write a RLE encoded High dynamic range image into a radiance
--- image file on disk.
-writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO ()
-writeRLENewStyleHDR filename img =
- L.writeFile filename $ encodeRLENewStyleHDR img
-
--- | Encode an High dynamic range image into a radiance image
--- file format.
--- Alias for encodeRawHDR
-encodeHDR :: Image PixelRGBF -> L.ByteString
-encodeHDR = encodeRawHDR
-
--- | Encode an High dynamic range image into a radiance image
--- file format. without compression
-encodeRawHDR :: Image PixelRGBF -> L.ByteString
-encodeRawHDR pic = encode descriptor
- where
- newImage = pixelMap rgbeInRgba pic
- -- we are cheating to death here, the layout we want
- -- correspond to the layout of pixelRGBA8, so we
- -- convert
- rgbeInRgba pixel = PixelRGBA8 r g b e
- where RGBE r g b e = toRGBE pixel
-
- descriptor = RadianceHeader
- { radianceInfos = []
- , radianceFormat = FormatRGBE
- , radianceHeight = imageHeight pic
- , radianceWidth = imageWidth pic
- , radianceData = L.fromChunks [toByteString $ imageData 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 pic = encode $ runST $ do
- let w = imageWidth pic
- h = imageHeight pic
-
- scanLineR <- M.new w :: ST s (M.STVector s Word8)
- scanLineG <- M.new w
- scanLineB <- M.new w
- scanLineE <- M.new w
-
- encoded <-
- forM [0 .. h - 1] $ \line -> do
- buff <- M.new $ w * 4 + w `div` 127 + 2
- let columner col | col >= w = return ()
- columner col = do
- let RGBE r g b e = toRGBE $ pixelAt pic col line
- (scanLineR `M.unsafeWrite` col) r
- (scanLineG `M.unsafeWrite` col) g
- (scanLineB `M.unsafeWrite` col) b
- (scanLineE `M.unsafeWrite` col) e
-
- columner (col + 1)
-
- columner 0
-
- (buff `M.unsafeWrite` 0) 2
- (buff `M.unsafeWrite` 1) 2
- (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF)
- (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF)
-
- i1 <- encodeScanlineColor scanLineR buff 4
- i2 <- encodeScanlineColor scanLineG buff i1
- i3 <- encodeScanlineColor scanLineB buff i2
- endIndex <- encodeScanlineColor scanLineE buff i3
-
- (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff
-
- pure RadianceHeader
- { radianceInfos = []
- , radianceFormat = FormatRGBE
- , radianceHeight = h
- , radianceWidth = w
- , radianceData = L.fromChunks encoded
- }
-
-
-decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s
PixelRGBF)
-decodeRadiancePicture hdr = do
- let width = abs $ radianceWidth hdr
- height = abs $ radianceHeight hdr
- packedData = radianceData hdr
-
- scanLine <- lift $ M.new $ width * 4
- resultBuffer <- lift $ M.new $ width * height * 3
-
- let scanLineImage = MutableImage
- { mutableImageWidth = width
- , mutableImageHeight = 1
- , mutableImageData = scanLine
- }
-
- finalImage = MutableImage
- { mutableImageWidth = width
- , mutableImageHeight = height
- , mutableImageData = resultBuffer
- }
-
- let scanLineExtractor readIdx line = do
- let color = unpackColor packedData readIdx
- inner | isNewRunLengthMarker color = do
- let calcSize = checkLineLength color
- when (calcSize /= width)
- (throwE "Invalid sanline size")
- pure $ \idx -> newStyleRLE packedData (idx + 4)
- | otherwise = pure $ oldStyleRLE packedData
- f <- inner
- newRead <- f readIdx scanLine
- forM_ [0 .. width - 1] $ \i -> do
- -- mokay, it's a hack, but I don't want to define a
- -- pixel instance of RGBE...
- PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0
- lift $ writePixel finalImage i line . toFloat $ RGBE r g b e
-
- return newRead
-
- foldM_ scanLineExtractor 0 [0 .. height - 1]
-
- return finalImage
-
+{-# 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
+(.<<.) = unsafeShiftL
+(.>>.) = unsafeShiftR
+
+{-# INLINE (.<-.) #-}
+(.<-.) :: (PrimMonad m, Storable a)
+ => M.STVector (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 r g b e) = put r >> put g >> put b >> put e
+ get = RGBE <$> get <*> get <*> get <*> get
+
+checkLineLength :: RGBE -> Int
+checkLineLength (RGBE _ _ a b) =
+ (fromIntegral a .<<. 8) .|. fromIntegral b
+
+isNewRunLengthMarker :: RGBE -> Bool
+isNewRunLengthMarker (RGBE 2 2 _ _) = True
+isNewRunLengthMarker _ = False
+
+data RadianceFormat =
+ FormatRGBE
+ | FormatXYZE
+
+radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString
+radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe"
+radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze"
+
+instance Binary RadianceFormat where
+ put FormatRGBE = putByteString radiance32bitRleRGBEFormat
+ put FormatXYZE = putByteString radiance32bitRleXYZEFromat
+
+ get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format
+ where format sig
+ | sig == radiance32bitRleRGBEFormat = pure FormatRGBE
+ | sig == radiance32bitRleXYZEFromat = pure FormatXYZE
+ | otherwise = fail "Unrecognized Radiance format"
+
+toRGBE :: PixelRGBF -> RGBE
+toRGBE (PixelRGBF r g b)
+ | d <= 1e-32 = RGBE 0 0 0 0
+ | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128)
+ where d = maximum [r, g, b]
+ e = exponent d
+ coeff = significand d * 255.9999 / d
+ fix v = truncate $ v * coeff
+
+
+dropUntil :: Word8 -> Get ()
+dropUntil c = getWord8 >>= inner
+ where inner val | val == c = pure ()
+ inner _ = getWord8 >>= inner
+
+getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString
+getUntil f initialAcc = getWord8 >>= inner initialAcc
+ where inner acc c | f c = pure acc
+ inner acc c = getWord8 >>= inner (B.snoc acc c)
+
+data RadianceHeader = RadianceHeader
+ { radianceInfos :: [(B.ByteString, B.ByteString)]
+ , radianceFormat :: RadianceFormat
+ , radianceHeight :: !Int
+ , radianceWidth :: !Int
+ , radianceData :: L.ByteString
+ }
+
+radianceFileSignature :: B.ByteString
+radianceFileSignature = BC.pack "#?RADIANCE\n"
+
+unpackColor :: L.ByteString -> Int -> RGBE
+unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3)
+ where at n = L.index str . fromIntegral $ idx + n
+
+storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s ()
+storeColor vec idx (RGBE r g b e) = do
+ (vec .<-. (idx + 0)) r
+ (vec .<-. (idx + 1)) g
+ (vec .<-. (idx + 2)) b
+ (vec .<-. (idx + 3)) e
+
+parsePair :: Char -> Get (B.ByteString, B.ByteString)
+parsePair firstChar = do
+ let eol c = c == fromIntegral (ord '\n')
+ line <- getUntil eol B.empty
+ case BC.split '=' line of
+ [] -> pure (BC.singleton firstChar, B.empty)
+ [val] -> pure (BC.singleton firstChar, val)
+ [key, val] -> pure (BC.singleton firstChar <> key, val)
+ (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals)
+
+decodeInfos :: Get [(B.ByteString, B.ByteString)]
+decodeInfos = do
+ char <- getChar8
+ case char of
+ -- comment
+ '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos
+ -- end of header, no more information
+ '\n' -> pure []
+ -- Classical parsing
+ c -> (:) <$> parsePair c <*> decodeInfos
+
+
+-- | Decode an HDR (radiance) image, the resulting image can be:
+--
+-- * 'ImageRGBF'
+--
+decodeHDR :: B.ByteString -> Either String DynamicImage
+decodeHDR = fmap fst . decodeHDRWithMetadata
+
+-- | Equivalent to decodeHDR but with aditional metadatas.
+decodeHDRWithMetadata :: B.ByteString -> Either String (DynamicImage,
Metadatas)
+decodeHDRWithMetadata str = runST $ runExceptT $
+ case runGet decodeHeader $ L.fromChunks [str] of
+ Left err -> throwE err
+ Right rez ->
+ let meta = basicMetadata SourceHDR (abs $ radianceWidth rez) (abs $
radianceHeight rez) in
+ (, meta) . ImageRGBF <$> (decodeRadiancePicture rez >>= lift .
unsafeFreezeImage)
+
+getChar8 :: Get Char
+getChar8 = chr . fromIntegral <$> getWord8
+
+isSign :: Char -> Bool
+isSign c = c == '+' || c == '-'
+
+isAxisLetter :: Char -> Bool
+isAxisLetter c = c == 'X' || c == 'Y'
+
+decodeNum :: Get Int
+decodeNum = do
+ sign <- getChar8
+ letter <- getChar8
+ space <- getChar8
+
+ unless (isSign sign && isAxisLetter letter && space == ' ')
+ (fail "Invalid radiance size declaration")
+
+ let numDec acc c | isDigit c =
+ getChar8 >>= numDec (acc * 10 + ord c - ord '0')
+ numDec acc _
+ | sign == '-' = pure $ negate acc
+ | otherwise = pure acc
+
+ getChar8 >>= numDec 0
+
+copyPrevColor :: M.STVector s Word8 -> Int -> ST s ()
+copyPrevColor scanLine idx = do
+ r <- scanLine `M.unsafeRead` (idx - 4)
+ g <- scanLine `M.unsafeRead` (idx - 3)
+ b <- scanLine `M.unsafeRead` (idx - 2)
+ e <- scanLine `M.unsafeRead` (idx - 1)
+
+ (scanLine `M.unsafeWrite` (idx + 0)) r
+ (scanLine `M.unsafeWrite` (idx + 1)) g
+ (scanLine `M.unsafeWrite` (idx + 2)) b
+ (scanLine `M.unsafeWrite` (idx + 3)) e
+
+oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
+ -> HDRReader s Int
+oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0
+ where maxOutput = M.length scanLine
+ maxInput = fromIntegral $ L.length inputData
+
+ inner readIdx writeIdx _
+ | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx
+ inner readIdx writeIdx shift = do
+ let color@(RGBE r g b e) = unpackColor inputData readIdx
+ isRun = r == 1 && g == 1 && b == 1
+
+ if not isRun
+ then do
+ lift $ storeColor scanLine writeIdx color
+ inner (readIdx + 4) (writeIdx + 4) 0
+
+ else do
+ let count = fromIntegral e .<<. shift
+ lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine
(writeIdx + 4 * i)
+ inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8)
+
+newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
+ -> HDRReader s Int
+newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3]
+ where dataAt idx
+ | fromIntegral idx >= maxInput = throwE $ "Read index out of bound
(" ++ show idx ++ ")"
+ | otherwise = pure $ L.index inputData (fromIntegral idx)
+
+ maxOutput = M.length scanline
+ maxInput = fromIntegral $ L.length inputData
+ stride = 4
+
+
+ strideSet count destIndex _ | endIndex > maxOutput + stride =
+ throwE $ "Out of bound HDR scanline " ++ show endIndex ++ " (max "
++ show maxOutput ++ ")"
+ where endIndex = destIndex + count * stride
+ strideSet count destIndex val = aux destIndex count
+ where aux i 0 = pure i
+ aux i c = do
+ lift $ (scanline .<-. i) val
+ aux (i + stride) (c - 1)
+
+
+ strideCopy _ count destIndex
+ | writeEndBound > maxOutput + stride = throwE "Out of bound HDR
scanline"
+ where writeEndBound = destIndex + count * stride
+ strideCopy sourceIndex count destIndex = aux sourceIndex destIndex
count
+ where aux _ j 0 = pure j
+ aux i j c = do
+ val <- dataAt i
+ lift $ (scanline .<-. j) val
+ aux (i + 1) (j + stride) (c - 1)
+
+ inner readIdx writeIdx
+ | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx
+ inner readIdx writeIdx = do
+ code <- dataAt readIdx
+ if code > 128
+ then do
+ let repeatCount = fromIntegral code .&. 0x7F
+ newVal <- dataAt $ readIdx + 1
+ endIndex <- strideSet repeatCount writeIdx newVal
+ inner (readIdx + 2) endIndex
+
+ else do
+ let iCode = fromIntegral code
+ endIndex <- strideCopy (readIdx + 1) iCode writeIdx
+ inner (readIdx + iCode + 1) endIndex
+
+instance Binary RadianceHeader where
+ get = decodeHeader
+ put hdr = do
+ putByteString radianceFileSignature
+ putByteString $ BC.pack "FORMAT="
+ put $ radianceFormat hdr
+ let sizeString =
+ BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr)
+ ++ " +X " ++ show (radianceWidth hdr) ++ "\n"
+ putByteString sizeString
+ putLazyByteString $ radianceData hdr
+
+
+decodeHeader :: Get RadianceHeader
+decodeHeader = do
+ sig <- getByteString $ B.length radianceFileSignature
+ when (sig /= radianceFileSignature)
+ (fail "Invalid radiance file signature")
+
+ infos <- decodeInfos
+ let formatKey = BC.pack "FORMAT"
+ case partition (\(k,_) -> k /= formatKey) infos of
+ (_, []) -> fail "No radiance format specified"
+ (info, [(_, formatString)]) ->
+ case runGet get $ L.fromChunks [formatString] of
+ Left err -> fail err
+ Right format -> do
+ (n1, n2, b) <- (,,) <$> decodeNum
+ <*> decodeNum
+ <*> getRemainingBytes
+ return . RadianceHeader info format n1 n2 $ L.fromChunks [b]
+
+ _ -> fail "Multiple radiance format specified"
+
+toFloat :: RGBE -> PixelRGBF
+toFloat (RGBE r g b e) = PixelRGBF rf gf bf
+ where f = encodeFloat 1 $ fromIntegral e - (128 + 8)
+ rf = (fromIntegral r + 0.0) * f
+ gf = (fromIntegral g + 0.0) * f
+ bf = (fromIntegral b + 0.0) * f
+
+encodeScanlineColor :: M.STVector s Word8
+ -> M.STVector s Word8
+ -> Int
+ -> ST s Int
+encodeScanlineColor vec outVec outIdx = do
+ val <- vec `M.unsafeRead` 0
+ runLength 1 0 val 1 outIdx
+ where maxIndex = M.length vec
+
+ pushRun len val at = do
+ (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80
+ (outVec `M.unsafeWrite` (at + 1)) val
+ return $ at + 2
+
+ pushData start len at = do
+ (outVec `M.unsafeWrite` at) $ fromIntegral len
+ let first = start - len
+ end = start - 1
+ offset = at - first + 1
+ forM_ [first .. end] $ \i -> do
+ v <- vec `M.unsafeRead` i
+ (outVec `M.unsafeWrite` (offset + i)) v
+
+ return $ at + len + 1
+
+ -- End of scanline, empty the thing
+ runLength run cpy prev idx at | idx >= maxIndex =
+ case (run, cpy) of
+ (0, 0) -> pure at
+ (0, n) -> pushData idx n at
+ (n, 0) -> pushRun n prev at
+ (_, _) -> error "HDR - Run length algorithm is wrong"
+
+ -- full runlength, we must write the packet
+ runLength r@127 _ prev idx at = do
+ val <- vec `M.unsafeRead` idx
+ pushRun r prev at >>=
+ runLength 1 0 val (idx + 1)
+
+ -- full copy, we must write the packet
+ runLength _ c@127 _ idx at = do
+ val <- vec `M.unsafeRead` idx
+ pushData idx c at >>=
+ runLength 1 0 val (idx + 1)
+
+ runLength n 0 prev idx at = do
+ val <- vec `M.unsafeRead` idx
+ case val == prev of
+ True -> runLength (n + 1) 0 prev (idx + 1) at
+ False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at
+ False ->
+ pushRun n prev at >>=
+ runLength 1 0 val (idx + 1)
+
+ runLength 0 n prev idx at = do
+ val <- vec `M.unsafeRead` idx
+ if val /= prev
+ then runLength 0 (n + 1) val (idx + 1) at
+ else
+ pushData (idx - 1) (n - 1) at >>=
+ runLength (2 :: Int) 0 val (idx + 1)
+
+ runLength _ _ _ _ _ =
+ error "HDR RLE inconsistent state"
+
+-- | Write an High dynamic range image into a radiance
+-- image file on disk.
+writeHDR :: FilePath -> Image PixelRGBF -> IO ()
+writeHDR filename img = L.writeFile filename $ encodeHDR img
+
+-- | Write a RLE encoded High dynamic range image into a radiance
+-- image file on disk.
+writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO ()
+writeRLENewStyleHDR filename img =
+ L.writeFile filename $ encodeRLENewStyleHDR img
+
+-- | Encode an High dynamic range image into a radiance image
+-- file format.
+-- Alias for encodeRawHDR
+encodeHDR :: Image PixelRGBF -> L.ByteString
+encodeHDR = encodeRawHDR
+
+-- | Encode an High dynamic range image into a radiance image
+-- file format. without compression
+encodeRawHDR :: Image PixelRGBF -> L.ByteString
+encodeRawHDR pic = encode descriptor
+ where
+ newImage = pixelMap rgbeInRgba pic
+ -- we are cheating to death here, the layout we want
+ -- correspond to the layout of pixelRGBA8, so we
+ -- convert
+ rgbeInRgba pixel = PixelRGBA8 r g b e
+ where RGBE r g b e = toRGBE pixel
+
+ descriptor = RadianceHeader
+ { radianceInfos = []
+ , radianceFormat = FormatRGBE
+ , radianceHeight = imageHeight pic
+ , radianceWidth = imageWidth pic
+ , radianceData = L.fromChunks [toByteString $ imageData 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 pic = encode $ runST $ do
+ let w = imageWidth pic
+ h = imageHeight pic
+
+ scanLineR <- M.new w :: ST s (M.STVector s Word8)
+ scanLineG <- M.new w
+ scanLineB <- M.new w
+ scanLineE <- M.new w
+
+ encoded <-
+ forM [0 .. h - 1] $ \line -> do
+ buff <- M.new $ w * 4 + w `div` 127 + 2
+ let columner col | col >= w = return ()
+ columner col = do
+ let RGBE r g b e = toRGBE $ pixelAt pic col line
+ (scanLineR `M.unsafeWrite` col) r
+ (scanLineG `M.unsafeWrite` col) g
+ (scanLineB `M.unsafeWrite` col) b
+ (scanLineE `M.unsafeWrite` col) e
+
+ columner (col + 1)
+
+ columner 0
+
+ (buff `M.unsafeWrite` 0) 2
+ (buff `M.unsafeWrite` 1) 2
+ (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF)
+ (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF)
+
+ i1 <- encodeScanlineColor scanLineR buff 4
+ i2 <- encodeScanlineColor scanLineG buff i1
+ i3 <- encodeScanlineColor scanLineB buff i2
+ endIndex <- encodeScanlineColor scanLineE buff i3
+
+ (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff
+
+ pure RadianceHeader
+ { radianceInfos = []
+ , radianceFormat = FormatRGBE
+ , radianceHeight = h
+ , radianceWidth = w
+ , radianceData = L.fromChunks encoded
+ }
+
+
+decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s
PixelRGBF)
+decodeRadiancePicture hdr = do
+ let width = abs $ radianceWidth hdr
+ height = abs $ radianceHeight hdr
+ packedData = radianceData hdr
+
+ scanLine <- lift $ M.new $ width * 4
+ resultBuffer <- lift $ M.new $ width * height * 3
+
+ let scanLineImage = MutableImage
+ { mutableImageWidth = width
+ , mutableImageHeight = 1
+ , mutableImageData = scanLine
+ }
+
+ finalImage = MutableImage
+ { mutableImageWidth = width
+ , mutableImageHeight = height
+ , mutableImageData = resultBuffer
+ }
+
+ let scanLineExtractor readIdx line = do
+ let color = unpackColor packedData readIdx
+ inner | isNewRunLengthMarker color = do
+ let calcSize = checkLineLength color
+ when (calcSize /= width)
+ (throwE "Invalid sanline size")
+ pure $ \idx -> newStyleRLE packedData (idx + 4)
+ | otherwise = pure $ oldStyleRLE packedData
+ f <- inner
+ newRead <- f readIdx scanLine
+ forM_ [0 .. width - 1] $ \i -> do
+ -- mokay, it's a hack, but I don't want to define a
+ -- pixel instance of RGBE...
+ PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0
+ lift $ writePixel finalImage i line . toFloat $ RGBE r g b e
+
+ return newRead
+
+ foldM_ scanLineExtractor 0 [0 .. height - 1]
+
+ return finalImage
+
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/JuicyPixels-3.3.3/src/Codec/Picture/Jpg/Internal/Types.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/Jpg/Internal/Types.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/Jpg/Internal/Types.hs
2018-12-16 22:36:06.000000000 +0100
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/Jpg/Internal/Types.hs
2019-06-19 21:11:57.000000000 +0200
@@ -34,7 +34,11 @@
import Control.Monad.ST( ST )
import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR )
import Data.List( partition )
+
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
+#endif
+
import Foreign.Storable ( Storable )
import Data.Vector.Unboxed( (!) )
import qualified Data.Vector as V
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/JuicyPixels-3.3.3/src/Codec/Picture/Jpg.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/Jpg.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/Jpg.hs 2018-12-16
22:36:06.000000000 +0100
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/Jpg.hs 2019-06-19
21:11:57.000000000 +0200
@@ -31,7 +31,9 @@
import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS )
import Data.Bits( (.|.), unsafeShiftL )
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
+#endif
import Data.Int( Int16, Int32 )
import Data.Word(Word8, Word32)
import Data.Binary( Binary(..), encode )
@@ -309,7 +311,7 @@
scanSpecifier scanCount scanSpec = do
compMapping <- gets componentIndexMapping
comp <- case lookup (componentSelector scanSpec) compMapping of
- Nothing -> fail "Jpg decoding error - bad component selector
in blob."
+ Nothing -> error "Jpg decoding error - bad component selector
in blob."
Just v -> return v
let maximumHuffmanTable = 4
dcIndex = min (maximumHuffmanTable - 1)
@@ -326,7 +328,7 @@
frameInfo <- gets currentFrame
blobId <- gets seenBlobs
case frameInfo of
- Nothing -> fail "Jpg decoding error - no previous frame"
+ Nothing -> error "Jpg decoding error - no previous frame"
Just v -> do
let compDesc = jpgComponents v !! comp
compCount = length $ jpgComponents v
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/JuicyPixels-3.3.3/src/Codec/Picture/Png/Internal/Export.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/Png/Internal/Export.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/Png/Internal/Export.hs
2018-12-16 22:36:06.000000000 +0100
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/Png/Internal/Export.hs
2019-06-19 21:11:57.000000000 +0200
@@ -19,7 +19,9 @@
import Control.Monad.ST( ST, runST )
import Data.Bits( unsafeShiftR, (.&.) )
import Data.Binary( encode )
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
+#endif
import Data.Word(Word8, Word16)
import qualified Codec.Compression.Zlib as Z
import qualified Data.ByteString as B
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/JuicyPixels-3.3.3/src/Codec/Picture/Png/Internal/Metadata.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/Png/Internal/Metadata.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/Png/Internal/Metadata.hs
2018-12-16 22:36:06.000000000 +0100
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/Png/Internal/Metadata.hs
2019-06-19 21:11:57.000000000 +0200
@@ -16,7 +16,9 @@
import Data.Binary.Get( getLazyByteStringNul )
import Data.Binary.Put( putLazyByteString, putWord8 )
import qualified Data.ByteString.Lazy.Char8 as L
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
+#endif
import Codec.Picture.InternalHelper
import qualified Codec.Picture.Metadata as Met
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/JuicyPixels-3.3.3/src/Codec/Picture/Png.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/Png.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/Png.hs 2018-12-16
22:36:06.000000000 +0100
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/Png.hs 2019-06-19
21:11:57.000000000 +0200
@@ -36,7 +36,11 @@
import Control.Arrow( first )
import Control.Monad( forM_, foldM_, when, void )
import Control.Monad.ST( ST, runST )
+
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
+#endif
+
import Data.Binary( Binary( get) )
import qualified Data.Vector.Storable as V
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/JuicyPixels-3.3.3/src/Codec/Picture/Tiff/Internal/Metadata.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/Tiff/Internal/Metadata.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/Tiff/Internal/Metadata.hs
2018-12-16 22:36:06.000000000 +0100
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/Tiff/Internal/Metadata.hs
2019-06-19 21:11:57.000000000 +0200
@@ -16,7 +16,9 @@
import Data.List( sortBy )
import Data.Function( on )
import qualified Data.Foldable as F
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
+#endif
import Codec.Picture.Metadata( Metadatas )
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/JuicyPixels-3.3.3/src/Codec/Picture/Types.hs
new/JuicyPixels-3.3.3.1/src/Codec/Picture/Types.hs
--- old/JuicyPixels-3.3.3/src/Codec/Picture/Types.hs 2018-07-10
12:36:32.000000000 +0200
+++ new/JuicyPixels-3.3.3.1/src/Codec/Picture/Types.hs 2019-06-19
21:11:57.000000000 +0200
@@ -109,8 +109,9 @@
import Data.Monoid( Monoid, mempty )
import Control.Applicative( Applicative, pure, (<*>), (<$>) )
#endif
-
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
+#endif
import Control.Monad( foldM, liftM, ap )
import Control.DeepSeq( NFData( .. ) )
import Control.Monad.ST( ST, runST )
