mirror of
https://github.com/danth/stylix
synced 2024-11-26 14:10:22 +00:00
ba5565d698
Simplified a lot of code which was unnecessarily generic. Now using monads to manage the state of the random number generator rather than passing it around by hand. Also made some performance improvements, then increased the population size so more combinations are tried in a similar length of time.
92 lines
3.2 KiB
Haskell
92 lines
3.2 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 )
|
|
|
|
-- | 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, 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
|
|
|
|
{-
|
|
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
|