Implement hooks to feed new genome code to Mainloop
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 24 Jun 2009 06:43:56 +0000 (08:43 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Wed, 24 Jun 2009 06:43:56 +0000 (08:43 +0200)
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 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..d020cd2 100644 (file)
@@ -16,4 +16,4 @@ getGarden = spread <$> map (either (error.show) id . parseGrammar "" . dbcCode)
 main = do
        garden <- getGarden
        obs <- cairoObserver
-       lseedMainLoop True obs 1 garden
+       lseedMainLoop True obs (constGardenSource garden) 200
index a1677ee..8aca1ad 100644 (file)
@@ -29,4 +29,4 @@ scoringObs = nullObserver {
 
 main = do
        garden <- getGarden
-       lseedMainLoop False scoringObs 10 garden
+       lseedMainLoop False scoringObs (constGardenSource garden) 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