HSGEP-0.1.0: GEP/TimeStep.hs
-- |
-- Code representing a single step of the GEP algorithm resides here.
--
-- single step of fitness evaluation, selection and reproduction to make
-- a new population
--
-- process includes:
--
-- (1) expression of individuals
--
-- (2) fitness evaluation
--
-- (3) filtration to eliminate individuals yielding impossible
-- fitness values (infinite or NaN)
--
-- (4) preservation of best individual
--
-- (5) generation of roulette selection weights
--
-- (6) roulette selection of individuals
--
-- (7) perform mutation operator
--
-- (8) IS transposition
--
-- (9) RIS transposition
--
-- (10) Gene transposition
--
-- (11) 1Pt recombination
--
-- (12) 2Pt recombination
--
-- (13) Gene recombination
--
-- Author: mjsottile\@computer.org
--
module GEP.TimeStep (
multiStep
) where
import GEP.Rmonad
import GEP.MonadicGeneOperations
import GEP.Random
import GEP.Selection
import GEP.Fitness
import GEP.Types
import GEP.Params
import Debug.Trace
import List (sort)
-- | debugging version of (!!) thanks to #haskell help. by default we let
-- (!!!) simply alias (!!), but when we need to we can swap in a new
-- implementation of (!!) to trace for debugging reasons.
(!!!) :: [a] -> Int -> String -> a
-- debugging version
-- (!!!) x y s = trace (s++": "++(show y)++"//"++(show (length x))) (x !! y)
-- production version : just alias (!!)
(!!!) x y _ = (x !! y)
--
-- helper for type conversion
--
intToDouble :: Int -> Double
intToDouble n = fromInteger (toInteger n)
{-|
Reassemble a population. We are given a full population, the set
of individuals that are to be replaced and their indices. The output
of this function is the new population where the unmodified individuals
are carried forward and those that were modified are replaced with their
new versions.
-}
putTogether :: [Int] -- ^ Indices of individuals to replace
-> [Individual] -- ^ Replacement individuals
-> [Individual] -- ^ Original population
-> [Individual] -- ^ New population
putTogether indices replacements original =
let innerPutTogether cur _ [] [] qs = drop (cur-1) qs
innerPutTogether cur _ [] _ qs = drop (cur-1) qs
innerPutTogether cur _ _ [] qs = drop (cur-1) qs
innerPutTogether cur mx (l:ls) (p:ps) qs =
if (cur > mx)
then
[]
else
if (l==cur)
then
(p:(innerPutTogether (cur+1) mx ls ps qs))
else
(((!!!) qs (cur-1) "putTogether"):
(innerPutTogether (cur+1) mx (l:ls) (p:ps) qs))
in
innerPutTogether 1 (length original) indices replacements original
fillFilterGap :: Genome ->
Int ->
[(Double,Individual)] ->
GEPMonad [(Double,Individual)]
fillFilterGap genome popsize pop =
if (popsize-(length pop)) > 0
then do newIndividuals <- newPopulation genome (popsize-(length pop))
newPop <- return $ map (\i -> (0.0,i)) newIndividuals
return $! pop++newPop
else return $! pop
{-|
Single step of GEP algorithm
-}
singleStep :: [Individual] -- ^ List of individuals
-> Genome -- ^ Genome
-> SimParams -- ^ Simulation parameters
-> Rates -- ^ Gene operator rates
-> (Individual -> Genome -> a) -- ^ Expression function
-> (a -> b -> Double -> Double -> Double) -- ^ Fitness function
-> [b] -- ^ Fitness inputs
-> [Double] -- ^ Fitness outputs
-> GEPMonad (Double,[Individual])
singleStep pop g params r express_individual fitness_evaluate
testInputs testOutputs =
do indices <- roulette weights nSelect
filtered <- fillFilterGap g nSelect initialFiltering
-- selection
selected <- return $ map (\(_,b) -> b) (selector indices filtered)
-- mutation
mutated <- mapM (mutate g r) selected
-- IS transposition
isTransposePop <- nextRListUnique pISCount [] nSelect
isPopIn <- return $ map (\i -> (!!!) mutated (i-1) "isPopIn")
isTransposePop
isPopOut <- mapM (isTransposer g params) isPopIn
isPop <- return $ putTogether (sort isTransposePop) isPopOut mutated
-- RIS transposition
risTransposePop <- nextRListUnique pRISCount [] nSelect
risPopIn <- return $ map (\i -> (!!!) isPop (i-1) "risPopIn")
risTransposePop
risPopOut <- mapM (risTransposer g params) risPopIn
risPop <- return $ putTogether (sort risTransposePop) risPopOut isPop
-- Gene transposition
geneTransposePop <- nextRListUnique pGTCount [] nSelect
genePopIn <- return $ map (\i -> (!!!) risPop (i-1) "genePopIn")
geneTransposePop
genePopOut <- mapM (geneTransposer g) genePopIn
genePop <- return $ putTogether (sort geneTransposePop) genePopOut risPop
-- 1Pt crossover
x1ptPopPairs <- generatePairs nSelect
x1ptPopSomePairs <- return $ take p1PCount x1ptPopPairs
x1UnpairPop <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] x1ptPopSomePairs
x1ptPopIn <- return $ map (\(a,b) -> ((!!!) genePop (a-1) "x1A",
(!!!) genePop (b-1) "x1B"))
x1ptPopSomePairs
x1ptPopOut <- mapM (x1PHelper g) x1ptPopIn
x1ptPopOutFlat <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] x1ptPopOut
x1ptPop <- return $ putTogether (sort x1UnpairPop) x1ptPopOutFlat genePop
-- 2Pt crossover
x2ptPopPairs <- generatePairs nSelect
x2ptPopSome <- return $ take p2PCount x2ptPopPairs
x2UnpairPop <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] x2ptPopSome
x2ptPopIn <- return $ map (\(a,b) -> ((!!!) x1ptPop (a-1) "x2A",
(!!!) x1ptPop (b-1) "x2B"))
x2ptPopSome
x2ptPopOut <- mapM (x2PHelper g) x2ptPopIn
x2ptPopOutFlat <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] x2ptPopOut
x2ptPop <- return $ putTogether (sort x2UnpairPop) x2ptPopOutFlat x1ptPop
-- Gene crossover
xGPopPairs <- generatePairs nSelect
xGPopSome <- return $ take pGRCount xGPopPairs
xGUnpairPop <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] xGPopSome
xGPopIn <- return $ map (\(a,b) -> ((!!!) x2ptPop (a-1) "xGA",
(!!!) x2ptPop (b-1) "xGB"))
xGPopSome
xGPopOut <- mapM (xGHelper g) xGPopIn
xGPopOutFlat <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] xGPopOut
xGPop <- return $ putTogether (sort xGUnpairPop) xGPopOutFlat x2ptPop
-- return $ (trace (bestIndividual++" => "++(show bestFitness)++" AVG="++(show avgFitness)) (bestFitness,[bestIndividual]++x2ptPop))
return $ (trace ((show bestFitness)++" "++(show avgFitness)) (bestFitness,[bestIndividual]++xGPop))
where
nPop = length pop
nSelect = nPop - 1
fnSelect = intToDouble nSelect
pISCount = floor (fnSelect * (pIS r))
pRISCount = floor (fnSelect * (pRIS r))
pGTCount = floor (fnSelect * (pGT r))
p1PCount = floor (fnSelect * (p1R r))
p2PCount = floor (fnSelect * (p2R r))
pGRCount = floor (fnSelect * (pGR r))
expressedPop = map (\i -> express_individual i g) pop
fitnesses = map (\i -> fitness_tester
i (fitness_evaluate)
testInputs testOutputs
(selectionRange params))
expressedPop
initialFiltering = fitness_filter fitnesses pop
avgFitness = foldr (\(x,_) ->
\a -> a +
(x /
(intToDouble (length initialFiltering))))
0.0 initialFiltering
best = getBest initialFiltering
Just (bestFitness,bestIndividual) = best
weights = generate_roulette_weights
(intToDouble (length initialFiltering))
(rouletteExponent params)
multiStep :: [Individual] -- ^ List of individuals
-> Genome -- ^ Genome
-> SimParams -- ^ Simulation parameters
-> Rates -- ^ Gene operator rates
-> (Individual -> Genome -> a) -- ^ Expression function
-> (a -> b -> Double -> Double -> Double) -- ^ Fitness function
-> [b] -- ^ Fitness inputs
-> [Double] -- ^ Fitness outputs
-> Int -- ^ Maximum number of generations to test
-> Double -- ^ Ideal fitness
-> GEPMonad (Double,[Individual])
multiStep pop g params r expresser fitnesser tests outs 0 _ =
do (bf,newp) <- singleStep pop g params r expresser fitnesser tests outs
return (bf,newp)
multiStep pop g params r expresser fitnesser tests outs i maxfitness =
do (bf,newp) <- singleStep pop g params r expresser fitnesser tests outs
(if (bf == maxfitness)
then return $ (bf,newp)
else do (bf',newp') <- multiStep newp g params r expresser fitnesser tests outs (i-1) maxfitness
return $ (bf',newp'))