-- |
-- Module      :  Graphics.Identicon.Primitive
-- Copyright   :  © 2016–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- 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 the 'circle' combinator that
-- limits a 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.
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
black = Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 Word8
0 Word8
0 Word8
0

-- | Layer filled with a given color.
color :: PixelRGB8 -> Layer
color :: PixelRGB8 -> Layer
color PixelRGB8
a = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
_ Int
_ Int
_ Int
_ -> PixelRGB8
a
{-# INLINE color #-}

-- | Gradient changing from left to right.
gradientLR ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | Left color
  PixelRGB8 ->
  -- | Right color
  PixelRGB8 ->
  Layer
gradientLR :: (Float -> Float) -> PixelRGB8 -> PixelRGB8 -> Layer
gradientLR Float -> Float
f PixelRGB8
a PixelRGB8
b = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
_ Int
x Int
_ ->
  forall a.
Pixel a =>
(Int
 -> PixelBaseComponent a
 -> PixelBaseComponent a
 -> PixelBaseComponent a)
-> a -> a -> a
mixWith (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ (Float -> Float) -> Int -> Int -> Word8 -> Word8 -> Word8
ξ Float -> Float
f Int
x Int
w) PixelRGB8
a PixelRGB8
b
{-# INLINE gradientLR #-}

-- | Gradient changing from top to bottom.
gradientTB ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | Top color
  PixelRGB8 ->
  -- | Bottom color
  PixelRGB8 ->
  Layer
gradientTB :: (Float -> Float) -> PixelRGB8 -> PixelRGB8 -> Layer
gradientTB Float -> Float
f PixelRGB8
a PixelRGB8
b = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
_ Int
h Int
_ Int
y ->
  forall a.
Pixel a =>
(Int
 -> PixelBaseComponent a
 -> PixelBaseComponent a
 -> PixelBaseComponent a)
-> a -> a -> a
mixWith (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ (Float -> Float) -> Int -> Int -> Word8 -> Word8 -> Word8
ξ Float -> Float
f Int
y Int
h) PixelRGB8
a PixelRGB8
b
{-# INLINE gradientTB #-}

-- | Gradient changing from top left corner to bottom right corner.
gradientTLBR ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | Top left color
  PixelRGB8 ->
  -- | Bottom right color
  PixelRGB8 ->
  Layer
gradientTLBR :: (Float -> Float) -> PixelRGB8 -> PixelRGB8 -> Layer
gradientTLBR Float -> Float
f PixelRGB8
a PixelRGB8
b = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
h 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 forall a b. (a -> b) -> a -> b
$ (Float -> Float) -> Int -> Int -> Word8 -> Word8 -> Word8
ξ Float -> Float
f (Int
x forall a. Num a => a -> a -> a
+ Int
y) (Int
w forall a. Num a => a -> a -> a
+ Int
h)) PixelRGB8
a PixelRGB8
b
{-# INLINE gradientTLBR #-}

-- | Gradient changing from top right corner to bottom left corner.
gradientTRBL ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | Top right color
  PixelRGB8 ->
  -- | Bottom left color
  PixelRGB8 ->
  Layer
gradientTRBL :: (Float -> Float) -> PixelRGB8 -> PixelRGB8 -> Layer
gradientTRBL Float -> Float
f PixelRGB8
a PixelRGB8
b = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
h 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 forall a b. (a -> b) -> a -> b
$ (Float -> Float) -> Int -> Int -> Word8 -> Word8 -> Word8
ξ Float -> Float
f (Int
w forall a. Num a => a -> a -> a
- Int
x forall a. Num a => a -> a -> a
+ Int
y) (Int
w forall a. Num a => a -> a -> a
+ Int
h)) PixelRGB8
a PixelRGB8
b
{-# INLINE gradientTRBL #-}

-- | Gradient with one color everywhere and another in the center.
gradientXY ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | “Edge” color
  PixelRGB8 ->
  -- | Color in the center
  PixelRGB8 ->
  Layer
gradientXY :: (Float -> Float) -> PixelRGB8 -> PixelRGB8 -> Layer
gradientXY Float -> Float
f PixelRGB8
a PixelRGB8
b = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
h Int
x Int
y ->
  let g :: a -> a -> b
g a
x' a
y' = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ (Float
1 forall a. Num a => a -> a -> a
- Float
n) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x' forall a. Num a => a -> a -> a
+ Float
n forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y'
      n :: Float
n = Float -> Float
f (Float
nx forall a. Num a => a -> a -> a
* Float
ny)
      nx :: Float
nx = Float -> Float
mid (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w)
      ny :: Float
ny = Float -> Float
mid (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
   in forall a.
Pixel a =>
(Int
 -> PixelBaseComponent a
 -> PixelBaseComponent a
 -> PixelBaseComponent a)
-> a -> a -> a
mixWith (forall a b. a -> b -> a
const forall {b} {a} {a}.
(Integral b, Integral a, Integral a) =>
a -> a -> b
g) PixelRGB8
a PixelRGB8
b
{-# INLINE gradientXY #-}

-- | A gradient helper function.
ξ ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | Actual value of coordinate
  Int ->
  -- | Maximum value of coordinate
  Int ->
  -- | Color at the beginning of the range
  Word8 ->
  -- | Color at the end of the range
  Word8 ->
  -- | Resulting color
  Word8
ξ :: (Float -> Float) -> Int -> Int -> Word8 -> Word8 -> Word8
ξ Float -> Float
f Int
v Int
l Word8
x Word8
y = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ (Float
1 forall a. Num a => a -> a -> a
- Float
n) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x forall a. Num a => a -> a -> a
+ Float
n forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
y
  where
    n :: Float
n = Float -> Float
f (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 :: Float -> Float
mid Float
x = Float
2 forall a. Num a => a -> a -> a
* (if Float
x forall a. Ord a => a -> a -> Bool
>= Float
0.5 then Float
1.0 forall a. Num a => a -> a -> a
- Float
x else Float
x)
{-# INLINE mid #-}

-- | This sharpens gradient transitions.
edge :: Float -> Float
edge :: Float -> Float
edge Float
x = Float
x forall a. Num a => a -> a -> a
* Float
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) =>
  -- | Number of horizontal positions
  Int ->
  -- | Number of vertical positions
  Int ->
  -- | Index of this cell
  a ->
  -- | Layer to insert
  Layer ->
  -- | Resulting layer
  Layer
onGrid :: forall a. Integral a => Int -> Int -> a -> Layer -> Layer
onGrid Int
α Int
β a
n' Layer
l = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
h Int
x Int
y ->
  let n :: Int
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n' forall a. Integral a => a -> a -> a
`rem` (Int
α forall a. Num a => a -> a -> a
* Int
β)
      (Int
y', Int
x') = Int
n forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
α
      xu, yu :: Float
      xu :: Float
xu = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
α
      yu :: Float
yu = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
β
      xA :: Int
xA = forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x' forall a. Num a => a -> a -> a
* Float
xu)
      xB :: Int
xB = forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
x' forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
* Float
xu)
      yA :: Int
yA = forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y' forall a. Num a => a -> a -> a
* Float
yu)
      yB :: Int
yB = forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
y' forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
* Float
yu)
   in if Int
x forall a. Ord a => a -> a -> Bool
< Int
xA Bool -> Bool -> Bool
|| Int
x forall a. Ord a => a -> a -> Bool
>= Int
xB Bool -> Bool -> Bool
|| Int
y forall a. Ord a => a -> a -> Bool
< Int
yA Bool -> Bool -> Bool
|| Int
y forall a. Ord a => a -> a -> Bool
>= Int
yB
        then PixelRGB8
black
        else Layer -> Int -> Int -> Int -> Int -> PixelRGB8
unLayer Layer
l (Int
xB forall a. Num a => a -> a -> a
- Int
xA) (Int
yB forall a. Num a => a -> a -> a
- Int
yA) (Int
x forall a. Num a => a -> a -> a
- Int
xA) (Int
y forall a. Num a => a -> a -> a
- Int
yA)
{-# INLINE onGrid #-}

-- | Limit given layer so that it forms a circle.
circle :: Layer -> Layer
circle :: Layer -> Layer
circle Layer
l = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
h Int
x Int
y ->
  let w', h', v, r0, r1 :: Float
      w' :: Float
w' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
      h' :: Float
h' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
      sqr :: a -> a
sqr a
a = a
a forall a. Num a => a -> a -> a
* a
a
      v :: Float
v = forall {a}. Num a => a -> a
sqr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x forall a. Num a => a -> a -> a
- Float
w' forall a. Fractional a => a -> a -> a
/ Float
2) forall a. Num a => a -> a -> a
+ forall {a}. Num a => a -> a
sqr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y forall a. Num a => a -> a -> a
- Float
h' forall a. Fractional a => a -> a -> a
/ Float
2)
      r0 :: Float
r0 = forall a. Ord a => a -> a -> a
min Float
w' Float
h' forall a. Fractional a => a -> a -> a
/ Float
2
      r1 :: Float
r1 = forall {a}. Num a => a -> a
sqr Float
r0
      β :: Float
β = Float
2.0 forall a. Num a => a -> a -> a
* Float
r0
      δ :: Float
δ = (Float
r1 forall a. Num a => a -> a -> a
- Float
v) forall a. Fractional a => a -> a -> a
/ Float
β
      τ :: Word8 -> Word8
τ = forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Float
δ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
      ~px :: PixelRGB8
px@(PixelRGB8 Word8
r Word8
g Word8
b) = Layer -> Int -> Int -> Int -> Int -> PixelRGB8
unLayer Layer
l Int
w Int
h Int
x Int
y
      e :: PixelRGB8
e
        | Float
v forall a. Ord a => a -> a -> Bool
< Float
r1 forall a. Num a => a -> a -> a
- Float
β = PixelRGB8
px
        | Float
v forall a. Ord a => a -> a -> Bool
<= Float
r1 = Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 (Word8 -> Word8
τ Word8
r) (Word8 -> Word8
τ Word8
g) (Word8 -> Word8
τ Word8
b)
        | Bool
otherwise = PixelRGB8
black
   in PixelRGB8
e
{-# INLINE circle #-}

----------------------------------------------------------------------------
-- Symmetry

-- | Add horizontal symmetry to a layer.
hsym :: Layer -> Layer
hsym :: Layer -> Layer
hsym Layer
l = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
h Int
x Int
y ->
  let w' :: Int
w' = Int
w forall a. Integral a => a -> a -> a
`quot` Int
2
   in Layer -> Int -> Int -> Int -> Int -> PixelRGB8
unLayer Layer
l Int
w' Int
h (if Int
x forall a. Ord a => a -> a -> Bool
> Int
w' then Int
w forall a. Num a => a -> a -> a
- Int
x else Int
x) Int
y
{-# INLINE hsym #-}

-- | Add vertical symmetry to a layer.
vsym :: Layer -> Layer
vsym :: Layer -> Layer
vsym Layer
l = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
h Int
x Int
y ->
  let h' :: Int
h' = Int
h forall a. Integral a => a -> a -> a
`quot` Int
2
   in Layer -> Int -> Int -> Int -> Int -> PixelRGB8
unLayer Layer
l Int
w Int
h' Int
x (if Int
y forall a. Ord a => a -> a -> Bool
> Int
h' then Int
h forall a. Num a => a -> a -> a
- Int
y else Int
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 :: Layer -> Layer
hvsym Layer
l = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
h Int
x Int
y ->
  let h' :: Int
h' = Int
h forall a. Integral a => a -> a -> a
`quot` Int
2
      w' :: Int
w' = Int
w forall a. Integral a => a -> a -> a
`quot` Int
2
   in Layer -> Int -> Int -> Int -> Int -> PixelRGB8
unLayer
        Layer
l
        Int
w'
        Int
h'
        (if Int
x forall a. Ord a => a -> a -> Bool
> Int
w' then Int
w forall a. Num a => a -> a -> a
- Int
x else Int
x)
        (if Int
y forall a. Ord a => a -> a -> Bool
> Int
h' then Int
h forall a. Num a => a -> a -> a
- Int
y else Int
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 :: Layer -> Layer
rsym Layer
l = (Int -> Int -> Int -> Int -> PixelRGB8) -> Layer
Layer forall a b. (a -> b) -> a -> b
$ \Int
w Int
h Int
x Int
y ->
  let h' :: Int
h' = Int
h forall a. Integral a => a -> a -> a
`quot` Int
2
      w' :: Int
w' = Int
w forall a. Integral a => a -> a -> a
`quot` Int
2
      α :: Bool
α = Int
x forall a. Ord a => a -> a -> Bool
> Int
w'
      β :: Bool
β = Int
y forall a. Ord a => a -> a -> Bool
> Int
h'
   in Layer -> Int -> Int -> Int -> Int -> PixelRGB8
unLayer
        Layer
l
        Int
w'
        Int
h'
        (if Bool
α then (if Bool
β then Int
w forall a. Num a => a -> a -> a
- Int
x else Int
y) else (if Bool
β then Int
h forall a. Num a => a -> a -> a
- Int
y else Int
x))
        (if Bool
β then (if Bool
α then Int
h forall a. Num a => a -> a -> a
- Int
y else Int
x) else (if Bool
α then Int
w forall a. Num a => a -> a -> a
- Int
x else Int
y))
{-# INLINE rsym #-}

----------------------------------------------------------------------------
-- Other

-- | Select one of the provided alternatives given a number.
oneof :: (Integral n) => [a] -> n -> a
oneof :: forall n a. Integral n => [a] -> n -> a
oneof [a]
xs n
n = [a]
xs forall a. [a] -> Int -> a
!! (forall a b. (Integral a, Num b) => a -> b
fromIntegral n
n forall a. Integral a => a -> a -> a
`rem` forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)
{-# INLINE oneof #-}