{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.HDR
-- Copyright   : (c) Alexey Kuleshevich 2019-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Data.Massiv.Array.IO.Image.JuicyPixels.HDR
  ( HDR(..)
  , HdrOptions(..)
  , decodeHDR
  , decodeWithMetadataHDR
  , decodeAutoHDR
  , decodeAutoWithMetadataHDR
  , encodeHDR
  , encodeAutoHDR
  ) where

import qualified Codec.Picture as JP
import qualified Codec.Picture.HDR as JP
import qualified Codec.Picture.Metadata as JP
import Data.Bifunctor (first)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL (ByteString)
import Data.Massiv.Array as A
import Data.Massiv.Array.IO.Base
import Data.Massiv.Array.IO.Image.JuicyPixels.Base
import Data.Typeable
import qualified Graphics.Pixel as CM
import Graphics.Pixel.ColorSpace
import Prelude as P

--------------------------------------------------------------------------------
-- HDR Format ------------------------------------------------------------------
--------------------------------------------------------------------------------

newtype HdrOptions = HdrOptions
  { HdrOptions -> Bool
hdrUseLightRLE :: Bool
  -- ^ Use light RLE compression. Causes problems in some viewers. See:
  -- `JP.encodeRLENewStyleHDR`
  } deriving (Int -> HdrOptions -> ShowS
[HdrOptions] -> ShowS
HdrOptions -> String
(Int -> HdrOptions -> ShowS)
-> (HdrOptions -> String)
-> ([HdrOptions] -> ShowS)
-> Show HdrOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HdrOptions] -> ShowS
$cshowList :: [HdrOptions] -> ShowS
show :: HdrOptions -> String
$cshow :: HdrOptions -> String
showsPrec :: Int -> HdrOptions -> ShowS
$cshowsPrec :: Int -> HdrOptions -> ShowS
Show)

instance Default HdrOptions where
  def :: HdrOptions
def = Bool -> HdrOptions
HdrOptions Bool
False


-- | High-dynamic-range image with @.hdr@ or @.pic@ extension.
data HDR = HDR deriving Int -> HDR -> ShowS
[HDR] -> ShowS
HDR -> String
(Int -> HDR -> ShowS)
-> (HDR -> String) -> ([HDR] -> ShowS) -> Show HDR
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HDR] -> ShowS
$cshowList :: [HDR] -> ShowS
show :: HDR -> String
$cshow :: HDR -> String
showsPrec :: Int -> HDR -> ShowS
$cshowsPrec :: Int -> HDR -> ShowS
Show

instance FileFormat HDR where
  type WriteOptions HDR = HdrOptions
  type Metadata HDR = JP.Metadatas
  ext :: HDR -> String
ext HDR
_ = String
".hdr"
  exts :: HDR -> [String]
exts HDR
_ = [String
".hdr", String
".pic"]

getHdrEncoder
  :: HdrOptions -> JP.Image JP.PixelRGBF -> BL.ByteString
getHdrEncoder :: HdrOptions -> Image PixelRGBF -> ByteString
getHdrEncoder HdrOptions {Bool
hdrUseLightRLE :: Bool
hdrUseLightRLE :: HdrOptions -> Bool
hdrUseLightRLE}
  | Bool
hdrUseLightRLE = Image PixelRGBF -> ByteString
JP.encodeRLENewStyleHDR
  | Bool
otherwise = Image PixelRGBF -> ByteString
JP.encodeHDR

instance Writable HDR (Image S CM.RGB Float) where
  encodeM :: HDR -> WriteOptions HDR -> Image S RGB Float -> m ByteString
encodeM HDR
HDR WriteOptions HDR
opts = ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString)
-> (Image S RGB Float -> ByteString)
-> Image S RGB Float
-> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HdrOptions -> Image PixelRGBF -> ByteString
getHdrEncoder WriteOptions HDR
HdrOptions
opts (Image PixelRGBF -> ByteString)
-> (Image S RGB Float -> Image PixelRGBF)
-> Image S RGB Float
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image S RGB Float -> Image PixelRGBF
forall r.
Source r Ix2 (Pixel RGB Float) =>
Image r RGB Float -> Image PixelRGBF
toJPImageRGBF

instance Writable HDR (Image S (SRGB 'NonLinear) Float) where
  encodeM :: HDR
-> WriteOptions HDR
-> Image S (SRGB 'NonLinear) Float
-> m ByteString
encodeM HDR
f WriteOptions HDR
opts = HDR -> WriteOptions HDR -> Image S RGB Float -> m ByteString
forall f arr (m :: * -> *).
(Writable f arr, MonadThrow m) =>
f -> WriteOptions f -> arr -> m ByteString
encodeM HDR
f WriteOptions HDR
opts (Image S RGB Float -> m ByteString)
-> (Image S (SRGB 'NonLinear) Float -> Image S RGB Float)
-> Image S (SRGB 'NonLinear) Float
-> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image S (SRGB 'NonLinear) Float -> Image S RGB Float
forall cs e.
Array S Ix2 (Pixel cs e) -> Array S Ix2 (Pixel (BaseModel cs) e)
toImageBaseModel

instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) =>
         Writable (Auto HDR) (Image r cs e) where
  encodeM :: Auto HDR -> WriteOptions (Auto HDR) -> Image r cs e -> m ByteString
encodeM Auto HDR
f WriteOptions (Auto HDR)
opts = ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString)
-> (Image r cs e -> ByteString) -> Image r cs e -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Auto HDR -> HdrOptions -> Image r cs e -> ByteString
forall r cs i e.
(ColorSpace cs i e, Source r Ix2 (Pixel cs e)) =>
Auto HDR -> HdrOptions -> Image r cs e -> ByteString
encodeAutoHDR Auto HDR
f WriteOptions (Auto HDR)
HdrOptions
opts


instance Readable HDR (Image S CM.RGB Float) where
  decodeWithMetadataM :: HDR -> ByteString -> m (Image S RGB Float, Metadata HDR)
decodeWithMetadataM = HDR -> ByteString -> m (Image S RGB Float, Metadata HDR)
forall cs e (m :: * -> *).
(ColorModel cs e, MonadThrow m) =>
HDR -> ByteString -> m (Image S cs e, Metadatas)
decodeWithMetadataHDR

instance Readable HDR (Image S (SRGB 'NonLinear) Float) where
  decodeWithMetadataM :: HDR
-> ByteString -> m (Image S (SRGB 'NonLinear) Float, Metadata HDR)
decodeWithMetadataM HDR
f = ((Image S RGB Float, Metadatas)
 -> (Image S (SRGB 'NonLinear) Float, Metadatas))
-> m (Image S RGB Float, Metadatas)
-> m (Image S (SRGB 'NonLinear) Float, Metadatas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Image S RGB Float -> Image S (SRGB 'NonLinear) Float)
-> (Image S RGB Float, Metadatas)
-> (Image S (SRGB 'NonLinear) Float, Metadatas)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Image S RGB Float -> Image S (SRGB 'NonLinear) Float
forall cs e.
Array S Ix2 (Pixel (BaseModel cs) e) -> Array S Ix2 (Pixel cs e)
fromImageBaseModel) (m (Image S RGB Float, Metadatas)
 -> m (Image S (SRGB 'NonLinear) Float, Metadatas))
-> (ByteString -> m (Image S RGB Float, Metadatas))
-> ByteString
-> m (Image S (SRGB 'NonLinear) Float, Metadatas)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HDR -> ByteString -> m (Image S RGB Float, Metadata HDR)
forall f arr (m :: * -> *).
(Readable f arr, MonadThrow m) =>
f -> ByteString -> m (arr, Metadata f)
decodeWithMetadataM HDR
f

-- | Decode a HDR Image
decodeHDR :: (ColorModel cs e, MonadThrow m) => HDR -> B.ByteString -> m (Image S cs e)
decodeHDR :: HDR -> ByteString -> m (Image S cs e)
decodeHDR HDR
f ByteString
bs = HDR -> Either String DynamicImage -> m (Image S cs e)
forall (m :: * -> *) cs e f.
(MonadThrow m, ColorModel cs e, FileFormat f) =>
f -> Either String DynamicImage -> m (Image S cs e)
convertWith HDR
f (ByteString -> Either String DynamicImage
JP.decodeHDR ByteString
bs)

-- | Decode a HDR Image
decodeWithMetadataHDR ::
     (ColorModel cs e, MonadThrow m) => HDR -> B.ByteString -> m (Image S cs e, JP.Metadatas)
decodeWithMetadataHDR :: HDR -> ByteString -> m (Image S cs e, Metadatas)
decodeWithMetadataHDR HDR
f ByteString
bs = HDR
-> Either String (DynamicImage, Metadata HDR)
-> m (Image S cs e, Metadata HDR)
forall (m :: * -> *) cs e f.
(MonadThrow m, ColorModel cs e, FileFormat f) =>
f
-> Either String (DynamicImage, Metadata f)
-> m (Image S cs e, Metadata f)
convertWithMetadata HDR
f (ByteString -> Either String (DynamicImage, Metadatas)
JP.decodeHDRWithMetadata ByteString
bs)


-- | Decode a HDR Image
decodeAutoHDR ::
     (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m)
  => Auto HDR
  -> B.ByteString
  -> m (Image r cs e)
decodeAutoHDR :: Auto HDR -> ByteString -> m (Image r cs e)
decodeAutoHDR Auto HDR
f ByteString
bs = Auto HDR -> Either String DynamicImage -> m (Image r cs e)
forall (m :: * -> *) r cs e i f.
(MonadThrow m, Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>
Auto f -> Either String DynamicImage -> m (Image r cs e)
convertAutoWith Auto HDR
f (ByteString -> Either String DynamicImage
JP.decodeHDR ByteString
bs)

-- | Decode a HDR Image
decodeAutoWithMetadataHDR ::
     (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m)
  => Auto HDR
  -> B.ByteString
  -> m (Image r cs e, JP.Metadatas)
decodeAutoWithMetadataHDR :: Auto HDR -> ByteString -> m (Image r cs e, Metadatas)
decodeAutoWithMetadataHDR Auto HDR
f ByteString
bs = Auto HDR
-> Either String (DynamicImage, Metadata HDR)
-> m (Image r cs e, Metadata HDR)
forall (m :: * -> *) r cs e i f.
(MonadThrow m, Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>
Auto f
-> Either String (DynamicImage, Metadata f)
-> m (Image r cs e, Metadata f)
convertAutoWithMetadata Auto HDR
f (ByteString -> Either String (DynamicImage, Metadatas)
JP.decodeHDRWithMetadata ByteString
bs)

instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>
         Readable (Auto HDR) (Image r cs e) where
  decodeM :: Auto HDR -> ByteString -> m (Image r cs e)
decodeM = Auto HDR -> ByteString -> m (Image r cs e)
forall r cs e i (m :: * -> *).
(Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) =>
Auto HDR -> ByteString -> m (Image r cs e)
decodeAutoHDR
  decodeWithMetadataM :: Auto HDR -> ByteString -> m (Image r cs e, Metadata (Auto HDR))
decodeWithMetadataM = Auto HDR -> ByteString -> m (Image r cs e, Metadata (Auto HDR))
forall r cs e i (m :: * -> *).
(Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) =>
Auto HDR -> ByteString -> m (Image r cs e, Metadatas)
decodeAutoWithMetadataHDR

encodeHDR ::
     forall cs e m.
     (ColorModel cs e, MonadThrow m)
  => HDR
  -> HdrOptions
  -> Image S cs e
  -> m BL.ByteString
encodeHDR :: HDR -> HdrOptions -> Image S cs e -> m ByteString
encodeHDR HDR
f HdrOptions
opts Image S cs e
img =
  HDR -> Proxy (Image S cs e) -> Maybe ByteString -> m ByteString
forall f r cs e b (m :: * -> *).
(ColorModel cs e, FileFormat f, Typeable r, MonadThrow m) =>
f -> Proxy (Image r cs e) -> Maybe b -> m b
fromMaybeEncode HDR
f (Proxy (Image S cs e)
forall k (t :: k). Proxy t
Proxy :: Proxy (Image S cs e)) (Maybe ByteString -> m ByteString)
-> Maybe ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
    e :~: Float
Refl <- Maybe (e :~: Float)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (e :~: Float)
    HdrOptions -> Image PixelRGBF -> ByteString
getHdrEncoder HdrOptions
opts (Image PixelRGBF -> ByteString)
-> Maybe (Image PixelRGBF) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Image S cs Float -> Maybe (Image PixelRGBF)
forall cs.
(Typeable cs, Source S Ix2 (Pixel cs Float)) =>
Image S cs Float -> Maybe (Image PixelRGBF)
maybeJPImageRGBF Image S cs e
Image S cs Float
img



encodeAutoHDR ::
     forall r cs i e. (ColorSpace cs i e, Source r Ix2 (Pixel cs e))
  => Auto HDR
  -> HdrOptions
  -> Image r cs e
  -> BL.ByteString
encodeAutoHDR :: Auto HDR -> HdrOptions -> Image r cs e -> ByteString
encodeAutoHDR Auto HDR
_ HdrOptions
opts = (Pixel cs e -> Pixel RGB Float) -> Image r cs e -> ByteString
forall a.
Source r Ix2 a =>
(a -> Pixel RGB Float) -> Array r Ix2 a -> ByteString
toHdr (Pixel (SRGB 'NonLinear) Float -> Pixel RGB Float
forall k cs (i :: k) e.
ColorSpace cs i e =>
Pixel cs e -> Pixel (BaseModel cs) e
toPixelBaseModel (Pixel (SRGB 'NonLinear) Float -> Pixel RGB Float)
-> (Pixel cs e -> Pixel (SRGB 'NonLinear) Float)
-> Pixel cs e
-> Pixel RGB Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixel cs e -> Pixel (SRGB 'NonLinear) Float
toSRGBF)
  where
    toSRGBF :: Pixel cs e -> Pixel (SRGB 'NonLinear) Float
toSRGBF = Pixel cs e -> Pixel (SRGB 'NonLinear) Float
forall k1 k2 cs (i :: k1) e cs' (i' :: k2) e'.
(ColorSpace cs' i' e', ColorSpace cs i e) =>
Pixel cs' e' -> Pixel cs e
convertPixel :: Pixel cs e -> Pixel (SRGB 'NonLinear) Float
    toHdr :: Source r Ix2 a => (a -> Pixel CM.RGB Float) -> Array r Ix2 a -> BL.ByteString
    toHdr :: (a -> Pixel RGB Float) -> Array r Ix2 a -> ByteString
toHdr a -> Pixel RGB Float
adjustPixel = HdrOptions -> Image PixelRGBF -> ByteString
getHdrEncoder HdrOptions
opts (Image PixelRGBF -> ByteString)
-> (Array r Ix2 a -> Image PixelRGBF)
-> Array r Ix2 a
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image D RGB Float -> Image PixelRGBF
forall r.
Source r Ix2 (Pixel RGB Float) =>
Image r RGB Float -> Image PixelRGBF
toJPImageRGBF (Image D RGB Float -> Image PixelRGBF)
-> (Array r Ix2 a -> Image D RGB Float)
-> Array r Ix2 a
-> Image PixelRGBF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Pixel RGB Float) -> Array r Ix2 a -> Image D RGB Float
forall r ix e' e.
Source r ix e' =>
(e' -> e) -> Array r ix e' -> Array D ix e
A.map a -> Pixel RGB Float
adjustPixel