packages feed

JuicyPixels-blurhash (empty) → 0.1.0.0

raw patch · 17 files changed

+1078/−0 lines, 17 filesdep +Globdep +JuicyPixelsdep +JuicyPixels-blurhashsetup-changedbinary-added

Dependencies added: Glob, JuicyPixels, JuicyPixels-blurhash, base, bytestring, containers, doctest, filepath, hedgehog, optparse-applicative, tasty, tasty-discover, tasty-hedgehog, tasty-hunit, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for JuicyPixels-blurhash++## 0.1.0.0++	- Initial release
+ JuicyPixels-blurhash.cabal view
@@ -0,0 +1,112 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: e45283c97885b15746864eb0047cc10b59b460da5d045bdfa7bc3758dcbe7144++name:           JuicyPixels-blurhash+version:        0.1.0.0+synopsis:       Blurhash is a very compact represenation of a placeholder for an image+description:    Please see the README on GitHub at <https://github.com/SamProtas/JuicyPixels-blurhash#readme>+category:       Graphics, Image+homepage:       https://github.com/SamProtas/JuicyPixels-blurhash#readme+bug-reports:    https://github.com/SamProtas/JuicyPixels-blurhash/issues+author:         Sam Protas+maintainer:     sam.protas@gmail.com+copyright:      2020 Sam Protas+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md+extra-doc-files:+    docs/example.jpg+    docs/blurred.png++source-repository head+  type: git+  location: https://github.com/SamProtas/JuicyPixels-blurhash++library+  exposed-modules:+      Codec.Picture.Blurhash+      Codec.Picture.Blurhash.Internal.Base83+      Codec.Picture.Blurhash.Internal.Common+      Codec.Picture.Blurhash.Internal.Decode+      Codec.Picture.Blurhash.Internal.DList+      Codec.Picture.Blurhash.Internal.Encode+  other-modules:+      Paths_JuicyPixels_blurhash+  hs-source-dirs:+      src+  build-depends:+      JuicyPixels >=3.2.8 && <3.4+    , base >=4.7 && <5+    , bytestring >=0.9 && <0.11+    , containers >=0.4.2 && <0.7+    , filepath >=1.4.1.1 && <1.5+    , vector >=0.10 && <0.13+  default-language: Haskell2010++executable JuicyPixels-blurhash-exe+  main-is: Main.hs+  other-modules:+      Paths_JuicyPixels_blurhash+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      JuicyPixels >=3.2.8 && <3.4+    , JuicyPixels-blurhash+    , base >=4.7 && <5+    , bytestring >=0.9 && <0.11+    , containers >=0.4.2 && <0.7+    , filepath >=1.4.1.1 && <1.5+    , optparse-applicative >=0.14.3 && <0.16+    , vector >=0.10 && <0.13+  default-language: Haskell2010++test-suite JuicyPixels-blurhash-doctests+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_JuicyPixels_blurhash+  hs-source-dirs:+      doctest+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      Glob >=0.10 && <0.11+    , JuicyPixels >=3.2.8 && <3.4+    , JuicyPixels-blurhash+    , base >=4.7 && <5+    , bytestring >=0.9 && <0.11+    , containers >=0.4.2 && <0.7+    , doctest >=0.16.2 && <0.17+    , filepath >=1.4.1.1 && <1.5+    , vector >=0.10 && <0.13+  default-language: Haskell2010++test-suite JuicyPixels-blurhash-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      JuicyPixels >=3.2.8 && <3.4+    , JuicyPixels-blurhash+    , base >=4.7 && <5+    , bytestring >=0.9 && <0.11+    , containers >=0.4.2 && <0.7+    , filepath >=1.4.1.1 && <1.5+    , hedgehog >=1.0.2 && <1.1+    , tasty >=1.2.3 && <1.4+    , tasty-discover >=4.2.1 && <4.3+    , tasty-hedgehog >=1.0.0.2 && <1.1+    , tasty-hunit >=0.10.0.2 && <0.11+    , vector >=0.10 && <0.13+  default-language: Haskell2010+  other-modules: Blurhash
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Sam Protas (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sam Protas nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,31 @@+# JuicyPixels-blurhash++![CI](https://github.com/SamProtas/JuicyPixels-blurhash/workflows/CI/badge.svg)+![Hackage Version](https://img.shields.io/hackage/v/JuicyPixels-blurhash?color=blue)+![Hackage Deps](https://img.shields.io/hackage-deps/v/JuicyPixels-blurhash)+++Blurhash is a very compact represenation of a placeholder for an image.++This library provides a Blurhash encoding and decoding implementation based on the JuicyPixels represenation of images.++For the full Blurhash sales pitch and algorithm explaination see either of:++  - The website: <https://blurha.sh/>++  - The central git repo: <https://github.com/woltapp/blurhash>++An image such as:++![example image](docs/example.jpg)++Can be encoded as:++LGFFaWYk^6#M@-5c,1Ex\@\@or[j6o++Which your client can render as:++![example blurred image](docs/blurred.png)+++Full library documentation can be found in the Haddocks for `Codec.Picture.Blurhash`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,98 @@+module Main where++import Control.Exception++import Codec.Picture+import qualified Data.ByteString.Lazy.Char8 as BS+import Options.Applicative++import Codec.Picture.Blurhash+import Codec.Picture.Blurhash.Internal.Encode+import Codec.Picture.Blurhash.Internal.Decode+++main :: IO ()+main = execParser cliParser >>= execCommand++execCommand :: Command -> IO ()+execCommand (Encode input config) = encodeFromCommand input config >>= BS.putStrLn+execCommand (Decode blurhash config output) = decodeFromCommand blurhash config output+execCommand (Blur input inConfig outConfig output) = do+  blurhash <- encodeFromCommand input inConfig+  decodeFromCommand blurhash outConfig output++encodeFromCommand :: FilePath -> EncodeConfig -> IO BS.ByteString+encodeFromCommand fp config = do+  imgE <- readImage fp+  img <- either throwStr pure imgE+  either (throwStr . show) pure $ encodeDynamicWithConfig config img+++decodeFromCommand :: BS.ByteString -> DecodeConfig -> FilePath -> IO ()+decodeFromCommand blurhash config output = do+  img <- either (throwStr . show) pure $ decodeRGB8WithConfig config blurhash+  writePng output img+  ++cliParser :: ParserInfo Command+cliParser =+  info+  (commandParser  <**> helper)+  (fullDesc <> progDesc "Simple CLI for using blurhash-hs library")+++commandParser :: Parser Command+commandParser =+  subparser (command "encode" (info encodeParser (progDesc "")) <>+             command "decode" (info decodeParser (progDesc "")) <>+             command "blur" (info blurParser (progDesc "")))+  ++encodeParser :: Parser Command+encodeParser = Encode <$> inputPathParser <*> encodingConfigParser++decodeParser :: Parser Command+decodeParser = Decode <$> blurhashParser <*> decodingConfigParser <*> outputPathParser++blurParser :: Parser Command+blurParser =+  Blur <$>+  inputPathParser <*>+  encodingConfigParser <*>+  decodingConfigParser <*>+  outputPathParser++outputPathParser :: Parser FilePath+outputPathParser = strOption (long "output-path" <> value "blurred.png" <> showDefault)++inputPathParser :: Parser FilePath+inputPathParser = strOption (long "input-path")++blurhashParser :: Parser BS.ByteString+blurhashParser = strOption (long "blurhash")++encodingConfigParser :: Parser EncodeConfig+encodingConfigParser =+  EncodeConfig <$>+  option auto (long "componentsX" <> value (componentsX encodeConfigDefault) <> showDefault) <*>+  option auto (long "componentsY" <> value (componentsY encodeConfigDefault) <> showDefault)++decodingConfigParser :: Parser DecodeConfig+decodingConfigParser =+  DecodeConfig <$>+  option auto (long "punch" <> value (punch decodeConfigDefault) <> showDefault) <*>+  option auto (long "width" <> value (outputWidth decodeConfigDefault) <> showDefault) <*>+  option auto (long "height" <> value (outputWidth decodeConfigDefault) <> showDefault)+++data Command+  = Encode FilePath EncodeConfig +  | Decode BS.ByteString DecodeConfig FilePath+  | Blur FilePath EncodeConfig DecodeConfig FilePath+++throwStr :: String -> IO a+throwStr = throwIO . StrException++data StrException = StrException String deriving Show+instance Exception StrException
+ docs/blurred.png view

binary file changed (absent → 74502 bytes)

+ docs/example.jpg view

binary file changed (absent → 101373 bytes)

+ doctest/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "src/**/*.hs" >>= doctest
+ src/Codec/Picture/Blurhash.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: Codec.Picture.Blurhash+-- Copyright: (c) 2020 Sam Protas+-- License: BSD3+-- Maintainer: Sam Protas <sam.protas@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- Blurhash is a very compact represenation of a placeholder for an image.+--+-- This library provides a Blurhash encoding and decoding implementation based on the JuicyPixels represenation of images.+--+-- For the full Blurhash sales pitch and algorithm explaination see either of:+-- +--   - The website: <https://blurha.sh/>+-- +--   - The central git repo: <https://github.com/woltapp/blurhash>+--+-- An image such as:+-- +-- <<docs/example.jpg>>+--+-- Can be encoded as:+--+-- LGFFaWYk^6#M@-5c,1Ex\@\@or[j6o+--+-- Which your client can render as:+--+-- <<docs/blurred.png>>+--+module Codec.Picture.Blurhash+  (+    -- * Example Use+    -- $setup+    -- $exampleEncode+    -- $exampleDecode+    +    -- * Encoding Images+    -- $encoding++    -- ** Default+    -- $defencoding+    encodeDynamic+  , encodeRGB8+  , encodeLinear++    -- ** Custom+  , encodeDynamicWithConfig+  , encodeRGB8WithConfig+  , encodeLinearWithConfig++    -- ** Configuration+  , encodeConfigDefault+  , EncodeConfig+  , componentsX+  , componentsY++    -- ** Errors+  , EncodeError(..)++    -- * Decoding To Images+    -- $decoding++    -- ** Default+    -- $defdecoding+  , decodeRGB8+  , decodeLinear++    -- ** Custom+  , decodeRGB8WithConfig+  , decodeLinearWithConfig++    -- ** Configuration+  , decodeConfigDefault+  , DecodeConfig+  , punch+  , outputWidth+  , outputHeight++    -- ** Errors+  , DecodeError(..)+  ) where++import System.FilePath (FilePath, (</>), takeDirectory)+-- Imported for Haddock links+import Codec.Picture (DynamicImage, Image, PixelRGB8, PixelRGBF)++import Codec.Picture.Blurhash.Internal.Encode+import Codec.Picture.Blurhash.Internal.Decode+++-- $setup+-- First some imports.+--+-- >>> :set -XOverloadedStrings+-- >>> import           Codec.Picture (readImage)+-- >>> import qualified Codec.Picture.Blurhash as BH+-- >>> import           Data.ByteString.Lazy (ByteString)+--++-- $exampleEncode+-- Given a an image filepath @(imgFilePath :: FilePath)@.+--+-- >>> :{+--  do+--    Right img <- readImage imgFilePath+--    print $ BH.encodeDynamic img+-- :}+-- Right "UBMOZfK1GG%LBBNG,;Rj2skq=eE1s9n4S5Na"+--+-- Now you can store this nice compact encoding in a database column and send it to the client along with the asset path to the full size image.+--++-- $exampleDecode+-- If you're lucky enough to write your client in Haskell, you receive that encoding and draw a Blurhash placeholder while the full asset is fetched.+--+-- >>> let Right myBlurryPlaceholderImg = BH.decodeRGB8 "UBMOZfK1GG%LBBNG,;Rj2skq=eE1s9n4S5Na"+--+  +-- $encoding+--+-- The Blurhash algorithm natively supports encoding 'Image' 'PixelRGB8' and 'Image' 'PixelRGBF'. This library additionally supports encoding a 'DynamicImage' via conversion to 'Image' 'PixelRGB8'.++-- $defencoding+--+-- Encode various image representations to a blurhash using 'encodeConfigDefault'.++-- $decoding+--+-- The Blurhash algorithm natively supports decoding into 'Image' 'PixelRGB8' and 'Image' 'PixelRGBF'.++-- $defdecoding+--+-- Decode a blurhash to various image representations using 'decodeConfigDefault'.+++imgDir :: FilePath+imgDir = takeDirectory __FILE__ </> ".." </> ".." </> ".." </> "imgs"++imgFilePath :: FilePath+imgFilePath = imgDir </> "cool_cat.jpg"
+ src/Codec/Picture/Blurhash/Internal/Base83.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: Codec.Picture.Blurhash.Internal.Base83+-- Copyright: (c) 2020 Sam Protas+-- License: BSD3+-- Maintainer: Sam Protas <sam.protas@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- Internal Base83 encoding/decoding implementation.+--+-- __Note__: This is an internal module not subject to PVP adherence.+module Codec.Picture.Blurhash.Internal.Base83 where++import Control.Monad (guard)+import Data.Foldable (foldlM)+import Data.Word (Word8)++import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Builder as BS+import qualified Data.Map as Map+import qualified Data.Vector as V+++-- | Base 83 encoding per the 'alphabet' specified by Blurhash+base83Encode :: Int -> Int -> Maybe BS.Builder+base83Encode toEncode len = do+  guard $ (toEncode `div` 83 ^ len) == 0++  mconcat <$>+    traverse+    (\i -> do+        let digit = toEncode `div` (83 ^ (len - i)) `mod` 83+        BS.word8 <$> alphabet V.!? digit)+    [1..len]++-- | Base 83 decoding per the 'alphabet' specified by Blurhash+base83Decode :: BS.ByteString -> Either Word8 Int+base83Decode toDecode = foldlM acc 0 $ BS.unpack toDecode+  where+    acc ret word = maybe (Left word) (Right . (+ (ret * 83))) $  Map.lookup word charToIndex+++-- | Helper function providing a mapping from a byte to it's index in the Blurhash 'alphabet'+charToIndex :: Map.Map Word8 Int+charToIndex = V.ifoldl' (\mapping index char -> Map.insert char index mapping) mempty alphabet++-- | The Blurhash 'alphabet'+alphabet :: V.Vector Word8+alphabet = V.fromList $+           BS.unpack+           "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz#$%*+,-.:;=?@[]^_{|}~"
+ src/Codec/Picture/Blurhash/Internal/Common.hs view
@@ -0,0 +1,56 @@+-- |+-- Module: Codec.Picture.Blurhash.Internal.Common+-- Copyright: (c) 2020 Sam Protas+-- License: BSD3+-- Maintainer: Sam Protas <sam.protas@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- Internal Blurhash helper functions shared by encoding and decoding.+--+-- __Note__: This is an internal module not subject to PVP adherence.+module Codec.Picture.Blurhash.Internal.Common where++import Codec.Picture (Image, PixelRGB8(..), PixelRGBF(..), pixelMap)++-- | Helper function specified by other Blurhash implementations+signPow :: Float -> Float -> Float+signPow v ex = fixSign $ (abs v) ** ex+  where+    fixSign = if v < 0 then ((-1)*) else id    ++-- | Clamps it's 3rd argument between the min and max specified by the 1st and 2nd arguments+--   respectively+clamp :: Ord a => a -> a -> a -> a+clamp minVal maxVal = min maxVal . max minVal++-- | Convert an RGB8 Image to an RGBF Image using the color conversion specified by Blurhash+sRGBImageToLinear :: Image PixelRGB8 -> Image PixelRGBF+sRGBImageToLinear = pixelMap pixelToLinear++-- | Convert an RGB8 Pixel to an RGBF Pixel using the color conversion specified by Blurhash+pixelToLinear :: PixelRGB8 -> PixelRGBF+pixelToLinear (PixelRGB8 r g b) = PixelRGBF (toLinear r) (toLinear g) (toLinear b)+  where+    toLinear c = let v = realToFrac c / 255+                 in if v < 0.04045+                    then v / 12.92+                    else ((v + 0.055) / 1.055) ** 2.4++-- | Convert an RGBF Image to an RGB8 Image using the color conversion specified by Blurhash+linearImageToSRGB :: Image PixelRGBF -> Image PixelRGB8+linearImageToSRGB = pixelMap linearPixelToSRGB++-- | Convert an RGBF Pixel to an RGB8 Pixel using the color conversion specified by Blurhash+linearPixelToSRGB :: PixelRGBF -> PixelRGB8+linearPixelToSRGB (PixelRGBF r g b) = PixelRGB8 (linearToSRGB r) (linearToSRGB g) (linearToSRGB b)++-- | Convert an RGBF color to an RGB8 color using the color conversion specified by Blurhash+linearToSRGB :: (RealFrac a, Integral b, Floating a) => a -> b+linearToSRGB p = +  floor $ if v < 0.0031308+          then v * 12.92 * 255 + 0.5+          else (1.055 * (v ** (1 / 2.4)) - 0.055) * 255 + 0.5+  where+    v = clamp 0 1 p+
+ src/Codec/Picture/Blurhash/Internal/DList.hs view
@@ -0,0 +1,27 @@+-- |+-- Module: Codec.Picture.Blurhash.Internal.DList+-- Copyright: (c) 2020 Sam Protas+-- License: BSD3+-- Maintainer: Sam Protas <sam.protas@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- Internal difference list implementation.+--+-- __Note__: This is an internal module not subject to PVP adherence.+module Codec.Picture.Blurhash.Internal.DList where++-- | A type alias for a Difference list for effecient appents+type DList a = [a] -> [a]++-- | Convert a list to a difference list+toDList :: [a] -> DList a+toDList l = \l' -> l ++ l'++-- | Convert a difference list to a list+dListToList :: DList a -> [a]+dListToList = ($[])++-- | Append an item to the end of a difference list+dListSnoc :: DList a -> a -> DList a+dListSnoc dlist a = dlist . (a:)
+ src/Codec/Picture/Blurhash/Internal/Decode.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module: Codec.Picture.Blurhash.Internal.Decode+-- Copyright: (c) 2020 Sam Protas+-- License: BSD3+-- Maintainer: Sam Protas <sam.protas@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- Internal Blurhash decoding implementation.+--+-- __Note__: This is an internal module not subject to PVP adherence.+module Codec.Picture.Blurhash.Internal.Decode where++import Control.Monad (when)+import qualified Data.Bits as Bits+import Data.Foldable (foldrM, foldl')+import Data.Word (Word8)+import GHC.Generics (Generic)++import Codec.Picture (Image, PixelRGB8(..), PixelRGBF(..), generateImage)+import qualified Data.ByteString.Lazy as BS+import qualified Data.Vector as V++import Codec.Picture.Blurhash.Internal.Base83+import Codec.Picture.Blurhash.Internal.Common++-- | Configuration for how to decode a blurhash to an image.+--+-- >>> let myDecodeConfig = decodeConfigDefault { punch = 1.1, outputWidth = 64, outputHeight = 64}+--+data DecodeConfig = DecodeConfig+  { punch :: Float+  -- ^ Adjusts the contrast of the decoded image. Larger values mean more contrast.+  --+  -- See 'DecodeConfig' for example use with record update syntax.+  , outputWidth :: Int+  -- ^ Output image pixel width.+  --+  -- See 'DecodeConfig' for example use with record update syntax.+  , outputHeight :: Int+  -- ^ Output image pixel height.+  --+  -- See 'DecodeConfig' for example use with record update syntax.+  } deriving (Show, Generic)++-- | Decoding error types.+data DecodeError+  = InvalidCharacterError Word8 -- ^ The provided blurhash included an un-decodable byte.+  | InvalidHashLength -- ^ The provided blurhash length was wrong.+  deriving (Show, Generic)+++-- | A reasonable default configuration for decoding.+--+-- >>> punch decodeConfigDefault == 1+-- True+--+-- >>> outputWidth decodeConfigDefault == 32+-- True+--+-- >>> outputHeight decodeConfigDefault == 32+-- True+--+decodeConfigDefault :: DecodeConfig+decodeConfigDefault = DecodeConfig 1 32 32++-- | Decode a blurhash into an 'Image' 'PixelRGB8'. Calls 'decodeRGB8WithConfig' with 'decodeConfigDefault'.+-- +--   When in doubt, use this function to decode a blurhash.+decodeRGB8+  :: BS.ByteString -- ^ The blurhash+  -> Either DecodeError (Image PixelRGB8)+decodeRGB8 = decodeRGB8WithConfig decodeConfigDefault++-- | Decode a blurhash into an 'Image' 'PixelRGB8' given a 'DecodeConfig'+decodeRGB8WithConfig+  :: DecodeConfig+  -> BS.ByteString -- ^ The blurhash.+  -> Either DecodeError (Image PixelRGB8)+decodeRGB8WithConfig config blurhash+  = linearImageToSRGB <$> decodeLinearWithConfig config blurhash++-- | Decode a blurhash into an 'Image' 'PixelRGBF'. Calls 'decodeLinearWithConfig' with 'decodeConfigDefault'.+--+-- Note: Blurhash implementations use a non-naive 'PixelRGBF' to 'PixelRGB8' conversion. If your+-- ultimate goal is to end up with an 'Image' 'PixelRGB8', be careful using this function and+-- scaling pixels by 255 as you will get different results.+decodeLinear+  :: BS.ByteString -- ^ The blurhash+  -> Either DecodeError (Image PixelRGBF)+decodeLinear = decodeLinearWithConfig decodeConfigDefault++-- | Decode a blurhash into an 'Image' 'PixelRGBF' given a 'DecodeConfig'.+--+-- Note: Blurhash implementations use a non-naive 'PixelRGBF' to 'PixelRGB8' conversion. If your+-- ultimate goal is to end up with an 'Image' 'PixelRGB8', be careful using this function and+-- scaling pixels by 255 as you will get different results.+decodeLinearWithConfig+  :: DecodeConfig+  -> BS.ByteString -- ^ The blurhash+  -> Either DecodeError (Image PixelRGBF)+decodeLinearWithConfig config hash = do+  let (sizeSection, lessSize) = BS.splitAt 1 hash+      (quantMaxSection, lessQuantMax) = BS.splitAt 1 lessSize+      dcSection = BS.take 4 lessQuantMax+  when+    (BS.null sizeSection || BS.null quantMaxSection || BS.length dcSection < 4)+    (Left InvalidHashLength)++  sizeInfo <- base83DecodeTagged sizeSection+  quantMaxVal <- base83DecodeTagged quantMaxSection+  dcValue <- base83DecodeTagged dcSection++  let sizeY = floor (realToFrac sizeInfo / 9 :: Float) + 1+      sizeX = (sizeInfo `mod` 9) + 1+      realMaxVal = (realToFrac (quantMaxVal + 1) / 166) * punch config++  when (fromIntegral (BS.length hash) /= 4 + 2 * sizeX * sizeY) (Left InvalidHashLength)++  let firstColor = pixelToLinear $+        PixelRGB8+        (fromIntegral $ Bits.shiftR dcValue 16)+        (fromIntegral $ Bits.shiftR dcValue 8 Bits..&. 255)+        (fromIntegral $ dcValue Bits..&. 255) :: PixelRGBF++  restColor <- foldrM+    (\component acc -> do+        let acValStart = 4 + component * 2+            acValStop = 4 + (component + 1) * 2+            acValRange = acValStop - acValStart+            acValStr = BS.take acValRange . BS.drop acValStart $ hash+        acValue <- base83DecodeTagged acValStr++        let acValue' = realToFrac acValue :: Float+            r = realMaxVal * signPow ((realToFrac @Int (floor (acValue' / (19 * 19))) - 9) / 9) 2+            g = realMaxVal * signPow ((realToFrac @Int (floor (acValue' / 19) `mod` 19) - 9) / 9) 2+            b = realMaxVal * signPow ((realToFrac (acValue  `mod` 19) - 9) / 9) 2+            color = PixelRGBF r g b+        pure (color:acc)+    )+    []+    [1..fromIntegral $ sizeX * sizeY - 1]+  let height = outputHeight config+      width = outputWidth config+      colors = V.fromList (firstColor:restColor)++  pure $ generateImage (decodePixel colors height width sizeY sizeX) width height++-- | Helper function to decode a single pixel.+decodePixel :: V.Vector PixelRGBF -> Int -> Int -> Int -> Int -> Int -> Int -> PixelRGBF+decodePixel colors height width sizeY sizeX x y  = foldl' acc (PixelRGBF 0 0 0) ji+  where+    x' = realToFrac x+    y' = realToFrac y+    height' = realToFrac height+    width' = realToFrac width+    ji = (,) <$> [0..sizeY - 1] <*> [0..sizeX - 1]+    acc (PixelRGBF r g b) (j, i) =+      let i' = realToFrac i+          j' = realToFrac j+          basis = cos (pi * x' * i' / width') * cos (pi * y' * j' / height')+          -- Vector index safe in practice, convered by garbage data and property tests+          PixelRGBF r' g' b' = colors V.! (i + j * sizeX) +      in PixelRGBF (r + r' * basis) (g + g' * basis) (b + b' * basis)  ++-- | Helper function to decode a base83 value or return an errorl+base83DecodeTagged :: BS.ByteString -> Either DecodeError Int+base83DecodeTagged = either (Left . InvalidCharacterError) Right . base83Decode
+ src/Codec/Picture/Blurhash/Internal/Encode.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE DeriveGeneric #-}+-- |+-- Module: Codec.Picture.Blurhash.Internal.Encode+-- Copyright: (c) 2020 Sam Protas+-- License: BSD3+-- Maintainer: Sam Protas <sam.protas@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- Internal Blurhash encoding implementation.+--+-- __Note__: This is an internal module not subject to PVP adherence.+module Codec.Picture.Blurhash.Internal.Encode where++import qualified Data.Bits as Bits+import qualified Data.List as List+import Data.Foldable (foldl')+import GHC.Generics (Generic)++import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Builder as BS+import Codec.Picture (DynamicImage, Image(..), PixelRGB8(..), PixelRGBF(..), convertRGB8, colorMap)+import Codec.Picture.Types (pixelFold, ColorConvertible(..)) -- ColorConvertible imported for haddocks++import Codec.Picture.Blurhash.Internal.DList+import Codec.Picture.Blurhash.Internal.Base83+import Codec.Picture.Blurhash.Internal.Common++-- | Configuration for how to encode an image into a blurhash.+--+-- Create custom configs using record update syntax and 'encodeConfigDefault'.+--+-- >>> let myEncodeConfig = encodeConfigDefault { componentsX = 4, componentsY = 3 }+--+data EncodeConfig = EncodeConfig+  { componentsX :: !Int+  -- ^ Number of components along the X axis. +  --+  -- See 'EncodeConfig' for example use with record update syntax.+  , componentsY :: !Int+  -- ^ Number of components along the Y axis.+  --+  -- See 'EncodeConfig' for example use with record update syntax.+  } deriving (Show, Generic)++-- | Encoding error types.+data EncodeError+  = InvalidComponents -- ^ The provided config components were invalid.+  | B83EncodingError Int Int -- ^ The provided number cannot be base83 encoded into the provided length.+  deriving (Show, Generic)++-- | A reasonable default configuration for encoding.+--+-- >>> componentsX encodeConfigDefault == 4+-- True+--+-- >>> componentsY encodeConfigDefault == 4+-- True+encodeConfigDefault :: EncodeConfig+encodeConfigDefault = EncodeConfig 4 4++-- | A helper funciton to validate the provided encoding component count.+checkComponent :: Int -> Either EncodeError Int+checkComponent c+  | c < 1 || c > 9 = Left InvalidComponents+  | otherwise = pure c++-- | Encode a 'DynamicImage' to a blurhash. Calls 'encodeDynamicWithConfig' with 'encodeConfigDefault'.+--+-- Note: Relies on 'convertRGB8' before proceding with the standard Blurhash algorithm.+encodeDynamic :: DynamicImage -> Either EncodeError BS.ByteString+encodeDynamic = encodeDynamicWithConfig encodeConfigDefault++-- | Encode a 'DynamicImage' to a blurhash with a given an 'EncodeConfig'.+--+-- Note: Relies on 'convertRGB8' before proceding with the standard Blurhash algorithm.+encodeDynamicWithConfig :: EncodeConfig -> DynamicImage -> Either EncodeError BS.ByteString+encodeDynamicWithConfig config = encodeRGB8WithConfig config . convertRGB8  ++-- | Encode an 'Image' 'PixelRGB8' to a blurhash. Calls 'encodeRGB8WithConfig' with 'encodeConfigDefault'.+--+-- Note: This is the most direct port of other language's implementation's default encoding function.+encodeRGB8 :: Image PixelRGB8 -> Either EncodeError BS.ByteString+encodeRGB8 = encodeRGB8WithConfig encodeConfigDefault++-- | Encode an 'Image' 'PixelRGB8' to a blurhash given an 'EncodeConfig'.+--+-- Note: This is the most direct port of other languages implementation's encoding function.+encodeRGB8WithConfig :: EncodeConfig -> Image PixelRGB8 -> Either EncodeError BS.ByteString+encodeRGB8WithConfig config = encodeLinearWithConfig config . sRGBImageToLinear++-- | Encode an 'Image' 'PixelRGBF' to a blurhash. Calls 'encodeLinearWithConfig' with 'encodeConfigDefault'.+--+-- Note: Blurhash implementations use a non-naive 'PixelRGB8' to 'PixelRGBF' conversion. Beware that using 'promotePixel' or 'promoteImage' from 'ColorConvertible' to convert an 'Image' 'PixelRGB8' to an 'Image' 'PixelRGBF' before using 'encodeLinear' will give different results than 'encodeRGB8'.+encodeLinear :: Image PixelRGBF -> Either EncodeError BS.ByteString+encodeLinear = encodeLinearWithConfig encodeConfigDefault++-- | Encode an 'Image' 'PixelRGBF' to a blurhash given an 'EncodeConfig'.+--+-- Note: Blurhash implementations use a non-naive 'PixelRGB8' to 'PixelRGBF' conversion. Beware that using 'promotePixel' or 'promoteImage' from 'ColorConvertible' to convert an 'Image' 'PixelRGB8' to an 'Image' 'PixelRGBF' before using 'encodeLinearWithConfig' will give different results than 'encodeRGB8WithConfig'.+encodeLinearWithConfig+  :: EncodeConfig+  -> Image PixelRGBF+  -> Either EncodeError BS.ByteString+encodeLinearWithConfig config img = do+  cx <- checkComponent . componentsX $ config+  cy <- checkComponent . componentsY $ config+  +  let EncodedComponents compDList maxAC = encodeComponents cx cy img+      components = dListToList compDList+  (firstComp, restComp) <- maybe (Left InvalidComponents) Right $ List.uncons components+  let dcValue = encodeDcValue firstComp+      quantMaxAcComp = max 0 $ min 82 $ floor $ maxAC * 166 - 0.5+      acCompNormFactor = (fromIntegral . succ $ quantMaxAcComp) / 166+      acValues = fmap (encodeAcValue acCompNormFactor) restComp+  e1 <- base83EncodeTagged ((cx - 1) + ((cy - 1) * 9)) 1+  e2 <- base83EncodeTagged quantMaxAcComp 1+  e3 <- base83EncodeTagged dcValue 4+  e4 <- mconcat <$> traverse (flip base83EncodeTagged 2) acValues+  pure $ BS.toLazyByteString $ e1 <> e2 <> e3 <> e4++-- | Helper function to encode a base83 value or return an error.+base83EncodeTagged+  :: Int -- ^ toEncode+  -> Int -- ^ encoded length+  -> Either EncodeError BS.Builder+base83EncodeTagged toEncode len =+  maybe (Left $ B83EncodingError toEncode len) Right $ base83Encode toEncode len++-- | Encode encode the color components.+encodeComponents :: Int -> Int -> Image PixelRGBF -> EncodedComponents+encodeComponents compX compY img = foldl' acc start ji+  where+    acc (EncodedComponents comps maxAC) (j, i) =+      let isFirst = i == 0 && j == 0+          normFactor = if isFirst then 1 else 2+          component@(PixelRGBF r g b) = encodeComponent i j normFactor img+          maxAC' = if isFirst then maxAC else maximum [maxAC, abs r, abs g, abs b]+      in EncodedComponents (dListSnoc comps  component) maxAC'+    ji = (,) <$> [0..compY - 1] <*> [0..compX - 1]+    start = EncodedComponents (toDList []) 0++-- | Encode a single color component.    +encodeComponent :: Int -> Int -> Float -> Image PixelRGBF -> PixelRGBF+encodeComponent i j normFactor img = colorMap (/hw') $ pixelFold acc (PixelRGBF 0 0 0) img+  where+    acc (PixelRGBF r g b) x y (PixelRGBF r' g' b') =+      let x' = realToFrac x+          y' = realToFrac y+          basis = normFactor * cos (pi * i' * x'  / width') * cos (pi * j' * y' / height')+      in PixelRGBF (r + r' * basis) (g + g' * basis) (b + b' * basis)+    width = imageWidth img+    width' = realToFrac width+    height' = realToFrac . imageHeight $ img+    hw' = width' * height'+    i' = realToFrac i+    j' = realToFrac j+        +-- | Intermediate data for calculating color components and macAC in one pass.+data EncodedComponents = EncodedComponents+  !(DList PixelRGBF)+  !Float++-- | Helper function for encoding the DC value.+encodeDcValue :: PixelRGBF -> Int+encodeDcValue (PixelRGBF r g b) =+  Bits.shiftL (linearToSRGB r) 16 + Bits.shiftL (linearToSRGB g) 8 + linearToSRGB b++-- | Helper function for encoding an AC value.+encodeAcValue :: Float -> PixelRGBF -> Int+encodeAcValue acCompNormFactor (PixelRGBF r g b) = encodedR + encodedG + encodedB+  where+    encodeColor c = max 0 $ min 18 $ floor $ (signPow (c / acCompNormFactor) 0.5) * 9 + 9.5+    encodedR = encodeColor r * 19 * 19+    encodedG = encodeColor g * 19+    encodedB = encodeColor b++
+ test/Blurhash.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Blurhash where++import Control.Monad (void)++import Codec.Picture+import System.FilePath+import qualified Data.ByteString.Lazy as BS+import qualified Data.Vector.Storable as V++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty.HUnit++import qualified Codec.Picture.Blurhash as BH+++imgDir :: FilePath+imgDir = takeDirectory __FILE__ </> ".." </> "imgs"++readAsset :: FilePath -> IO DynamicImage+readAsset fp = either assertFailure pure =<< (readImage $ imgDir </> fp)++unit_testEncodeKnownHashPurePython :: IO ()+unit_testEncodeKnownHashPurePython = do+  img <- readAsset "cool_cat.jpg"+  hash <- either (assertFailure . show) pure $ BH.encodeDynamic img+  assertEqual "Correct hash" "UBMOZfK1GG%LBBNG,;Rj2skq=eE1s9n4S5Na" hash++unit_testBadXComponents :: IO ()+unit_testBadXComponents = do+  img <- readAsset "cool_cat.jpg"+  let res = BH.encodeDynamicWithConfig BH.encodeConfigDefault {BH.componentsX = 0} img+  case res of Left BH.InvalidComponents -> pure ()+              _ -> assertFailure $ "Unexpected response" <> show res++unit_testBadYComponents :: IO ()+unit_testBadYComponents = do+  img <- readAsset "cool_cat.jpg"+  let res = BH.encodeDynamicWithConfig BH.encodeConfigDefault {BH.componentsY = 10} img+  case res of Left BH.InvalidComponents -> pure ()+              _ -> assertFailure $ "Unexpected response " <> show res+++unit_testBadHashLength :: IO ()+unit_testBadHashLength = do+  let res = BH.decodeRGB8 "bogus"+  case res of Left BH.InvalidHashLength -> pure ()+              _ -> assertFailure $ "Unexpected response " <> either show showImgRGB8 res++unit_testInvalidCharacter :: IO ()+unit_testInvalidCharacter = do+  let res = BH.decodeRGB8 "``````````````````````"+  case res of+    Left (BH.InvalidCharacterError char) -> assertEqual "Correct byte" (BS.singleton char) "`"+    _ -> assertFailure $ "Unexpected response " <> either show showImgRGB8 res++genValidEncodeConfig :: Gen BH.EncodeConfig+genValidEncodeConfig = do+  compX <- genValidComponent+  compY <- genValidComponent+  pure $ BH.encodeConfigDefault { BH.componentsX = compX, BH.componentsY = compY }++genInvalidEncodeConfigWith :: Gen Int -> Gen Int -> Gen BH.EncodeConfig+genInvalidEncodeConfigWith genX genY = do+  compX <- genX+  compY <- genY+  pure BH.encodeConfigDefault { BH.componentsX = compX, BH.componentsY = compY }++genInvalidEncodeConfig :: Gen BH.EncodeConfig+genInvalidEncodeConfig =+  Gen.frequency [ (4, genInvalidEncodeConfigWith genInvalidComponent genValidComponent)+                , (4, genInvalidEncodeConfigWith genValidComponent genInvalidComponent)+                , (2, genInvalidEncodeConfigWith genInvalidComponent genInvalidComponent)]++genValidComponent :: Gen Int+genValidComponent = Gen.integral $ Range.linear 1 9++genInvalidComponent :: Gen Int+genInvalidComponent =+  Gen.choice [Gen.integral $ Range.linear (-10) 0, Gen.integral $ Range.linear 1 9]++genValidDecodeConfig :: Gen BH.DecodeConfig+genValidDecodeConfig = do+  punch <- Gen.float $ Range.linearFrac 0.5 3+  width <- Gen.integral $ Range.linear 10 50+  height <- Gen.integral $ Range.linear 10 50+  pure $+    BH.decodeConfigDefault { BH.punch = punch, BH.outputWidth = width, BH.outputHeight = height}++genRGB8 :: MonadGen m => m PixelRGB8+genRGB8 = PixelRGB8 <$> Gen.enumBounded <*> Gen.enumBounded <*> Gen.enumBounded++genValidRGB8Img :: Int -> Int -> Gen (Image PixelRGB8)+genValidRGB8Img width height = do+  imgData <- V.fromList <$>+             Gen.list (Range.singleton $ width * height) Gen.enumBounded +  pure $ Image width height imgData+  +hprop_validComponentsValidBlur :: Property+hprop_validComponentsValidBlur = property $ do++  inConfig <- forAll genValidEncodeConfig+  width <- forAll $ Gen.integral $ Range.linear 10 100+  height <- forAll $ Gen.integral $ Range.linear 10 100+  img <- forAllWith showImgRGB8 $ genValidRGB8Img width height++  blurhash <- evalEither $ BH.encodeRGB8WithConfig inConfig img++  outConfig <- forAll genValidDecodeConfig++  void $ evalEither $ BH.decodeRGB8WithConfig outConfig blurhash+++hprop_encodeRGB8DoesNotThrow :: Property+hprop_encodeRGB8DoesNotThrow = property $ do+  config <- forAll $ Gen.choice [genInvalidEncodeConfig, genInvalidEncodeConfig]+  +  imgData <- forAll $ Gen.list (Range.linear 0 400) Gen.enumBounded++  w <- forAll $ Gen.integral $ Range.linear 0 100+  h <- forAll $ Gen.integral $ Range.linear 0 100++  let img = Image w h (V.fromList imgData)++  case BH.encodeRGB8WithConfig config img of+    Left BH.InvalidComponents -> label "Invalid components"+    Left (BH.B83EncodingError _ _) -> label "Base83 encoding error"+    Right _ -> label "Encoded"+++hprop_encodeLinearDoesNotThrow :: Property+hprop_encodeLinearDoesNotThrow = property $ do+  config <- forAll $ Gen.choice [genInvalidEncodeConfig, genInvalidEncodeConfig]+  +  imgData <- forAll $ Gen.list (Range.linear 0 400) (Gen.float (Range.linearFrac (-100) 100))++  w <- forAll $ Gen.integral $ Range.linear 0 100+  h <- forAll $ Gen.integral $ Range.linear 0 100++  let img = Image w h (V.fromList imgData)+  case BH.encodeLinearWithConfig config img of+    Left BH.InvalidComponents -> label "Invalid components"+    Left (BH.B83EncodingError _ _) -> label "Base83 encoding error"+    Right _ -> label "Encoded"+++hprop_decodeDoesNotThrow :: Property+hprop_decodeDoesNotThrow = property $ do+  blurhash <- forAll $ Gen.bytes $ Range.linear 0 1000+  config <- forAll $ genValidDecodeConfig+  case BH.decodeRGB8WithConfig config $ BS.fromStrict blurhash of+    Left BH.InvalidHashLength -> label "Invalid hash length"+    Left (BH.InvalidCharacterError _) -> label "Invalid char error"+    Right _ -> label "Decoded"+  +++showImgRGB8 :: Image PixelRGB8 -> String+showImgRGB8 img =+  "Width: " ++ (show $ imageWidth img) +++  ", Height: " ++ (show $ imageWidth img) +++  ", Bytes: " ++ (show $ V.length $ imageData img)
+ test/Spec.hs view
@@ -0,0 +1,3 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}++