neet 0.2.0.1 → 0.3.0.0
raw patch · 6 files changed
+245/−41 lines, 6 files
Files
- neet.cabal +1/−1
- src/Neet/Examples/XOR.hs +9/−1
- src/Neet/Genome.hs +79/−8
- src/Neet/Parameters.hs +68/−9
- src/Neet/Population.hs +82/−22
- src/Neet/Species.hs +6/−0
neet.cabal view
@@ -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
src/Neet/Examples/XOR.hs view
@@ -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
src/Neet/Genome.hs view
@@ -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)
src/Neet/Parameters.hs view
@@ -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)
src/Neet/Population.hs view
@@ -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
src/Neet/Species.hs view
@@ -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)