{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Graphics.Identicon
(
Identicon (..),
Consumer,
(:+) (..),
Layer (..),
BytesAvailable,
BytesConsumed,
Implementation,
ToLayer,
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
data Identicon (n :: Nat) = Identicon
data Consumer (n :: Nat)
infixl 8 :+
data a :+ b = a :+ b
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.<>)
type family BytesAvailable a :: Nat where
BytesAvailable (Identicon n) = n
BytesAvailable (x :+ y) = BytesAvailable x
type family BytesConsumed a :: Nat where
BytesConsumed (Identicon n) = 0
BytesConsumed (Consumer n) = n
BytesConsumed (x :+ y) = BytesConsumed x + BytesConsumed y
type family Implementation a where
Implementation (Identicon n) = Identicon n
Implementation (a :+ Consumer n) = Implementation a :+ ToLayer n
type family ToLayer (n :: Nat) where
ToLayer 0 = Layer
ToLayer n = Word8 -> ToLayer (n - 1)
class Renderable a where
render ::
Proxy a ->
Implementation a ->
Int ->
Int ->
ByteString ->
(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))
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 #-}
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 #-}
class ApplyBytes a where
applyBytes ::
a ->
ByteString ->
(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'
renderIdenticon ::
forall a.
( Renderable a,
KnownNat (BytesAvailable a),
BytesAvailable a ~ BytesConsumed a
) =>
Proxy a ->
Implementation a ->
Int ->
Int ->
ByteString ->
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 #-}