selection and individual, remove cyclic dependencies for PushArgs

This commit is contained in:
Rowan Torbitzky-Lane 2025-03-01 23:21:43 -06:00
parent 5a410dd605
commit 1293e27b69
5 changed files with 66 additions and 4 deletions

View File

@ -4,12 +4,12 @@ import System.Random.Shuffle
import System.Random
import Data.List
import Data.Maybe
import HushGP.Genome
import HushGP.Utility
import HushGP.GP.PushData
import HushGP.GP.PushArgs
import HushGP.Tools.Metrics
import HushGP.Instructions.Utility
import HushGP.GP.Individual
-- |Sets the index of the passed training data.
assignIndicesToData :: [PushData] -> [PushData]

View File

@ -0,0 +1,24 @@
module HushGP.GP.Individual where
import HushGP.State
-- | The structure for an individual containing the genome, the totalFitness, and
-- the individual fitness cases for lexicase.
data Individual = Individual
{ plushy :: [Gene],
totalFitness :: Maybe Double,
fitnessCases :: Maybe [Double]
}
deriving (Show, Eq)
instance Ord Individual where
ind0 <= ind1 = totalFitness ind0 <= totalFitness ind1
-- | Extracts the fitnessCases from an Individual. Errors if the field is empty.
extractFitnessCases :: Individual -> [Double]
extractFitnessCases Individual {fitnessCases = Nothing} = error "Error: fitnessCases is empty!"
extractFitnessCases Individual {fitnessCases = Just xs} = xs
extractTotalFitness :: Individual -> Double
extractTotalFitness Individual {totalFitness = Nothing} = error "Error: totalFitness is empty!"
extractTotalFitness Individual {totalFitness = Just x} = x

View File

@ -3,6 +3,7 @@ module HushGP.GP.PushArgs where
import HushGP.State
import HushGP.Instructions
import HushGP.GP.PushData
import HushGP.GP.Individual
import Data.Map qualified as Map
-- | The structure holding the arguments for the various aspects
@ -96,7 +97,11 @@ data PushArgs = PushArgs
epsilons :: Maybe [Double],
-- | Used with the CaseMaxminAuto downsampling strategy. Tells downsampling to stop when
-- the maximum minimum distance is too far away.
caseDelta :: Double
caseDelta :: Double,
-- | Used in lexicase selection. If initialCases is present will use those before randomly
-- selecting from the population for initial cases. Can raise a value into the IO monad using
-- `pure @IO`
initialCases :: Maybe [Int]
}
-- | The default values for which all runs of Hush derive
@ -143,5 +148,6 @@ defaultPushArgs = PushArgs {
umadRate = 0.1,
variation = Map.fromList [("umad", 1.0)],
epsilons = Nothing,
caseDelta = 0
caseDelta = 0,
initialCases = Nothing
}

View File

@ -0,0 +1,32 @@
module HushGP.GP.Selection where
import Data.List
import System.Random
import System.Random.Shuffle
import HushGP.GP.PushArgs
import HushGP.GP.Individual
-- | Tournament selection based off tournament size from PushArgs and a population.
-- Takes the individual with the lowest total error in the tournament.
tournamentSelection :: PushArgs -> [Individual] -> IO Individual
tournamentSelection PushArgs{tournamentSize = tSize} pop = do
shuffledPop <- shuffle' pop (length pop) <$> initStdGen
let tournSet = take tSize shuffledPop
pure $ minimum tournSet
-- |Selects an individual from the population using lexicase selection.
-- Lexicase parent selection filters the population by considering one random training case at a time,
-- eliminating any individuals with errors for the current case that are worse than the best error in the selection pool,
-- until a single individual remains. This is the top level function.
lexicaseSelection :: PushArgs -> [Individual] -> IO Individual
lexicaseSelection PushArgs{initialCases = iCases} pop = do
startCases <- maybe (shuffle' [0..lehp] lehp <$> initStdGen) (pure @IO) iCases
undefined
where
lehp :: Int -- length of the extracted fitness cases of the head of the passed population.
lehp = length $ extractFitnessCases $
case uncons pop of
Just (x, _) -> x
_ -> error "Error: Population in lexicaseSelection cannot be empty!"
-- lexicaseSelection' ::

View File

@ -1,7 +1,7 @@
module HushGP.GP.Variation where
import HushGP.Genome
import HushGP.GP.PushArgs
import HushGP.GP.Individual
newIndividual :: PushArgs -> [Individual] -> Individual
newIndividual = error "Implement this later"