More robust against bad code
[L-seed.git] / src / dbclient.hs
1 import Lseed.Data
2 import Lseed.Data.Functions
3 import Lseed.DB
4 import Lseed.Grammar.Parse
5 import Lseed.Mainloop
6 import Lseed.Renderer.Cairo
7 import Control.Applicative
8 import Control.Monad
9 import Text.Printf
10 import System.Environment
11 import Data.Monoid
12 import Data.Maybe
13
14 getDBGarden conf = spread <$> mapMaybe compileDBCode <$> getCodeToRun conf
15   where spread gs = zipWith (\(u,n,g) p ->
16                  Planted ((fromIntegral p + 0.5) / l)
17                          u
18                          n
19                          g
20                          inititalPlant
21                 ) gs [0..]
22           where l = fromIntegral (length gs)
23
24 compileDBCode dbc =
25         case  parseGrammar "" (dbcCode dbc) of
26                 Left err          -> Nothing
27                 Right grammarFile -> Just (dbcUserID dbc, dbcUserName dbc, grammarFile)
28
29 dbc2genome = either (const Nothing) Just . parseGrammar "" . dbcCode
30
31 getDBUpdate conf planted = fromMaybe (genome planted) <$>
32                 maybe Nothing dbc2genome <$>
33                 getUpdatedCodeFromDB conf (plantOwner planted)
34
35 scoringObs conf = nullObserver {
36         obFinished = \garden -> do
37                 forM_ garden $ \planted -> do
38                         printf "Plant from %d at %.4f: Total size %.4f\n"
39                                 (plantOwner planted)
40                                 (plantPosition planted)
41                                 (plantLength (phenotype planted))
42                 addFinishedSeasonResults conf garden
43         }
44
45 main = do
46         args <- getArgs
47         case args of
48           [conf] -> do
49                 obs <- cairoObserver
50                 forever $ lseedMainLoop True
51                               (obs `mappend` scoringObs conf)
52                               (GardenSource (getDBGarden conf) (getDBUpdate conf))
53                               30
54           _ -> do
55                 putStrLn "L-Seed DB client application."
56                 putStrLn "Please pass DB configuration file on the command line."