Write a little guyHEADmain

This program is in a weird state right now, but I'm checking it in to
git so that I can back it up, since I want to reinstall again.

1 files changed, 45 insertions, 0 deletions

diff --git a/Evolve.hs b/Evolve.hs
new file mode 100644
index 0000000..a34a382
--- /dev/null
+++ b/Evolve.hs
@@ -0,0 +1,45 @@
+module Evolve (Evolvable, evolve, mutate, score, mutateProbability) where
+
+import qualified System.Random as Random
+import Data.List (maximumBy)
+import qualified Par
+import qualified Control.Monad.State as State
+import RandomState (splits)
+import Data.Function (on)
+import qualified Control.Concurrent.Chan as Chan
+import System.Timeout (timeout)
+import Control.Exception (evaluate)
+
+class Evolvable e where
+  mutate :: Random.RandomGen g => e -> State.State g e
+  score :: e -> Double
+
+numChildren :: Int
+numChildren = 100
+
+printModCount :: Int
+printModCount = 100
+
+scoreTimeout :: Int
+scoreTimeout = 1000
+
+mutateProbability :: Double
+mutateProbability = 0.005
+
+evolve :: (Evolvable e, Show e) => Chan.Chan e -> e -> IO ()
+evolve c e = evolve' 0 c e 0
+
+timeoutScore :: Evolvable e => e -> IO Double
+timeoutScore e = maybe (-1) id <$> timeout scoreTimeout (evaluate (score e))
+
+evolve' :: (Evolvable e, Show e) => Int -> Chan.Chan e -> e -> Double -> IO ()
+evolve' generation chan startState myScore = do gs <- take numChildren . State.evalState splits <$> Random.newStdGen
+                                                childrenScores <- ((myScore, startState) :) <$> Par.mapIO scoreChild gs
+                                                let (bestScore, bestChild) = maximumBy (compare `on` fst) childrenScores
+                                                if generation `mod` printModCount == 0
+                                                  then Chan.writeChan chan bestChild
+                                                  else return ()
+                                                evolve' (succ generation) chan bestChild bestScore
+  where scoreChild g = do let myChild = State.evalState (mutate startState) g
+                          realScore <- timeoutScore myChild
+                          return (realScore, myChild)