From b002d571a364b79eb1226b79d2c92055206eff5c Mon Sep 17 00:00:00 2001 From: Rowan Torbitzky-Lane Date: Tue, 4 Mar 2025 14:17:07 -0600 Subject: [PATCH] more variation done --- src/HushGP/GP.hs | 2 +- src/HushGP/GP/Individual.hs | 5 ++ src/HushGP/GP/PushArgs.hs | 19 +++-- src/HushGP/GP/Variation.hs | 99 ++++++++++++++++++++++-- src/HushGP/Genome.hs | 15 +++- src/HushGP/Problems/IntegerRegression.hs | 14 ++-- src/HushGP/Utility.hs | 6 +- 7 files changed, 134 insertions(+), 26 deletions(-) diff --git a/src/HushGP/GP.hs b/src/HushGP/GP.hs index 2845699..58c42a4 100644 --- a/src/HushGP/GP.hs +++ b/src/HushGP/GP.hs @@ -68,7 +68,7 @@ gpLoop' do print $ "Successful generation: " <> show generation print $ "Successful plushy: " <> show (plushy bestInd) - print $ "Successful program: " <> show (plushyToPush $ plushy bestInd) + print $ "Successful program: " <> show (plushyToPush pushArgs (plushy bestInd)) when (useSimplification epsilonPushArgs) $ do let simplifiedPlushy = undefined -- TODO: simplification later diff --git a/src/HushGP/GP/Individual.hs b/src/HushGP/GP/Individual.hs index 8ba2c5e..3d78d7c 100644 --- a/src/HushGP/GP/Individual.hs +++ b/src/HushGP/GP/Individual.hs @@ -15,6 +15,11 @@ data Individual = Individual instance Ord Individual where ind0 <= ind1 = totalFitness ind0 <= totalFitness ind1 +-- |Creates a new individual with all fields set to Nothing besides plushy which gets set to the +-- passed [Gene]. +postVariationInd :: [Gene] -> Individual +postVariationInd newPlushy = Individual{plushy = newPlushy, totalFitness = Nothing, fitnessCases = Nothing, selectionCases = Nothing} + -- | Extracts the fitnessCases from an Individual. Errors if the field is empty. -- Known as :errors in propeller. extractFitnessCases :: Individual -> [Double] diff --git a/src/HushGP/GP/PushArgs.hs b/src/HushGP/GP/PushArgs.hs index 1312207..7c0998a 100644 --- a/src/HushGP/GP/PushArgs.hs +++ b/src/HushGP/GP/PushArgs.hs @@ -12,7 +12,7 @@ data PushArgs = PushArgs -- | For alternation, std deviation for index when alternating. alignmentDeviation :: Double, -- | For alternation, probability of switching parents at each location. Should be a value in the range [1,100] - alternationRate :: Int, + alternationRate :: Double, -- | For bmx, rate genes are exchanged. bmxExchangeRate :: Float, -- | For bmx, max length of a gene. @@ -29,6 +29,8 @@ data PushArgs = PushArgs ssxNotBmx :: Bool, -- | Ways to construct a phenotype from a plushy genome, so far only "specified" is implemented. Unused (for now). closes :: String, + -- | Whether or not to use best match crossover + useBMX :: Bool, -- | Custom report for each generation if provided. customReport :: Maybe (PushArgs -> IO ()), -- | If True, keeps running regardless of success. @@ -65,8 +67,8 @@ data PushArgs = PushArgs parentSelectionAlgo :: String, -- |Size of the population in the evolutionary run. populationSize :: Int, - -- | For uniform replacement, rate of item replacement. - replacementRate :: Float, + -- | For uniform replacement, rate of item replacement. A number in the bounds of [1,100]. + replacementRate :: Double, -- | Whether or not to auto simplify solutions. useSimplification :: Bool, -- | When auto simplifying, max amt items deleted in a single step. @@ -87,11 +89,11 @@ data PushArgs = PushArgs trainingData :: [PushData], -- | Testing data for the gp, must be provided if there is any. testingData :: [PushData], - -- | Addition rate for UMAD (deletion rate derived from this). - umadRate :: Float, + -- | Addition rate for UMAD (deletion rate derived from this). Should be an Int [0-100]. + umadRate :: Double, -- | Genetic operators and probabilities for their use, should sum to one -- Takes a Map of String -> Float where the string is the genetic operator - variation :: Map.Map String Float, + variation :: [(String,Double)], -- | The epsilons calculated for epsilon lexicase selection. Only used for epsilon lexicase selection. epsilons :: Maybe [Double], -- | Used with the CaseMaxminAuto downsampling strategy. Tells downsampling to stop when @@ -108,7 +110,7 @@ data PushArgs = PushArgs defaultPushArgs :: PushArgs defaultPushArgs = PushArgs { alignmentDeviation = 2.0, - alternationRate = 10, + alternationRate = 0.1, bmxExchangeRate = 0.5, bmxGeneLengthLimit = 10, bmxGapChangeProbability = 0.001, @@ -116,6 +118,7 @@ defaultPushArgs = PushArgs { bmxMaxDistance = 1000000, bmxSameGeneCount = False, closes = "specified", + useBMX = False, customReport = Nothing, dontEnd = False, enableDownsampling = True, @@ -145,7 +148,7 @@ defaultPushArgs = PushArgs { testingData = error "Must supply the testingData yourself", trainingData = error "Must supply the trainingData yourself", umadRate = 0.1, - variation = Map.fromList [("umad", 1.0)], + variation = [("umad", 1.0)], epsilons = Nothing, caseDelta = 0, initialCases = Nothing diff --git a/src/HushGP/GP/Variation.hs b/src/HushGP/GP/Variation.hs index 5fa7f42..8aeba67 100644 --- a/src/HushGP/GP/Variation.hs +++ b/src/HushGP/GP/Variation.hs @@ -1,16 +1,19 @@ module HushGP.GP.Variation where +import Data.List import Control.Monad import HushGP.State import HushGP.GP.PushArgs import HushGP.GP.Individual import HushGP.Utility +import HushGP.Genome +import HushGP.GP.Selection -- |Performs a uniform crossover on two parents and returns the child. -- Padding is placed to left of the shorter genome. crossover :: [Gene] -> [Gene] -> IO [Gene] crossover plushyA plushyB = do - filter (CrossoverPadding /=) <$> zipWithM (\short long -> randOneToOneHundred >>= (\num -> if num < 50 then pure short else pure long)) shorterPadded longer + filter (CrossoverPadding /=) <$> zipWithM (\short long -> randZeroToOne >>= (\num -> if num < 0.5 then pure short else pure long)) shorterPadded longer where shorter :: [Gene] shorter = if length plushyA <= length plushyB then plushyA else plushyB @@ -37,7 +40,7 @@ alternation pushArgs plushyA plushyB = do -- This returns the first [Gene] when the loop is complete. alternation' :: PushArgs -> Int -> Bool -> [Gene] -> Int -> [Gene] -> [Gene] -> IO [Gene] alternation' pushArgs@PushArgs{alternationRate = altRate, alignmentDeviation = alignDeviation} n usePlushyA !resultPlushy iterationBudget plushyA plushyB = do - randNum <- randOneToOneHundred + randNum <- randZeroToOne let nextAction | n >= length (if usePlushyA then plushyA else plushyB) || iterationBudget <= 0 = pure resultPlushy | randNum < altRate = do @@ -50,7 +53,7 @@ alternation' pushArgs@PushArgs{alternationRate = altRate, alignmentDeviation = a -- Padding is placed to left of the shorter genome. tailAlignedCrossover :: [Gene] -> [Gene] -> IO [Gene] tailAlignedCrossover plushyA plushyB = do - filter (CrossoverPadding /=) <$> zipWithM (\short long -> randOneToOneHundred >>= (\num -> if num < 50 then pure short else pure long)) shorterPadded longer + filter (CrossoverPadding /=) <$> zipWithM (\short long -> randZeroToOne >>= (\num -> if num < 0.5 then pure short else pure long)) shorterPadded longer where shorter :: [Gene] shorter = if length plushyA <= length plushyB then plushyA else plushyB @@ -64,8 +67,90 @@ tailAlignedCrossover plushyA plushyB = do -- |Takes the PushArgs for the evolutionary run and a singular plushy. -- Returns the added onto plushy. Returns the the passed plushy with -- new instructions possibly added before or after each existing instruction. -uniformAddition :: PushArgs -> [Gene] -> [Gene] -uniformAddition pushArgs plushy = undefined +uniformAddition :: PushArgs -> [Gene] -> IO [Gene] +uniformAddition pushArgs plushy = uniformAddition' pushArgs plushy [] + +-- |Guts of uniform addition. Appends to the second [Gene] recursively until the first [Gene] +-- is empty. Ignores Gaps used for bmx if applicable. +uniformAddition' :: PushArgs -> [Gene] -> [Gene] -> IO [Gene] +uniformAddition' _ [] newPlushy = pure newPlushy +uniformAddition' pushArgs@PushArgs{instructionList = iList, umadRate = uRate} (old:oldList) !newList = do + frontInstruction <- randomInstruction iList + backInstruction <- randomInstruction iList + frontZeroToOne <- randZeroToOne + backZeroToOne <- randZeroToOne + uniformAddition' pushArgs oldList (newList <> [frontInstruction | frontZeroToOne < uRate && not (isGap old)] <> [old] <> [backInstruction | backZeroToOne < uRate && not (isGap old)]) + +-- |Takes the PushArgs for the evolutionary run and a singular plushy. +-- Returns the replacement plushy. Returns the the passed plushy with +-- new instructions possibly replacing each existing instruction. +uniformReplacement :: PushArgs -> [Gene] -> IO [Gene] +uniformReplacement pushArgs plushy = uniformAddition' pushArgs plushy [] + +-- |Guts of uniform replacement. Appends to the second [Gene] recursively until the first [Gene] +-- is empty. +uniformReplacement' :: PushArgs -> [Gene] -> [Gene] -> IO [Gene] +uniformReplacement' _ [] newPlushy = pure newPlushy +uniformReplacement' pushArgs@PushArgs{instructionList = iList, replacementRate = rRate} (old:oldList) !newList = do + randInstruction <- randomInstruction iList + randDecimal <- randZeroToOne + uniformReplacement' pushArgs oldList (newList <> if randDecimal < rRate then [randInstruction] else [old]) + +-- |Takes the PushArgs for the evolutionary run and a singular plushy. +-- Returns the deleted plushy. Returns the passed plushy with +-- instructions that were there possibly deleted. Ignores Gaps used for bmx if applicable. +uniformDeletion :: PushArgs -> [Gene] -> IO [Gene] +uniformDeletion PushArgs{umadRate = uRate} plushy = + if uRate == 0 + then pure plushy + else uniformDeletion' plushy [] adjustedRate + where + adjustedRate :: Double + adjustedRate = 1 / (1 + (1 / uRate)) + +-- |Internals for uniform deletion. The Double is the adjusted rate +-- calculated based on the original umad rate. +uniformDeletion' :: [Gene] -> [Gene] -> Double -> IO [Gene] +uniformDeletion' [] newPlushy _ = pure newPlushy +uniformDeletion' (old:oldList) !newList adjustRate = do + randDecimal <- randZeroToOne + uniformDeletion' oldList (newList <> [old | randDecimal < adjustRate]) adjustRate + +-- |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 + randOp <- randomOperation var 0.0 + case randOp of + "reproduction" -> selectParent pushArgs population + "crossover" -> do + parent0 <- selectParent pushArgs population + parent1 <- selectParent pushArgs population + childPlushy <- crossover (plushy parent0) (plushy parent1) + pure $ postVariationInd childPlushy + "tailAlignedCrossover" -> do + parent0 <- selectParent pushArgs population + parent1 <- selectParent pushArgs population + childPlushy <- tailAlignedCrossover (plushy parent0) (plushy parent1) + pure $ postVariationInd childPlushy + "umad" -> do + parent <- selectParent pushArgs population + child <- uniformAddition pushArgs (plushy parent) >>= uniformDeletion pushArgs + pure $ postVariationInd child + "rumad" -> undefined -- TODO: this tomorrow! + _ -> error ("Error: No match for selection operation: " <> randOp) + where + randDecimal :: IO Double + randDecimal = randZeroToOne + randomOperation :: [(String, Double)] -> Double -> IO String + randomOperation operations acc = do + randD <- randDecimal + let nextAction + | null operations = pure "reproduction" + | acc + tempProb >= randD = pure tempOp + | otherwise = randomOperation (drop 1 operations) (tempProb + acc) + nextAction + where + (tempOp,tempProb) = case uncons operations of Just (x, _) -> x; _ -> error "Error: operations cannot be empty!" + -newIndividual :: PushArgs -> [Individual] -> Individual -newIndividual = error "Implement this later" diff --git a/src/HushGP/Genome.hs b/src/HushGP/Genome.hs index 5ab05c4..3c212c4 100644 --- a/src/HushGP/Genome.hs +++ b/src/HushGP/Genome.hs @@ -43,6 +43,11 @@ isOpenerList [instruction] = _ -> False isOpenerList _ = False +-- | Checks if the Gene is a Gap, returns True if it is. +isGap :: Gene -> Bool +isGap Gap = True +isGap _ = False + -- | Gets the amount of blocks to open from a list of genes with a single element. getOpenAmountList :: [Gene] -> Int getOpenAmountList [instruction] = @@ -52,8 +57,14 @@ getOpenAmountList [instruction] = getOpenAmountList _ = 0 -- | Converts a plushy genome into a push genome. -plushyToPush :: [Gene] -> [Gene] -plushyToPush plushy = plushyToPush' (concatMap (\x -> if isOpenerList x then x <> [Open (getOpenAmountList x)] else x) (chunksOf 1 plushy)) [] +plushyToPush :: PushArgs -> [Gene] -> [Gene] +plushyToPush PushArgs {useBMX = bmx} plushy = plushyToPush' modPlushy [] + where + modPlushy :: [Gene] + modPlushy = + if bmx + then concatMap (filter (not . isGap) . (\x -> if isOpenerList x then x <> [Open (getOpenAmountList x)] else x)) (chunksOf 1 plushy) + else concatMap (\x -> if isOpenerList x then x <> [Open (getOpenAmountList x)] else x) (chunksOf 1 plushy) -- | Internal function used to convert a plushy genome with opens in it into its push phenotype. plushyToPush' :: [Gene] -> [Gene] -> [Gene] diff --git a/src/HushGP/Problems/IntegerRegression.hs b/src/HushGP/Problems/IntegerRegression.hs index 9090a69..b34cdde 100644 --- a/src/HushGP/Problems/IntegerRegression.hs +++ b/src/HushGP/Problems/IntegerRegression.hs @@ -62,16 +62,16 @@ errorHead xs = _ -> 100000000 -- Make this a variable for later? -- | Loads a plushy and a list of genes into the input state. -loadState :: [Gene] -> [Gene] -> State -loadState plushy vals = - (loadProgram (plushyToPush plushy) emptyState){_input = Map.fromList (zip [0..] vals)} +loadState :: PushArgs -> [Gene] -> [Gene] -> State +loadState pushArgs plushy vals = + (loadProgram (plushyToPush pushArgs plushy) emptyState){_input = Map.fromList (zip [0..] vals)} -- | The error function for a single set of inputs and outputs. intErrorFunction :: PushArgs -> [PushData] -> [Gene] -> [Double] -intErrorFunction _args pushData plushy = +intErrorFunction pushArgs pushData plushy = map abs $ zipWith (-) - (map ((fromIntegral @Integer @Double . (errorHead . _int) . interpretExec) . loadState plushy) + (map ((fromIntegral @Integer @Double . (errorHead . _int) . interpretExec) . loadState pushArgs plushy) (extractField inputData pushData)) (map (fromIntegral @Integer @Double . extractGeneInt) (extractField outputData pushData)) intPushArgs :: PushArgs @@ -87,8 +87,8 @@ intPushArgs = defaultPushArgs stepLimit = 200, parentSelectionAlgo = "lexicase", tournamentSize = 5, - umadRate = 0.1, - variation = Map.fromList [("umad", 1.0), ("crossover", 0.0)], + umadRate = 0.6, + variation = [("umad", 1.0), ("crossover", 0.0)], elitism = False, enableDownsampling = False, downsampleRate = 0.5 diff --git a/src/HushGP/Utility.hs b/src/HushGP/Utility.hs index 880967b..6a4aba0 100644 --- a/src/HushGP/Utility.hs +++ b/src/HushGP/Utility.hs @@ -41,6 +41,10 @@ gaussianNoiseFactor = do randDecimal1 <- fst . uniformR (0.0 :: Double, 1.0 :: Double) <$> initStdGen pure (sqrt ((-2.0) * log randDecimal0) * cos (2.0 * pi * randDecimal1)) --- | A random number between 1 and 100. +-- | A random Int between 1 and 100 inclusive. randOneToOneHundred :: IO Int randOneToOneHundred = fst . uniformR (1 :: Int, 100 :: Int) <$> initStdGen + +-- | A random Double between 0.1 and 1.0 inclusive. +randZeroToOne :: IO Double +randZeroToOne = fst . uniformR (0.1 :: Double, 1.0 :: Double) <$> initStdGen