more variation done

TODO.md

@@ -43,3 +43,4 @@
   - [ ] Find a way to multi-thread this
 - [ ] Look at using `uniformShuffleList` over System.Random.Shuffle
 - [ ] Impelment selectionCases for lexicase and tournament selection.
+- [X] Make all randomness a float and not an int in Variation

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

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]

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.
+    -- | For uniform replacement, rate of item replacement. A number in the bounds of [1,100].
-    replacementRate :: Float,
+    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).
+    -- | Addition rate for UMAD (deletion rate derived from this). Should be an Int [0-100].
-    umadRate :: Float,
+    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

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 -> [Gene] -> IO [Gene]
-uniformAddition pushArgs plushy = undefined
+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"

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 :: PushArgs -> [Gene] -> [Gene]
-plushyToPush plushy = plushyToPush' (concatMap (\x -> if isOpenerList x then x <> [Open (getOpenAmountList x)] else x) (chunksOf 1 plushy)) []
+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]

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 :: PushArgs -> [Gene] -> [Gene] -> State
-loadState plushy vals = 
+loadState pushArgs plushy vals = 
-  (loadProgram (plushyToPush plushy) emptyState){_input = Map.fromList (zip [0..] 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,
+    umadRate = 0.6,
-    variation = Map.fromList [("umad", 1.0), ("crossover", 0.0)],
+    variation = [("umad", 1.0), ("crossover", 0.0)],
     elitism = False,
     enableDownsampling = False,
     downsampleRate = 0.5

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