Plants are growing continuously now
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 18 Feb 2009 22:24:02 +0000 (23:24 +0100)
committerJoachim Breitner <mail@joachim-breitner.de>
Wed, 18 Feb 2009 22:24:02 +0000 (23:24 +0100)
src/Lseed/Data.hs
src/Lseed/LSystem.hs
src/Lseed/Renderer/Cairo.hs
src/main.hs

index 45fdeb5..29b02e4 100644 (file)
@@ -12,8 +12,8 @@ type Garden a = [ Planted a ]
 -- | A plant with metainformatoin
 data Planted a = Planted
        { plantPosition :: Double -- ^ Position in the garden, interval [0,1]
-       , genome :: LSystem  -- ^ Lsystem in use
-       , phenotype :: Plant a -- ^ Actual current form of the plant
+       , genome        :: LSystem  -- ^ Lsystem in use
+       , phenotype     :: Plant a -- ^ Actual current form of the plant
        }
 
 -- | A plant, which is
@@ -29,11 +29,18 @@ data Plant a
        deriving (Show)
 
 -- | A (compiled) rule of an L-system, with a matching function and a weight
-type LRule = (Int, Plant () -> Maybe (Plant ()))
+type LRule = (Int, Plant () -> Maybe (Plant (Maybe Double)))
 
 -- | An complete LSystem 
 type LSystem = [LRule]
 
+-- | Representation of what is on screen
+data ScreenContent = ScreenContent
+       { scGarden     :: Garden ()
+       , scLightAngle :: Double
+       , scTime       :: String
+       }
+
 -- Instances
 instance Functor Plant where
        fmap f (Bud x) = Bud (f x)
index eb22001..4c18531 100644 (file)
@@ -5,9 +5,9 @@ import Data.Maybe
 import Data.Monoid
 import System.Random
 
-applyLSystem :: RandomGen g => g -> LSystem -> Plant () -> Plant ()
+applyLSystem :: RandomGen g => g -> LSystem -> Plant () -> Plant (Maybe Double)
 applyLSystem rgen rules plant = if null choices
-                          then plant
+                          then unmodified plant
                            else chooseWeighted rgen choices
   where choices = go plant id
         applyLocal p prev = mapMaybe (\(w,r) -> fmap (\p' -> (w,prev p')) (r p)) rules
@@ -17,10 +17,12 @@ applyLSystem rgen rules plant = if null choices
                        Bud () ->
                                mempty
                        Stipe () len p' ->
-                               go p' (prev . (Stipe () len))
+                               go p' (prev . (Stipe Nothing len))
                        Fork () angle p1 p2 ->
-                               go p1 (prev . (\x -> Fork () angle x p2)) `mappend`
-                               go p2 (prev . (\x -> Fork () angle p1 x))
+                               go p1 (prev . (\x -> Fork Nothing angle x (unmodified p2)))
+                                `mappend`
+                               go p2 (prev . (\x -> Fork Nothing angle (unmodified p1) x))
+       unmodified = fmap (const Nothing)
 
 chooseWeighted rgen list = replicated !! (c-1)
   where replicated = concatMap (\(w,e) -> replicate w e) list
index 0d15de9..21609be 100644 (file)
@@ -13,12 +13,12 @@ import Lseed.Geometry
 import Text.Printf
 import System.Time
 
-initRenderer :: IO (Garden a -> IO ())
+initRenderer :: IO ((ClockTime -> ScreenContent) -> IO ())
 initRenderer = do
        initGUI
 
        -- global renderer state
-       currentGardenRef <- newIORef []
+       currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet"))
 
        -- widgets
        canvas <- drawingAreaNew
@@ -35,12 +35,11 @@ initRenderer = do
        forkIO $ mainGUI
 
        -- The actual drawing function
-       onExpose canvas$ \e -> do garden <- readIORef currentGardenRef
+       onExpose canvas$ \e -> do scGen <- readIORef currentGardenRef
+                                 ScreenContent garden angle timeInfo <-
+                                               scGen `fmap` getClockTime 
                                  dwin <- widgetGetDrawWindow canvas
                                  (w,h) <- drawableGetSize dwin
-                                 -- Sun rotation based on time for now
-                                 TOD s p <- getClockTime
-                                 let angle = fromIntegral (s * 1000*1000*1000*1000 + p `mod` (30*1000*1000*1000*1000)) * pi/(30*1000*1000*1000*1000)
                                  renderWithDrawable dwin $ do
                                        -- Set up coordinates
                                        translate 0 (fromIntegral h)
@@ -50,12 +49,13 @@ initRenderer = do
                                        setLineWidth stipeWidth
 
                                        render angle garden
+                                       renderTimeInfo timeInfo
                                  return (eventSent e)
 
        timeoutAdd (widgetQueueDraw canvas >> return True) 20
 
-       return $ \garden -> do
-               writeIORef currentGardenRef garden
+       return $ \scGen -> do
+               writeIORef currentGardenRef scGen
                widgetQueueDraw canvas
 
 render :: Double -> Garden a -> Render ()
@@ -160,6 +160,14 @@ renderInfo angle garden = do
                        moveTo x (0.5*groundLevel)
                        showText text2
 
+renderTimeInfo timeStr = do
+       preserve $ do
+               scale 1 (-1)
+               setSourceRGB 0 0 0
+               setFontSize (groundLevel/2)
+               moveTo 0 (0.5*groundLevel)
+               showText timeStr
+
 renderGround :: Render ()
 renderGround = do
        -- Clear Background
index 17a2e26..b2e6c69 100644 (file)
@@ -5,22 +5,64 @@ import Data.List
 import Control.Concurrent
 import Control.Monad
 import System.Random
+import System.Time
+import Text.Printf
+
+-- | Length of one day, in seconds
+dayLength = 10 
+
+
+timeSpanFraction :: ClockTime -> ClockTime -> Double
+timeSpanFraction (TOD sa pa) (TOD sb pb) = 
+       min 1 $ max 0 $
+       (fromIntegral $ (sb - sa) * 1000000000000 + (pb-pa)) /
+        (fromIntegral $ dayLength * 1000000000000 )
 
 main = do
        renderGarden <- initRenderer
        -- mapM_ (\g -> threadDelay (500*1000) >> renderGarden g) (inits testGarden)
-       let nextStep garden = do
-               renderGarden garden
-               garden' <- forM garden $ \planted ->  do
-                       rgen <- newStdGen
-                       return $ growPlanted rgen planted
-               threadDelay (2*1000*1000)
-               nextStep garden'
-       nextStep testGarden
+       let nextDay (day,garden) = do
+               now <- getClockTime
+               rgen <- newStdGen
+               let garden' = growGarden rgen garden
+
+               renderGarden $ \later -> 
+                       let timeDiff = timeSpanFraction now later
+                            timeInfo = printf "Day %d (%2.0f%%)" day (timeDiff*100)
+                           angle = timeDiff * pi
+                           gardenNow = applyGrowth timeDiff garden'
+                       in ScreenContent gardenNow angle timeInfo
+
+               threadDelay (dayLength*1000*1000)
+               nextDay (succ day,finishGrowth garden')
+       nextDay (0::Integer,testGarden)
 
+growGarden :: (RandomGen g) => g -> Garden () -> Garden (Maybe Double)
+growGarden rgen = snd . mapAccumL go rgen 
+  where go rgen planted = let (rgen1,rgen2) = split rgen in (rgen2, growPlanted rgen1 planted)
+
+-- | Applies an L-System to a Plant, putting the new length in the additional
+--   information field
+growPlanted :: (RandomGen g) => g -> Planted () -> Planted (Maybe Double)
 growPlanted rgen planted =
        planted { phenotype = applyLSystem rgen (genome planted) (phenotype planted) }
 
+-- | Finishes Growth by reading lenght from the 
+finishGrowth :: Garden (Maybe Double) -> Garden ()
+finishGrowth = applyGrowth' (flip const)
+
+-- | Applies Growth at given fraction
+applyGrowth :: Double -> Garden (Maybe Double) -> Garden ()
+applyGrowth r = applyGrowth' (\a b -> a * (1-r) + b * r)
+
+applyGrowth' :: (Double -> Double -> Double) -> Garden (Maybe Double) -> Garden ()
+applyGrowth' f = map (\planted -> planted { phenotype = go (phenotype planted) })
+  where go (Bud Nothing) = Bud ()
+        go (Stipe Nothing l p) = Stipe () l (go p)
+        go (Fork Nothing a p1 p2) = Fork () a (go p1) (go p2)
+       go (Stipe (Just l2) l1 p) = Stipe () (f l1 l2) (go p)
+       go p                    = error $ "Unexpected data in growing plant: " ++ show p
+
 testGarden =
        [ Planted 0.1 testLSystem1 (Bud ())
        , Planted 0.3 testLSystem2 (Bud ())
@@ -34,19 +76,19 @@ testGarden2 =
        ]
 
 testLSystem1 = [
-       (1, \x -> case x of Bud () -> Just (Stipe () 1 (Bud ())); _ -> Nothing )
+       (1, \x -> case x of Bud () -> Just (Stipe (Just 1) 0 (Bud Nothing)); _ -> Nothing )
        ]
 testLSystem2 = [
-       (3, \x -> case x of Bud () -> Just (Stipe () 2 (Bud ())); _ -> Nothing ),
-       (2, \x -> case x of Bud () -> Just (Fork () ( pi/4) (Stipe () 1 (Bud ())) (Stipe () 1 (Bud ()))); _ -> Nothing ),
-       (1, \x -> case x of Bud () -> Just (Fork () (-pi/4) (Stipe () 1 (Bud ())) (Stipe () 1 (Bud ()))); _ -> Nothing )
+       (3, \x -> case x of Bud () -> Just (Stipe (Just 2) 0 (Bud Nothing)); _ -> Nothing ),
+       (2, \x -> case x of Bud () -> Just (Fork Nothing ( pi/4) (Stipe (Just 1) 0 (Bud Nothing)) (Stipe (Just 1) 0 (Bud Nothing))); _ -> Nothing ),
+       (1, \x -> case x of Bud () -> Just (Fork Nothing (-pi/4) (Stipe (Just 1) 0 (Bud Nothing)) (Stipe (Just 1) 0 (Bud Nothing))); _ -> Nothing )
        ]
 testLSystem3 = [
-       (1, \x -> case x of Bud () -> Just (Stipe () 3 (Bud ())); _ -> Nothing ),
+       (1, \x -> case x of Bud () -> Just (Stipe (Just 3) 0 (Bud Nothing)); _ -> Nothing ),
        (1, \x -> case x of Bud () -> Just (
-                                       Fork () (-2*pi/5) (Stipe () 1 (Bud ())) $
-                                       Fork () (-1*pi/5) (Stipe () 1 (Bud ())) $
-                                       Fork () ( 1*pi/5) (Stipe () 1 (Bud ())) $
-                                       Fork () ( 2*pi/5) (Stipe () 1 (Bud ())) $
-                                       Stipe () 1 (Bud ())); _ -> Nothing )
+                                       Fork Nothing (-2*pi/5) (Stipe (Just 1) 0 (Bud Nothing)) $
+                                       Fork Nothing (-1*pi/5) (Stipe (Just 1) 0 (Bud Nothing)) $
+                                       Fork Nothing ( 1*pi/5) (Stipe (Just 1) 0 (Bud Nothing)) $
+                                       Fork Nothing ( 2*pi/5) (Stipe (Just 1) 0 (Bud Nothing)) $
+                                       Stipe (Just 1) 0 (Bud Nothing)); _ -> Nothing )
        ]