Primitive.hs

-- |
-- 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 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 ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | Left color
  PixelRGB8 ->
  -- | Right color
  PixelRGB8 ->
  Layer
gradientLR f a b = Layer $ \w _ x _ ->
  mixWith (const $ ξ f x w) a b
{-# INLINE gradientLR #-}

-- | Gradient changing from top to bottom.
gradientTB ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | Top color
  PixelRGB8 ->
  -- | Bottom color
  PixelRGB8 ->
  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 ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | Top left color
  PixelRGB8 ->
  -- | Bottom right color
  PixelRGB8 ->
  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 ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | Top right color
  PixelRGB8 ->
  -- | Bottom left color
  PixelRGB8 ->
  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 ::
  -- | Gradient transforming function
  (Float -> Float) ->
  -- | “Edge” color
  PixelRGB8 ->
  -- | Color in the center
  PixelRGB8 ->
  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.
ξ ::
  -- | 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
ξ 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) =>
  -- | Number of horizontal positions
  Int ->
  -- | Number of vertical positions
  Int ->
  -- | Index of this cell
  a ->
  -- | Layer to insert
  Layer ->
  -- | Resulting layer
  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 that 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 the provided alternatives given a number.
oneof :: (Integral n) => [a] -> n -> a
oneof xs n = xs !! (fromIntegral n `rem` length xs)
{-# INLINE oneof #-}