Update plant code from database, if there is active code
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 24 Jun 2009 06:53:27 +0000 (08:53 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Wed, 24 Jun 2009 06:57:52 +0000 (08:57 +0200)
src/Lseed/DB.hs
src/dbclient.hs
src/dbscorer.hs

index 5cdaf4c..e28445a 100644 (file)
@@ -1,6 +1,7 @@
 module Lseed.DB 
        ( DBCode(..)
        , getCodeToRun
+       , getUpdatedCodeFromDB
        , addFinishedSeasonResults
        ) where
 
@@ -11,6 +12,7 @@ import qualified Data.Map as M
 
 import Lseed.Data
 import Lseed.Data.Functions
+import Data.Maybe
 
 data DBCode = DBCode
        { dbcUserName :: String
@@ -42,6 +44,19 @@ getCodeToRun = withLseedDB $ \conn -> do
                       (fromSql (m ! "plantid"))
                       (fromSql (m ! "code"))
 
+getUpdatedCodeFromDB :: Integer -> IO (Maybe DBCode)
+getUpdatedCodeFromDB userid = withLseedDB $ \conn -> do
+       let query = "SELECT plant.ID AS plantid, user.ID AS userid, code, plant.Name AS plantname, user.Name AS username from plant, user WHERE user.NextSeed = plant.ID AND user.ID = ?;"
+       stmt <- prepare conn query
+       execute stmt [toSql userid]
+       result <- fetchAllRowsMap' stmt
+       return $ listToMaybe $ flip map result $ \m -> 
+               DBCode (fromSql (m ! "username"))
+                      (fromSql (m ! "userid"))
+                      (fromSql (m ! "plantname"))
+                      (fromSql (m ! "plantid"))
+                      (fromSql (m ! "code"))
+
 addFinishedSeasonResults garden = withLseedDB $ \conn -> do 
        let owernerscore = M.toList $ foldr go M.empty garden
                where go p = M.insertWith (+) (plantOwner p) (plantLength (phenotype p))
index d020cd2..9e766bb 100644 (file)
@@ -8,12 +8,15 @@ import Control.Applicative
 import Control.Monad
 import Text.Printf
 
-getGarden = spread <$> map (either (error.show) id . parseGrammar "" . dbcCode)
-                  <$> getCodeToRun
+dbc2genome = either (error.show) id . parseGrammar "" . dbcCode
+
+getDBGarden = spread <$> map dbc2genome <$> getCodeToRun
   where spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g inititalPlant) gs [0..]
          where l = fromIntegral (length gs)
 
+getDBUpdate planted = maybe (genome planted) dbc2genome <$>
+                      getUpdatedCodeFromDB (plantOwner planted)
+
 main = do
-       garden <- getGarden
        obs <- cairoObserver
-       lseedMainLoop True obs (constGardenSource garden) 200
+       lseedMainLoop True obs (GardenSource getDBGarden getDBUpdate) 200
index 8aca1ad..411a1d5 100644 (file)
@@ -7,8 +7,7 @@ import Control.Applicative
 import Control.Monad
 import Text.Printf
 
-getGarden = spread <$> map compileDBCode
-                  <$> getCodeToRun
+getDBGarden = spread <$> map compileDBCode <$> getCodeToRun
   where spread gs = zipWith (\(u,g) p -> Planted ((fromIntegral p + 0.5) / l) u g inititalPlant) gs [0..]
          where l = fromIntegral (length gs)
 
@@ -17,6 +16,11 @@ compileDBCode dbc =
                Left err          -> error (show err)
                Right grammarFile -> (dbcUserID dbc, grammarFile)
 
+dbc2genome = either (error.show) id . parseGrammar "" . dbcCode
+
+getDBUpdate planted = maybe (genome planted) dbc2genome <$>
+                      getUpdatedCodeFromDB (plantOwner planted)
+
 scoringObs = nullObserver {
        obFinished = \garden -> do
                forM_ garden $ \planted -> do
@@ -27,6 +31,4 @@ scoringObs = nullObserver {
                addFinishedSeasonResults garden
        }
 
-main = do
-       garden <- getGarden
-       lseedMainLoop False scoringObs (constGardenSource garden) 10
+main = lseedMainLoop False scoringObs (GardenSource getDBGarden getDBUpdate) 10