Do not run forever (rather use bash for that)
[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 import System.Random
14 import System.Random.Shuffle (shuffle')
15
16 randomize l = shuffle' l (length l) <$> newStdGen
17
18 getDBGarden conf = do
19         dbc <- getCodeToRun conf
20         gs <- randomize $ mapMaybe compileDBCode dbc
21         return $ spread gs
22   where spread gs = zipWith (\(u,n,g) p ->
23                  Planted ((fromIntegral p + 0.5) / l)
24                          u
25                          n
26                          g
27                          inititalPlant
28                 ) gs [0..]
29           where l = fromIntegral (length gs)
30
31 compileDBCode dbc =
32         case  parseGrammar "" (dbcCode dbc) of
33                 Left err          -> Nothing
34                 Right grammarFile -> Just (dbcUserID dbc, dbcUserName dbc, grammarFile)
35
36 dbc2genome = either (const Nothing) Just . parseGrammar "" . dbcCode
37
38 getDBUpdate conf planted = fromMaybe (genome planted) <$>
39                 maybe Nothing dbc2genome <$>
40                 getUpdatedCodeFromDB conf (plantOwner planted)
41
42 scoringObs conf = nullObserver {
43         obFinished = \garden -> do
44                 forM_ garden $ \planted -> do
45                         printf "Plant from %d at %.4f: Total size %.4f\n"
46                                 (plantOwner planted)
47                                 (plantPosition planted)
48                                 (plantLength (phenotype planted))
49                 addFinishedSeasonResults conf garden
50         }
51
52 main = do
53         args <- getArgs
54         case args of
55           [conf] -> do
56                 obs <- cairoObserver
57                 lseedMainLoop True
58                               (obs `mappend` scoringObs conf)
59                               (GardenSource (getDBGarden conf) (getDBUpdate conf))
60                               30
61           _ -> do
62                 putStrLn "L-Seed DB client application."
63                 putStrLn "Please pass DB configuration file on the command line."