From d1d36eb3aa4ac21e1126152c3da62af18ae2ebd2 Mon Sep 17 00:00:00 2001 From: Rowan Torbitzky-Lane Date: Tue, 4 Mar 2025 16:11:37 -0600 Subject: [PATCH] variation done --- src/HushGP/GP.hs | 11 ++++++----- src/HushGP/GP/PushArgs.hs | 1 - src/HushGP/GP/Variation.hs | 37 +++++++++++++++++++++++++++++++++---- 3 files changed, 39 insertions(+), 10 deletions(-) diff --git a/src/HushGP/GP.hs b/src/HushGP/GP.hs index 58c42a4..979c489 100644 --- a/src/HushGP/GP.hs +++ b/src/HushGP/GP.hs @@ -46,7 +46,7 @@ gpLoop pushArgs@(PushArgs {trainingData = tData}) = do -- the training data (possibly downsampled). gpLoop' :: PushArgs -> Int -> Int -> [Individual] -> [PushData] -> IO () gpLoop' - pushArgs@(PushArgs {enableDownsampling = enableDS, solutionErrorThreshold = seThresh, downsampleParentsGens = dsParentGens, downsampleParentRate = dsParentRate, trainingData = tData}) + pushArgs@(PushArgs {enableDownsampling = enableDS, solutionErrorThreshold = seThresh, downsampleParentsGens = dsParentGens, downsampleParentRate = dsParentRate, trainingData = tData, elitism = isElite, populationSize = popSize}) generation evaluations population @@ -78,7 +78,8 @@ gpLoop' | (not (enableDownsampling epsilonPushArgs) && (generation >= maxGenerations epsilonPushArgs)) || (enableDownsampling epsilonPushArgs && (evaluations >= (maxGenerations epsilonPushArgs * length population * length indexedTrainingData))) = print $ "Best individual: " <> show (plushy bestInd) - | otherwise = + | otherwise = do + newPop <- if isElite then replicateM (popSize - 1) (newIndividual epsilonPushArgs evaledPop) else replicateM popSize (newIndividual epsilonPushArgs evaledPop) gpLoop' pushArgs (succ generation) @@ -87,9 +88,9 @@ gpLoop' + (if generation `mod` downsampleParentsGens pushArgs == 0 then length parentReps * (length indexedTrainingData - length (trainingData pushArgs)) else 0) + (if bestIndPassesDownsample then length indexedTrainingData - length tData else 0) ) - ( if elitism pushArgs - then bestInd : replicate (populationSize epsilonPushArgs - 1) (newIndividual epsilonPushArgs evaledPop) - else replicate (populationSize epsilonPushArgs) (newIndividual epsilonPushArgs evaledPop) + ( if isElite + then bestInd : newPop + else newPop ) ( if enableDS && ((generation `mod` dsParentGens) == 0) then updateCaseDistances repEvaluatedPop indexedTrainingData indexedTrainingData (informedDownsamplingType pushArgs) (solutionErrorThreshold pushArgs / fromIntegral @Int @Double (length indexedTrainingData)) diff --git a/src/HushGP/GP/PushArgs.hs b/src/HushGP/GP/PushArgs.hs index 7c0998a..b32c515 100644 --- a/src/HushGP/GP/PushArgs.hs +++ b/src/HushGP/GP/PushArgs.hs @@ -3,7 +3,6 @@ module HushGP.GP.PushArgs where import HushGP.State import HushGP.Instructions import HushGP.GP.PushData -import Data.Map qualified as Map -- | The structure holding the arguments for the various aspects -- of the evolutionary run in Hush. diff --git a/src/HushGP/GP/Variation.hs b/src/HushGP/GP/Variation.hs index 8aeba67..3b67ee0 100644 --- a/src/HushGP/GP/Variation.hs +++ b/src/HushGP/GP/Variation.hs @@ -2,6 +2,7 @@ module HushGP.GP.Variation where import Data.List import Control.Monad +import System.Random import HushGP.State import HushGP.GP.PushArgs import HushGP.GP.Individual @@ -119,7 +120,7 @@ uniformDeletion' (old:oldList) !newList adjustRate = do -- |Creates a new individual based on the probabilities of the desired -- crossover methods. newIndividual :: PushArgs -> [Individual] -> IO Individual -newIndividual pushArgs@PushArgs{variation = var} population = do +newIndividual pushArgs@PushArgs{variation = var, umadRate = uRate} population = do randOp <- randomOperation var 0.0 case randOp of "reproduction" -> selectParent pushArgs population @@ -135,9 +136,37 @@ newIndividual pushArgs@PushArgs{variation = var} population = do pure $ postVariationInd childPlushy "umad" -> do parent <- selectParent pushArgs population - child <- uniformAddition pushArgs (plushy parent) >>= uniformDeletion pushArgs - pure $ postVariationInd child - "rumad" -> undefined -- TODO: this tomorrow! + childPlushy <- uniformAddition pushArgs (plushy parent) >>= uniformDeletion pushArgs + pure $ postVariationInd childPlushy + "alternation" -> do + parent0 <- selectParent pushArgs population + parent1 <- selectParent pushArgs population + childPlushy <- alternation pushArgs (plushy parent0) (plushy parent1) + pure $ postVariationInd childPlushy + "rumad" -> do -- Responsive umad, deletion rate from computed amount of additions. + parent <- selectParent pushArgs population + addedChildPlushy <- uniformAddition pushArgs (plushy parent) + let effectiveAdditionRate = fromIntegral @Int @Double (length addedChildPlushy - length (plushy parent)) / fromIntegral @Int @Double (length (plushy parent)) + finalChild <- uniformDeletion pushArgs{umadRate = effectiveAdditionRate} addedChildPlushy + pure $ postVariationInd finalChild + "vumad" -> do -- variable umad, umad rate chosen randomly from [0, umadRate] + rate <- fst . uniformR (0.0 :: Double, uRate) <$> initStdGen + parent <- selectParent pushArgs population + addedChildPlushy <- uniformAddition pushArgs{umadRate = rate} (plushy parent) + deletedChildPlushy <- uniformDeletion pushArgs{umadRate = rate} addedChildPlushy + pure $ postVariationInd deletedChildPlushy + "uniformAddition" -> do + parent <- selectParent pushArgs population + childPlushy <- uniformAddition pushArgs (plushy parent) + pure $ postVariationInd childPlushy + "uniformReplacement" -> do + parent <- selectParent pushArgs population + childPlushy <- uniformReplacement pushArgs (plushy parent) + pure $ postVariationInd childPlushy + "uniformDeletion" -> do + parent <- selectParent pushArgs population + childPlushy <- uniformDeletion pushArgs (plushy parent) + pure $ postVariationInd childPlushy _ -> error ("Error: No match for selection operation: " <> randOp) where randDecimal :: IO Double