119 lines
3.9 KiB
Haskell
119 lines
3.9 KiB
Haskell
{-# 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 :: LAB(lightness) -> Float-> Float -> Float -> Int
|
|
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,Float,Float, 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,_,_, _) 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 [90, 70, 55, 35, 25, 10, 5, 5]) 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 [10, 30, 45, 65, 75, 90, 95, 95]) 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
|