turn a plant into a list of lines
authorJoachim Breitner <mail@joachim-breitner.de>
Fri, 6 Feb 2009 09:54:01 +0000 (10:54 +0100)
committerJoachim Breitner <mail@joachim-breitner.de>
Fri, 6 Feb 2009 09:54:01 +0000 (10:54 +0100)
src/Lseed/Constants.hs [new file with mode: 0644]
src/Lseed/Geometry.hs [new file with mode: 0644]
src/Lseed/Geometry/Generator.hs [new file with mode: 0644]
src/Lseed/Renderer/Cairo.hs

diff --git a/src/Lseed/Constants.hs b/src/Lseed/Constants.hs
new file mode 100644 (file)
index 0000000..588b002
--- /dev/null
@@ -0,0 +1,7 @@
+module Lseed.Constants where 
+
+-- All relative to the screen width
+groundLevel = 0.03
+budSize     = 0.01
+stipeLength = 0.05
+stipeWidth  = 0.01
diff --git a/src/Lseed/Geometry.hs b/src/Lseed/Geometry.hs
new file mode 100644 (file)
index 0000000..4cb015f
--- /dev/null
@@ -0,0 +1,19 @@
+module Lseed.Geometry where
+
+import Lseed.Data
+import Lseed.Constants
+import Lseed.Geometry.Generator
+
+type Point = (Double, Double)
+type Line  = (Point, Point)
+
+plantedToLines :: Planted -> [Line]
+plantedToLines planted = runGeometryGenerator (plantPosition planted, 0) (pi/2) $
+               plantToGeometry (phenotype planted)
+
+plantToGeometry :: Plant -> GeometryGenerator ()
+plantToGeometry Bud = return ()
+plantToGeometry (Stipe p) = addLine ((0,0),(0,stipeLength)) >>
+                           translated (0,stipeLength) (plantToGeometry p)
+plantToGeometry (Fork p1 p2) = rotated (-pi/4) (plantToGeometry p1) >>
+                               rotated ( pi/4) (plantToGeometry p2)
diff --git a/src/Lseed/Geometry/Generator.hs b/src/Lseed/Geometry/Generator.hs
new file mode 100644 (file)
index 0000000..138a8b3
--- /dev/null
@@ -0,0 +1,48 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | Helper module providing a monad that collects lines
+module Lseed.Geometry.Generator
+       ( GeometryGenerator
+       , translated
+       , rotated
+       , runGeometryGenerator
+       , addLine
+       )
+       where
+
+import Control.Monad.Reader
+import Control.Monad.Writer
+
+type Point = (Double, Double)
+type Line  = (Point, Point)
+
+
+newtype GeometryGenerator a = GeometryGenerator (ReaderT (Point, Double) (Writer [Line]) a)
+ deriving (Monad)
+
+transformed :: Point -> GeometryGenerator Point
+transformed (x,y) = GeometryGenerator $ do
+       ((bx,by),r) <- ask
+       let (x', y') = (cos r * x + sin r *y, -sin r * x + cos r *y)
+       return (bx + x', by + y')
+
+translated :: Point -> GeometryGenerator a -> GeometryGenerator a
+translated p (GeometryGenerator act) = do
+       (x',y') <- transformed p
+       GeometryGenerator $
+               local (\(_,r) -> ((x',y'),r)) act
+
+rotated :: Double -> GeometryGenerator a -> GeometryGenerator a
+rotated r (GeometryGenerator act) = 
+       GeometryGenerator $ local (\(p,r') -> (p, r' * r)) act
+
+addLine :: Line -> GeometryGenerator ()
+addLine (p1,p2) = do
+       p1' <- transformed p1
+       p2' <- transformed p2
+       GeometryGenerator $ tell [(p1', p2')]
+
+       
+runGeometryGenerator :: Point -> Double -> GeometryGenerator () -> [Line]
+runGeometryGenerator p r (GeometryGenerator gen) = 
+       execWriter (runReaderT gen (p,r))
index ea01acd..c3b5905 100644 (file)
@@ -5,13 +5,7 @@ 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
-
+import Lseed.Constants
 
 initRenderer :: IO (Garden -> IO ())
 initRenderer = do