diff --git a/neet.cabal b/neet.cabal --- a/neet.cabal +++ b/neet.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: neet -version: 0.2.0.1 +version: 0.3.0.0 synopsis: A NEAT library for Haskell -- description: homepage: https://github.com/raymoo/NEET diff --git a/src/Neet/Examples/XOR.hs b/src/Neet/Examples/XOR.hs --- a/src/Neet/Examples/XOR.hs +++ b/src/Neet/Examples/XOR.hs @@ -88,7 +88,12 @@ _ <- getLine putStrLn "Running XOR experiment with 150 population and default parameters" seed <- randomIO - let pop = newPop seed (PS 150 2 1 defParams { distParams = dp } Nothing) + let pp = Just (PhaseParams 10 10) + pop = newPop seed (PS 150 2 1 params Nothing pp) + params = defParams { specParams = sp, mutParams = mp, mutParamsS = mpS } + mp = defMutParams { delConnChance = 0.3, delNodeChance = 0.03 } + mpS = defMutParamsS { addConnRate = 0.05, delConnChance = 0.05 } + sp = Target dp (SpeciesTarget (14,17) 0.1) dp = defDistParams { delta_t = 5 } (pop', sol) <- xorLoop pop printInfo pop' @@ -96,6 +101,9 @@ let score = gScorer xorFit sol putStrLn $ "\nOutputs to XOR inputs are: " ++ show score putStrLn $ "Fitness (Out of 16): " ++ show (fitnessFunction xorFit score) + + putStrLn $ "Final distance threshold: " ++ show (distParams . specParams $ popParams pop') + putStrLn "\nPress Enter to view network" _ <- getLine renderGenome sol diff --git a/src/Neet/Genome.hs b/src/Neet/Genome.hs --- a/src/Neet/Genome.hs +++ b/src/Neet/Genome.hs @@ -33,6 +33,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiWayIf #-} module Neet.Genome ( -- * Genes NodeId(..) @@ -46,8 +47,11 @@ -- ** Construction , fullConn , sparseConn + -- ** Stats + , genomeComplexity -- ** Breeding - , mutate + , mutateAdd + , mutateSub , crossover , breed -- ** Distance @@ -68,6 +72,8 @@ import Data.Map.Strict (Map) import qualified Data.Traversable as T +import qualified Data.Foldable as F + import qualified Data.Map.Strict as M import qualified Data.IntSet as IS @@ -131,7 +137,8 @@ -- | A NEAT genome. The innovation numbers are stored in here, and not the genes, -- to prevent data duplication. data Genome = - Genome { nodeGenes :: IntMap NodeGene + Genome { ioCount :: Int + , nodeGenes :: IntMap NodeGene , connGenes :: IntMap ConnGene , nextNode :: NodeId } @@ -156,6 +163,7 @@ nodeGenes = IM.fromList $ inputGenes ++ outputGenes nextNode = NodeId $ inCount + oSize + 1 nodePairs = (,) <$> inIDs <*> outIDs + ioCount = inCount + oSize conns <- zipWith (\(inN, outN) w -> ConnGene (NodeId inN) (NodeId outN) w True False) nodePairs `liftM` getRandomRs (-weightRange,weightRange) let connGenes = IM.fromList $ zip [1..] conns @@ -175,6 +183,7 @@ nextNode = NodeId $ inCount + oSize + 1 nodePairs = (,) <$> inIDs <*> outIDs idNodePairs = zip [1..] nodePairs + ioCount = inCount + oSize conPairs <- replicateM cons (uniform idNodePairs) conns <- zipWith (\(inno,(inN, outN)) w -> (inno, ConnGene (NodeId inN) (NodeId outN) w True False)) conPairs `liftM` getRandomRs (-weightRange, weightRange) @@ -347,10 +356,63 @@ pickConn >>= uncurry (addNode . InnoId) +isOrphanNode :: NodeId -> IntMap ConnGene -> Bool +isOrphanNode nId imap = F.all doesntContain imap + where doesntContain ConnGene{..} = nId /= connIn && nId /= connOut + + +-- | Mutation that can delete a connection +mutDelConn :: MonadRandom m => MutParams -> Genome -> m Genome +mutDelConn MutParams{..} genome@Genome{..} = do + roll <- getRandomR (0,1) + if IM.size connGenes <= 1 || roll > delConnChance + then return genome + else do + (connId, deleteThis) <- uniform $ IM.toList connGenes + let newConns = IM.delete connId connGenes + inOfDeleted = connIn deleteThis + outOfDeleted = connOut deleteThis + inIsHidden = nodeType (nodeGenes IM.! (getNodeId inOfDeleted)) == Hidden + outIsHidden = nodeType (nodeGenes IM.! (getNodeId outOfDeleted)) == Hidden + possiblyRemoved + | inIsHidden && isOrphanNode inOfDeleted newConns = + IM.delete (getNodeId inOfDeleted) nodeGenes + | otherwise = nodeGenes + possiblyRemoved2 + | outIsHidden && isOrphanNode outOfDeleted newConns = + IM.delete (getNodeId outOfDeleted) possiblyRemoved + | otherwise = possiblyRemoved + return genome { nodeGenes = possiblyRemoved2, connGenes = newConns } + + +doesntContainNode :: NodeId -> ConnGene -> Bool +doesntContainNode nId cg = connIn cg /= nId && connOut cg /= nId + + +-- | Mutation that may delete a node +mutDelNode :: MonadRandom m => MutParams -> Genome -> m Genome +mutDelNode MutParams{..} genome@Genome{..} = do + roll <- getRandomR (0,1) + if + | IM.size nodeGenes == ioCount -> return genome + | roll > delNodeChance -> return genome + | otherwise -> do + deleteThis <- uniform delCandidates + let newNodes = IM.delete deleteThis nodeGenes + newConns = IM.filter (doesntContainNode (NodeId deleteThis)) connGenes + return $ genome { nodeGenes = newNodes, connGenes = newConns } + where delCandidates = drop ioCount $ IM.keys nodeGenes + + +-- | Mutates the genome, but uses subtractive mutations instead of additive. +mutateSub :: MonadRandom m => MutParams -> Genome -> m Genome +mutateSub params = mutDelNode params >=> mutDelConn params >=> mutateWeights params + + -- | Mutates the genome, using the specified parameters and innovation context. -mutate :: (MonadRandom m, MonadFresh InnoId m) => MutParams -> Map ConnSig InnoId -> +mutateAdd :: (MonadRandom m, MonadFresh InnoId m) => MutParams -> Map ConnSig InnoId -> Genome -> m (Map ConnSig InnoId, Genome) -mutate params innos g = do +mutateAdd params innos g = do g' <- mutateWeights params g uncurry (mutateNode params) >=> uncurry (mutateConn params) $ (innos, g') @@ -391,7 +453,7 @@ -- | Crossover. The first argument is the fittest genome. crossover :: MonadRandom m => MutParams -> Genome -> Genome -> m Genome -crossover params g1 g2 = Genome newNodes `liftM` newConns `ap` return newNextNode +crossover params g1 g2 = Genome (ioCount g1) newNodes `liftM` newConns `ap` return newNextNode where newNextNode = max (nextNode g1) (nextNode g2) newConns = crossConns params (connGenes g1) (connGenes g2) newNodes = crossNodes (nodeGenes g1) (nodeGenes g2) @@ -402,7 +464,7 @@ MutParams -> Map ConnSig InnoId -> Genome -> Genome -> m (Map ConnSig InnoId, Genome) breed params innos g1 g2 = - crossover params g1 g2 >>= mutate params innos + crossover params g1 g2 >>= mutateAdd params innos -- | Gets differences where they exist @@ -414,7 +476,7 @@ -- | Genetic distance between two genomes distance :: Parameters -> Genome -> Genome -> Double distance params g1 g2 = c1 * exFactor + c2 * disFactor + c3 * weightFactor - where DistParams c1 c2 c3 _ = distParams params + where DistParams c1 c2 c3 _ = distParams . specParams $ params conns1 = connGenes g1 conns2 = connGenes g2 @@ -546,4 +608,13 @@ nonDup | uniq sigList = Nothing | otherwise = Just "Non unique connection signatures" - errRes = catMaybes [nodeOk, connsOk, nonDup] + ioCountGood + | IM.size (IM.filter (\n -> nodeType n == Input || nodeType n == Output) nodeGenes) == + ioCount = Nothing + | otherwise = Just "ioCount bad" + errRes = catMaybes [nodeOk, connsOk, nonDup, ioCountGood] + + +-- | Total number of links and nodes. +genomeComplexity :: Genome -> Int +genomeComplexity gen = IM.size (nodeGenes gen) + IM.size (nodeGenes gen) diff --git a/src/Neet/Parameters.hs b/src/Neet/Parameters.hs --- a/src/Neet/Parameters.hs +++ b/src/Neet/Parameters.hs @@ -28,27 +28,46 @@ -} module Neet.Parameters ( Parameters(..) - , DistParams(..) - , MutParams(..) , defParams + , DistParams(..) , defDistParams + , MutParams(..) , defMutParams , defMutParamsS + , SpeciesParams(..) + , distParams + , SpeciesTarget(..) + , SearchStrat(..) + , PhaseParams(..) + , PhaseState(..) ) where -- | The genetic parameters data Parameters = - Parameters { mutParams :: MutParams - , mutParamsS :: MutParams -- ^ Mutation parameters for small populations - , largeSize :: Int -- ^ The minimum size for a species to be considered large - , distParams :: DistParams -- ^ Parameters for the distance function - , dropTime :: Maybe Int -- ^ Drop a species if it doesn't improve for this long, - -- and it hasn't hosted the most successful genome. + Parameters { mutParams :: MutParams + , mutParamsS :: MutParams -- ^ Mutation parameters for small populations + , largeSize :: Int -- ^ The minimum size for a species to be considered large + , specParams :: SpeciesParams -- ^ Parameters for the distance function + , dropTime :: Maybe Int -- ^ Drop a species if it doesn't improve for this long, + -- and it hasn't hosted the most successful genome. } deriving (Show) +-- | Settings for distance. `Simple` is for fixed distance calculations. `Target` +-- should be used when you want the threshold value for distance to change to +-- try to meet a desired species count. +data SpeciesParams = Simple DistParams + | Target DistParams SpeciesTarget + deriving (Show) + + +distParams :: SpeciesParams -> DistParams +distParams (Simple dp) = dp +distParams (Target dp _) = dp + + -- | Distance Parameters data DistParams = DistParams { dp1 :: Double -- ^ Coefficient to the number of excess genes @@ -59,6 +78,15 @@ deriving (Show) +-- | How to seek a target species count +data SpeciesTarget = + SpeciesTarget { targetCount :: (Int,Int) -- ^ Desired range of species count, inclusive + , adjustAmount :: Double -- ^ How much to adjust the distance threshold + -- if there are too many/not enough species + } + deriving (Show) + + -- | Mutation Parameters data MutParams = MutParams { mutWeightRate :: Double -- ^ How often weights are mutated @@ -67,6 +95,9 @@ , weightRange :: Double -- ^ A new max is between negative this and positive this , addConnRate :: Double -- ^ How often new connections are made , addNodeRate :: Double -- ^ How often new nodes are added + , delConnChance :: Double -- ^ How likely it is for a connection to + -- be erased + , delNodeChance :: Double -- ^ How likely it is for a node to be erased , recurrencies :: Bool -- ^ Whether to allow recurrent connections , noCrossover :: Double -- ^ Percent of population that mutates without crossover , disableChance :: Double -- ^ How likely that a disabled parent results @@ -84,6 +115,8 @@ , weightRange = 2.5 , addConnRate = 0.3 , addNodeRate = 0.03 + , delConnChance = 0 + , delNodeChance = 0 , recurrencies = False , noCrossover = 0.25 , disableChance = 0.75 @@ -97,7 +130,7 @@ Parameters { mutParams = defMutParams , mutParamsS = defMutParamsS , largeSize = 20 - , distParams = defDistParams + , specParams = Simple defDistParams , dropTime = Just 15 } @@ -109,3 +142,29 @@ -- | Parameters used for distance in the paper defDistParams :: DistParams defDistParams = DistParams 1 1 0.4 3 + + +-- | Search Strategy +data SearchStrat = Complexify + | Phased PhaseParams + deriving (Show) + + +-- | Parameters for phased search +data PhaseParams = + PhaseParams { phaseAddAmount :: Double -- ^ How much to add to the mean complexity + -- to get the next complexity + , phaseWaitTime :: Int -- ^ How many generations without a drop + -- in complexity warrants going back to + -- a complexify strategy + } + deriving (Show) + + +-- | State of phasing +data PhaseState = Complexifying Double -- ^ The argument is the current threshold + -- to start pruning at. + | Pruning Int Double -- ^ The first argument is how many generations + -- the mean complexity has not fallen. The second + -- is the last mean complexity. + deriving (Show) diff --git a/src/Neet/Population.hs b/src/Neet/Population.hs --- a/src/Neet/Population.hs +++ b/src/Neet/Population.hs @@ -63,7 +63,7 @@ import Data.Map (Map) import qualified Data.Map as M -import Data.List (foldl', maximumBy, sortBy) +import Data.List (foldl', maximumBy, sortBy, mapAccumL) import Data.Maybe @@ -91,7 +91,9 @@ , popBSpec :: !SpecId -- ^ Id of the species that hosted the best score , popCont :: !PopContext -- ^ Tracking state and fresh values , nextSpec :: !SpecId -- ^ The next species ID - , popParams :: Parameters -- ^ Parameters for large species + , popParams :: Parameters -- ^ Parameters for large species + , popStrat :: SearchStrat + , popPhase :: PhaseState , popGen :: Int -- ^ Current generation } deriving (Show) @@ -141,6 +143,7 @@ , psParams :: Parameters -- ^ Parameters for large species , sparse :: Maybe Int -- ^ If Just n, will be sparse with n connections. -- Otherwise fully connected. + , psStrategy :: Maybe PhaseParams } deriving (Show) @@ -166,7 +169,7 @@ shuttleOrgs :: MonadFresh SpecId m => Parameters -> [SpecBucket] -> [Genome] -> m [SpecBucket] shuttleOrgs p@Parameters{..} buckets = foldM shutOne buckets - where DistParams{..} = distParams + where DistParams{..} = distParams specParams shutOne :: MonadFresh SpecId m => [SpecBucket] -> Genome -> m [SpecBucket] shutOne (SB sId rep gs:bs) g | distance p g rep <= delta_t = return $ SB sId rep (g:gs) : bs @@ -223,6 +226,11 @@ gens <- generateGens let (popSpecs, nextSpec) = runSpecM (speciate psParams M.empty gens) (SpecId 1) popBOrg = head gens + avgComp = fromIntegral (foldl' (+) 0 . map genomeComplexity $ gens) / fromIntegral popSize + (popStrat, popPhase) = case psStrategy of + Nothing -> (Complexify, Complexifying 0) -- not used + Just pp@PhaseParams{..} -> + (Phased pp, Complexifying (phaseAddAmount + avgComp)) popCont <- PopM get return Population{..} @@ -235,7 +243,24 @@ mParams = mutParams params mParamsS = mutParamsS params - + + avgComp = avgComplexity pop + + newPhase = case (popPhase pop, popStrat pop) of + (_, Complexify) -> Complexifying 0 + (Complexifying thresh, Phased PhaseParams{..}) + | avgComp < thresh -> Complexifying thresh + | otherwise -> Pruning 0 avgComp + (Pruning lastFall lastComp, Phased PhaseParams{..}) + | avgComp < lastComp -> Pruning 0 avgComp + | lastFall >= phaseWaitTime -> Complexifying (avgComp + phaseAddAmount) + | otherwise -> Pruning (lastFall + 1) avgComp + + isPruning = case newPhase of + Pruning _ _ -> True + _ -> False + + chooseParams :: Species -> MutParams chooseParams s = if specSize s >= largeSize params then mParams else mParamsS {-# INLINE chooseParams #-} @@ -295,8 +320,11 @@ where sortedMaster = sortBy revComp masterList -- | Reversed comparison on best score, to get a descending sorted list revComp (_,(sp1,_,_)) (_,(sp2,_,_)) = (compare `on` (bestScore . specScore)) sp2 sp1 - initShares = map share sortedMaster - share (_,(_, _, adj)) = floor $ adj / totalFitness * dubSize + initShares = snd $ mapAccumL share 0 sortedMaster + share skim (_,(_, _, adj)) = (newSkim, actualShare) + where everything = adj / totalFitness * dubSize + skim + actualShare = floor everything + newSkim = everything - fromIntegral actualShare remaining = totalSize - foldl' (+) 0 initShares distributeRem _ [] = error "Should run out of numbers first" distributeRem n l@(x:xs) @@ -323,21 +351,26 @@ Map ConnSig InnoId -> (MutParams, Int, m (Double, Genome)) -> m (Map ConnSig InnoId, [Genome]) specGens inns (p, n, gen) = applyN n genOne (inns, []) - where genOne (innos, gs) = do - roll <- getRandomR (0,1) - if roll <= noCrossover p - then do - (_,parent) <- gen - (innos', g) <- mutate p innos parent - return (innos', g:gs) - else do - (fit1, mom) <- gen - (fit2, dad) <- gen - (innos', g) <- if fit1 > fit2 - then breed p innos mom dad - else breed p innos dad mom - return (innos', g:gs) - + where genOne (innos, gs) + | isPruning = do + (_,parent) <- gen + g <- mutateSub p parent + return (innos, g:gs) + | otherwise = do + roll <- getRandomR (0,1) + if roll <= noCrossover p + then do + (_,parent) <- gen + (innos', g) <- mutateAdd p innos parent + return (innos', g:gs) + else do + (fit1, mom) <- gen + (fit2, dad) <- gen + (innos', g) <- if fit1 > fit2 + then breed p innos mom dad + else breed p innos dad mom + return (innos', g:gs) + allGens :: (MonadRandom m, MonadFresh InnoId m) => m [Genome] allGens = liftM (concat . snd) $ foldM ag' (M.empty, []) candSpecs where ag' (innos, cands) cand = do @@ -353,10 +386,26 @@ generated :: Population generated = fst $ runPopM generate (popCont pop) + generate :: PopM Population generate = do (specs, nextSpec') <- genNewSpecies - let bScoreNow = (bestScore . specScore) veryBest + let specCount = M.size specs + newParams :: Parameters + newParams = + case specParams params of + Simple _ -> newParams + Target dp st@SpeciesTarget{..} + | specCount > snd targetCount -> + let newDP = dp { delta_t = delta_t dp + adjustAmount } + in params { specParams = Target newDP st } + | specCount < fst targetCount -> + let newDP = dp { delta_t = delta_t dp - adjustAmount } + in params { specParams = Target newDP st } + | otherwise -> params + + + bScoreNow = (bestScore . specScore) veryBest bOrgNow = (bestGen . specScore) veryBest bSpecNow = bestId (bScore, bOrg, bSpec) = @@ -369,6 +418,7 @@ , popBOrg = bOrg , popBSpec = bSpec , popCont = cont' + , popParams = newParams , nextSpec = nextSpec' , popGen = popGen pop + 1 } @@ -399,6 +449,16 @@ -- | Gets the number of species speciesCount :: Population -> Int speciesCount Population{..} = M.size popSpecs + + +-- | Average genome complexity of a population +avgComplexity :: Population -> Double +avgComplexity pop = fromIntegral (totalComplexityMap (popSpecs pop)) / fromIntegral (popSize pop) + + +-- | Helper for avgComplexity +totalComplexityMap :: Map SpecId Species -> Int +totalComplexityMap smap = M.foldl' (+) 0 . M.map speciesComplexity $ smap -- | Validate a population, possibly returning a list of errors diff --git a/src/Neet/Species.hs b/src/Neet/Species.hs --- a/src/Neet/Species.hs +++ b/src/Neet/Species.hs @@ -40,6 +40,7 @@ , updateSpec -- * Statistics , maxDist + , speciesComplexity -- * Debugging , validateSpecies ) where @@ -138,3 +139,8 @@ -- | Gets the max distance between two genomes in a species maxDist :: Parameters -> Species -> Double maxDist ps Species{..} = maximum . map (uncurry (distance ps)) $ (,) <$> specOrgs <*> specOrgs + + +-- | Total complexity of all member genomes +speciesComplexity :: Species -> Int +speciesComplexity spec = sum $ map genomeComplexity (specOrgs spec)