Add type variable to plants
authorJoachim Breitner <mail@joachim-breitner.de>
Sun, 8 Feb 2009 20:34:57 +0000 (21:34 +0100)
committerJoachim Breitner <mail@joachim-breitner.de>
Sun, 8 Feb 2009 20:34:57 +0000 (21:34 +0100)
src/Lseed/Data.hs
src/Lseed/Geometry.hs
src/Lseed/LSystem.hs
src/Lseed/Renderer/Cairo.hs
src/main.hs

index 6a5fe39..3f2443b 100644 (file)
@@ -2,26 +2,29 @@
 module Lseed.Data where 
 
 -- | A list of plants, together with their position in the garden, in the interval [0,1]
-type Garden = [ Planted ]
+type Garden a = [ Planted a ]
 
 -- | A plant with metainformatoin
-data Planted = Planted
+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
+       , 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 Double Plant -- ^ a stipe with a length (factor of stipeLength)
-                             --   and more of the plant next
-       | Fork Double Plant Plant -- ^ a fork with a sidewise offspring at a radial angle,
-                                  --   and a straight continuation 
+data Plant a 
+       -- | a bud, i.e. the end of a sprout
+       = Bud a
+       -- | a stipe with a length (factor of stipeLength)
+       --   and more of the plant next
+       | Stipe a Double (Plant a)
+       -- ^ a fork with a sidewise offspring at a radial angle,
+       --   and a straight continuation 
+       | Fork a Double (Plant a) (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 ()))
 
 -- | An complete LSystem 
 type LSystem = [LRule]
index 2c20c3e..b0ac9c1 100644 (file)
@@ -41,19 +41,19 @@ crossPoint ((x1,y1),(x2,y2)) ((x3,y3),(x4,y4)) =
            else Nothing
 
 
-plantedToLines :: Planted -> [Line]
+plantedToLines :: Planted -> [Line]
 plantedToLines planted = runGeometryGenerator (plantPosition planted, 0) 0 $
                plantToGeometry (phenotype planted)
 
-plantToGeometry :: Plant -> GeometryGenerator ()
-plantToGeometry Bud = return ()
-plantToGeometry (Stipe len p) = addLine ((0,0),(0,len * stipeLength)) >>
-                               translated (0,len * stipeLength) (plantToGeometry p)
-plantToGeometry (Fork angle p1 p2) = rotated angle (plantToGeometry p1) >>
-                                                   (plantToGeometry p2)
+plantToGeometry :: Plant -> GeometryGenerator ()
+plantToGeometry (Bud _) = return ()
+plantToGeometry (Stipe len p) = addLine ((0,0),(0,len * stipeLength)) >>
+                                 translated (0,len * stipeLength) (plantToGeometry p)
+plantToGeometry (Fork angle p1 p2) = rotated angle (plantToGeometry p1) >>
+                                                     (plantToGeometry p2)
 
 -- | Lines are annotated with its plant, identified by the position
-gardenToLines :: Garden -> [(Line, Double)]
+gardenToLines :: Garden -> [(Line, Double)]
 gardenToLines = concatMap (\planted -> map (\line -> (line, plantPosition planted)) (plantedToLines planted))
 
 -- | Add lightning from a given angle
index 4a03873..eb22001 100644 (file)
@@ -5,7 +5,7 @@ import Data.Maybe
 import Data.Monoid
 import System.Random
 
-applyLSystem :: RandomGen g => g -> LSystem -> Plant -> Plant
+applyLSystem :: RandomGen g => g -> LSystem -> Plant () -> Plant ()
 applyLSystem rgen rules plant = if null choices
                           then plant
                            else chooseWeighted rgen choices
@@ -14,10 +14,13 @@ applyLSystem rgen rules plant = if null choices
 
        go p prev = applyLocal p prev `mappend`
                    case p of
-                       Bud -> mempty
-                       Stipe len p' -> go p' (prev . (Stipe len))
-                       Fork angle p1 p2 -> go p1 (prev . (\x -> Fork angle x p2)) `mappend`
-                                           go p2 (prev . (\x -> Fork angle p1 x))
+                       Bud () ->
+                               mempty
+                       Stipe () len p' ->
+                               go p' (prev . (Stipe () len))
+                       Fork () angle p1 p2 ->
+                               go p1 (prev . (\x -> Fork () angle x p2)) `mappend`
+                               go p2 (prev . (\x -> Fork () angle p1 x))
 
 chooseWeighted rgen list = replicated !! (c-1)
   where replicated = concatMap (\(w,e) -> replicate w e) list
index 5854019..962b539 100644 (file)
@@ -11,7 +11,7 @@ import Lseed.Geometry
 import Text.Printf
 import System.Time
 
-initRenderer :: IO (Garden -> IO ())
+initRenderer :: IO (Garden -> IO ())
 initRenderer = do
        initGUI
 
@@ -56,7 +56,7 @@ initRenderer = do
                writeIORef currentGardenRef garden
                widgetQueueDraw canvas
 
-render :: Double -> Garden -> Render ()
+render :: Double -> Garden -> Render ()
 render angle garden = do
        renderGround
        -- mapM_ renderLightedLine (lightenLines (pi/3) (gardenToLines garden))
@@ -66,23 +66,23 @@ render angle garden = do
 
        mapM_ (renderInfo) (totalLight angle (gardenToLines garden))
 
-renderPlanted :: Planted -> Render ()
+renderPlanted :: Planted -> Render ()
 renderPlanted planted = preserve $ do
        translate (plantPosition planted) 0
        setSourceRGB 0 0.8 0
        renderPlant (phenotype planted)
 
-renderPlant :: Plant -> Render ()      
-renderPlant Bud = do
+renderPlant :: Plant a -> Render ()    
+renderPlant (Bud _) = do
        arc 0 0 budSize 0 (2*pi)
        fill
-renderPlant (Stipe len p) = do
+renderPlant (Stipe len p) = do
        moveTo 0 0
        lineTo 0 (len * stipeLength)
        stroke
        translate 0 (len * stipeLength)
        renderPlant p
-renderPlant (Fork angle p1 p2) = do
+renderPlant (Fork angle p1 p2) = do
        preserve $ rotate angle >> renderPlant p1
        renderPlant p2
                
index caf4b7f..21d285f 100644 (file)
@@ -22,27 +22,27 @@ growPlanted rgen planted =
        planted { phenotype = applyLSystem rgen (genome planted) (phenotype planted) }
 
 testGarden =
-       [ Planted 0.1 testLSystem1 Bud
-       , Planted 0.3 testLSystem2 Bud
-       , Planted 0.5 testLSystem3 Bud
-       , Planted 0.7 testLSystem2 Bud
-       , Planted 0.9 testLSystem1 Bud
+       [ Planted 0.1 testLSystem1 (Bud ())
+       , Planted 0.3 testLSystem2 (Bud ())
+       , Planted 0.5 testLSystem3 (Bud ())
+       , Planted 0.7 testLSystem2 (Bud ())
+       , Planted 0.9 testLSystem1 (Bud ())
        ]
 
 testLSystem1 = [
-       (1, \x -> case x of Bud -> Just (Stipe 1 Bud); _ -> Nothing )
+       (1, \x -> case x of Bud () -> Just (Stipe () 1 (Bud ())); _ -> 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 () 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 )
        ]
 testLSystem3 = [
-       (1, \x -> case x of Bud -> Just (Stipe 3 Bud); _ -> 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 )
+       (1, \x -> case x of Bud () -> Just (Stipe () 3 (Bud ())); _ -> 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 )
        ]