diff --git a/palette-generator/Ai/Evolutionary.hs b/palette-generator/Ai/Evolutionary.hs index f120966..d5a4742 100644 --- a/palette-generator/Ai/Evolutionary.hs +++ b/palette-generator/Ai/Evolutionary.hs @@ -6,7 +6,8 @@ import Control.Applicative ( liftA2 ) import Data.Bifunctor ( first, second ) import Data.List ( mapAccumR, sortBy ) import Data.Ord ( Down(Down, getDown), comparing ) -import System.Random ( RandomGen, randomR ) +import System.Random ( RandomGen, mkStdGen, randomR ) +import Text.Printf ( printf ) {- | Find every possible combination of two values, with the first value @@ -133,16 +134,26 @@ evolveGeneration environment config (generator, population) evolveUntilThreshold :: (RandomGen r, Species e g) => e -- ^ Environment -> EvolutionConfig + -> Int -- ^ Generation number -> Double -- ^ Fitness of previous generation -> (r, [g]) -- ^ Random generator, population from previous generation - -> (r, [g]) -- ^ New random generator, final population -evolveUntilThreshold environment config fitness = - recurse . evolveGeneration environment config - where - recurse (generator', fitness', population') = - if 1 - (fitness' / fitness) < changeThreshold config - then (generator', population') - else evolveUntilThreshold environment config fitness' (generator', population') + -> IO (r, [g]) -- ^ New random generator, final population +evolveUntilThreshold environment config generation fitness (generator, population) = + do + let generation' = generation + 1 + (generator', fitness', population') = + evolveGeneration environment config (generator, population) + change = 1 - (fitness' / fitness) + + if generation == 0 + then printf "Generation: %3i Fitness: %7.1f\n" + generation' fitness' + else printf "Generation: %3i Fitness: %7.1f Improvement: %5.1f%%\n" + generation' fitness' (change * 100) + + if change < changeThreshold config + then return (generator', population') + else evolveUntilThreshold environment config generation' fitness' (generator', population') {- | Create the initial population, to be fed into the first @@ -157,12 +168,14 @@ initialGeneration environment config = unfoldWithGen (generate environment) (survivors config) -- | Run the full genetic algorithm. -evolve :: (RandomGen r, Species e g) +evolve :: Species e g => e -- ^ Environment -> EvolutionConfig - -> r -- ^ Random generator - -> (r, g) -- ^ New random generator, optimal genotype -evolve environment config generator - = second head - $ evolveUntilThreshold environment config 0 - $ initialGeneration environment config generator + -> IO g -- ^ Optimal genotype +evolve environment config = do + (_, population) <- + evolveUntilThreshold environment config 0 0 + $ initialGeneration environment config + $ mkStdGen 0 -- Fixed seed for determinism + + return $ head population diff --git a/palette-generator/Stylix/Main.hs b/palette-generator/Stylix/Main.hs index a66847d..40dfb85 100644 --- a/palette-generator/Stylix/Main.hs +++ b/palette-generator/Stylix/Main.hs @@ -6,16 +6,15 @@ import Stylix.Output ( makeOutputTable ) import Stylix.Palette ( ) import System.Environment ( getArgs ) import System.Exit ( die ) -import System.Random ( mkStdGen ) import Text.JSON ( encode ) -- | Run the genetic algorithm to generate a palette from the given image. selectColours :: (Floating a, Real a) => String -- ^ Scheme type: "either", "light" or "dark" -> V.Vector (LAB a) -- ^ Colours of the source image - -> V.Vector (LAB a) -- ^ Generated palette + -> IO (V.Vector (LAB a)) -- ^ Generated palette selectColours polarity image - = snd $ evolve (polarity, image) (EvolutionConfig 1000 100 0.5 0.01) (mkStdGen 0) + = evolve (polarity, image) (EvolutionConfig 1000 100 0.5 0.01) -- | Convert a 'DynamicImage' to a simple 'V.Vector' of colours. unpackImage :: (Num a) => DynamicImage -> V.Vector (RGB a) @@ -35,11 +34,11 @@ mainProcess :: (String, String, String) -> IO () mainProcess (polarity, input, output) = do putStrLn $ "Processing " ++ input image <- loadImage input - let outputTable = makeOutputTable - $ V.map lab2rgb - $ selectColours polarity - $ V.map rgb2lab - $ unpackImage image + + let labImage = V.map rgb2lab $ unpackImage image + palette <- selectColours polarity labImage + let outputTable = makeOutputTable $ V.map lab2rgb palette + writeFile output $ encode outputTable putStrLn $ "Saved to " ++ output