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.1.0.0 +version: 0.2.0.0 synopsis: A NEAT library for Haskell -- description: homepage: https://github.com/raymoo/NEET @@ -23,12 +23,13 @@ library exposed-modules: Neet.Genome, Control.Monad.Fresh.Class, Neet.Parameters, Neet.Network, - Neet.Species, Neet.Population, Neet.Examples.XOR + Neet.Species, Neet.Population, Neet.Examples.XOR, Neet -- other-modules: other-extensions: FunctionalDependencies, MultiParamTypeClasses build-depends: base >=4.7 && <4.8, MonadRandom >=0.4 && <0.5, containers >= 0.5 && < 0.6, multimap >= 1.2 && < 1.3, - transformers == 0.4.*, graphviz == 2999.17.* + transformers == 0.4.*, graphviz == 2999.17.*, cereal == 0.4.*, + random == 1.1.*, parallel == 3.2.* hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Neet.hs b/src/Neet.hs new file mode 100644 --- /dev/null +++ b/src/Neet.hs @@ -0,0 +1,39 @@ +{- +Copyright (C) 2015 Leon Medvinsky + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 3 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +-} + +{-| +Module : Neet +Description : Reexport convenience module +Copyright : (c) Leon Medvinsky, 2015 + +License : GPL-3 +Maintainer : lmedvinsky@hotmail.com +Stability : experimental +Portability : ghc +-} + +module Neet (module Genome + , module Population + , module Parameters + , module Network + ) where + +import Neet.Genome as Genome +import Neet.Population as Population +import Neet.Parameters as Parameters +import Neet.Network as Network 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 @@ -27,13 +27,19 @@ Portability : ghc -} -module Neet.Examples.XOR (xorFit, andFit, orFit) where +module Neet.Examples.XOR (xorFit, andFit, orFit, xorExperiment) where -import Neet.Genome -import Neet.Network +import Neet +import Neet.Species +import qualified Data.Map.Strict as M +import System.Random + +import Data.List (intercalate) + + boolQuestions :: [[Double]] boolQuestions = [ [0, 0] , [0, 1] @@ -41,30 +47,77 @@ , [1, 1] ] -xorAnswers :: [Double] -xorAnswers = [0, 1, 1, 0] +xorAnswers :: [Bool] +xorAnswers = [False, True, True, False] -sampleFit :: [[Double]] -> [Double] -> Genome -> Double -sampleFit questions answers g = (fromIntegral (length answers) - sumDiffs)**2 - where net = mkPhenotype g - try samp = head . getOutput $ snapshot net samp - responses = map try questions - sumDiffs = sum $ zipWith (\x y -> abs (x - y)) responses answers +sampleFit :: [[Double]] -> [Bool] -> GenScorer [Double] +sampleFit questions answers = GS intermed ff criteria + where intermed g = map try questions + where try samp = head $ pushThrough net samp + net = mkPhenotype g + ff ds = (fromIntegral (length answers) - sumDiffs)**2 + where sumDiffs = sum $ zipWith (\x y -> abs (x - y)) ds binarized + binarized = map (\b -> if b then 1 else 0) answers + bounds = map (\b -> if b then (>0.5) else (<0.5)) answers + criteria ds = and $ zipWith id bounds ds -xorFit :: Genome -> Double +xorFit :: GenScorer [Double] xorFit = sampleFit boolQuestions xorAnswers -andAnswers :: [Double] -andAnswers = [0, 0, 0, 1] +andAnswers :: [Bool] +andAnswers = [False, False, False, True] -andFit :: Genome -> Double +andFit :: GenScorer [Double] andFit = sampleFit boolQuestions andAnswers -orAnswers :: [Double] -orAnswers = [0, 1, 1, 1] +orAnswers :: [Bool] +orAnswers = [False, True, True, True] -orFit :: Genome -> Double +orFit :: GenScorer [Double] orFit = sampleFit boolQuestions orAnswers + + +-- | Automated XOR experiment +xorExperiment :: IO () +xorExperiment = do + putStrLn $ "XOR Input list is: " ++ show boolQuestions + putStrLn "Press Enter to start learning" + _ <- getLine + putStrLn "Running XOR experiment with 150 population and default parameters" + seed <- randomIO + let pop = newPop seed (PS 150 2 1 defParams (Just 2)) + (pop', sol) <- xorLoop pop + printInfo pop' + putStrLn $ "Solution found in generation " ++ show (popGen pop') + let score = gScorer xorFit sol + putStrLn $ "\nOutputs to XOR inputs are: " ++ show score + putStrLn $ "Fitness (Out of 16): " ++ show (fitnessFunction xorFit score) + putStrLn "\nPress Enter to view network" + _ <- getLine + renderGenome sol + + +mkSpecInfo :: Population -> String +mkSpecInfo pop = intercalate ", " infos + where infos = map (\((SpecId k), sp) -> "S" ++ show k ++ " P" ++ show (specSize sp)) ass + ass = M.toList $ popSpecs pop + + +xorLoop :: Population -> IO (Population, Genome) +xorLoop pop = do + printInfo pop + let (pop', mg) = trainOnce xorFit pop + case mg of + Nothing -> xorLoop pop' + Just g -> return (pop',g) + + +printInfo :: Population -> IO () +printInfo pop = do + putStrLn $ "Generation " ++ show (popGen pop) + putStrLn $ "Species: " ++ mkSpecInfo pop + putStrLn $ "High Score: " ++ show (popBScore pop) + putStrLn "" diff --git a/src/Neet/Genome.hs b/src/Neet/Genome.hs --- a/src/Neet/Genome.hs +++ b/src/Neet/Genome.hs @@ -31,6 +31,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DefaultSignatures #-} module Neet.Genome ( -- * Genes NodeId(..) @@ -43,25 +45,38 @@ , Genome(..) -- ** Construction , fullConn + , sparseConn -- ** Breeding , mutate , crossover , breed -- ** Distance , distance + -- ** Fitness + , GenScorer(..) -- ** Visualization , renderGenome + , printGenome + -- ** Debugging + , validateGenome ) where import Control.Applicative import Control.Monad import Control.Monad.Random +import Control.Arrow (first) + import Data.Map.Strict (Map) import qualified Data.Traversable as T import qualified Data.Map.Strict as M +import qualified Data.IntSet as IS + import qualified Data.Set as S +import qualified Data.IntMap as IM +import Data.IntMap (IntMap) + import Data.Maybe import Control.Monad.Fresh.Class @@ -70,23 +85,32 @@ import Data.GraphViz import Data.GraphViz.Attributes.Complete +import GHC.Generics (Generic) +import Data.Serialize (Serialize) + +import Text.Printf + -- | The IDs node genes use to refer to nodes. -newtype NodeId = NodeId Int - deriving (Show, Eq, Ord, PrintDot) +newtype NodeId = NodeId { getNodeId :: Int } + deriving (Show, Eq, Ord, PrintDot, Serialize) -- | Types of nodes data NodeType = Input | Hidden | Output - deriving (Show, Eq) + deriving (Show, Eq, Generic) +instance Serialize NodeType + -- | Node genes data NodeGene = NodeGene { nodeType :: NodeType , yHint :: Rational -- ^ A hint for recurrency } - deriving (Show) + deriving (Show, Generic) +instance Serialize NodeGene + -- | Connection genes data ConnGene = ConnGene { connIn :: NodeId , connOut :: NodeId @@ -94,47 +118,73 @@ , connEnabled :: Bool , connRec :: Bool -- ^ A hint for recurrency } - deriving (Show) + deriving (Show, Generic) +instance Serialize ConnGene + -- | Innovation IDs -newtype InnoId = InnoId Int +newtype InnoId = InnoId { getInnoId :: Int } deriving (Show, Eq, Ord) -- | A NEAT genome. The innovation numbers are stored in here, and not the genes, -- to prevent data duplication. data Genome = - Genome { nodeGenes :: Map NodeId NodeGene - , connGenes :: Map InnoId ConnGene + Genome { nodeGenes :: IntMap NodeGene + , connGenes :: IntMap ConnGene , nextNode :: NodeId } - deriving (Show) + deriving (Show, Generic) +instance Serialize Genome + + -- | Takes the number of inputs, the number of outputs, and gives a genome with -- the inputs fully connected to the outputs with random weights. The order of -- the connections are deterministic, so when generating a population, you -- can just start the innovation number at (iSize + 1) * oSize, since the network -- includes an additional input for the bias. -fullConn :: MonadRandom m => Parameters -> Int -> Int -> m Genome -fullConn Parameters{..} iSize oSize = do +fullConn :: MonadRandom m => MutParams -> Int -> Int -> m Genome +fullConn MutParams{..} iSize oSize = do let inCount = iSize + 1 - inIDs = map NodeId [1..inCount] - outIDs = map NodeId [inCount + 1..oSize + inCount] + inIDs = [1..inCount] + outIDs = [inCount + 1..oSize + inCount] inputGenes = zip inIDs $ repeat (NodeGene Input 0) outputGenes = zip outIDs $ repeat (NodeGene Output 1) - nodeGenes = M.fromList $ inputGenes ++ outputGenes + nodeGenes = IM.fromList $ inputGenes ++ outputGenes nextNode = NodeId $ inCount + oSize + 1 nodePairs = (,) <$> inIDs <*> outIDs - conns <- zipWith (\(inN, outN) w -> ConnGene inN outN w True False) nodePairs `liftM` getRandomRs (-weightRange,weightRange) - let connGenes = M.fromList $ zip (map InnoId [1..]) conns + 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 return $ Genome{..} +-- | Like 'fullConn', but with only some input-outputs connected. First integer +-- parameters is the max number of connections to start with. +sparseConn :: MonadRandom m => MutParams -> Int -> Int -> Int -> m Genome +sparseConn MutParams{..} cons iSize oSize = do + let inCount = iSize + 1 + inIDs = [1..inCount] + outIDs = [inCount + 1..oSize + inCount] + inputGenes = zip inIDs $ repeat (NodeGene Input 0) + outputGenes = zip outIDs $ repeat (NodeGene Output 1) + nodeGenes = IM.fromList $ inputGenes ++ outputGenes + nextNode = NodeId $ inCount + oSize + 1 + nodePairs = (,) <$> inIDs <*> outIDs + idNodePairs = zip [1..] nodePairs + 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) + let connGenes = IM.fromList conns + return $ Genome{..} + + -- | Mutate the weights - perturb or make entirely new weights -mutateWeights :: MonadRandom m => Parameters -> Genome -> m Genome -mutateWeights Parameters{..} gen@Genome{..} = do +mutateWeights :: MonadRandom m => MutParams -> Genome -> m Genome +mutateWeights MutParams{..} gen@Genome{..} = do roll <- getRandomR (0,1) if roll > mutWeightRate then return gen @@ -162,20 +212,20 @@ -- | Adds a single connection, updating the innovation context addConn :: MonadFresh InnoId m => ConnGene -> - (Map ConnSig InnoId, Map InnoId ConnGene) -> - m (Map ConnSig InnoId, Map InnoId ConnGene) + (Map ConnSig InnoId, IntMap ConnGene) -> + m (Map ConnSig InnoId, IntMap ConnGene) addConn conn (innos, conns) = case M.lookup siggy innos of - Just inno -> return (innos, M.insert inno conn conns) + Just inno -> return (innos, IM.insert (getInnoId inno) conn conns) Nothing -> do - newInno <- fresh - return (M.insert siggy newInno innos, M.insert newInno conn conns) + nI@(InnoId newInno) <- fresh + return (M.insert siggy nI innos, IM.insert newInno conn conns) where siggy = toConnSig conn -- | Mutation of additional connection. 'Map' parameter is context of previous -- innovations. This could be global, or per species generation. mutateConn :: (MonadFresh InnoId m, MonadRandom m) => - Parameters -> Map ConnSig InnoId -> Genome -> m (Map ConnSig InnoId, Genome) + MutParams -> Map ConnSig InnoId -> Genome -> m (Map ConnSig InnoId, Genome) mutateConn params innos g = do roll <- getRandomR (0,1) if roll > addConnRate params @@ -190,24 +240,29 @@ -- | Which connections are already filled up by genes. Value is a dummy -- value because taken is only used in difference anyway. taken :: Map ConnSig Bool - taken = M.fromList . map (\c -> (toConnSig c, True)) . M.elems . connGenes $ g + taken = M.fromList . map (\c -> (toConnSig c, True)) . IM.elems . connGenes $ g -- | Whether a gene is an input gene notInput (NodeGene Input _) = False notInput _ = True -- | The genome's nodes, in an assoc list - nodes = M.toList $ nodeGenes g + nodes = IM.toList $ nodeGenes g -- | Nodes that are not input nonInputs = filter (notInput . snd) nodes -- | Make a pair of 'ConnSig' and the recurrentness - makePair (n1,g1) (n2,g2) = (ConnSig n1 n2, yHint g2 <= yHint g1) + makePair (n1,g1) (n2,g2) = (ConnSig (NodeId n1) (NodeId n2), yHint g2 <= yHint g1) -- | Possible input -> output pairs - candidates = M.fromList $ makePair <$> nodes <*> nonInputs + candidates = M.fromList $ + if recurrencies params + then makePair <$> nodes <*> nonInputs + else filter nonRec $ makePair <$> nodes <*> nonInputs + nonRec (_,reccy) = not reccy + -- | Which pairs are not taken allowed = M.toList $ M.difference candidates taken @@ -221,8 +276,8 @@ -- | Randomly chooses one of the available connections and creates a -- gene for it addRandConn :: (MonadRandom m, MonadFresh InnoId m) => - Map ConnSig InnoId -> Map InnoId ConnGene -> - m (Map ConnSig InnoId, Map InnoId ConnGene) + Map ConnSig InnoId -> IntMap ConnGene -> + m (Map ConnSig InnoId, IntMap ConnGene) addRandConn innos' conns = do (ConnSig inNode outNode, recc) <- pickOne w <- pickWeight @@ -232,7 +287,7 @@ -- | Mutation of additional node. mutateNode :: (MonadRandom m, MonadFresh InnoId m) => - Parameters -> Map ConnSig InnoId -> + MutParams -> Map ConnSig InnoId -> Genome -> m (Map ConnSig InnoId, Genome) mutateNode params innos g = do roll <- getRandomR (0,1) @@ -241,8 +296,8 @@ nodes = nodeGenes g -- | Pick one of the 'InnoId' 'ConnGene' pairs from conns - pickConn :: MonadRandom m => m (InnoId, ConnGene) - pickConn = uniform $ M.toList conns + pickConn :: MonadRandom m => m (Int, ConnGene) + pickConn = uniform $ IM.toList conns -- | What will the new node's ID be newId = nextNode g @@ -255,45 +310,45 @@ addNode :: MonadFresh InnoId m => InnoId -> ConnGene -> m (Map ConnSig InnoId, Genome) addNode inno gene = do - let ConnSig inId outId = toConnSig gene + let ConnSig (NodeId inId) (NodeId outId) = toConnSig gene -- | Gene of the input node of this connection - inGene = nodes M.! inId + inGene = nodes IM.! inId -- | Gene of the output node of this connection - outGene = nodes M.! outId + outGene = nodes IM.! outId -- | The new node gene newGene = NodeGene Hidden ((yHint inGene + yHint outGene) / 2) -- | The new map of nodes, after inserting the new one - newNodes = M.insert newId newGene nodes + newNodes = IM.insert (getNodeId newId) newGene nodes -- | The disabled version of the old connection disabledConn = gene { connEnabled = False } -- | The gene for the connection between the input and the new node - backGene = ConnGene inId newId 1 True (connRec gene) + backGene = ConnGene (NodeId inId) newId 1 True (connRec gene) -- | The gene for the connection between the new node and the output - forwardGene = ConnGene newId outId (connWeight gene) True (connRec gene) + forwardGene = ConnGene newId (NodeId outId) (connWeight gene) True (connRec gene) (innos', newConns) <- addConn backGene >=> addConn forwardGene $ (innos, conns) return $ (innos', g { nodeGenes = newNodes - , connGenes = M.insert inno disabledConn newConns + , connGenes = IM.insert (getInnoId inno) disabledConn newConns , nextNode = newNextNode }) -- | Pick an available connection randomly and make a gene for it addRandNode :: (MonadRandom m, MonadFresh InnoId m) => m (Map ConnSig InnoId, Genome) addRandNode = - pickConn >>= uncurry addNode + pickConn >>= uncurry (addNode . InnoId) -- | Mutates the genome, using the specified parameters and innovation context. -mutate :: (MonadRandom m, MonadFresh InnoId m) => Parameters -> Map ConnSig InnoId -> +mutate :: (MonadRandom m, MonadFresh InnoId m) => MutParams -> Map ConnSig InnoId -> Genome -> m (Map ConnSig InnoId, Genome) mutate params innos g = do g' <- mutateWeights params g @@ -301,18 +356,20 @@ -- | Super left biased merge -- loners on the right map don't get in -superLeft :: Ord k => (a -> b -> c) -> (a -> c) -> Map k a -> Map k b -> Map k c -superLeft comb mk = M.mergeWithKey (\_ a b -> Just $ comb a b) (M.map mk) (const M.empty) +superLeft :: (a -> b -> c) -> (a -> c) -> IntMap a -> IntMap b -> IntMap c +superLeft comb mk = IM.mergeWithKey (\_ a b -> Just $ comb a b) (IM.map mk) (const IM.empty) -- | Choose between two alternatives with coin chance flipCoin :: MonadRandom m => a -> a -> m a -flipCoin a1 a2 = uniform [a1, a2] +flipCoin a1 a2 = do + roll <- getRandom + return $ if roll then a1 else a2 -- | Crossover on just the connections. Put the fittest map first. -crossConns :: MonadRandom m => Parameters -> Map InnoId ConnGene -> Map InnoId ConnGene -> - m (Map InnoId ConnGene) +crossConns :: MonadRandom m => MutParams -> IntMap ConnGene -> IntMap ConnGene -> + m (IntMap ConnGene) crossConns params m1 m2 = T.sequence $ superLeft flipConn return m1 m2 where flipConn c1 c2 = do if connEnabled c1 && connEnabled c2 @@ -327,14 +384,14 @@ -- | Crossover on just nodes -crossNodes :: MonadRandom m => Map NodeId NodeGene -> Map NodeId NodeGene -> - m (Map NodeId NodeGene) -crossNodes m1 m2 = T.sequence $ superLeft flipCoin return m1 m2 +crossNodes :: IntMap NodeGene -> IntMap NodeGene -> + IntMap NodeGene +crossNodes m1 m2 = superLeft (\a _ -> a) id m1 m2 -- | Crossover. The first argument is the fittest genome. -crossover :: MonadRandom m => Parameters -> Genome -> Genome -> m Genome -crossover params g1 g2 = Genome `liftM` newNodes `ap` newConns `ap` return newNextNode +crossover :: MonadRandom m => MutParams -> Genome -> Genome -> m Genome +crossover params g1 g2 = Genome 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) @@ -342,15 +399,15 @@ -- | Breed two genomes together breed :: (MonadRandom m, MonadFresh InnoId m) => - Parameters -> Map ConnSig InnoId -> Genome -> Genome -> + MutParams -> Map ConnSig InnoId -> Genome -> Genome -> m (Map ConnSig InnoId, Genome) breed params innos g1 g2 = crossover params g1 g2 >>= mutate params innos -- | Gets differences where they exist -differences :: Map InnoId ConnGene -> Map InnoId ConnGene -> Map InnoId Double -differences = M.mergeWithKey (\_ c1 c2 -> Just $ oneDiff c1 c2) (const M.empty) (const M.empty) +differences :: IntMap ConnGene -> IntMap ConnGene -> IntMap Double +differences = IM.mergeWithKey (\_ c1 c2 -> Just $ oneDiff c1 c2) (const IM.empty) (const IM.empty) where oneDiff c1 c2 = abs $ connWeight c1 - connWeight c2 @@ -364,22 +421,23 @@ weightDiffs = differences conns1 conns2 - weightFactor = M.foldl (+) 0 weightDiffs / fromIntegral (M.size weightDiffs) + weightFactor = IM.foldl (+) 0 weightDiffs / fromIntegral (IM.size weightDiffs) - ids1 = M.keysSet conns1 - ids2 = M.keysSet conns2 + ids1 = IM.keysSet conns1 + ids2 = IM.keysSet conns2 + -- | The lower of the top bounds of innovation numbers - edge = min (S.findMax ids1) (S.findMax ids2) + edge = min (IS.findMax ids1) (IS.findMax ids2) -- | Excess and Disjoint - exJoints = (ids1 `S.difference` ids2) `S.union` (ids2 `S.difference` ids1) + exJoints = (ids1 `IS.difference` ids2) `IS.union` (ids2 `IS.difference` ids1) - (excess, disjoint) = S.partition (<= edge) exJoints + (excess, disjoint) = IS.partition (>= edge) exJoints - exFactor = fromIntegral $ S.size excess + exFactor = fromIntegral $ IS.size excess - disFactor = fromIntegral $ S.size disjoint + disFactor = fromIntegral $ IS.size disjoint graphParams :: GraphvizParams NodeId NodeGene Double Rational Rational @@ -396,7 +454,7 @@ , clusterID = iderizer , fmtCluster = clusterizer , fmtNode = const [] - , fmtEdge = \(_,_,w) -> [ toLabel w ] + , fmtEdge = \(_,_,w) -> [ toLabel $ (printf "%.2f" w :: String) ] } where categorizer (nId, ng) = C (yHint ng) (N (nId, yHint ng)) iderizer 0 = Str "Input Layer" @@ -425,7 +483,63 @@ -- else that there really is a problem. renderGenome :: Genome -> IO () renderGenome g = runGraphvizCanvas Dot graph Xlib - where nodes = M.toList . nodeGenes $ g - edges = mapMaybe mkEdge . M.elems . connGenes $ g + where nodes = map (first NodeId) . IM.toList . nodeGenes $ g + edges = mapMaybe mkEdge . IM.elems . connGenes $ g mkEdge ConnGene{..} = if connEnabled then Just (connIn, connOut, connWeight) else Nothing graph = graphElemsToDot graphParams nodes edges + + +-- | A nicer way to display a 'Genome' than the Show instance. +printGenome :: Genome -> IO () +printGenome g = putStrLn $ unlines stuff + where unwrap (NodeId x) = x + eText True = "" + eText False = "(Disabled)" + stuff = [header, nHeader] ++ nInfo ++ [cHeader] ++ cInfo + header = "Genetic Info:" + nHeader = "Nodes:" + nInfo = map mkNInfo . IM.toList $ nodeGenes g + mkNInfo (x, NodeGene t _) = show x ++ "(" ++ show t ++ ")" + cHeader = "\n\nConnections:" + cInfo = map mkCInfo . IM.toList $ connGenes g + mkCInfo (i, ConnGene{..}) = + "\nInnovation " ++ show i ++ + "\nConnection from " ++ show (unwrap connIn) ++ " to " ++ + show (unwrap connOut) ++ " " ++ eText connEnabled ++ + " with weight " ++ show connWeight + + +-- | Parameters for search. The type parameter determines the intermediate +-- type for determining if a solution is valid. +data GenScorer score = + GS { gScorer :: Genome -> score -- ^ Scoring function + , fitnessFunction :: score -> Double -- ^ Convert the score to a fitness + , winCriteria :: score -> Bool -- ^ Determines if a result is win + } + + +uniq :: Ord a => [a] -> Bool +uniq = go S.empty + where go _ [] = True + go set (x:xs) = not (S.member x set) && go (S.insert x set) xs + + +-- | Validates a 'Genome', returning Nothing on success. +validateGenome :: Genome -> Maybe [String] +validateGenome Genome{..} = case errRes of + [] -> Nothing + xs -> Just xs + where nodeOk = case IM.maxViewWithKey nodeGenes of + Nothing -> Nothing + Just ((nid,_), _) + | nid < getNodeId nextNode -> Nothing + | otherwise -> Just "NodeId too low" + connOk (ConnSig (NodeId n1) (NodeId n2)) + | IM.member n1 nodeGenes && IM.member n2 nodeGenes = Nothing + | otherwise = Just "Connection gene between nonexistent nodes" + connsOk = join . listToMaybe $ map connOk sigList + sigList = map toConnSig . IM.elems $ connGenes + nonDup + | uniq sigList = Nothing + | otherwise = Just "Non unique connection signatures" + errRes = catMaybes [nodeOk, connsOk, nonDup] diff --git a/src/Neet/Network.hs b/src/Neet/Network.hs --- a/src/Neet/Network.hs +++ b/src/Neet/Network.hs @@ -42,18 +42,21 @@ , stepNetwork , snapshot -- ** Output + , pushThrough , getOutput ) where -import Data.Map (Map) import Data.Set (Set) import qualified Data.Set as S -import qualified Data.Map as M -import Data.List (foldl') +import Data.List (sortBy, foldl') +import qualified Data.IntMap as IM +import Data.IntMap (IntMap) + import Neet.Genome +import Data.Function -- | Modified sigmoid function from the original NEAT paper modSig :: Double -> Double @@ -62,9 +65,10 @@ -- | A single neuron data Neuron = - Neuron { activation :: Double -- ^ The current activation - , connections :: Map NodeId Double -- ^ The inputs to this Neuron - , yHint :: Rational -- ^ Visualization height + Neuron { activation :: Double -- ^ The current activation + , connections :: IntMap Double -- ^ The inputs to this Neuron + , yHeight :: Rational -- ^ Visualization height + , neurType :: NodeType -- ^ Type, used in pushThrough } deriving (Show) @@ -73,7 +77,7 @@ data Network = Network { netInputs :: [NodeId] -- ^ Which nodes are inputs , netOutputs :: [NodeId] -- ^ Which nodes are outputs - , netState :: Map NodeId Neuron + , netState :: IntMap Neuron , netDepth :: Int -- ^ Upper bound on depth } deriving (Show) @@ -81,24 +85,24 @@ -- | Takes the previous step's activations and current inputs and gives a -- function to update a neuron. -stepNeuron :: Map NodeId Double -> Neuron -> Neuron -stepNeuron acts (Neuron _ conns yh) = Neuron (modSig weightedSum) conns yh - where oneFactor nId w = (acts M.! nId) * w - weightedSum = M.foldlWithKey' (\acc k w -> acc + oneFactor k w) 0 conns +stepNeuron :: IntMap Double -> Neuron -> Neuron +stepNeuron acts (Neuron _ conns yh nt) = Neuron (modSig weightedSum) conns yh nt + where oneFactor nId w = (acts IM.! nId) * w + weightedSum = IM.foldlWithKey' (\acc k w -> acc + oneFactor k w) 0 conns -- | Steps a network one step. Takes the network and the current input, minus -- the bias. stepNetwork :: Network -> [Double] -> Network stepNetwork net@Network{..} ins = net { netState = newNeurons } - where pairs = zip netInputs (ins ++ [1]) + where pairs = zipWith (\x y -> (getNodeId x, y)) netInputs (ins ++ [1]) - acts = M.map activation netState + acts = IM.map activation netState -- | The previous state, except updated to have new inputs - modState = foldl' (flip $ uncurry M.insert) acts pairs + modState = foldl' (flip $ uncurry IM.insert) acts pairs - newNeurons = M.map (stepNeuron modState) netState + newNeurons = IM.map (stepNeuron modState) netState -- | Steps a network for at least its depth @@ -108,34 +112,57 @@ go n ds = stepNetwork (go (n - 1) ds) ds +-- | Specialized 'snapshot' for nonrecurrent nets. Will break on recurrent +-- connections. +pushThrough :: Network -> [Double] -> [Double] +pushThrough net inputs = output + where nodeOrder = sortBy (compare `on` (yHeight . snd)) $ IM.toList nodeMap + + nodeMap = netState net + + nonInputs = filter (\p -> neurType (snd p) /= Input) nodeOrder + + inPairs = zip (map getNodeId $ netInputs net) (inputs ++ [1]) + + initState = foldl' (flip $ uncurry IM.insert) IM.empty inPairs + + addOne :: IntMap Double -> (Int, Neuron) -> IntMap Double + addOne acc (nId, neur) = + IM.insert nId (activation (stepNeuron acc neur)) acc + + final = foldl' addOne initState nonInputs + + output = map ((final IM.!) . getNodeId) (netOutputs net) + + mkPhenotype :: Genome -> Network -mkPhenotype Genome{..} = (M.foldl' addConn nodeHusk connGenes) { netInputs = ins - , netOutputs = outs - , netDepth = dep } - where addNode n@(Network _ _ s _) nId (NodeGene _ yh) = - n { netState = M.insert nId (Neuron 0 M.empty yh) s +mkPhenotype Genome{..} = (IM.foldl' addConn nodeHusk connGenes) { netInputs = map NodeId ins + , netOutputs = map NodeId outs + , netDepth = dep } + where addNode n@(Network _ _ s _) nId (NodeGene nt yh) = + n { netState = IM.insert nId (Neuron 0 IM.empty yh nt) s } - ins = M.keys . M.filter (\ng -> nodeType ng == Input) $ nodeGenes - outs = M.keys . M.filter (\ng -> nodeType ng == Output) $ nodeGenes + ins = IM.keys . IM.filter (\ng -> nodeType ng == Input) $ nodeGenes + outs = IM.keys . IM.filter (\ng -> nodeType ng == Output) $ nodeGenes -- | Network without connections added - nodeHusk = M.foldlWithKey' addNode (Network [] [] M.empty 0) nodeGenes + nodeHusk = IM.foldlWithKey' addNode (Network [] [] IM.empty 0) nodeGenes depthSet :: Set Rational - depthSet = M.foldl' (flip S.insert) S.empty $ M.map Neet.Genome.yHint nodeGenes + depthSet = IM.foldl' (flip S.insert) S.empty $ IM.map Neet.Genome.yHint nodeGenes dep = S.size depthSet - addConn2Node nId w (Neuron a cs yh) = Neuron a (M.insert nId w cs) yh + addConn2Node nId w (Neuron a cs yh nt) = Neuron a (IM.insert nId w cs) yh nt addConn net@Network{ netState = s } ConnGene{..} | not connEnabled = net | otherwise = - let newS = M.adjust (addConn2Node connIn connWeight) connOut s + let newS = IM.adjust (addConn2Node (getNodeId connIn) connWeight) (getNodeId connOut) s in net { netState = newS } -- | Gets the output of the current state getOutput :: Network -> [Double] -getOutput Network{..} = map (activation . (netState M.!)) netOutputs +getOutput Network{..} = map (activation . (netState IM.!) . getNodeId) netOutputs diff --git a/src/Neet/Parameters.hs b/src/Neet/Parameters.hs --- a/src/Neet/Parameters.hs +++ b/src/Neet/Parameters.hs @@ -27,28 +27,29 @@ Portability : portable -} -module Neet.Parameters (Parameters(..), DistParams(..), defParams, defDP, smallParams ) where +module Neet.Parameters ( Parameters(..) + , DistParams(..) + , MutParams(..) + , defParams + , defDistParams + , defMutParams + , defMutParamsS + ) where -- | The genetic parameters data Parameters = - Parameters { mutWeightRate :: Double -- ^ How often weights are mutated - , newWeightRate :: Double -- ^ How often weights are replaced if mutated - , pertAmount :: Double -- ^ Max amount of perturbation - , 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 - , largeSize :: Int -- ^ The minimum size for a species to be considered large - , disableChance :: Double -- ^ How likely that a disabled parent results - -- in a disabled child - , 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. - , noCrossover :: Double -- ^ Percent of population that mutates without crossover + 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. } deriving (Show) +-- | Distance Parameters data DistParams = DistParams { dp1 :: Double -- ^ Coefficient to the number of excess genes , dp2 :: Double -- ^ Coefficient to the number of disjoint genes @@ -58,29 +59,53 @@ deriving (Show) +-- | Mutation Parameters +data MutParams = + MutParams { mutWeightRate :: Double -- ^ How often weights are mutated + , newWeightRate :: Double -- ^ How often weights are replaced if mutated + , pertAmount :: Double -- ^ Max amount of perturbation + , 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 + , 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 + -- in a disabled child + } + deriving (Show) + + +-- | Mutation parameters for defParams +defMutParams :: MutParams +defMutParams = + MutParams { mutWeightRate = 0.8 + , newWeightRate = 0.1 + , pertAmount = 2.5 + , weightRange = 2.5 + , addConnRate = 0.3 + , addNodeRate = 0.03 + , recurrencies = False + , noCrossover = 0.25 + , disableChance = 0.75 + } + + -- | The parameters used in the original NEAT paper, except the perturbation amount -- and threshold for size. defParams :: Parameters defParams = - Parameters { mutWeightRate = 0.8 - , newWeightRate = 0.1 - , pertAmount = 0.1 -- This value I made up - , weightRange = 10 -- This one too - , addConnRate = 0.3 - , addNodeRate = 0.03 + Parameters { mutParams = defMutParams + , mutParamsS = defMutParamsS , largeSize = 20 - , disableChance = 0.75 - , distParams = defDP + , distParams = defDistParams , dropTime = Just 15 - , noCrossover = 0.25 } --- | Parameters used in the paper for small populations -smallParams :: Parameters -smallParams = defParams { addConnRate = 0.05 } +defMutParamsS :: MutParams +defMutParamsS = defMutParams { addConnRate = 0.05 } -- | Parameters used for distance in the paper -defDP :: DistParams -defDP = DistParams 1 1 0.4 3 +defDistParams :: DistParams +defDistParams = DistParams 1 1 0.4 3 diff --git a/src/Neet/Population.hs b/src/Neet/Population.hs --- a/src/Neet/Population.hs +++ b/src/Neet/Population.hs @@ -35,6 +35,7 @@ {-# LANGUAGE BangPatterns #-} module Neet.Population ( Population(..) + , SpecId(..) -- * PopM , PopM , PopContext @@ -46,6 +47,10 @@ , trainOnce , trainN , trainUntil + -- * Statistics + , speciesCount + -- * Debugging + , validatePopulation ) where import Neet.Species @@ -58,7 +63,7 @@ import Data.Map (Map) import qualified Data.Map as M -import Data.List (foldl', maximumBy) +import Data.List (foldl', maximumBy, sortBy) import Data.Maybe @@ -69,7 +74,7 @@ import Control.Applicative import Control.Monad - +import Control.Parallel.Strategies import Data.Function @@ -87,7 +92,7 @@ , popCont :: !PopContext -- ^ Tracking state and fresh values , nextSpec :: !SpecId -- ^ The next species ID , popParams :: Parameters -- ^ Parameters for large species - , popParamsS :: Parameters -- ^ Parameters for small species + , popGen :: Int -- ^ Current generation } deriving (Show) @@ -134,7 +139,8 @@ , psInputs :: Int -- ^ Number of inputs , psOutputs :: Int -- ^ Number of outputs , psParams :: Parameters -- ^ Parameters for large species - , psParamsS :: Parameters -- ^ Parameters for small species + , sparse :: Maybe Int -- ^ If Just n, will be sparse with n connections. + -- Otherwise fully connected. } deriving (Show) @@ -199,16 +205,20 @@ newSpecies (SB sId _ (g:gs)) = Just $ (sId, newSpec g gs) --- | Generates a fully connected starter population, given a seed. +-- | Generates a starter population newPop :: Int -> PopSettings -> Population newPop seed PS{..} = fst $ runPopM generate initCont - where popSize = psSize + where Parameters{..} = psParams + popSize = psSize popBScore = 0 popBSpec = SpecId 1 initCont = PC (InnoId $ psInputs * psOutputs + 2) (mkStdGen seed) popParams = psParams - popParamsS = psParamsS - generateGens = replicateM psSize (fullConn psParams psInputs psOutputs) + orgGenner = case sparse of + Nothing -> fullConn mutParams + Just conCount -> sparseConn mutParams conCount + generateGens = replicateM psSize (orgGenner psInputs psOutputs) + popGen = 1 generate = do gens <- generateGens let (popSpecs, nextSpec) = runSpecM (speciate psParams M.empty gens) (SpecId 1) @@ -217,29 +227,40 @@ return Population{..} --- | Advances the population one generation with the fitness function. -trainOnce :: (Genome -> Double) -> Population -> Population -trainOnce f pop = generated +-- | Advances the population one generation with the fitness function, possibly +-- giving a solution. +trainOnce :: GenScorer a -> Population -> (Population, Maybe Genome) +trainOnce scorer pop = (generated, msolution) where params = popParams pop - paramsS = popParamsS pop - chooseParams :: Species -> Parameters - chooseParams s = if specSize s >= largeSize params then params else paramsS + mParams = mutParams params + mParamsS = mutParamsS params + + chooseParams :: Species -> MutParams + chooseParams s = if specSize s >= largeSize params then mParams else mParamsS {-# INLINE chooseParams #-} initSpecs = popSpecs pop + oneEval :: Strategy (Species, TestResult) + oneEval = evalTuple2 r0 rseq + -- | Map to fitness data from runFitTest - fits = M.map (\sp -> (sp, runFitTest f sp)) initSpecs + fits = M.map (\sp -> (sp, runFitTest scorer sp)) initSpecs `using` parTraversable oneEval + msolution = go $ map (trSol . snd) $ M.elems fits + where go [] = Nothing + go (Just x:_) = Just x + go (_:xs) = go xs + -- | Whether a species deserves to live (did it improve recently?) - eugenics :: SpecId -> (Species, (MultiMap Double Genome, SpecScore, Double)) -> + eugenics :: SpecId -> (Species, TestResult) -> Maybe (Species, MultiMap Double Genome, Double) - eugenics sId (sp, (fitmap, ss, adj)) + eugenics sId (sp, TR{..}) | maybe False (lastImprovement nSpec >=) (dropTime params) && sId /= popBSpec pop = Nothing - | otherwise = Just (nSpec, fitmap, adj) - where nSpec = updateSpec ss sp + | otherwise = Just (nSpec, trScores, trAdj) + where nSpec = updateSpec trSS sp -- | Species that have improved recently enough. masterRace :: Map SpecId (Species, MultiMap Double Genome, Double) @@ -269,25 +290,29 @@ dubSize = fromIntegral totalSize -- | Distribution of species. - candSpecs :: MonadRandom m => [(Parameters, Int, m Genome)] + candSpecs :: MonadRandom m => [(MutParams, Int, m (Double,Genome))] candSpecs = zip3 ps realShares pickers - where initShares = map share masterList - share (_,(_, _, adj)) = round $ adj / totalFitness * dubSize + 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 remaining = totalSize - foldl' (+) 0 initShares distributeRem _ [] = error "Should run out of numbers first" distributeRem n l@(x:xs) | n > 0 = x + 1 : distributeRem (n - 1) xs + | n < 0 = error "Remainder should be positive" | otherwise = l realShares = distributeRem remaining initShares - pickers :: MonadRandom m => [m Genome] - pickers = map picker masterList + pickers :: MonadRandom m => [m (Double, Genome)] + pickers = map picker sortedMaster where picker (_,(s, mmap, _)) = let numToTake = specSize s `div` 5 + 1 desc = M.toDescList $ MM.toMap mmap toPairs (k, vs) = map (\v -> (k,v)) vs culled = take numToTake $ desc >>= toPairs - in fromList . map (\(d,g) -> (g, toRational d)) $ culled - ps = map (\(_,(s,_,_)) -> chooseParams s) masterList + in uniform culled + ps = map (\(_,(s,_,_)) -> chooseParams s) sortedMaster applyN :: Monad m => Int -> (a -> m a) -> a -> m a applyN 0 _ x = return x @@ -295,23 +320,30 @@ -- | Generate the genomes for a species specGens :: (MonadFresh InnoId m, MonadRandom m) => - (Parameters, Int, m Genome) -> m [Genome] - specGens (p, n, gen) = liftM snd $ applyN n genOne (M.empty, []) + 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 + (_,parent) <- gen (innos', g) <- mutate p innos parent return (innos', g:gs) else do - mom <- gen - dad <- gen - (innos', g) <- breed p innos mom dad + (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 $ mapM specGens candSpecs + allGens = liftM (concat . snd) $ foldM ag' (M.empty, []) candSpecs + where ag' (innos, cands) cand = do + (innos', specGen) <- specGens innos cand + return $ (innos', specGen:cands) + genNewSpecies :: (MonadRandom m, MonadFresh InnoId m) => m (Map SpecId Species, SpecId) genNewSpecies = do @@ -338,26 +370,48 @@ , popBSpec = bSpec , popCont = cont' , nextSpec = nextSpec' + , popGen = popGen pop + 1 } -- | Train the population n times. Values less than 1 return the original. -trainN :: Int -> (Genome -> Double) -> Population -> Population -trainN n f p +trainN :: Int -> GenScorer a -> Population -> Population +trainN n scorer p | n <= 0 = p - | otherwise = applyN n (trainOnce f) p + | otherwise = applyN n (trainOnce scorer) p where applyN 0 _ !x = x - applyN n' h !x = applyN (n' - 1) h (h x) + applyN n' h !x = applyN (n' - 1) h (fst $ h x) --- | Train until the given fitness (first parameter) is reached, or the max number --- of generations (second parameter) is reached. Also gives generations needed. -trainUntil :: Double -> Int -> (Genome -> Double) -> Population -> (Population, Int) -trainUntil goal n f p - | n <= 0 = (p, 0) +-- | Train until the provided goal is reached, or the max number +-- of generations (first parameter) is reached. Possibly also returns a solution +-- and the number of generations elapsed. +trainUntil :: Int -> GenScorer a -> Population -> (Population, Maybe (Genome, Int)) +trainUntil n f p + | n <= 0 = (p, Nothing) | otherwise = go n p - where go 0 !p' = (p', n) - go n' !p' - | reached = (p', n - n') - | otherwise = go (n' - 1) (trainOnce f p') - where reached = popBScore p' >= goal + where go 0 !p' = (p', Nothing) + go n' !p' = case trainOnce f p' of + (p'', Nothing) -> go (n' - 1) p'' + (p'', Just g) -> (p'', Just (g, n - n')) + + +-- | Gets the number of species +speciesCount :: Population -> Int +speciesCount Population{..} = M.size popSpecs + + +-- | Validate a population, possibly returning a list of errors +validatePopulation :: Population -> Maybe [String] +validatePopulation Population{..} = case errRes of + [] -> Nothing + xs -> Just xs + where totalSSize = M.foldl' (\acc x -> specSize x + acc) 0 popSpecs + goodSize + | totalSSize == popSize = [] + | otherwise = ["Population size differs from actual size"] + goodSId + | (not . M.null) popSpecs && fst (M.findMax popSpecs) < nextSpec = [] + | otherwise = ["SpecId lower than extant species"] + specErrs = concat . M.elems $ M.mapMaybe validateSpecies popSpecs + errRes = goodSId ++ goodSize ++ specErrs diff --git a/src/Neet/Species.hs b/src/Neet/Species.hs --- a/src/Neet/Species.hs +++ b/src/Neet/Species.hs @@ -28,22 +28,34 @@ -} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} module Neet.Species ( Species(..) , SpecScore(..) -- * Construction , newSpec -- * Update/Fitness + , TestResult(..) , runFitTest , updateSpec + -- * Statistics + , maxDist + -- * Debugging + , validateSpecies ) where import Neet.Genome +import Neet.Parameters + import Data.MultiMap (MultiMap) import qualified Data.MultiMap as MM import Data.List (foldl') +import Data.Maybe +import Control.Applicative ((<$>), (<*>)) + + -- | A NEAT Species. data Species = Species { specSize :: Int @@ -54,7 +66,7 @@ -- | Scoring data -data SpecScore = SpecScore { bestScore :: Double, bestGen :: Genome } +data SpecScore = SpecScore { bestScore :: !Double, bestGen :: !Genome } instance Show Species where @@ -70,13 +82,31 @@ newSpec gen gens = Species (length gens + 1) (gen:gens) (SpecScore 0 gen) 0 +-- | A result of evaluating a species +data TestResult = + TR { trScores :: MultiMap Double Genome -- ^ The score of each organism + , trSS :: !SpecScore -- ^ Result 'SpecScore' + , trAdj :: !Double -- ^ Total adjusted fitness + , trSol :: !(Maybe Genome) -- ^ Possible Solution + } + +findMay :: (a -> Bool) -> [a] -> Maybe a +findMay _ [] = Nothing +findMay p (a:as) + | p a = Just a + | otherwise = findMay p as + + -- | Output the result of testing fitness. Last value is the total adjusted fitness -runFitTest :: (Genome -> Double) -> Species -> (MultiMap Double Genome, SpecScore, Double) -runFitTest f Species{..} = (mmap, ss, totF / dubSize) +runFitTest :: GenScorer a -> Species -> TestResult +runFitTest GS{..} Species{..} = TR mmap ss (totF / dubSize) msolution where dubSize = fromIntegral specSize :: Double - (mmap, totF) = foldl' accumOne (MM.empty, 0) $ map calcOne specOrgs - calcOne g = let fitness = f g in (fitness, g) - accumOne (accM, accA) (fit, g) = (MM.insert fit g accM, accA + fit) + (mmap, totF) = foldl' accumOne (MM.empty, 0) resses + calcOne g = let !score = gScorer g in (score, g) + resses = map calcOne specOrgs + msolution = fmap snd . findMay (\pair -> winCriteria (fst pair)) $ resses + accumOne (accM, accA) (score, g) = (MM.insert fit g accM, accA + fit) + where fit = fitnessFunction score ss = case MM.findMaxWithValues mmap of Nothing -> error "(runFitTest) folding fitness resulted in empty map!" Just (scr, (x:_)) -> SpecScore scr x @@ -92,3 +122,19 @@ (newScr, li) | bestScore ss > bestScore oldScr = (ss, 0) | otherwise = (oldScr, lastImprovement spec + 1) + + +-- | Validates a species, possibly returning errors +validateSpecies :: Species -> Maybe [String] +validateSpecies Species{..} = case orgErrs ++ goodSize of + [] -> Nothing + xs -> Just xs + where orgErrs = concat $ mapMaybe validateGenome specOrgs + goodSize + | specSize == length specOrgs = [] + | otherwise = ["Species size differs from number of organisms"] + + +-- | Gets the max distance between two genomes in a species +maxDist :: Parameters -> Species -> Double +maxDist ps Species{..} = maximum . map (uncurry (distance ps)) $ (,) <$> specOrgs <*> specOrgs