Merge branch 'master' of gitosis@git.nomeata.de:L-seed
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 24 Jun 2009 07:47:59 +0000 (09:47 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Wed, 24 Jun 2009 07:47:59 +0000 (09:47 +0200)
.gitignore
src/Lseed/DB.hs
src/Lseed/Data.hs
src/Lseed/Logic.hs
src/Lseed/Mainloop.hs
src/dbclient.hs
src/dbscorer.hs
src/fastScorer.hs
src/main.hs

index c97a6c4..055f20d 100644 (file)
@@ -1 +1,5 @@
 db.conf
+*.hi
+*.o
+dist/
+Setup
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 d06dd1c..75d02d7 100644 (file)
@@ -94,6 +94,15 @@ data Observer = Observer {
        }
 nullObserver = Observer (return ()) (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ())
 
+-- | Methods to get the initial garden and the updated code when a plant multiplies
+data GardenSource = GardenSource {
+       -- | Called at the beginning of a season, to aquire the garden
+         getGarden :: IO (Garden ())
+       -- | Given a plant, returns the genome to be used for a seedling.
+       , getUpdatedCode :: Planted () -> IO GrammarFile
+       }
+constGardenSource :: Garden () -> GardenSource
+constGardenSource garden = GardenSource (return garden) (return . genome)
 
 -- | A complete grammar file
 type GrammarFile = [ GrammarRule ]
index 2524e0a..06cfa5a 100644 (file)
@@ -38,40 +38,38 @@ remainingGrowth getGrowths planted = go (phenotype planted)
                 EnlargingTo l2   -> l2 - l1
                 GrowingSeed done -> (1-done) * seedGrowthCost 
 
+-- | For a GrowingGarden, calculates the current amount of light and then
+-- advance the growth. This ought to be called after applyGenome
 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
-growGarden angle rgen garden = sequence $ zipWith growPlanted garden' lightings
-  where lightings = map (plantTotalSum . fmap snd . phenotype) $ lightenGarden angle garden'
-       garden' = applyGenome angle rgen garden
+growGarden angle rgen garden = sequence $ zipWith growPlanted garden totalLight
+  where totalLight = map (plantTotalSum . fmap snd . phenotype) $ lightenGarden angle garden
 
 -- | For all Growing plants that are done, find out the next step
--- This involves creating new plants if some are done
-applyGenome :: (RandomGen g) => Angle -> g -> GrowingGarden -> GrowingGarden 
-applyGenome angle rgen garden = concat $ zipWith applyGenome' rgens aGarden
+-- If new plants are to be created, these are returned via their position, next
+-- to their parent plant.
+applyGenome :: (RandomGen g) => Angle -> g -> GrowingGarden -> [(GrowingPlanted,[Double])]
+applyGenome angle rgen garden = zipWith applyGenome' rgens aGarden
   where rgens = unfoldr (Just . split) rgen
        aGarden = annotateGarden angle garden
        applyGenome' rgen planted =
                if   remainingGrowth siGrowth planted < eps
-               then planted { phenotype = applyLSystem rgen
+               then planted { phenotype = applyLSystem rgen
                                                        (genome planted)
                                                        (phenotype planted)
                     -- here, we throw away the last eps of growth. Is that a problem?
-                            } :
-                    collectSeeds rgen planted
-               else [fmap siGrowth planted]
-       collectSeeds :: (RandomGen g) => g -> AnnotatedPlanted -> GrowingGarden
+                            }
+                    , collectSeeds rgen planted)
+               else (fmap siGrowth planted,[])
+       collectSeeds :: (RandomGen g) => g -> AnnotatedPlanted -> [Double]
        collectSeeds rgen planted = snd $ F.foldr go (rgen,[]) planted
-         where go si (rgen,newPlants) = case siGrowth si of
+         where go si (rgen,seedPoss) = case siGrowth si of
                        GrowingSeed _ ->
                                let spread = ( - siHeight si + siOffset si
                                             ,   siHeight si + siOffset si
                                             )
                                    (posDelta,rgen') = randomR spread rgen
-                                   p = Planted (plantPosition planted + posDelta)
-                                                 (plantOwner planted)
-                                                 (genome planted)
-                                                 (fmap (const NoGrowth) inititalPlant)
-                               in (rgen, p:newPlants)
-                       _ -> (rgen,newPlants)
+                               in (rgen', posDelta:seedPoss)
+                       _ -> (rgen,seedPoss)
 
 -- | Applies an L-System to a Plant, putting the new length in the additional
 --   information field
index 215d6dc..23368de 100644 (file)
@@ -17,10 +17,11 @@ import Control.Monad
 -- observer informed about any changes.
 lseedMainLoop :: Bool -- ^ Run in real time, e.g. call 'threadDelay'
        -> Observer -- ^ Who to notify about the state of the game
+       -> GardenSource -- ^ Where do get the plant code from
        -> Integer -- ^ Maximum days to run
-       -> Garden () -- ^ Initial garden state
        -> IO ()
-lseedMainLoop rt obs maxDays garden = do
+lseedMainLoop rt obs gardenSource maxDays = do
+       garden <- getGarden gardenSource
        obInit obs
        let nextDay (tick, garden) = 
                let (day, tickOfDay) = tick `divMod` ticksPerDay in
@@ -32,7 +33,18 @@ lseedMainLoop rt obs maxDays garden = do
                rgen <- newStdGen
                let sampleAngle = lightAngle $ (fromIntegral tickOfDay + 0.5) /
                                                 fromIntegral ticksPerDay
-               let growingGarden = growGarden sampleAngle rgen garden
+               let newGardenWithSeeds = applyGenome sampleAngle rgen garden
+               rgen <- newStdGen
+               newGarden <- fmap concat $ forM newGardenWithSeeds $
+                       \(parent,seedPoss) -> fmap (parent:) $ forM seedPoss $ \seedPos -> do
+                               genome <- getUpdatedCode gardenSource (fmap (const ()) parent)
+                               return $ Planted (plantPosition parent + seedPos)
+                                                (plantOwner parent)
+                                                genome
+                                                (fmap (const NoGrowth) inititalPlant)
+
+               let growingGarden = growGarden sampleAngle rgen newGarden
+
 
                obState obs tick garden
                when rt $ do
index dbce6ce..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 1 garden
+       lseedMainLoop True obs (GardenSource getDBGarden getDBUpdate) 200
index a1677ee..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 10 garden
+main = lseedMainLoop False scoringObs (GardenSource getDBGarden getDBUpdate) 10
index fcc5bb4..4baba8e 100644 (file)
@@ -42,4 +42,4 @@ scoringObs = nullObserver {
        }
 
 main = readArgs $ \garden -> do
-       lseedMainLoop False scoringObs 30 garden
+       lseedMainLoop False scoringObs (constGardenSource garden) 30
index 3579e14..5682fc7 100644 (file)
@@ -29,4 +29,4 @@ readArgs doit = do
                
 main = readArgs $ \garden -> do
        obs <- cairoObserver
-       lseedMainLoop True obs 200 garden
+       lseedMainLoop True obs (constGardenSource garden) 200