Make dbclient write results to the DB and run forever
authorJoachim Breitner <mail@joachim-breitner.de>
Thu, 25 Jun 2009 22:18:53 +0000 (00:18 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Thu, 25 Jun 2009 22:18:53 +0000 (00:18 +0200)
src/Lseed/Data.hs
src/dbclient.hs

index 75b1daf..78b6a41 100644 (file)
@@ -7,6 +7,7 @@ import Control.Applicative ((<$>),(<*>),pure)
 import Control.Arrow (second)
 import Data.Monoid
 import System.Time (ClockTime)
+import Data.Monoid
 
 -- | User Tag
 type UserTag = String
@@ -187,3 +188,13 @@ instance Foldable Planted where
 
 instance Traversable Planted where
        sequenceA planted = (\x -> planted { phenotype = x }) <$> sequenceA (phenotype planted)
+
+instance Monoid Observer where
+       mempty = nullObserver
+       obs1 `mappend` obs2 = nullObserver {
+               obInit = obInit obs1 >> obInit obs2,
+               obState = \d g -> obState obs1 d g >> obState obs2 d g,
+               obGrowingState = \f -> obGrowingState obs1 f >> obGrowingState obs2 f,
+               obFinished = \g -> obFinished obs1 g >> obFinished obs2 g
+               }
+       
index 2ca5641..2887235 100644 (file)
@@ -8,6 +8,7 @@ import Control.Applicative
 import Control.Monad
 import Text.Printf
 import System.Environment
+import Data.Monoid
 
 getDBGarden conf = spread <$> map compileDBCode <$> getCodeToRun conf
   where spread gs = zipWith (\(u,n,g) p ->
@@ -28,13 +29,23 @@ dbc2genome = either (error.show) id . parseGrammar "" . dbcCode
 getDBUpdate conf planted = maybe (genome planted) dbc2genome <$>
                       getUpdatedCodeFromDB conf (plantOwner planted)
 
+scoringObs conf = nullObserver {
+       obFinished = \garden -> do
+               forM_ garden $ \planted -> do
+                       printf "Plant from %d at %.4f: Total size %.4f\n"
+                               (plantOwner planted)
+                               (plantPosition planted)
+                               (plantLength (phenotype planted))
+               addFinishedSeasonResults conf garden
+       }
+
 main = do
        args <- getArgs
        case args of
-         [conf] -> do
+         [conf] -> forever $ do
                obs <- cairoObserver
                lseedMainLoop True
-                             obs
+                             (obs `mappend` scoringObs conf)
                              (GardenSource (getDBGarden conf) (getDBUpdate conf))
                              200
          _ -> do