{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      :  Graphics.Identicon
-- Copyright   :  © 2016–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Core types and definitions for flexible generation of identicons. Please
-- see the "Graphics.Identicon.Primitive" module for a 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 the desired width, height, and a 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 when
-- width\/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.
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.ByteString qualified as B
import Data.Maybe (fromJust)
import Data.Proxy
import Data.Semigroup qualified as S
import Data.Word (Word8)
import GHC.TypeLits

----------------------------------------------------------------------------
-- Basic types

-- | 'Identicon' is a type that represents an identicon consisting of zero
-- layers. The type is parametrized over a phantom type @n@ which is a
-- natural number on the 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 a 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 a phantom
-- type @n@ which is a natural number on the type level that represents the
-- number of bytes that this entity consumes. At this moment, a 'Consumer'
-- always adds one 'Layer' to an '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 the 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 a “superposition” of several 'Layers'.
newtype Layer = Layer
  {Layer -> Int -> Int -> Int -> Int -> PixelRGB8
unLayer :: Int -> Int -> Int -> Int -> PixelRGB8}

instance S.Semigroup Layer where
  Layer Int -> Int -> Int -> Int -> PixelRGB8
a <> :: Layer -> Layer -> Layer
<> Layer Int -> Int -> Int -> Int -> PixelRGB8
b = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer (\Int
w Int
h -> (Int -> Int -> PixelRGB8)
-> (Int -> Int -> PixelRGB8) -> Int -> Int -> PixelRGB8
mixPixels (Int -> Int -> Int -> Int -> PixelRGB8
a Int
w Int
h) (Int -> Int -> Int -> Int -> PixelRGB8
b Int
w Int
h))

instance Monoid Layer where
  mempty :: Layer
mempty = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
_ Int
_ Int
_ Int
_ -> Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 Word8
0 Word8
0 Word8
0
  mappend :: Layer -> Layer -> Layer
mappend = forall a. Semigroup a => a -> a -> a
(S.<>)

-- | The 'BytesAvailable' type function calculates how many bytes are
-- 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 are
-- 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 the 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 a layer-producing
-- function should have to consume the given number of bytes @n@.
type family ToLayer (n :: Nat) 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 ::
    -- | A 'Proxy' clarifying identicon type
    Proxy a ->
    -- | Corresponding implementation
    Implementation a ->
    -- | Width in pixels
    Int ->
    -- | Height in pixels
    Int ->
    -- | Bytes to consume
    ByteString ->
    -- | The rest of bytes and producing function
    (ByteString, Int -> Int -> PixelRGB8)

instance Renderable (Identicon n) where
  render :: Proxy (Identicon n)
-> Implementation (Identicon n)
-> Int
-> Int
-> ByteString
-> (ByteString, Int -> Int -> PixelRGB8)
render Proxy (Identicon n)
_ Implementation (Identicon n)
_ Int
_ Int
_ ByteString
bs = (ByteString
bs, \Int
_ Int
_ -> Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 Word8
0 Word8
0 Word8
0)

instance
  (Renderable a, ApplyBytes (ToLayer n)) =>
  Renderable (a :+ Consumer n)
  where
  render :: Proxy (a :+ Consumer n)
-> Implementation (a :+ Consumer n)
-> Int
-> Int
-> ByteString
-> (ByteString, Int -> Int -> PixelRGB8)
render Proxy (a :+ Consumer n)
_ (Implementation a
a :+ ToLayer n
b) Int
weight Int
height ByteString
bs0 =
    let (ByteString
bs1, Int -> Int -> PixelRGB8
x) = forall a.
Renderable a =>
Proxy a
-> Implementation a
-> Int
-> Int
-> ByteString
-> (ByteString, Int -> Int -> PixelRGB8)
render (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) Implementation a
a Int
weight Int
height ByteString
bs0
        (ByteString
bs2, Layer
y) = forall a. ApplyBytes a => a -> ByteString -> (ByteString, Layer)
applyBytes ToLayer n
b ByteString
bs1
     in (ByteString
bs2, (Int -> Int -> PixelRGB8)
-> (Int -> Int -> PixelRGB8) -> Int -> Int -> PixelRGB8
mixPixels Int -> Int -> PixelRGB8
x (Layer -> Int -> Int -> Int -> Int -> PixelRGB8
unLayer Layer
y Int
weight Int
height))

-- | Combine results of two rending functions.
mixPixels ::
  (Int -> Int -> PixelRGB8) ->
  (Int -> Int -> PixelRGB8) ->
  Int ->
  Int ->
  PixelRGB8
mixPixels :: (Int -> Int -> PixelRGB8)
-> (Int -> Int -> PixelRGB8) -> Int -> Int -> PixelRGB8
mixPixels Int -> Int -> PixelRGB8
a Int -> Int -> PixelRGB8
b Int
x Int
y = forall a.
Pixel a =>
(Int
 -> PixelBaseComponent a
 -> PixelBaseComponent a
 -> PixelBaseComponent a)
-> a -> a -> a
mixWith (forall a b. a -> b -> a
const Word8 -> Word8 -> Word8
saturatedAddition) (Int -> Int -> PixelRGB8
a Int
x Int
y) (Int -> Int -> PixelRGB8
b Int
x Int
y)
{-# INLINE mixPixels #-}

-- | An implementation of saturated addition for bytes.
saturatedAddition :: Word8 -> Word8 -> Word8
saturatedAddition :: Word8 -> Word8 -> Word8
saturatedAddition Word8
x Word8
y =
  let z :: Word8
z = Word8
x forall a. Num a => a -> a -> a
+ Word8
y
   in if Word8
z forall a. Ord a => a -> a -> Bool
< Word8
x then Word8
0xff else Word8
z
{-# INLINE saturatedAddition #-}

-- | Consume bytes from a strict 'ByteString' and apply them to a function
-- that takes 'Word8' until it produces a 'Layer'.
class ApplyBytes a where
  applyBytes ::
    -- | Function that produces a layer
    a ->
    -- | Bytes to consume
    ByteString ->
    -- | The rest of 'ByteString' and produced 'Layer'
    (ByteString, Layer)

instance ApplyBytes Layer where
  applyBytes :: Layer -> ByteString -> (ByteString, Layer)
applyBytes Layer
f ByteString
bs = (ByteString
bs, Layer
f)

instance (ApplyBytes f) => ApplyBytes (Word8 -> f) where
  applyBytes :: (Word8 -> f) -> ByteString -> (ByteString, Layer)
applyBytes Word8 -> f
f ByteString
bs =
    let (Word8
b, ByteString
bs') = forall a. HasCallStack => Maybe a -> a
fromJust (ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs)
     in forall a. ApplyBytes a => a -> ByteString -> (ByteString, Layer)
applyBytes (Word8 -> f
f Word8
b) ByteString
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
  ) =>
  -- | Type that defines an identicon
  Proxy a ->
  -- | Implementation that generates layers
  Implementation a ->
  -- | Width in pixels
  Int ->
  -- | Height in pixels
  Int ->
  -- | Collection of bytes to use, should be long enough
  ByteString ->
  -- | Rendered identicon, or 'Nothing' if there is not enough bytes
  Maybe (Image PixelRGB8)
renderIdenticon :: forall a.
(Renderable a, KnownNat (BytesAvailable a),
 BytesAvailable a ~ BytesConsumed a) =>
Proxy a
-> Implementation a
-> Int
-> Int
-> ByteString
-> Maybe (Image PixelRGB8)
renderIdenticon Proxy a
proxy Implementation a
impl Int
width Int
height ByteString
bs =
  if ByteString -> Int
B.length ByteString
bs forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy (BytesAvailable a)))
    Bool -> Bool -> Bool
|| Int
width forall a. Ord a => a -> a -> Bool
< Int
1
    Bool -> Bool -> Bool
|| Int
height forall a. Ord a => a -> a -> Bool
< Int
1
    then forall a. Maybe a
Nothing
    else
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage
          (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a.
Renderable a =>
Proxy a
-> Implementation a
-> Int
-> Int
-> ByteString
-> (ByteString, Int -> Int -> PixelRGB8)
render Proxy a
proxy Implementation a
impl Int
width Int
height ByteString
bs)
          Int
width
          Int
height
{-# NOINLINE renderIdenticon #-}