packages feed

identicon (empty) → 0.1.0

raw patch · 17 files changed

+900/−0 lines, 17 filesdep +JuicyPixelsdep +basedep +bytestringsetup-changedbinary-added

Dependencies added: JuicyPixels, base, bytestring, hspec, identicon

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## Identicon 0.1.0++* Initial release.
+ Graphics/Identicon.hs view
@@ -0,0 +1,234 @@+-- |+-- Module      :  Graphics.Identicon+-- Copyright   :  © 2016 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Core types and definitions for flexible generation of identicons. Please+-- see the "Graphics.Identicon.Primitive" module for collection of building+-- blocks to code layers of your identicon.+--+-- A basic complete example looks like this:+--+-- > import Codec.Picture+-- > import Data.ByteString (ByteString)+-- > import Data.Proxy+-- > import Data.Word (Word8)+-- > import Graphics.Identicon+-- > import Graphics.Identicon.Primitive+-- >+-- > myImageType :: Proxy (Identicon 4 :+ Consumer 4)+-- > myImageType = Proxy+-- >+-- > myImpl = Identicon :+ a+-- >   where+-- >     a :: Word8 -> Word8 -> Word8 -> Word8 -> Layer+-- >     a r g b n = rsym $ onGrid 6 6 n $+-- >       circle $ gradientLR (edge . mid) black (PixelRGB8 r g b)+-- >+-- > myGenerator :: Int -> Int -> ByteString -> Maybe (Image PixelRGB8)+-- > myGenerator = renderIdenticon myImageType myImpl+-- >+-- @myGenerator@ takes desired width, height, and hash that should have at+-- least 4 bytes in it and returns an identicon corresponding to that hash+-- or 'Nothing' if the hash has less than 4 bytes in it or width or height+-- don't make sense. The identicon has randomly placed circle with gradient+-- filling changing (horizontally) from black to some color and back to+-- black. The circle is mirrored 4 times, and every repetition is rotated by+-- 90°. This identicon consumes 4 bytes and has one layer.++{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE KindSignatures       #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++module Graphics.Identicon+  ( -- * Basic types+    Identicon (..)+  , Consumer+  , (:+) (..)+  , Layer (..)+  , BytesAvailable+  , BytesConsumed+  , Implementation+  , ToLayer+    -- * Identicon rendering+  , Renderable (..)+  , ApplyBytes (..)+  , renderIdenticon )+where++import Codec.Picture+import Data.ByteString (ByteString)+import Data.Maybe (fromJust)+import Data.Proxy+import Data.Word (Word8, Word16)+import GHC.TypeLits+import qualified Data.ByteString as B++----------------------------------------------------------------------------+-- Basic types++-- | 'Identicon' is a type that represents an identicon consisting of zero+-- layers. The type is parametrized over the phantom type @n@ which is a+-- natural number on type level that represents the number of bytes that+-- should be provided to generate this type of identicon. Bytes typically+-- come from some sort of hash that has fixed size.++data Identicon (n :: Nat) = Identicon++-- | 'Consumer' is a type that represents an entity that consumes bytes that+-- are available for identicon generation. It's parametrized over the+-- phantom type @n@ which is a natural number on type level that represents+-- the number of bytes that this entity consumes. At this moment, a+-- 'Consumer' always adds one 'Layer' to identicon when attached to it. The+-- number of bytes, specified as type parameter of 'Identicon' type must be+-- completely consumed by a collection of consumers attached to it. To+-- attach a consumer to 'Identicon', you use the ':+' type operator, see+-- below.++data Consumer (n :: Nat)++-- | The ':+' type operator is used to attach 'Consumer's to 'Identicon',+-- thus adding layers to it and exhausting bytes that are available for+-- identicon generation. An example of identicon that can be generated from+-- 16 byte hash is shown below:+--+-- > type Icon = Identicon 16 :+ Consumer 5 :+ Consumer 5 :+ Consumer 6+--+-- The identicon above has three layers.++infixl 8 :++data a :+ b = a :+ b++-- | 'Layer' is the basic building block of an identicon. It's a function+-- that takes the following arguments (in order):+--+--     * Width of identicon+--     * Height of identicon+--     * Position on X axis+--     * Position on Y axis+--+-- …and returns a 'PixelRGB8' value. In this library, an identicon is+-- generated as “superposition” of several 'Layers'.++newtype Layer = Layer+  { unLayer :: Int -> Int -> Int -> Int -> PixelRGB8 }++-- | The 'BytesAvailable' type function calculates how many bytes available+-- for consumption in a given identicon.++type family BytesAvailable a :: Nat where+  BytesAvailable (Identicon n) = n+  BytesAvailable (x :+ y)      = BytesAvailable x++-- | The 'BytesConsumed' type function calculates how many bytes is consumed+-- in a given identicon.++type family BytesConsumed a :: Nat where+  BytesConsumed (Identicon n) = 0+  BytesConsumed (Consumer  n) = n+  BytesConsumed (x :+ y)      = BytesConsumed x + BytesConsumed y++-- | The 'Implementation' type function returns type of the code which can+-- implement the given identicon.++type family Implementation a where+  Implementation (Identicon n)     = Identicon n+  Implementation (a :+ Consumer n) = Implementation a :+ ToLayer n++-- | The 'ToLayer' type function calculates type that layer-producing+-- function should have to consume given number of bytes @n@.++type family ToLayer (n :: Nat) :: k where+  ToLayer 0 = Layer+  ToLayer n = Word8 -> ToLayer (n - 1)++----------------------------------------------------------------------------+-- Identicon rendering++-- | Identicons that can be rendered as an image implement this class.++class Renderable a where+  render+    :: Proxy a         -- ^ A 'Proxy' clarifying identicon type+    -> Implementation a -- ^ Corresponding implementation+    -> Int             -- ^ Width in pixels+    -> Int             -- ^ Height in pixels+    -> ByteString      -- ^ Bytes to consume+    -> (ByteString, Int -> Int -> PixelRGB8)+       -- ^ The rest of bytes and producing function++instance Renderable (Identicon n) where+  render _ _ _ _ bs = (bs, \_ _ -> PixelRGB8 0 0 0)++instance (Renderable a, ApplyBytes (ToLayer n))+    => Renderable (a :+ Consumer n) where+  render _ (a :+ b) weight height bs0 =+    let (bs1, x) = render (Proxy :: Proxy a) a weight height bs0+        (bs2, y) = applyWords b bs1+    in (bs2, mixPixels x (unLayer y weight height))++-- | Combine results of two rending functions.++mixPixels+  :: (Int -> Int -> PixelRGB8)+  -> (Int -> Int -> PixelRGB8)+  ->  Int -> Int -> PixelRGB8+mixPixels a b x y = mixWith (const saturatedAddition) (a x y) (b x y)+{-# INLINE mixPixels #-}++-- | An implementation of saturated addition for bytes. This is a reasonably+-- efficient thing.++saturatedAddition :: Word8 -> Word8 -> Word8+saturatedAddition x y = fromIntegral $+  (0xff :: Word16) `min` (fromIntegral x + fromIntegral y)+{-# INLINE saturatedAddition #-}++-- | Consume bytes from strict 'ByteString' and apply them to a function+-- that takes 'Word8' until it produces a 'Layer'.++class ApplyBytes a where+  applyWords+    :: a               -- ^ Function that produces a layer+    -> ByteString      -- ^ Bytes to consume+    -> (ByteString, Layer) -- ^ The rest of 'ByteString' and produced 'Layer'++instance ApplyBytes Layer where+  applyWords f bs = (bs, f)++instance ApplyBytes f => ApplyBytes (Word8 -> f) where+  applyWords f bs =+    let (b,bs') = fromJust (B.uncons bs)+    in applyWords (f b) bs'++-- | Render an identicon. The function returns 'Nothing' if given+-- 'ByteString' is too short or when width or height is lesser than 1.++renderIdenticon :: forall a.+     ( Renderable a+     , KnownNat (BytesAvailable a)+     , BytesAvailable a ~ BytesConsumed a )+  => Proxy a           -- ^ Type that defines an identicon+  -> Implementation a  -- ^ Implementation that generates layers+  -> Int               -- ^ Width in pixels+  -> Int               -- ^ Height in pixels+  -> ByteString        -- ^ Collection of bytes to use, should be long enough+  -> Maybe (Image PixelRGB8)+     -- ^ Rendered identicon, or 'Nothing' if there is not enough bytes+renderIdenticon proxy impl width height bs =+  if B.length bs < fromIntegral (natVal (Proxy :: Proxy (BytesAvailable a)))+     || width  < 1+     || height < 1+    then Nothing+    else Just $ generateImage+         (snd $ render proxy impl width height bs) width height
+ Graphics/Identicon/Primitive.hs view
@@ -0,0 +1,272 @@+-- |+-- Module      :  Graphics.Identicon.Primitive+-- Copyright   :  © 2016 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Various primitives and combinators that help you write code for your+-- identicon. Filling functions is where you start. They create color layers+-- that occupy all available space. If you want to limit a layer in size,+-- specify where this smaller part should be, take a look at the “Position,+-- size, and shape” section. It also contains a 'circle' combinator that+-- limits given filling is such a way that it forms a circle. Finally, we+-- have combinators that add symmetry to layers and other auxiliary+-- functions.+--+-- As a starting point, here is the function that generates a circle with+-- gradient filling changing from black (on the left hand side) to some+-- color (on the right hand side):+--+-- > f :: Word8 -> Word8 -> Word8 -> Layer+-- > f r g b = circle $ gradientLR id black (PixelRGB8 r g b)+--+-- The function consumes 3 bytes from hash when it's used in identicon.++module Graphics.Identicon.Primitive+  ( -- * Filling+    black+  , color+  , gradientLR+  , gradientTB+  , gradientTLBR+  , gradientTRBL+  , gradientXY+    -- ** Gradient transforming functions+    -- $gtrans+  , mid+  , edge+    -- * Position, size, and shape+  , onGrid+  , circle+    -- * Symmetry+  , hsym+  , vsym+  , hvsym+  , rsym+    -- * Other+  , oneof )+where++import Codec.Picture+import Data.Word (Word8)+import Graphics.Identicon++----------------------------------------------------------------------------+-- Filling++-- | Black is a special color, it means absence of light. We give this pixel+-- a name because it's used very frequently in layer coding.++black :: PixelRGB8+black = PixelRGB8 0 0 0++-- | Layer filled with a given color.++color :: PixelRGB8 -> Layer+color a = Layer $ \_ _ _ _ -> a+{-# INLINE color #-}++-- | Gradient changing from left to right.++gradientLR+  :: (Float -> Float)  -- ^ Gradient transforming function+  -> PixelRGB8         -- ^ Left color+  -> PixelRGB8         -- ^ Right color+  -> Layer+gradientLR f a b = Layer $ \w _ x _ ->+  mixWith (const $ ξ f x w) a b+{-# INLINE gradientLR #-}++-- | Gradient changing from top to bottom.++gradientTB+  :: (Float -> Float)  -- ^ Gradient transforming function+  -> PixelRGB8         -- ^ Top color+  -> PixelRGB8         -- ^ Bottom color+  -> Layer+gradientTB f a b = Layer $ \_ h _ y ->+  mixWith (const $ ξ f y h) a b+{-# INLINE gradientTB #-}++-- | Gradient changing from top left corner to bottom right corner.++gradientTLBR+  :: (Float -> Float)  -- ^ Gradient transforming function+  -> PixelRGB8         -- ^ Top left color+  -> PixelRGB8         -- ^ Bottom right color+  -> Layer+gradientTLBR f a b = Layer $ \w h x y ->+  mixWith (const $ ξ f (x + y) (w + h)) a b+{-# INLINE gradientTLBR #-}++-- | Gradient changing from top right corner to bottom left corner.++gradientTRBL+  :: (Float -> Float)  -- ^ Gradient transforming function+  -> PixelRGB8         -- ^ Top right color+  -> PixelRGB8         -- ^ Bottom left color+  -> Layer+gradientTRBL f a b = Layer $ \w h x y ->+  mixWith (const $ ξ f (w - x + y) (w + h)) a b+{-# INLINE gradientTRBL #-}++-- | Gradient with one color everywhere and another in the center.++gradientXY+  :: (Float -> Float)  -- ^ Gradient transforming function+  -> PixelRGB8         -- ^ “Edge” color+  -> PixelRGB8         -- ^ Color in the center+  -> Layer+gradientXY f a b = Layer $ \w h x y ->+  let g x' y' = floor $ (1 - n) * fromIntegral x' + n * fromIntegral y'+      n  = f (nx * ny)+      nx = mid (fromIntegral x / fromIntegral w)+      ny = mid (fromIntegral y / fromIntegral h)+  in mixWith (const g) a b+{-# INLINE gradientXY #-}++-- | A gradient helper function.++ξ+  :: (Float -> Float)  -- ^ Gradient transforming function+  -> Int               -- ^ Actual value of coordinate+  -> Int               -- ^ Maximum value of coordinate+  -> Word8             -- ^ Color at the beginning of the range+  -> Word8             -- ^ Color at the end of the range+  -> Word8             -- ^ Resulting color+ξ f v l x y = floor $ (1 - n) * fromIntegral x + n * fromIntegral y+  where+    n = f (fromIntegral v / fromIntegral l)+{-# INLINE ξ #-}++----------------------------------------------------------------------------+-- Gradient transforming functions++-- $gtrans+--+-- A note about “gradient transforming functions”: these normally map value+-- changing from 0 to 1 somehow, but they should not produce values outside+-- of that range. With help of such functions you can change character of+-- gradient transitions considerably.++-- | A built-in gradient transforming function. It maps continuous floating+-- value changing from 0 to 1 to value changing from 0 to 1 (in the middle)+-- and back to 0.++mid :: Float -> Float+mid x = 2 * (if x >= 0.5 then 1.0 - x else x)+{-# INLINE mid #-}++-- | This sharpens gradient transitions.++edge :: Float -> Float+edge x = x * x+{-# INLINE edge #-}++----------------------------------------------------------------------------+-- Position, size, and shape++-- | @onGrid w h n l@, given grid that has @w@ horizontal discrete positions+-- (of equal length) and @h@ vertical positions, it makes given layer @l@+-- occupy cell at index @n@. This approach allows you control position and+-- size at the same time.+--+-- The index @n@ can be greater than maximal index, in this case reminder of+-- division of @n@ by @w * h@ is used.++onGrid :: Integral a+  => Int               -- ^ Number of horizontal positions+  -> Int               -- ^ Number of vertical positions+  -> a                 -- ^ Index of this cell+  -> Layer             -- ^ Layer to insert+  -> Layer             -- ^ Resulting layer+onGrid α β n' l = Layer $ \w h x y ->+  let n = fromIntegral n' `rem` (α * β)+      (y', x') = n `quotRem` α+      xu, yu :: Float+      xu = fromIntegral w / fromIntegral α+      yu = fromIntegral h / fromIntegral β+      xA = floor (fromIntegral x' * xu)+      xB = floor (fromIntegral (x' + 1) * xu)+      yA = floor (fromIntegral y' * yu)+      yB = floor (fromIntegral (y' + 1) * yu)+  in if x < xA || x >= xB || y < yA || y >= yB+       then black+       else unLayer l (xB - xA) (yB - yA) (x - xA) (y - yA)+{-# INLINE onGrid #-}++-- | Limit given layer so it forms a circle.++circle :: Layer -> Layer+circle l = Layer $ \w h x y ->+  let w', h', v, r0, r1 :: Float+      w' = fromIntegral w+      h' = fromIntegral h+      sqr a = a * a+      v = sqr (fromIntegral x - w' / 2) + sqr (fromIntegral y - h' / 2)+      r0 = min w' h' / 2+      r1 = sqr r0+      β = 2.0 * r0+      δ = (r1 - v) / β+      τ = floor . (* δ) . fromIntegral+      ~px@(PixelRGB8 r g b) = unLayer l w h x y+      e | v <  r1 - β = px+        | v <= r1     = PixelRGB8 (τ r) (τ g) (τ b)+        | otherwise   = black+  in e+{-# INLINE circle #-}++----------------------------------------------------------------------------+-- Symmetry++-- | Add horizontal symmetry to a layer.++hsym :: Layer -> Layer+hsym l = Layer $ \w h x y ->+  let w' = w `quot` 2+  in unLayer l w' h (if x > w' then w - x else x) y+{-# INLINE hsym #-}++-- | Add vertical symmetry to a layer.++vsym :: Layer -> Layer+vsym l = Layer $ \w h x y ->+  let h' = h `quot` 2+  in unLayer l w h' x (if y > h' then h - y else y)+{-# INLINE vsym #-}++-- | Add horizontal and vertical symmetry to layer. Result is a layer with+-- four mirrored repetitions of the same figure.++hvsym :: Layer -> Layer+hvsym l = Layer $ \w h x y ->+  let h' = h `quot` 2+      w' = w `quot` 2+  in unLayer l w' h' (if x > w' then w - x else x)+                     (if y > h' then h - y else y)+{-# INLINE hvsym #-}++-- | Just like 'hvsym', but every repetition is rotated by 90°. Only works+-- with square layers because for speed it just swaps coordinates.++rsym :: Layer -> Layer+rsym l = Layer $ \w h x y ->+  let h' = h `quot` 2+      w' = w `quot` 2+      α  = x > w'+      β  = y > h'+  in unLayer l w' h'+     (if α then (if β then w - x else y) else (if β then h - y else x))+     (if β then (if α then h - y else x) else (if α then w - x else y))+{-# INLINE rsym #-}++----------------------------------------------------------------------------+-- Other++-- | Select one of provided alternatives given a number.++oneof :: Integral n => [a] -> n -> a+oneof xs n = xs !! (fromIntegral n `rem` length xs)
+ LICENSE.md view
@@ -0,0 +1,28 @@+Copyright © 2016 Mark Karpov++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 Mark Karpov nor the names of 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 “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 HOLDERS 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,97 @@+# Identicon++[![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause)+[![Hackage](https://img.shields.io/hackage/v/identicon.svg?style=flat)](https://hackage.haskell.org/package/identicon)+[![Stackage Nightly](http://stackage.org/package/identicon/badge/nightly)](http://stackage.org/nightly/package/identicon)+[![Stackage LTS](http://stackage.org/package/identicon/badge/lts)](http://stackage.org/lts/package/identicon)+[![Build Status](https://travis-ci.org/mrkkrp/identicon.svg?branch=master)](https://travis-ci.org/mrkkrp/identicon)+[![Coverage Status](https://coveralls.io/repos/mrkkrp/identicon/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/identicon?branch=master)++The package implements flexible generation of identicons using the+[Juicy Pixels](https://hackage.haskell.org/package/JuicyPixels) package.+It's reasonably fast for my taste, and since identicons are usually not+bigger than 420 × 420 pixels, I think that sequential generation that+JuicyPixels supports fits the task very well.++## Quick start++To use the package you usually need the following set of imports (and a+couple of language extensions for type level magic):++```haskell+{-# LANGUAGE DataKinds     #-}+{-# LANGUAGE TypeOperators #-}++import Codec.Picture -- JuicyPixels+import Data.ByteString (ByteString) -- we use strict byte strings+import Data.Proxy+import Data.Word (Word8)+import Graphics.Identicon -- core definitions+import Graphics.Identicon.Primitive -- some visual primitives+```++You first write a type that has information about total number of bytes your+identicon consumes and number of distinct visual components it has (it's+called “layers” in terminology of the package):++```haskell+type MyIcon = Identicon 12 :+ Consumer 4 :+ Consumer 4 :+ Consumer 4+```++Here we have an identicon that needs 12 bytes to be generated. It has three+consumers that take 4 bytes each and generate layers, i.e. visual objects+(circles, squares, etc.).++The second step is to write implementation of every layer. We can use+primitives available out-of-box, they live in the+`Graphics.Identicon.Primitive` module:++```haskell+myImpl :: Implementation MyIcon+myImpl = Identicon :+ a :+ a :+ a+  where+    a :: Word8 -> Word8 -> Word8 -> Word8 -> Layer+    a r g b n = rsym $ onGrid 3 3 n $+      gradientXY (edge . mid) black (PixelRGB8 r g b)+```++We could choose to code every layer differently, but since position and+color of every layer are unlikely to be the same, this approach will work+well too.++Every byte is available to layer-generating function as a distinct `Word8`+argument. The type system makes sure that:++* you consume exactly as many bytes as you promised in type of your+  identicon;++* you have as many layers as you described in type of your identicon;++* every function in your implementation has correct signature (i.e. it grabs+  as many `Word8`s as promised and produces a `Layer` in the end).++Mixing of layers and generation is handled by the library like this:++```haskell+-- | Here is the function that generates your identicons. It's usually+-- convenient to wrap the 'renderIdenticon' function that comes with the+-- library.++genMyIdenticon+  :: Int               -- ^ Identicon width+  -> Int               -- ^ Identicon height+  -> ByteString        -- ^ Input (some sort of hash or something)+  -> Maybe (Image PixelRGB8)+     -- ^ Identicon, unless 'ByteString' is too short+genMyIdenticon = renderIdenticon (Proxy :: Proxy MyIcon) myImpl+```++For more information head straight to Haddocks. BTW, I have written+[a blog post](https://mrkkrp.github.io/posts/the-identicon-package.html)+about the package where I demonstrate some pictures generated with it.++## License++Copyright © 2016 Mark Karpov++Distributed under BSD 3 clause license.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ data-examples/identicon-00.png view

binary file changed (absent → 109 bytes)

+ data-examples/identicon-01.png view

binary file changed (absent → 380 bytes)

+ data-examples/identicon-02.png view

binary file changed (absent → 365 bytes)

+ data-examples/identicon-10.png view

binary file changed (absent → 1881 bytes)

+ data-examples/identicon-11.png view

binary file changed (absent → 1318 bytes)

+ data-examples/identicon-12.png view

binary file changed (absent → 1099 bytes)

+ data-examples/identicon-20.png view

binary file changed (absent → 479 bytes)

+ data-examples/identicon-21.png view

binary file changed (absent → 17473 bytes)

+ data-examples/identicon-22.png view

binary file changed (absent → 19618 bytes)

+ identicon.cabal view
@@ -0,0 +1,92 @@+--+-- Cabal configuration for ‘identicon’ package.+--+-- Copyright © 2016 Mark Karpov <markkarpov@openmailbox.org>+--+-- 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 Mark Karpov nor the names of 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 “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 HOLDERS 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.++name:                 identicon+version:              0.1.0+cabal-version:        >= 1.10+license:              BSD3+license-file:         LICENSE.md+author:               Mark Karpov <markkarpov@openmailbox.org>+maintainer:           Mark Karpov <markkarpov@openmailbox.org>+homepage:             https://github.com/mrkkrp/identicon+bug-reports:          https://github.com/mrkkrp/identicon/issues+category:             Graphics, Image+synopsis:             Flexible generation of identicons+build-type:           Simple+description:          Flexible generation of identicons.+extra-source-files:   CHANGELOG.md+                    , README.md+                    , data-examples/identicon-00.png+                    , data-examples/identicon-01.png+                    , data-examples/identicon-02.png+                    , data-examples/identicon-10.png+                    , data-examples/identicon-11.png+                    , data-examples/identicon-12.png+                    , data-examples/identicon-20.png+                    , data-examples/identicon-21.png+                    , data-examples/identicon-22.png++source-repository head+  type:               git+  location:           https://github.com/mrkkrp/identicon.git++flag dev+  description:        Turn on development settings.+  manual:             True+  default:            False++library+  build-depends:      base             >= 4.7 && < 5+                    , JuicyPixels      >= 3.2.6.5+                    , bytestring       >= 0.10.6+  exposed-modules:    Graphics.Identicon+                    , Graphics.Identicon.Primitive+  if flag(dev)+    ghc-options:      -Wall -Werror+  else+    ghc-options:      -O2 -Wall+  default-language:   Haskell2010++test-suite tests+  main-is:            Spec.hs+  hs-source-dirs:     tests+  type:               exitcode-stdio-1.0+  build-depends:      base             >= 4.7 && < 5+                    , JuicyPixels      >= 3.2.6.5+                    , bytestring       >= 0.10.6+                    , hspec            >= 2.0+                    , identicon        >= 0.1.0+  if flag(dev)+    ghc-options:      -Wall -Werror+  else+    ghc-options:      -O2 -Wall+  default-language:   Haskell2010
+ tests/Spec.hs view
@@ -0,0 +1,168 @@+--+-- Tests for the ‘identicon’ package.+--+-- Copyright © 2016 Mark Karpov <markkarpov@openmailbox.org>+--+-- 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 Mark Karpov nor the names of 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 “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 HOLDERS 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.++{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++module Main (main) where++import Codec.Picture+import Control.Monad+import Data.ByteString+import Data.Function (on)+import Data.Proxy+import Data.Word (Word8)+import Graphics.Identicon+import Graphics.Identicon.Primitive+import Test.Hspec+import qualified Data.ByteString as B++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "renderIdenticon" renderIdenticonSpec+  ω gen0 [0x00,0x00,0x00,0x00] "data-examples/identicon-00.png"+  ω gen0 [0x8f,0x55,0x6e,0x93] "data-examples/identicon-01.png"+  ω gen0 [0x31,0xa8,0x29,0x5b] "data-examples/identicon-02.png"+  ω gen1 [0x3e,0xf1,0xde,0x08,0x85,0x0b,0x9c,0x81,0x25,0xf0,0x53,0x0b]+    "data-examples/identicon-10.png"+  ω gen1 [0xa9,0xf7,0x66,0xf0,0xd7,0xf9,0xb0,0x8e,0x57,0x21,0xc5,0x06]+    "data-examples/identicon-11.png"+  ω gen1 [0x23,0x29,0x2d,0x29,0x2f,0x05,0x28,0x11,0x1e,0x0e,0x0d,0x06]+    "data-examples/identicon-12.png"+  ω gen2 [0xcf,0xe7,0xb9,0x49,0x93,0xb1,0x01]+    "data-examples/identicon-20.png"+  ω gen2 [0xc8,0xa4,0xda,0xa1,0xe9,0x93,0x86]+    "data-examples/identicon-21.png"+  ω gen2 [0xf9,0x9b,0xb7,0x11,0x5b,0xca,0x00]+    "data-examples/identicon-22.png"++renderIdenticonSpec :: Spec+renderIdenticonSpec = do+  context "when we pass too short byte string" $+    it "returns Nothing" $+      shouldBeNothing (gen0 100 100 "aaa")+  context "when we pass nonsential width value" $+    it "returns Nothing" $+      shouldBeNothing (gen0 0 100 "aaaa")+  context "when we pass nonsential height value" $+    it "returns Nothing" $+      shouldBeNothing (gen0 100 0 "aaaa")++----------------------------------------------------------------------------+-- Identicon generators++type Gen0 = Identicon 4 :+ Consumer 4++gen0 :: Int -> Int -> ByteString -> Maybe (Image PixelRGB8)+gen0 = renderIdenticon (Proxy :: Proxy Gen0) i+  where+    i = Identicon :+ a+    a r g b n = rsym $ onGrid 4 4 n $+      circle $ gradientLR (edge . mid) black (PixelRGB8 r g b)++type Gen1 = Identicon 12 :+ Consumer 4 :+ Consumer 4 :+ Consumer 4++gen1 :: Int -> Int -> ByteString -> Maybe (Image PixelRGB8)+gen1 = renderIdenticon (Proxy :: Proxy Gen1) i+  where+    i = Identicon :+ a0 :+ a1 :+ a2+    a0 r g b n = hsym $ onGrid 3 3 n $+      gradientTLBR id black (PixelRGB8 r g b)+    a1 r g b n = vsym $ onGrid 4 4 n $+      gradientXY id black (PixelRGB8 r g b)+    a2 r g b n = hvsym $ onGrid 5 5 n $+      circle $ gradientTRBL mid (PixelRGB8 r g b) black++type Gen2 = Identicon 7 :+ Consumer 3 :+ Consumer 4++gen2 :: Int -> Int -> ByteString -> Maybe (Image PixelRGB8)+gen2 = renderIdenticon (Proxy :: Proxy Gen2) i+  where+    i = Identicon :+ a0 :+ a1+    a0 r g b = gradientTB edge (PixelRGB8 r g b) black+    a1 r g b n = oneof [gradientXY id black, color] n (PixelRGB8 r g b)++----------------------------------------------------------------------------+-- Helpers++-- | A helper to check that 'Nothing' is returned without requiring that+-- argument is an instance of 'Show' or 'Eq' type class.++shouldBeNothing :: Maybe a -> Expectation+shouldBeNothing m =+  case m of+    Nothing -> return ()+    Just _  ->+      expectationFailure "it returned not Nothing"++-- | A shorthand for test cases.++ω+  :: (Int -> Int -> ByteString -> Maybe (Image PixelRGB8))+     -- ^ Identicon generator+  -> [Word8]           -- ^ Input to use for identicon generation+  -> FilePath          -- ^ Where to get image to compare with+  -> Spec+ω f bs path = describe path $ it ("reproduces " ++ path) $+  compareWithFile f (B.pack bs) path++-- | Take function that produces identicon, binary input for it, path to+-- already rendered identicon and compare them. Fail with informative+-- message if they differ.++compareWithFile+  :: (Int -> Int -> ByteString -> Maybe (Image PixelRGB8))+     -- ^ Identicon generator+  -> ByteString        -- ^ Input to use for identicon generation+  -> FilePath          -- ^ Where to get image to compare with+  -> Expectation+compareWithFile f bs path = do+  (Right (ImageRGB8 img)) <- readImage path+  let mimg = f (imageWidth img) (imageHeight img) bs+  case mimg of+    Nothing -> expectationFailure "failed to generate an image"+    Just img' ->+      unless (imageEq img img') $+        expectationFailure ("generated image is different from " ++ path)++-- | Since 'Image' for some reason is not an instance of 'Eq', we use this+-- to compare 'Image's.++imageEq :: Image PixelRGB8 -> Image PixelRGB8 -> Bool+imageEq a b =+  ((==) `on` imageWidth)  a b &&+  ((==) `on` imageHeight) a b &&+  ((==) `on` imageData)   a b