neet 0.3.1.0 → 0.4.0.0

raw patch · 4 files changed

+80/−36 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• neet.cabal +1/−1
• src/Neet/Examples/XOR.hs +3/−1
• src/Neet/Population.hs +59/−17
• src/Neet/Species.hs +17/−17

@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/  name:                neet-version:             0.3.1.0+version:             0.4.0.0 synopsis:            A NEAT library for Haskell -- description:          homepage:            https://github.com/raymoo/NEET

@@ -33,6 +33,8 @@ import Neet import Neet.Species +import Data.Monoid+ import qualified Data.Map.Strict as M  import System.Random@@ -118,7 +120,7 @@ xorLoop :: Population -> IO (Population, Genome) xorLoop pop = do   printInfo pop-  let (pop', mg) = trainOnce xorFit pop+  let (First mg, pop') = trainOnce (winTrain xorFit) pop   case mg of    Nothing -> xorLoop pop'    Just g -> return (pop',g)

@@ -33,6 +33,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-} module Neet.Population (                          Population(..)                        , SpecId(..)@@ -45,8 +46,14 @@                        , newPop                          -- * Training                        , trainOnce+                       , TrainMethod(..)+                         -- ** TrainMethods+                       , pureTrain+                       , winTrain+                         -- ** Convenience                        , trainN                        , trainUntil+                       , trainPure                          -- * Statistics                        , speciesCount                          -- * Debugging@@ -58,15 +65,19 @@ import Neet.Parameters  import Data.MultiMap (MultiMap)+ import qualified Data.MultiMap as MM  import Data.Map (Map) import qualified Data.Map as M -import Data.List (foldl', maximumBy, sortBy, mapAccumL)+import Data.List (foldl', maximumBy, sortBy)  import Data.Maybe+import Data.Monoid +import Data.Functor.Identity+ import Control.Monad.Random import Control.Monad.Fresh.Class import Control.Monad.Trans.State@@ -74,6 +85,8 @@ import Control.Applicative import Control.Monad +import Data.Traversable+ import Control.Parallel.Strategies  import Data.Function@@ -99,6 +112,29 @@   deriving (Show)  +-- | Describes how to handle each species or genome when processing fitness,+-- allowing the addition of additional effects+newtype TrainMethod f =+  TrainMethod { tmGen :: forall t. Traversable t => t Genome -> f (t Double)+                -- ^ How to process each 'Genome' of a species into a score.+              }+++-- | Train method without any additional effects+pureTrain :: GenScorer a -> TrainMethod Identity+pureTrain gs = TrainMethod go+  where go gmap = Identity $ fmap (fitnessFunction gs . gScorer gs) gmap+++-- | Train method that possibly returns a solution+winTrain :: GenScorer a -> TrainMethod ((,) (First Genome))+winTrain gs = TrainMethod (traverse go)+  where go genome+          | winCriteria gs score = (First (Just genome), fitnessFunction gs score)+          | otherwise = (First Nothing, fitnessFunction gs score)+          where score = gScorer gs genome++ data PopContext =   PC { nextInno :: InnoId      , randGen  :: StdGen@@ -235,10 +271,15 @@           return Population{..}  +trainOnce :: Applicative f => TrainMethod f -> Population -> f Population+trainOnce method pop = fmap (flip trainOnceWFits pop) $ specRes+  where specRes = traverse (runFitTestWStrategy (tmGen method)) (popSpecs pop)++ -- | 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)+trainOnceWFits :: Map SpecId TestResult -> Population -> Population+trainOnceWFits tResults pop = generated   where params = popParams pop          mParams = mutParams params@@ -271,12 +312,8 @@         oneEval = evalTuple2 r0 rseq          -- | Map to fitness data from runFitTest-        fits = M.map (\sp -> (sp, runFitTest scorer sp)) initSpecs `using` parTraversable oneEval+        fits = M.intersectionWith (,) initSpecs tResults `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, TestResult) ->@@ -426,14 +463,19 @@   -- | Train the population n times. Values less than 1 return the original.-trainN :: Int -> GenScorer a -> Population -> Population-trainN n scorer p-  | n <= 0 = p-  | otherwise = applyN n (trainOnce scorer) p-  where applyN 0  _ !x = x-        applyN n' h !x = applyN (n' - 1) h (fst $ h x)+trainN :: (Applicative f, Monad f) =>+          TrainMethod f -> Int -> Population -> f Population+trainN tm n p+  | n <= 0 = return p+  | otherwise = applyN n (trainOnce tm) (return p)+  where applyN n' h !x = iterate (>>= h) x !! n'  +-- | Train without effects+trainPure :: GenScorer a -> Population -> Population+trainPure gs pop = runIdentity $ trainOnce (pureTrain gs) pop++ -- | 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.@@ -442,9 +484,9 @@   | n <= 0 = (p, Nothing)   | otherwise = go n p   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'))+        go n' !p' = case trainOnce (winTrain f) p' of+                     (First Nothing, p'') -> go (n' - 1) p''+                     (First (Just g), p'') -> (p'', Just (g, n - n'))   -- | Gets the number of species

@@ -29,6 +29,7 @@  {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-} module Neet.Species (                       Species(..)                     , SpecScore(..)@@ -36,7 +37,7 @@                     , newSpec                       -- * Update/Fitness                     , TestResult(..)-                    , runFitTest+                    , runFitTestWStrategy                     , updateSpec                       -- * Statistics                     , maxDist@@ -53,6 +54,7 @@ import qualified Data.MultiMap as MM import Data.List (foldl') import Data.Maybe+import Data.Traversable (Traversable)  import Control.Applicative ((<$>), (<*>)) @@ -86,28 +88,26 @@ -- | 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+     , trSS     :: !SpecScore             -- ^ Result 'SpecScore'+     , trAdj    :: !Double                -- ^ Total adjusted fitness      } -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. The first argument tells how to process+-- each genome, with extra effects possible. If you don't need that, you can just+-- 'fmap' over your fitness function and put Identity over the result.+runFitTestWStrategy :: Functor f =>+                       (forall t. Traversable t =>  t Genome -> f (t Double)) -> Species -> f TestResult+runFitTestWStrategy strat spec = fmap (flip runFitTestWithScores spec) $ strat (specOrgs spec) --- | Output the result of testing fitness. Last value is the total adjusted fitness-runFitTest :: GenScorer a -> Species -> TestResult-runFitTest GS{..} Species{..} = TR mmap ss (totF / dubSize) msolution++-- | "Helper function" for runFitTestWStrategy+runFitTestWithScores :: [Double] -> Species -> TestResult+runFitTestWithScores fitList Species{..} = TR mmap ss (totF / dubSize)   where dubSize = fromIntegral specSize :: Double         (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+        resses = zip fitList specOrgs+        accumOne (accM, accA) (score, g) = (MM.insert score g accM, accA + score)         ss = case MM.findMaxWithValues mmap of               Nothing -> error "(runFitTest) folding fitness resulted in empty map!"               Just (scr, (x:_)) -> SpecScore scr x