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.3.1.0 +version: 0.4.0.0 synopsis: A NEAT library for Haskell -- description: homepage: https://github.com/raymoo/NEET diff --git a/src/Neet/Examples/XOR.hs b/src/Neet/Examples/XOR.hs --- a/src/Neet/Examples/XOR.hs +++ b/src/Neet/Examples/XOR.hs @@ -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) diff --git a/src/Neet/Population.hs b/src/Neet/Population.hs --- a/src/Neet/Population.hs +++ b/src/Neet/Population.hs @@ -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 diff --git a/src/Neet/Species.hs b/src/Neet/Species.hs --- a/src/Neet/Species.hs +++ b/src/Neet/Species.hs @@ -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