Es wächst (ein klein bisschen)
authorJoachim Breitner <mail@joachim-breitner.de>
Thu, 5 Feb 2009 20:33:22 +0000 (21:33 +0100)
committerJoachim Breitner <mail@joachim-breitner.de>
Thu, 5 Feb 2009 20:33:22 +0000 (21:33 +0100)
src/Lseed/Data.hs [new file with mode: 0644]
src/Lseed/LSystem.hs [new file with mode: 0644]
src/Lseed/Renderer/Cairo.hs [new file with mode: 0644]
src/main.hs [new file with mode: 0644]

diff --git a/src/Lseed/Data.hs b/src/Lseed/Data.hs
new file mode 100644 (file)
index 0000000..890c3ba
--- /dev/null
@@ -0,0 +1,25 @@
+-- | Data definitions for L-seed
+module Lseed.Data where 
+
+-- | A list of plants, together with their position in the garden, in the interval [0,1]
+type Garden = [ Planted ]
+
+-- | A plant with metainformatoin
+data Planted = Planted
+       { plantPosition :: Double -- ^ Position in the garden, interval [0,1]
+       , genome :: LSystem  -- ^ Lsystem in use
+       , phenotype :: Plant -- ^ Actual current form of the plant
+       }
+
+-- | A plant, which is
+data Plant 
+       = Bud -- ^ a bud, i.e. the end of a sprout
+       | Stipe Plant -- ^ a stipe with more of the plant next
+       | Fork Plant Plant -- ^ a fork with two successing pieces of a plant
+       deriving (Show)
+
+-- | A (compiled) rule of an L-system, with a matching function and a weight
+type LRule = (Int, Plant -> Maybe Plant)
+
+-- | An complete LSystem 
+type LSystem = [LRule]
diff --git a/src/Lseed/LSystem.hs b/src/Lseed/LSystem.hs
new file mode 100644 (file)
index 0000000..6724703
--- /dev/null
@@ -0,0 +1,23 @@
+module Lseed.LSystem where
+
+import Lseed.Data
+import Data.Maybe
+import Data.Monoid
+import System.Random
+
+applyLSystem :: RandomGen g => g -> LSystem -> Plant -> Plant
+applyLSystem rgen rules plant = if null choices
+                          then plant
+                           else chooseWeighted rgen choices
+  where choices = go plant id
+        applyLocal p prev = mapMaybe (\(w,r) -> fmap (\p' -> (w,prev p')) (r p)) rules
+
+       go p prev = applyLocal p prev `mappend` case p of
+                               Bud -> mempty
+                               Stipe p' -> go p' (prev . Stipe)
+                               Fork p1 p2 -> go p1 (prev . (\x -> Fork x p2)) `mappend`
+                                              go p2 (prev . (\x -> Fork p1 x))
+
+chooseWeighted rgen list = replicated !! (c-1)
+  where replicated = concatMap (\(w,e) -> replicate w e) list
+        (c,_) = randomR (1, length replicated) rgen
diff --git a/src/Lseed/Renderer/Cairo.hs b/src/Lseed/Renderer/Cairo.hs
new file mode 100644 (file)
index 0000000..ea01acd
--- /dev/null
@@ -0,0 +1,92 @@
+module Lseed.Renderer.Cairo where
+
+import Graphics.UI.Gtk hiding (fill)
+import Graphics.Rendering.Cairo
+import Control.Concurrent
+import Data.IORef
+import Lseed.Data
+
+-- All relative to the screen width
+groundLevel = 0.03
+budSize     = 0.01
+stipeLength = 0.05
+stipeWidth  = 0.01
+
+
+initRenderer :: IO (Garden -> IO ())
+initRenderer = do
+       initGUI
+
+       -- global renderer state
+       currentGardenRef <- newIORef []
+
+       -- widgets
+       canvas <- drawingAreaNew
+
+       window <- windowNew
+       set window [windowDefaultWidth := 800, windowDefaultHeight := 600,
+             containerChild := canvas, containerBorderWidth := 0]
+       widgetShowAll window
+
+       -- Make gtk and haskell threading compatible
+       timeoutAdd (yield >> return True) 50
+       
+       -- a thread for our GUI
+       forkIO $ mainGUI
+
+       -- The actual drawing function
+       onExpose canvas (\e -> do garden <- readIORef currentGardenRef
+                                 dwin <- widgetGetDrawWindow canvas
+                                 (w,h) <- drawableGetSize dwin
+                                 renderWithDrawable dwin $ do
+                                       -- Set up coordinates
+                                       translate 0 (fromIntegral h)
+                                       scale 1 (-1)
+                                       scale (fromIntegral w) (fromIntegral (w))
+                                       
+                                       setLineWidth stipeWidth
+                                       render garden
+                                 return (eventSent e))
+
+       return $ \garden -> do
+               writeIORef currentGardenRef garden
+               widgetQueueDraw canvas
+
+render :: Garden -> Render ()
+render garden = do
+       renderGround
+       mapM_ (renderPlanted) garden
+
+renderPlanted :: Planted -> Render ()
+renderPlanted planted = preserve $ do
+       translate (plantPosition planted) groundLevel
+       setSourceRGB 0 1 0
+       renderPlant (phenotype planted)
+
+renderPlant :: Plant -> Render ()      
+renderPlant Bud = do
+       arc 0 0 budSize 0 (2*pi)
+       fill
+renderPlant (Stipe p) = do
+       moveTo 0 0
+       lineTo 0 stipeLength
+       stroke
+       translate 0 stipeLength
+       renderPlant p
+renderPlant (Fork p1 p2) = do
+       preserve $ rotate (-pi/4) >> renderPlant p1
+       preserve $ rotate (pi/4) >> renderPlant p2
+               
+
+renderGround :: Render ()
+renderGround = do
+       -- Clear Background
+       setSourceRGB  0 1 1
+       fill
+       setSourceRGB  0.6 0.3 0.3
+       rectangle 0 0 1 groundLevel
+        fill
+
+-- | Wrapper that calls 'save' and 'restore' before and after the argument
+preserve :: Render () -> Render ()
+preserve r = save >> r >> restore
diff --git a/src/main.hs b/src/main.hs
new file mode 100644 (file)
index 0000000..5081821
--- /dev/null
@@ -0,0 +1,37 @@
+import Lseed.Renderer.Cairo
+import Lseed.Data
+import Lseed.LSystem
+import Data.List
+import Control.Concurrent
+import Control.Monad
+import System.Random
+
+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 (500*1000)
+               nextStep garden'
+       nextStep testGarden
+
+growPlanted rgen planted =
+       planted { phenotype = applyLSystem rgen (genome planted) (phenotype planted) }
+
+testGarden =
+       [ Planted 0.3 testLSystem1 Bud
+       , Planted 0.7 testLSystem2 Bud
+       , Planted 0.5 testLSystem2 Bud
+       , Planted 0.9 testLSystem2 Bud
+       ]
+
+testLSystem1 = [
+       (1, \x -> case x of Bud -> Just (Stipe Bud); _ -> Nothing )
+       ]
+testLSystem2 = [
+       (3, \x -> case x of Bud -> Just (Stipe Bud); _ -> Nothing ),
+       (2, \x -> case x of Bud -> Just (Fork (Stipe Bud ) (Stipe Bud)); _ -> Nothing )
+       ]