neet 0.1.0.0 → 0.2.0.0

raw patch · 8 files changed

+554/−195 lines, 8 filesdep +cerealdep +paralleldep +randomPVP ok

version bump matches the API change (PVP)

Dependencies added: cereal, parallel, random

API changes (from Hackage documentation)

Files

• neet.cabal +4/−3
• src/Neet.hs +39/−0
• src/Neet/Examples/XOR.hs +71/−18
• src/Neet/Genome.hs +180/−66
• src/Neet/Network.hs +54/−27
• src/Neet/Parameters.hs +53/−28
• src/Neet/Population.hs +101/−47
• src/Neet/Species.hs +52/−6

@@ -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 

@@ -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

@@ -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 ""

@@ -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]

@@ -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

@@ -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

@@ -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

@@ -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