stylix/palette-generator/Stylix/Palette.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}

module Stylix.Palette ( ) where

import Ai.Evolutionary ( Species(..) )
import Codec.Picture ( Image(imageWidth, imageHeight), PixelRGB8(PixelRGB8), pixelAt )
import Data.Colour ( LAB(lightness), RGB(RGB), deltaE, rgb2lab )
import Data.List ( delete )
import Data.Vector ( (//) )
import qualified Data.Vector as V
import System.Random ( randomRIO )

-- Adjust value according to coefficients
adjustValue :: Double -> Double->  Double -> Double -> Double
adjustValue v a b x = v*(a*x+b)

-- | Extract the primary scale from a pallete.
primary :: V.Vector a -> V.Vector a
primary = V.take 8

-- | Extract the accent colours from a palette.
accent :: V.Vector a -> V.Vector a
accent = V.drop 8

{- |
Combine two palettes by taking a colour from the left,
then the right, then the left, and so on until we have
taken enough colours for a new palette.
-}
alternatingZip :: V.Vector a -> V.Vector a -> V.Vector a
alternatingZip = V.izipWith (\i a b -> if even i then a else b)

randomFromImage :: Image PixelRGB8 -> IO LAB
randomFromImage image = do
  x <- randomRIO (0, imageWidth image - 1)
  y <- randomRIO (0, imageHeight image - 1)
  let (PixelRGB8 r g b) = pixelAt image x y
      color = RGB (fromIntegral r) (fromIntegral g) (fromIntegral b)
  return $ rgb2lab color

instance Species (String,Double,Double, Image PixelRGB8) (V.Vector LAB) where
  generate (_,_,_, image) = V.replicateM 16 $ randomFromImage image

  crossover _ a b = return $ alternatingZip a b

  mutate (_,_,_, image) palette = do
    index <- randomRIO (0, 15)
    colour <- randomFromImage image
    return $ palette // [(index, colour)]

  fitness (polarity,primaryScaleDark,primaryScaleLight, _) palette
    = realToFrac $ accentDifference - (primarySimilarity/10) - scheme
      where
        -- The primary scale should use similar colours, to an extent.
        primarySimilarity = maximum $ do
          a <- primary palette
          b <- primary palette
          return $ deltaE a b

        -- The accent colours should be as different as possible.
        accentDifference = minimum $ do
          index_x <- [0..7]
          index_y <- delete index_x [0..7]
          let x = accent palette V.! index_x
              y = accent palette V.! index_y
          return $ deltaE x y

        -- Helpers for the function below.
        lightnesses = V.map lightness palette
        difference a b = abs $ a - b

        lightnessError primaryScale accentValue
          -- The primary scale's lightnesses should match the given pattern.
          = sum (V.zipWith difference primaryScale $ primary lightnesses)
          -- The accent colours should all have the given lightness.
          + sum (V.map (difference accentValue) $ accent lightnesses)

        scheme = case polarity of
          "either" -> min lightScheme darkScheme
          "light" -> lightScheme
          "dark" -> darkScheme
          _ -> error ("Invalid polarity: " ++ polarity)

        {-
        For light themes, the background is bright and the text is dark.
        The accent colours are slightly darker.
        -}
        lightScheme
          = lightnessError (V.fromList [
            (adjustValue 90.0 0.889 0.111 primaryScaleLight), 
            (adjustValue 70.0 0.963 0.037 primaryScaleLight),
            (adjustValue 55.0 0.913 0.087 primaryScaleLight),
            (adjustValue 35.0 0.167 0.883 primaryScaleLight),
            (adjustValue 25.0 0.078 0.922 primaryScaleLight),
            (adjustValue 10.0 0.133 0.087 primaryScaleLight),
            (adjustValue 5.0 0.0 1.0 primaryScaleLight),
            (adjustValue 5.0 0.0 1.0 primaryScaleLight)
          ]) 40

        -- 0.2, 0.133,0.178,0.85,0.93,0.88,1.0,1.0 for 0.1 scale
        -- f(x) = ax+b for multiplier (light)
        -- 0.889, 0.111
        -- 0.963, 0.037
        -- 0.913, 0.087
        -- 0.167, 0.833
        -- 0.078, 0.922
        -- 0.133, 0.087
        -- 0.0, 1.0
        -- 0.0, 1.0

        {-
        For dark themes, the background is dark and the text is bright.
        The accent colours are slightly brighter.
        -}
        darkScheme
          = lightnessError (V.fromList [
            (adjustValue 10.0 0.889 0.111 primaryScaleDark), 
            (adjustValue 30.0 0.963 0.037 primaryScaleDark),
            (adjustValue 45.0 0.913 0.087 primaryScaleDark),
            (adjustValue 65.0 0.167 0.883 primaryScaleDark),
            (adjustValue 75.0 0.078 0.922 primaryScaleDark),
            (adjustValue 90.0 0.133 0.087 primaryScaleDark),
            (adjustValue 95.0 0.0 1.0 primaryScaleDark),
            (adjustValue 95.0 0.0 1.0 primaryScaleDark)
            ]) 60
        
        -- 0.2, 0.133,0.178,0.85,0.93,0.88,1.0,1.0 for 0.1 scale
        -- f(x) = ax+b for multiplier (dark)
        -- 0.889, 0.111
        -- 0.963, 0.037
        -- 0.913, 0.087
        -- 0.167, 0.833
        -- 0.078, 0.922
        -- 0.133, 0.087
        -- 0.0, 1.0
        -- 0.0, 1.0