module GA (Config (..),
PopulationConfig (..),
ChromosomeConfig (..),
defaultConfig,
GAState,
bestChromosome,
gaRand,
run,
rouletteM,
mutateM,
crossM,
tournamentM,
isDone)
where
import Maybe
import Random
import Control.Monad.State.Strict
type GAState c p = State (Config c p)
data Config c p = Config {
cConfig :: ChromosomeConfig c p,
pConfig :: PopulationConfig c p,
newPopulation :: p -> (GAState c p) p,
maxFitness :: Maybe Double,
maxGeneration :: Maybe Int,
currentGeneration :: Int,
gen :: StdGen
}
data ChromosomeConfig c p = ChromosomeConfig {
fitness :: c -> Double,
mutate :: c -> (GAState c p) c,
cross :: c -> c -> (GAState c p) (c,c)
}
data PopulationConfig c p = PopulationConfig {
bestChromosomePop :: p -> (GAState c p) c,
roulettePop :: p -> (GAState c p) p,
tournamentPop :: p -> (GAState c p) p,
applyCrossoverPop :: p -> (GAState c p) p,
applyMutationPop :: p -> (GAState c p) p
}
defaultConfig :: Config c p
defaultConfig = Config {
cConfig = undefined,
pConfig = undefined,
newPopulation = undefined,
maxFitness = Nothing,
maxGeneration = Nothing,
currentGeneration = 0,
gen = undefined
}
bestChromosome :: p -> (GAState c p) c
bestChromosome pop = do
config <- get
bestChromosomePop (pConfig config) pop
highestFitness :: p -> (GAState c p) Double
highestFitness pop = do
fitFunc <- (fitness . cConfig) `liftM` get
best <- bestChromosome pop
return $ fitFunc best
rouletteM :: p -> (GAState c p) p
rouletteM pop =
(roulettePop . pConfig) `liftM` get >>= ($pop)
tournamentM :: p -> (GAState c p) p
tournamentM pop =
(tournamentPop . pConfig) `liftM` get >>= ($pop)
mutateM :: p -> (GAState c p) p
mutateM pop = do
(applyMutationPop . pConfig) `liftM` get >>= ($pop)
crossM :: p -> (GAState c p) p
crossM pop =
(applyCrossoverPop . pConfig) `liftM` get >>= ($pop)
newPopulationM :: p -> (GAState c p) p
newPopulationM pop =
incGA >> newPopulation `liftM` get >>= ($pop)
incGA :: (GAState c p) ()
incGA = modify (\c@Config { currentGeneration = g} ->
c { currentGeneration = g + 1})
untilM :: (Monad m) => (a -> m Bool) -> (a -> m a) -> a -> m a
untilM p f x = do
test <- p x
if test
then return x
else f x >>= untilM p f
run :: p -> (GAState c p) p
run = untilM isDone newPopulationM
isDone :: p -> (GAState c p) Bool
isDone population = do
c <- get
f <- highestFitness population
let generationsDone =
maybe False (<(currentGeneration c)) $ maxGeneration c
let fitnessDone =
maybe False (>f) $ maxFitness c
return $ generationsDone || fitnessDone
gaRand :: (Random a) =>
(a,a) -> (GAState c p) a
gaRand range = do
config <- get
let g = gen config
let (x, g') = randomR range g
put $ config { gen = g' }
return x