simplification added

src/HushGP/GP.hs

@@ -9,6 +9,8 @@ import HushGP.GP.Individual
 import HushGP.GP.PushArgs
 import HushGP.GP.PushData
 import HushGP.GP.Variation
+import HushGP.GP.Selection
+import HushGP.GP.Simplification
 import HushGP.Genome
 import System.Random
 import System.Random.Shuffle
@@ -46,7 +48,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, elitism = isElite, populationSize = popSize})
+  pushArgs@(PushArgs {enableDownsampling = enableDS, solutionErrorThreshold = seThresh, downsampleParentsGens = dsParentGens, downsampleParentRate = dsParentRate, trainingData = trData, elitism = isElite, populationSize = popSize, useSimplification = useSimp, errorFunction = errorFunc, maxGenerations = maxGens, testingData = teData})
   generation
   evaluations
   population
@@ -60,23 +62,24 @@ gpLoop'
         else pure []
     let nextAction
           | ( bestIndPassesDownsample
-                && ( (case totalFitness (updateIndividual (errorFunction epsilonPushArgs epsilonPushArgs indexedTrainingData (plushy bestInd)) bestInd) of (Just x) -> x; _ -> error "Error: Best downsample individual has no fitness!")
+                && ( (case totalFitness (updateIndividual (errorFunc epsilonPushArgs indexedTrainingData (plushy bestInd)) bestInd) of (Just x) -> x; _ -> error "Error: Best downsample individual has no fitness!")
                        <= solutionErrorThreshold epsilonPushArgs
                    )
             )
-              || (not (enableDownsampling epsilonPushArgs) && ((case totalFitness bestInd of (Just x) -> x; _ -> error "error: Best non-downsample individual has no fitness!") <= solutionErrorThreshold epsilonPushArgs)) =
+              || (not enableDS && ((case totalFitness bestInd of (Just x) -> x; _ -> error "error: Best non-downsample individual has no fitness!") <= seThresh)) =
               do
                 print $ "Successful generation: " <> show generation
                 print $ "Successful plushy: " <> show (plushy bestInd)
                 print $ "Successful program: " <> show (plushyToPush pushArgs (plushy bestInd))
-                when (useSimplification epsilonPushArgs) $
+                print $ "Total test error: " <> show (errorFunc epsilonPushArgs teData (plushy bestInd))
+                when useSimp $
                   do
-                    let simplifiedPlushy = undefined -- TODO: simplification later
+                    simplifiedPlushy <- autoSimplifyPlushy pushArgs (plushy bestInd)
-                    print "Total test error simplified: " <> undefined -- Implement later
+                    print $ "Simplified plushy: " <> show simplifiedPlushy
-                    print $ "Simplified plushy: " <> undefined -- show simplifiedPlushy
+                    print $ "Simplified program: " <> show (plushyToPush pushArgs simplifiedPlushy)
-                    print $ "Simplified program: " <> undefined -- show plushyToPush simplifiedPlushy
+                    print $ "Total simplified test error: " <> show (errorFunc epsilonPushArgs teData simplifiedPlushy)
-          | (not (enableDownsampling epsilonPushArgs) && (generation >= maxGenerations epsilonPushArgs))
+          | (not enableDS && (generation >= maxGens))
-              || (enableDownsampling epsilonPushArgs && (evaluations >= (maxGenerations epsilonPushArgs * length population * length indexedTrainingData))) =
+              || (enableDS && (evaluations >= (maxGens * length population * length indexedTrainingData))) =
               print $ "Best individual: " <> show (plushy bestInd)
           | otherwise = do
               newPop <- if isElite then replicateM (popSize - 1) (newIndividual epsilonPushArgs evaledPop) else replicateM popSize (newIndividual epsilonPushArgs evaledPop)
@@ -86,14 +89,14 @@ gpLoop'
                 ( evaluations
                     + (populationSize pushArgs * length (trainingData pushArgs))
                     + (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 bestIndPassesDownsample then length indexedTrainingData - length trData else 0)
                 )
                 ( 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))
+                    then updateCaseDistances repEvaluatedPop indexedTrainingData indexedTrainingData (informedDownsamplingType pushArgs) (seThresh / fromIntegral @Int @Double (length indexedTrainingData))
                     else indexedTrainingData
                 )
     nextAction
@@ -105,10 +108,10 @@ gpLoop'
           then evaluatePopulation pushArgs indexedTrainingData population
           else []
       evaledPop :: [Individual]
-      evaledPop = evaluatePopulation pushArgs tData population
+      evaledPop = evaluatePopulation pushArgs trData population
       bestInd :: Individual
       bestInd = case uncons evaledPop of Just (x, _) -> x; _ -> error "Error: Population is empty!"
       bestIndPassesDownsample :: Bool
       bestIndPassesDownsample = enableDS && (extractTotalFitness bestInd <= seThresh)
       epsilonPushArgs :: PushArgs
-      epsilonPushArgs = pushArgs {epsilons = Nothing} -- TODO: And this
+      epsilonPushArgs = pushArgs {epsilons = Just $ epsilonList evaledPop}

src/HushGP/GP/Simplification.hs

@@ -1,9 +1,33 @@
 module HushGP.GP.Simplification where
 
+import System.Random.Shuffle
+import System.Random
 import Control.Monad
+import Data.List
 import HushGP.State
 import HushGP.GP.PushArgs
 
+import Debug.Trace
+
+-- | Takes a list of Genes (a plushy), chunks it up into sizes of 1 (type is [[Gene]]).
+-- and a list of indices for replacement (gets sorted before replacement).
+deleteAtMultiple :: [Int] -> [Gene] -> [Gene]
+deleteAtMultiple idxs = deleteAtMultiple' 0 (sort idxs)
+
+-- | Internals of replaceAtMultiple. Takes a chunked plushy and replaces indices
+-- that match the current index as specified at the idx.
+deleteAtMultiple' :: Int -> [Int] -> [Gene] -> [Gene]
+deleteAtMultiple' _ [] plushy = plushy
+deleteAtMultiple' _ _ [] = []
+deleteAtMultiple' curr (idx:idxs) (plushyPiece:plushy) =
+  if curr == idx then deleteAtMultiple' (curr + 1) idxs plushy else plushyPiece : deleteAtMultiple' (curr + 1) (idx:idxs) plushy
+
+-- | Deletes a random amount of genes from the passed plushy based on ant int.
+deleteRandomAmt :: Int -> [Gene] -> IO [Gene]
+deleteRandomAmt k plushy = do
+  randomIndicies <- take k . shuffle' [0..(length plushy - 1)] (length plushy) <$> initStdGen
+  pure $ deleteAtMultiple randomIndicies plushy
+
 -- | Simplifies a Plushy by randomly deleting instructions and seeing how it impacts
 -- performance. Removes genes that have zero to negative performance impact.
 autoSimplifyPlushy :: PushArgs -> [Gene] -> IO [Gene]
@@ -11,9 +35,23 @@ autoSimplifyPlushy pushArgs@PushArgs{simplificationVerbose = simpVerbose, errorF
   when simpVerbose (print ("simplification start plushy length: " <> show (length plushy)))
   autoSimplifyPlushy' pushArgs (eFunc pushArgs tData plushy) 0 plushy
 
+-- | Internals for autosimplification. Keeps track of the amount of steps.
 autoSimplifyPlushy' :: PushArgs -> [Double] -> Int -> [Gene] -> IO [Gene]
-autoSimplifyPlushy' pushArgs@PushArgs{simplificationSteps = simpSteps} initialErrors step plushy
+autoSimplifyPlushy' pushArgs@PushArgs{simplificationVerbose = simpVerbose, simplificationSteps = simpSteps, simplificationMaxAmt = simpK, errorFunction = eFunc, trainingData = tData} initialErrors step plushy
   | step < simpSteps = do
-      newPlushy <- undefined
+      randAmt <- fst . uniformR (1 :: Int, simpK) <$> initStdGen
-      undefined
+      newPlushy <- deleteRandomAmt randAmt plushy
-  | otherwise = undefined
+      let newPlushyErrors = eFunc pushArgs tData newPlushy
+      let isBetter = newPlushyErrors <= initialErrors
+      print "-----------------------------------------"
+      print $ "k: " <> show randAmt
+      print $ "step: " <> show step
+      print $ "newPlushy: " <> show newPlushy
+      print $ "plushy: " <> show plushy
+      print $ "isBetter: " <> show isBetter
+      print $ "initialErrors: " <> show initialErrors
+      print $ "newErrors: " <> show newPlushyErrors
+      autoSimplifyPlushy' pushArgs initialErrors (succ step) (if isBetter then newPlushy else plushy)
+  | otherwise = do
+      when simpVerbose (print ("simplification end plushy length: " <> show (length plushy)))
+      pure plushy

src/HushGP/Problems/IntegerRegression.hs

@@ -19,10 +19,30 @@ testPlushy = [
     -- GeneFloat 3.2
   ]
 
+intSolutionPlushy :: [Gene]
+intSolutionPlushy =
+  [ PlaceInput 0
+  , PlaceInput 0
+  , PlaceInput 0
+  , StateFunc (instructionIntMul, "instructionIntMul")
+  , StateFunc (instructionIntMul, "instructionIntMul")
+  -- , GeneInt 2
+  -- , PlaceInput 0
+  , GeneBool True -- A useless gene
+  -- , StateFunc (instructionIntMul, "instructionIntMul")
+  -- , GeneInt 6
+  -- , StateFunc (instructionIntAdd, "instructionIntAdd")
+  -- , StateFunc (instructionIntAdd, "instructionIntAdd")
+  -- , GeneInt 5 -- Also a useless gene
+  , GeneFloat 4.3
+  , GeneString "hello"
+  ]
+
 -- | The target function for this run. The function the gp
 -- is trying to evolve.
 targetFunction :: Integer -> Integer
-targetFunction x = (x * x * x) + (2 * x)
+-- targetFunction x = (x * x * x) + (2 * x) + 6
+targetFunction x = x * x * x
 
 -- | The training data for the model.
 intTrainData :: [PushData]
@@ -91,7 +111,10 @@ intPushArgs = defaultPushArgs
     variation = [("umad", 1.0), ("crossover", 0.0)],
     elitism = False,
     enableDownsampling = False,
-    downsampleRate = 0.5
+    downsampleRate = 0.5,
+    simplificationVerbose = True,
+    simplificationMaxAmt = 4,
+    simplificationSteps = 200
   }
 
 main :: IO ()