mirror of
https://github.com/danth/stylix
synced 2024-11-10 06:34:15 +00:00
Use a genetic algorithm to choose colours ✨
This produces much more visually pleasing palettes compared to the crude algorithm which was previously used.
This commit is contained in:
Daniel Thwaites
parent
95b7629d29
commit
09892b21a5
7 changed files with 272 additions and 169 deletions
10
flake.nix
10
flake.nix
|
|
@ -10,14 +10,18 @@
|
|||
let
|
||||
pkgs = nixpkgs.legacyPackages.${system};
|
||||
|
||||
ghc = pkgs.haskellPackages.ghcWithPackages
|
||||
(haskellPackages: with haskellPackages; [ json JuicyPixels ]);
|
||||
ghc = pkgs.haskellPackages.ghcWithPackages (haskellPackages:
|
||||
with haskellPackages; [
|
||||
json
|
||||
JuicyPixels
|
||||
random
|
||||
]);
|
||||
|
||||
palette-generator = pkgs.stdenvNoCC.mkDerivation {
|
||||
name = "palette-generator";
|
||||
src = ./palette-generator;
|
||||
buildInputs = [ ghc ];
|
||||
buildPhase = "ghc -O -threaded -Wall Stylix/Main.hs";
|
||||
buildPhase = "ghc -O -threaded -Wall -Wno-type-defaults Stylix/Main.hs";
|
||||
installPhase = "install -D Stylix/Main $out/bin/palette-generator";
|
||||
};
|
||||
|
||||
|
|
|
|||
86
palette-generator/Ai/Evolutionary.hs
Normal file
86
palette-generator/Ai/Evolutionary.hs
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module Ai.Evolutionary ( EvolutionConfig(..), Species(..), evolve ) where
|
||||
|
||||
import Control.Applicative ( liftA2 )
|
||||
import Data.Bifunctor ( second )
|
||||
import Data.List ( mapAccumR, sortBy )
|
||||
import Data.Ord ( Down(Down), comparing )
|
||||
import System.Random ( RandomGen, randomR )
|
||||
|
||||
cartesianProduct :: [a] -> [b] -> [(a, b)]
|
||||
cartesianProduct = liftA2 (,)
|
||||
|
||||
cartesianSquare :: [a] -> [(a, a)]
|
||||
cartesianSquare as = as `cartesianProduct` as
|
||||
|
||||
repeatCall :: Int -> (a -> a) -> a -> a
|
||||
repeatCall n f = (!! n) . iterate f
|
||||
|
||||
randomFromList :: (RandomGen r) => r -> [a] -> (a, r)
|
||||
randomFromList generator list
|
||||
= let (index, generator') = randomR (0, length list - 1) generator
|
||||
in (list !! index, generator')
|
||||
|
||||
mapWithGen :: (r -> a -> (r, b)) -> (r, [a]) -> (r, [b])
|
||||
mapWithGen = uncurry . mapAccumR
|
||||
|
||||
unfoldWithGen :: (r -> (r, a)) -> Int -> r -> (r, [a])
|
||||
unfoldWithGen _ 0 generator = (generator, [])
|
||||
unfoldWithGen f size generator =
|
||||
let (generator', as) = unfoldWithGen f (size - 1) generator
|
||||
(generator'', a) = f generator'
|
||||
in (generator'', a:as)
|
||||
|
||||
class Species environment genotype where
|
||||
generate :: (RandomGen r) => environment -> r -> (r, genotype)
|
||||
crossover :: (RandomGen r) => environment -> r -> genotype -> genotype -> (r, genotype)
|
||||
mutate :: (RandomGen r) => environment -> r -> genotype -> (r, genotype)
|
||||
fitness :: environment -> genotype -> Double
|
||||
|
||||
data EvolutionConfig = EvolutionConfig { populationSize :: Int
|
||||
, survivors :: Int
|
||||
, mutationProbability :: Double
|
||||
, generations :: Int
|
||||
}
|
||||
|
||||
randomMutation ::
|
||||
(RandomGen r, Species e g) =>
|
||||
e -> EvolutionConfig -> r -> g -> (r, g)
|
||||
randomMutation environment config generator chromosome
|
||||
= let (r, generator') = randomR (0.0, 1.0) generator
|
||||
in if r <= mutationProbability config
|
||||
then mutate environment generator' chromosome
|
||||
else (generator', chromosome)
|
||||
|
||||
naturalSelection :: (Species e g) => e -> EvolutionConfig -> [g] -> [g]
|
||||
naturalSelection environment config
|
||||
= map snd
|
||||
. take (survivors config)
|
||||
. sortBy (comparing fst)
|
||||
-- Avoid computing fitness multiple times during sorting
|
||||
-- Down reverses the sort order so that the best fitness comes first
|
||||
. map (\genotype -> (Down $ fitness environment genotype, genotype))
|
||||
|
||||
evolveGeneration ::
|
||||
(RandomGen r, Species e g) =>
|
||||
e -> EvolutionConfig -> (r, [g]) -> (r, [g])
|
||||
evolveGeneration environment config (generator, population)
|
||||
= second (naturalSelection environment config)
|
||||
$ mapWithGen (randomMutation environment config)
|
||||
$ unfoldWithGen randomCrossover (populationSize config) generator
|
||||
where pairs = cartesianSquare population
|
||||
randomCrossover gen = let (pair, gen') = randomFromList gen pairs
|
||||
in (uncurry $ crossover environment gen') pair
|
||||
|
||||
initialGeneration ::
|
||||
(RandomGen r, Species e g) =>
|
||||
e -> EvolutionConfig -> r -> (r, [g])
|
||||
initialGeneration environment config
|
||||
= unfoldWithGen (generate environment) (survivors config)
|
||||
|
||||
evolve :: (RandomGen r, Species e g) => e -> EvolutionConfig -> r -> (r, g)
|
||||
evolve environment config generator
|
||||
= second head
|
||||
$ repeatCall (generations config) (evolveGeneration environment config)
|
||||
$ initialGeneration environment config generator
|
||||
|
|
@ -1,44 +1,68 @@
|
|||
module Data.Colour ( RGB(..), HSV(..), rgbToHsv, hsvToRgb ) where
|
||||
module Data.Colour ( LAB(..), RGB(..), deltaE, lab2rgb, rgb2lab ) where
|
||||
|
||||
import Data.Fixed ( mod' )
|
||||
data LAB a = LAB { lightness :: a
|
||||
, channelA :: a
|
||||
, channelB :: a
|
||||
}
|
||||
|
||||
-- http://mattlockyer.github.io/iat455/documents/rgb-hsv.pdf
|
||||
data RGB a = RGB { red :: a
|
||||
, green :: a
|
||||
, blue :: a
|
||||
}
|
||||
|
||||
data RGB a = RGB a a a deriving (Eq, Show) -- 0 to 255
|
||||
data HSV a = HSV a a a deriving (Eq, Show) -- 0 to 1
|
||||
-- Based on https://github.com/antimatter15/rgb-lab/blob/master/color.js
|
||||
|
||||
normaliseHue :: (Real a) => a -> a
|
||||
normaliseHue h = h `mod'` 6
|
||||
deltaE :: (Floating a, Ord a) => LAB a -> LAB a -> a
|
||||
deltaE (LAB l1 a1 b1) (LAB l2 a2 b2) =
|
||||
let deltaL = l1 - l2
|
||||
deltaA = a1 - a2
|
||||
deltaB = b1 - b2
|
||||
c1 = sqrt $ a1^2 + b1^2
|
||||
c2 = sqrt $ a2^2 + b2^2
|
||||
deltaC = c1 - c2
|
||||
deltaH = deltaA^2 + deltaB^2 - deltaC^2
|
||||
deltaH' = if deltaH < 0 then 0 else sqrt deltaH
|
||||
sc = 1 + 0.045 * c1
|
||||
sh = 1 + 0.015 * c1
|
||||
deltaCkcsc = deltaC / sc
|
||||
deltaHkhsh = deltaH' / sh
|
||||
i = deltaL^2 + deltaCkcsc^2 + deltaHkhsh^2
|
||||
in if i < 0 then 0 else sqrt i
|
||||
|
||||
rgbToHsv :: (Eq a, Fractional a, Num a, Real a) => RGB a -> HSV a
|
||||
rgbToHsv (RGB r' g' b') = HSV h' s v
|
||||
where r = r' / 255
|
||||
g = g' / 255
|
||||
b = b' / 255
|
||||
maximal = maximum [r, g, b]
|
||||
minimal = minimum [r, g, b]
|
||||
delta = maximal - minimal
|
||||
h | delta == 0 = 0
|
||||
| maximal == r = (g - b) / delta
|
||||
| maximal == g = ((b - r) / delta) + 2
|
||||
| otherwise = ((r - g) / delta) + 4
|
||||
h' = normaliseHue h
|
||||
s | v == 0 = 0
|
||||
| otherwise = delta / v
|
||||
v = maximal
|
||||
lab2rgb :: (Floating a, Ord a) => LAB a -> RGB a
|
||||
lab2rgb (LAB l a bx) =
|
||||
let y = (l + 16) / 116
|
||||
x = a / 500 + y
|
||||
z = y - bx / 200
|
||||
x' = 0.95047 * (if x^3 > 0.008856 then x^3 else (x - 16/116) / 7.787)
|
||||
y' = if y^3 > 0.008856 then y^3 else (y - 16/116) / 7.787
|
||||
z' = 1.08883 * (if z^3 > 0.008856 then z^3 else (z - 16/116) / 7.787)
|
||||
r = x' * 3.2406 + y' * (-1.5372) + z' * (-0.4986)
|
||||
g = x' * (-0.9689) + y' * 1.8758 + z' * 0.0415
|
||||
b = x' * 0.0557 + y' * (-0.204) + z' * 1.0570
|
||||
r' = if r > 0.0031308 then 1.055 * r**(1/2.4) - 0.055 else 12.92 * r
|
||||
g' = if g > 0.0031308 then 1.055 * g**(1/2.4) - 0.055 else 12.92 * g
|
||||
b' = if b > 0.0031308 then 1.055 * b**(1/2.4) - 0.055 else 12.92 * b
|
||||
in RGB { red = max 0 (min 1 r') * 255
|
||||
, green = max 0 (min 1 g') * 255
|
||||
, blue = max 0 (min 1 b') * 255
|
||||
}
|
||||
|
||||
hsvToRgb :: (Num a, Ord a, Real a) => HSV a -> RGB a
|
||||
hsvToRgb (HSV h' s v) = RGB r' g' b'
|
||||
where h = normaliseHue h'
|
||||
alpha = v * (1 - s)
|
||||
beta = v * (1 - (h - abs h) * s)
|
||||
gamma = v * (1 - (1 - (h - abs h)) * s)
|
||||
(r, g, b) | h < 1 = (v, gamma, alpha)
|
||||
| h < 2 = (beta, v, alpha)
|
||||
| h < 3 = (alpha, v, gamma)
|
||||
| h < 4 = (alpha, beta, v)
|
||||
| h < 5 = (gamma, alpha, v)
|
||||
| otherwise = (v, alpha, beta)
|
||||
r' = r * 255
|
||||
g' = g * 255
|
||||
b' = b * 255
|
||||
rgb2lab :: (Floating a, Ord a) => RGB a -> LAB a
|
||||
rgb2lab (RGB r g b) =
|
||||
let r' = r / 255
|
||||
g' = g / 255
|
||||
b' = b / 255
|
||||
r'' = if r' > 0.04045 then ((r' + 0.055) / 1.055)**2.4 else r' / 12.92
|
||||
g'' = if g' > 0.04045 then ((g' + 0.055) / 1.055)**2.4 else g' / 12.92
|
||||
b'' = if b' > 0.04045 then ((b' + 0.055) / 1.055)**2.4 else b' / 12.92
|
||||
x = (r'' * 0.4124 + g'' * 0.3576 + b'' * 0.1805) / 0.95047
|
||||
y = r'' * 0.2126 + g'' * 0.7152 + b'' * 0.0722
|
||||
z = (r'' * 0.0193 + g'' * 0.1192 + b'' * 0.9505) / 1.08883
|
||||
x' = if x > 0.008856 then x**(1/3) else (7.787 * x) + 16/116
|
||||
y' = if y > 0.008856 then y**(1/3) else (7.787 * y) + 16/116
|
||||
z' = if z > 0.008856 then z**(1/3) else (7.787 * z) + 16/116
|
||||
in LAB { lightness = (116 * y') - 16
|
||||
, channelA = 500 * (x' - y')
|
||||
, channelB = 200 * (y' - z')
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,52 +0,0 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Stylix.Bucket
|
||||
( Bucket
|
||||
, emptyBucket
|
||||
, insertToBucket
|
||||
, bucketSize
|
||||
, bucketAverage
|
||||
, Buckets
|
||||
, emptyBuckets
|
||||
, makeBuckets
|
||||
, makeBuckets'
|
||||
) where
|
||||
|
||||
import Data.Colour ( HSV(HSV) )
|
||||
import Data.Map ( Map )
|
||||
import qualified Data.Map as Map
|
||||
|
||||
data Bucket a = Bucket Int a a a
|
||||
|
||||
emptyBucket :: (Num a) => Bucket a
|
||||
emptyBucket = Bucket 0 0 0 0
|
||||
|
||||
insertToBucket :: (Num a) => HSV a -> Bucket a -> Bucket a
|
||||
insertToBucket (HSV h s v) (Bucket count h' s' v')
|
||||
= Bucket (count + 1) (h' + h) (s' + s) (v' + v)
|
||||
|
||||
bucketSize :: Bucket a -> Int
|
||||
bucketSize (Bucket size _ _ _) = size
|
||||
|
||||
bucketAverage :: (Fractional a) => Bucket a -> HSV a
|
||||
bucketAverage (Bucket size h' s' v')
|
||||
= HSV (h' / size') (s' / size') (v' / size')
|
||||
where size' = fromIntegral size
|
||||
|
||||
type Buckets a = Map Int (Bucket a)
|
||||
|
||||
emptyBuckets :: (Num a) => Buckets a
|
||||
emptyBuckets = Map.fromList [(x, emptyBucket) | x <- [0..8]]
|
||||
|
||||
makeBuckets :: forall a. (Fractional a, Num a, RealFrac a) =>
|
||||
(HSV a -> a) -> Int -> [HSV a] -> Buckets a
|
||||
makeBuckets f numberOfBuckets = foldr allocateToBucket emptyBuckets
|
||||
|
||||
where allocateToBucket :: (Fractional a, Num a, RealFrac a) =>
|
||||
HSV a -> Buckets a -> Buckets a
|
||||
allocateToBucket colour = Map.adjust (insertToBucket colour) bucket
|
||||
where bucket = floor $ fromIntegral numberOfBuckets * f colour
|
||||
|
||||
makeBuckets' :: forall a. (Fractional a, Num a, RealFrac a) =>
|
||||
(HSV a -> a) -> Int -> [HSV a] -> [Bucket a]
|
||||
makeBuckets' f numberOfBuckets = Map.elems . makeBuckets f numberOfBuckets
|
||||
|
|
@ -1,90 +1,46 @@
|
|||
import Ai.Evolutionary ( EvolutionConfig(EvolutionConfig), evolve )
|
||||
import Codec.Picture ( DynamicImage, Image(imageWidth, imageHeight), PixelRGB8(PixelRGB8), convertRGB8, pixelAt, readImage )
|
||||
import Data.Bifunctor ( second )
|
||||
import Data.Colour ( HSV(HSV), RGB(RGB), hsvToRgb, rgbToHsv )
|
||||
import Data.List ( sortOn )
|
||||
import Data.Word ( Word8 )
|
||||
import Stylix.Bucket ( Bucket, bucketAverage, bucketSize, makeBuckets' )
|
||||
import Data.Colour ( LAB, RGB(RGB), lab2rgb, rgb2lab )
|
||||
import qualified Data.Vector as V
|
||||
import Stylix.Output ( makeOutputTable )
|
||||
import Stylix.Palette ( )
|
||||
import System.Environment ( getArgs )
|
||||
import System.Exit ( die )
|
||||
import Text.JSON ( JSObject, encode, toJSObject )
|
||||
import Text.Printf ( printf )
|
||||
import System.Random ( mkStdGen )
|
||||
import Text.JSON ( encode )
|
||||
|
||||
type OutputTable = JSObject String
|
||||
selectColours :: (Floating a, Real a) => V.Vector (LAB a) -> V.Vector (LAB a)
|
||||
selectColours image
|
||||
= snd $ evolve image (EvolutionConfig 1000 100 0.5 150) (mkStdGen 0)
|
||||
|
||||
makeOutputTable :: [(String, RGB Float)] -> OutputTable
|
||||
makeOutputTable = toJSObject . concatMap makeOutputs
|
||||
|
||||
where makeOutputs :: (String, RGB Float) -> [(String, String)]
|
||||
makeOutputs (name, RGB r g b) =
|
||||
[ (name ++ "-dec-r", show $ r / 255)
|
||||
, (name ++ "-dec-g", show $ g / 255)
|
||||
, (name ++ "-dec-b", show $ b / 255)
|
||||
, (name ++ "-rgb-r", show r')
|
||||
, (name ++ "-rgb-g", show g')
|
||||
, (name ++ "-rgb-b", show b')
|
||||
, (name ++ "-hex-r", printf "%02x" r')
|
||||
, (name ++ "-hex-g", printf "%02x" g')
|
||||
, (name ++ "-hex-b", printf "%02x" b')
|
||||
, (name ++ "-hex", printf "%02x%02x%02x" r' g' b')
|
||||
, (name ++ "-hash", printf "#%02x%02x%02x" r' g' b')
|
||||
]
|
||||
where r' :: Word8
|
||||
r' = round r
|
||||
g' :: Word8
|
||||
g' = round g
|
||||
b' :: Word8
|
||||
b' = round b
|
||||
|
||||
selectColours :: [HSV Float] -> [(String, HSV Float)]
|
||||
selectColours image = zip names palette
|
||||
|
||||
where names :: [String]
|
||||
names = map (printf "base%02X") ([0..15] :: [Int])
|
||||
|
||||
buckets :: [Bucket Float]
|
||||
buckets = makeBuckets' (\(HSV h _ _) -> h / 6) 9 image
|
||||
|
||||
shortlist :: [HSV Float]
|
||||
shortlist = map bucketAverage $ sortOn bucketSize buckets
|
||||
|
||||
primaryScale :: [HSV Float]
|
||||
primaryScale = [HSV h s (v / 8) | v <- [1..8]]
|
||||
where (HSV h s _) = head shortlist
|
||||
|
||||
secondaryScale :: [HSV Float]
|
||||
secondaryScale = sortOn (\(HSV h _ _) -> h) $ tail shortlist
|
||||
|
||||
palette :: [HSV Float]
|
||||
palette = primaryScale ++ secondaryScale
|
||||
|
||||
unpackImage :: DynamicImage -> [RGB Float]
|
||||
unpackImage :: (Num a) => DynamicImage -> V.Vector (RGB a)
|
||||
unpackImage image = do
|
||||
let image' = convertRGB8 image
|
||||
x <- [0 .. imageWidth image' - 1]
|
||||
y <- [0 .. imageHeight image' - 1]
|
||||
x <- V.enumFromN 0 (imageWidth image')
|
||||
y <- V.enumFromN 0 (imageHeight image')
|
||||
let (PixelRGB8 r g b) = pixelAt image' x y
|
||||
return (RGB (fromIntegral r) (fromIntegral g) (fromIntegral b))
|
||||
return $ RGB (fromIntegral r) (fromIntegral g) (fromIntegral b)
|
||||
|
||||
loadImage :: String -> IO DynamicImage
|
||||
loadImage input = either error id <$> readImage input
|
||||
|
||||
mainProcess :: (String, String) -> IO ()
|
||||
mainProcess (input, output) = do
|
||||
putStrLn $ "Processing " ++ input
|
||||
image <- loadImage input
|
||||
let outputTable = makeOutputTable
|
||||
$ V.map lab2rgb
|
||||
$ selectColours
|
||||
$ V.map rgb2lab
|
||||
$ unpackImage image
|
||||
writeFile output $ encode outputTable
|
||||
putStrLn $ "Saved to " ++ output
|
||||
|
||||
parseArguments :: [String] -> Either String (String, String)
|
||||
parseArguments [input, output] = Right (input, output)
|
||||
parseArguments [_] = Left "Please specify an output file"
|
||||
parseArguments [] = Left "Please specify an image"
|
||||
parseArguments _ = Left "Too many arguments"
|
||||
|
||||
main :: IO ()
|
||||
main = either die mainProcess . parseArguments =<< getArgs
|
||||
|
||||
where parseArguments :: [String] -> Either String (String, String)
|
||||
parseArguments [input, output] = Right (input, output)
|
||||
parseArguments [_] = Left "Please specify an output file"
|
||||
parseArguments [] = Left "Please specify an image"
|
||||
parseArguments _ = Left "Too many arguments"
|
||||
|
||||
mainProcess :: (String, String) -> IO ()
|
||||
mainProcess (input, output) = do
|
||||
putStrLn $ "Processing " ++ input
|
||||
image <- loadImage input
|
||||
let outputTable = makeOutputTable
|
||||
$ map (second hsvToRgb)
|
||||
$ selectColours
|
||||
$ map rgbToHsv
|
||||
$ unpackImage image
|
||||
writeFile output $ encode outputTable
|
||||
putStrLn $ "Saved to " ++ output
|
||||
|
|
|
|||
33
palette-generator/Stylix/Output.hs
Normal file
33
palette-generator/Stylix/Output.hs
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
module Stylix.Output ( makeOutputTable ) where
|
||||
|
||||
import Data.Colour ( RGB(RGB) )
|
||||
import qualified Data.Vector as V
|
||||
import Data.Word ( Word8 )
|
||||
import Text.JSON ( JSObject, toJSObject )
|
||||
import Text.Printf ( printf )
|
||||
|
||||
makeOutputs :: (String, RGB Word8) -> [(String, String)]
|
||||
makeOutputs (name, RGB r g b)
|
||||
= [ (name ++ "-dec-r", show $ fromIntegral r / 255)
|
||||
, (name ++ "-dec-g", show $ fromIntegral g / 255)
|
||||
, (name ++ "-dec-b", show $ fromIntegral b / 255)
|
||||
, (name ++ "-rgb-r", show r)
|
||||
, (name ++ "-rgb-g", show g)
|
||||
, (name ++ "-rgb-b", show b)
|
||||
, (name ++ "-hex-r", printf "%02x" r)
|
||||
, (name ++ "-hex-g", printf "%02x" g)
|
||||
, (name ++ "-hex-b", printf "%02x" b)
|
||||
, (name ++ "-hex", printf "%02x%02x%02x" r g b)
|
||||
, (name ++ "-hash", printf "#%02x%02x%02x" r g b)
|
||||
]
|
||||
|
||||
toWord8 :: (RealFrac a) => RGB a -> RGB Word8
|
||||
toWord8 (RGB r g b) = RGB (truncate r) (truncate g) (truncate b)
|
||||
|
||||
makeOutputTable :: (RealFrac a) => V.Vector (RGB a) -> JSObject String
|
||||
makeOutputTable
|
||||
= toJSObject
|
||||
. concat
|
||||
. V.map makeOutputs
|
||||
. V.imap (\i c -> (printf "base%02X" i, c))
|
||||
. V.map toWord8
|
||||
52
palette-generator/Stylix/Palette.hs
Normal file
52
palette-generator/Stylix/Palette.hs
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
|
||||
|
||||
module Stylix.Palette ( ) where
|
||||
|
||||
import Ai.Evolutionary ( Species(..) )
|
||||
import Data.Bifunctor ( second )
|
||||
import Data.Colour ( LAB(lightness), deltaE )
|
||||
import Data.Vector ( (!), (//) )
|
||||
import qualified Data.Vector as V
|
||||
import System.Random ( RandomGen, randomR )
|
||||
|
||||
primary :: V.Vector a -> V.Vector a
|
||||
primary = V.take 8
|
||||
|
||||
accent :: V.Vector a -> V.Vector a
|
||||
accent = V.drop 8
|
||||
|
||||
alternatingZip :: V.Vector a -> V.Vector a -> V.Vector a
|
||||
alternatingZip = V.izipWith (\i a b -> if even i then a else b)
|
||||
|
||||
randomFromVector :: (RandomGen r) => r -> V.Vector a -> (a, r)
|
||||
randomFromVector generator vector
|
||||
= let (index, generator') = randomR (0, V.length vector - 1) generator
|
||||
in (vector ! index, generator')
|
||||
|
||||
instance (Floating a, Real a) => Species (V.Vector (LAB a)) (V.Vector (LAB a)) where
|
||||
generate image = generateColour 16
|
||||
where generateColour 0 generator = (generator, V.empty)
|
||||
generateColour n generator
|
||||
= let (colour, generator') = randomFromVector generator image
|
||||
in second (V.cons colour) $ generateColour (n - 1) generator'
|
||||
|
||||
crossover _ generator a b = (generator, alternatingZip a b)
|
||||
|
||||
mutate image generator palette
|
||||
= let (index, generator') = randomR (0, 15) generator
|
||||
(colour, generator'') = randomFromVector generator' image
|
||||
in (generator'', palette // [(index, colour)])
|
||||
|
||||
fitness _ palette
|
||||
= realToFrac $ accentDifference - accentLightness - primaryLightness
|
||||
where accentDifference = minimum $ do
|
||||
a <- accent palette
|
||||
b <- accent palette
|
||||
return $ deltaE a b
|
||||
accentLightness
|
||||
= sum $ V.map (max 0 . (60 -) . lightness) $ accent palette
|
||||
primaryLightness
|
||||
= sum $ V.zipWith
|
||||
(\a b -> abs $ a - b)
|
||||
(V.map lightness $ primary palette)
|
||||
(V.fromList [10, 30, 45, 65, 75, 90, 95, 95])
|
||||
Loading…
Reference in a new issue