diff --git a/flake.nix b/flake.nix index 6da9c545..af16e6f0 100644 --- a/flake.nix +++ b/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"; }; diff --git a/palette-generator/Ai/Evolutionary.hs b/palette-generator/Ai/Evolutionary.hs new file mode 100644 index 00000000..f7bcd715 --- /dev/null +++ b/palette-generator/Ai/Evolutionary.hs @@ -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 diff --git a/palette-generator/Data/Colour.hs b/palette-generator/Data/Colour.hs index bd66cf85..c894802f 100644 --- a/palette-generator/Data/Colour.hs +++ b/palette-generator/Data/Colour.hs @@ -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') + } diff --git a/palette-generator/Stylix/Bucket.hs b/palette-generator/Stylix/Bucket.hs deleted file mode 100644 index 9ecda2da..00000000 --- a/palette-generator/Stylix/Bucket.hs +++ /dev/null @@ -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 diff --git a/palette-generator/Stylix/Main.hs b/palette-generator/Stylix/Main.hs index 4443b32e..f7c978db 100644 --- a/palette-generator/Stylix/Main.hs +++ b/palette-generator/Stylix/Main.hs @@ -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 diff --git a/palette-generator/Stylix/Output.hs b/palette-generator/Stylix/Output.hs new file mode 100644 index 00000000..7ac2728f --- /dev/null +++ b/palette-generator/Stylix/Output.hs @@ -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 diff --git a/palette-generator/Stylix/Palette.hs b/palette-generator/Stylix/Palette.hs new file mode 100644 index 00000000..3f01faac --- /dev/null +++ b/palette-generator/Stylix/Palette.hs @@ -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])