module AI.MEP.Operators (
Config (..)
, defaultConfig
, LossFunction
, initialize
, evaluateGeneration
, evolve
, phenotype
, binaryTournament
, crossover
, mutation3
, smoothMutation
, newChromosome
) where
import Data.Vector ( Vector )
import qualified Data.Vector as V
import Data.List
( nub
, sortBy
)
import Data.Ord ( comparing )
import qualified Control.Monad as CM
import AI.MEP.Random
import AI.MEP.Types
import AI.MEP.Run ( evaluate )
data Config a = Config
{
p'const :: Double
, p'var :: Double
, p'mutation :: Double
, p'crossover :: Double
, c'length :: Int
, c'popSize :: Int
, c'popN :: Int
, c'ops :: Vector (F a)
, c'vars :: Int
}
defaultConfig :: Config Double
defaultConfig = Config
{
p'const = 0.1
, p'var = 0.4
, p'mutation = 0.1
, p'crossover = 0.9
, c'length = 50
, c'popSize = 100
, c'popN = 1
, c'ops = V.empty
, c'vars = 1
}
type LossFunction a =
((V.Vector a -> V.Vector a) -> (V.Vector Int, Double))
phenotype
:: Num a =>
LossFunction a
-> Chromosome a
-> Phenotype a
phenotype loss chr = let (is, val) = loss (evaluate chr)
in (val, chr, is)
initialize :: Config Double -> Rand (Population Double)
initialize c@Config { c'popSize = size } = mapM (\_ -> newChromosome c) [1..size]
evaluateGeneration
:: Num a =>
LossFunction a
-> [Chromosome a]
-> [Phenotype a]
evaluateGeneration loss = map (phenotype loss)
evolve
::
Config Double
-> LossFunction Double
-> (Chromosome Double -> Rand (Chromosome Double))
-> (Chromosome Double -> Chromosome Double -> Rand (Chromosome Double, Chromosome Double))
-> ([Phenotype Double] -> Rand (Chromosome Double))
-> [Phenotype Double]
-> Rand [Phenotype Double]
evolve c loss mut cross select phenotypes = do
let pc = p'crossover c
pm = p'mutation c
sort' = sortBy (comparing (\(val, _, _) -> negate val))
ev phen0 _ = do
chr1 <- select phen0
chr2 <- select phen0
(of1, of2) <- withProbability pc (uncurry cross) (chr1, chr2)
of1' <- withProbability pm mut of1
of2' <- withProbability pm mut of2
let r1@(val1, _, _) = phenotype loss of1'
r2@(val2, _, _) = phenotype loss of2'
(worstVal, _, _) = head phen0
phen' | val1 < worstVal = r1 : tail phen0
| val2 < worstVal = r2 : tail phen0
| otherwise = phen0
let phen1 = sort' phen'
return phen1
CM.foldM ev (sort' phenotypes) [1..c'popSize c `div` 2]
binaryTournament :: Ord a => [Phenotype a] -> Rand (Chromosome a)
binaryTournament phen = do
(val1, cand1, _) <- draw $ V.fromList phen
(val2, cand2, _) <- draw $ V.fromList phen
if val1 < val2
then return cand1
else return cand2
crossover ::
Chromosome a
-> Chromosome a
-> Rand (Chromosome a, Chromosome a)
crossover ca cb = do
r <- V.zipWithM (curry (swap 0.5)) ca cb
return $ V.unzip r
swap :: Double -> (t, t) -> Rand (t, t)
swap p = withProbability p (\(a, b) -> return (b, a))
replaceAt :: Int -> a -> Vector a -> Vector a
replaceAt i gene chr0 =
let (c1, c2) = V.splitAt i chr0
in c1 V.++ V.singleton gene V.++ V.tail c2
mutation3 ::
Config Double
-> Chromosome Double
-> Rand (Chromosome Double)
mutation3 c chr = do
is <- nub <$> CM.replicateM k (getMaxInt (chrLen - 1))
genes <- mapM new' is
let chr' = foldr (uncurry replaceAt)
chr
(zip is genes)
return chr'
where chrLen = V.length chr
k = 3
new' = new (p'const c) (p'var c) (c'vars c) (c'ops c)
smoothMutation
::
Double
-> Config Double
-> Chromosome Double
-> Rand (Chromosome Double)
smoothMutation p c chr =
let new' = new (p'const c) (p'var c) (c'vars c) (c'ops c)
mutate i = withProbability p (\_ -> new' i)
in V.zipWithM mutate (V.enumFromN 0 (V.length chr)) chr
newChromosome ::
Config Double
-> Rand (Chromosome Double)
newChromosome c = do
let pConst = p'const c
pVar = p'var c
V.mapM (new pConst pVar (c'vars c) (c'ops c)) $ V.enumFromN 0 (c'length c)
new ::
Double
-> Double
-> Int
-> Vector (F Double)
-> Int
-> Rand (Gene Double Int)
new p1 p2 vars ops maxIndex = if maxIndex == 0
then let p1' = 0.5 * (1 + p1 - p2)
in newTerminal p1' vars
else do
p' <- getDouble
let sel | p' < p1 = newC
| p' < (p1 + p2) = newVar vars
| otherwise = newOp ops maxIndex
sel
newTerminal ::
Double
-> Int
-> Rand (Gene Double i)
newTerminal p vars = do
p' <- getDouble
if p' < p
then newC
else newVar vars
newVar :: Int -> Rand (Gene a i)
newVar vars = do
var <- draw $ V.enumFromN 0 vars
return $ Var var
newOp
:: Vector (F a)
-> Int
-> Rand (Gene a Int)
newOp ops maxIndex = do
op <- draw ops
i1 <- getMaxInt maxIndex
i2 <- getMaxInt maxIndex
return $ Op op i1 i2
newCNormal
:: Double
-> Double
-> Rand (Gene Double i)
newCNormal mu sigma = do
n <- getNormal
return $ C (mu + sigma*n)
newC :: Rand (Gene Double i)
newC = C <$> getDouble