Initial commit

.gitignore

@@ -0,0 +1,2 @@
+.stack-work/
+*~

ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for JuicyPixels-blurhash
+
+## Unreleased changes

JuicyPixels-blurhash.cabal

@@ -0,0 +1,87 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.33.0.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 8c8469fec0ccde55ff00cdf50888072cb6598b18d16ea87172c944f28613915a
+
+name:           JuicyPixels-blurhash
+version:        0.1.0.0
+description:    Please see the README on GitHub at <https://github.com/SamProtas/JuicyPixels-blurhash#readme>
+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
+
+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
+    , base >=4.7 && <5
+    , bytestring
+    , containers
+    , vector
+  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
+    , JuicyPixels-blurhash
+    , base >=4.7 && <5
+    , bytestring
+    , containers
+    , optparse-applicative
+    , vector
+  default-language: Haskell2010
+
+test-suite JuicyPixels-blurhash-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Blurhash
+      Paths_JuicyPixels_blurhash
+  hs-source-dirs:
+      test
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      JuicyPixels
+    , JuicyPixels-blurhash
+    , base >=4.7 && <5
+    , bytestring
+    , containers
+    , filepath
+    , hedgehog
+    , tasty
+    , tasty-discover
+    , tasty-hedgehog
+    , tasty-hunit
+    , vector
+  default-language: Haskell2010

LICENSE

@@ -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

@@ -0,0 +1 @@
+# JuicyPixels-blurhash

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -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

package.yaml

@@ -0,0 +1,60 @@
+name:                JuicyPixels-blurhash
+version:             0.1.0.0
+github:              "SamProtas/JuicyPixels-blurhash"
+license:             BSD3
+author:              "Sam Protas"
+maintainer:          "sam.protas@gmail.com"
+copyright:           "2020 Sam Protas"
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/SamProtas/JuicyPixels-blurhash#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- bytestring
+- containers
+- JuicyPixels
+- vector
+
+library:
+  source-dirs: src
+
+executables:
+  JuicyPixels-blurhash-exe:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - JuicyPixels-blurhash
+    - JuicyPixels
+    - optparse-applicative
+
+tests:
+  JuicyPixels-blurhash-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - JuicyPixels-blurhash
+    - hedgehog
+    - filepath
+    - tasty
+    - tasty-discover
+    - tasty-hedgehog
+    - tasty-hunit

src/Codec/Picture/Blurhash.hs

@@ -0,0 +1,29 @@
+module Codec.Picture.Blurhash
+  ( EncodeConfig (componentsX, componentsY)
+  , encodeConfigDefault
+  , EncodeError(..)
+
+  , encodeDynamic
+  , encodeDynamicWithConfig
+
+  , encodeRGB8
+  , encodeRGB8WithConfig
+
+  , encodeLinear
+  , encodeLinearWithConfig
+  
+  , DecodeConfig(punch, outputWidth, outputHeight)
+  , decodeConfigDefault
+  , DecodeError(..)
+
+  , decodeRGB8
+  , decodeRGB8WithConfig
+  
+  , decodeLinear
+  , decodeLinearWithConfig
+  ) where
+
+import Codec.Picture.Blurhash.Internal.Encode
+import Codec.Picture.Blurhash.Internal.Decode
+
+  

src/Codec/Picture/Blurhash/Internal/Base83.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE OverloadedStrings #-}
+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
+
+
+
+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]
+
+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
+
+
+
+charToIndex :: Map.Map Word8 Int
+charToIndex = V.ifoldl' (\mapping index char -> Map.insert char index mapping) mempty alphabet
+
+alphabet :: V.Vector Word8
+alphabet = V.fromList $
+           BS.unpack
+           "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz#$%*+,-.:;=?@[]^_{|}~"

src/Codec/Picture/Blurhash/Internal/Common.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Codec.Picture.Blurhash.Internal.Common where
+
+import Codec.Picture
+
+
+signPow :: Float -> Float -> Float
+signPow v ex = fixSign $ (abs v) ** ex
+  where
+    fixSign = if v < 0 then ((-1)*) else id    
+
+clamp :: Ord a => a -> a -> a -> a
+clamp minVal maxVal = min maxVal . max minVal
+
+
+sRGBImageToLinear :: Image PixelRGB8 -> Image PixelRGBF
+sRGBImageToLinear = pixelMap pixelToLinear
+
+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
+
+                         
+  
+linearImageToSRGB :: Image PixelRGBF -> Image PixelRGB8
+linearImageToSRGB = pixelMap linearPixelToSRGB
+
+linearPixelToSRGB :: PixelRGBF -> PixelRGB8
+linearPixelToSRGB (PixelRGBF r g b) = PixelRGB8 (linearToSRGB r) (linearToSRGB g) (linearToSRGB b)
+
+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

@@ -0,0 +1,13 @@
+module Codec.Picture.Blurhash.Internal.DList where
+
+
+type DList a = [a] -> [a]
+
+toDList :: [a] -> DList a
+toDList l = \l' -> l ++ l'
+
+dListToList :: DList a -> [a]
+dListToList = ($[])
+
+dListSnoc :: DList a -> a -> DList a
+dListSnoc dlist a = dlist . (a:)

src/Codec/Picture/Blurhash/Internal/Decode.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
+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
+
+import Codec.Picture
+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
+
+
+data DecodeConfig = DecodeConfig
+  { punch :: Float
+  , outputWidth :: Int
+  , outputHeight :: Int
+  } deriving Show
+
+data DecodeError
+  = InvalidCharacterError Word8
+  | InvalidHashLength
+  deriving Show
+
+
+decodeConfigDefault :: DecodeConfig
+decodeConfigDefault = DecodeConfig 1 32 32
+
+decodeRGB8 :: BS.ByteString -> Either DecodeError (Image PixelRGB8)
+decodeRGB8 = decodeRGB8WithConfig decodeConfigDefault
+
+decodeRGB8WithConfig :: DecodeConfig -> BS.ByteString -> Either DecodeError (Image PixelRGB8)
+decodeRGB8WithConfig config blurhash
+  = linearImageToSRGB <$> decodeLinearWithConfig config blurhash
+
+decodeLinear :: BS.ByteString -> Either DecodeError (Image PixelRGBF)
+decodeLinear = decodeLinearWithConfig decodeConfigDefault
+
+decodeLinearWithConfig
+  :: DecodeConfig
+  -> BS.ByteString
+  -> 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
+
+
+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')
+          PixelRGBF r' g' b' = colors V.! (i + j * sizeX) -- TODO - unsafe?
+      in PixelRGBF (r + r' * basis) (g + g' * basis) (b + b' * basis)  
+
+
+base83DecodeTagged :: BS.ByteString -> Either DecodeError Int
+base83DecodeTagged = either (Left . InvalidCharacterError) Right . base83Decode

src/Codec/Picture/Blurhash/Internal/Encode.hs

@@ -0,0 +1,124 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Codec.Picture.Blurhash.Internal.Encode where
+
+import qualified Data.Bits as Bits
+import qualified Data.List as List
+import Data.Foldable (foldl')
+
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy.Builder as BS
+import Codec.Picture
+import Codec.Picture.Types
+
+import Codec.Picture.Blurhash.Internal.DList
+import Codec.Picture.Blurhash.Internal.Base83
+import Codec.Picture.Blurhash.Internal.Common
+
+
+data EncodeConfig = EncodeConfig
+  { componentsX :: !Int
+  , componentsY :: !Int
+  } deriving Show
+
+encodeConfigDefault :: EncodeConfig
+encodeConfigDefault = EncodeConfig 4 4
+
+data EncodeError
+  = InvalidComponents
+  | B83EncodingError Int Int
+  deriving Show
+
+checkComponent :: Int -> Either EncodeError Int
+checkComponent c
+  | c < 1 || c > 9 = Left InvalidComponents
+  | otherwise = pure c
+
+
+encodeDynamic :: DynamicImage -> Either EncodeError BS.ByteString
+encodeDynamic = encodeDynamicWithConfig encodeConfigDefault
+
+encodeDynamicWithConfig :: EncodeConfig -> DynamicImage -> Either EncodeError BS.ByteString
+encodeDynamicWithConfig config = encodeRGB8WithConfig config . convertRGB8  
+
+encodeRGB8 :: Image PixelRGB8 -> Either EncodeError BS.ByteString
+encodeRGB8 = encodeRGB8WithConfig encodeConfigDefault
+
+encodeRGB8WithConfig :: EncodeConfig -> Image PixelRGB8 -> Either EncodeError BS.ByteString
+encodeRGB8WithConfig config = encodeLinearWithConfig config . sRGBImageToLinear
+
+encodeLinear :: Image PixelRGBF -> Either EncodeError BS.ByteString
+encodeLinear = encodeLinearWithConfig encodeConfigDefault
+
+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
+
+base83EncodeTagged :: Int -> Int -> Either EncodeError BS.Builder
+base83EncodeTagged toEncode len =
+  maybe (Left $ B83EncodingError toEncode len) Right $ base83Encode toEncode len
+
+
+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
+
+    
+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
+        
+
+data EncodedComponents = EncodedComponents
+  !(DList PixelRGBF)
+  !Float
+
+encodeDcValue :: PixelRGBF -> Int
+encodeDcValue (PixelRGBF r g b) =
+  Bits.shiftL (linearToSRGB r) 16 + Bits.shiftL (linearToSRGB g) 8 + linearToSRGB b
+
+
+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
+
+

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-14.27
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.3"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 524996
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml
+    sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0
+  original: lts-14.27

test/Blurhash.hs

@@ -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

@@ -0,0 +1,3 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+
+