Make LRules based on explicit Actions
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 2 Mar 2009 20:30:37 +0000 (21:30 +0100)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 2 Mar 2009 20:30:37 +0000 (21:30 +0100)
src/Lseed/Data.hs
src/Lseed/LSystem.hs
src/main.hs

index fe6c716..8089a50 100644 (file)
@@ -37,8 +37,13 @@ data Plant a
 -- | Named variants of a Plant, for more expressive type signatures
 type GrowingPlant = Plant (Maybe Double)
 
--- | A (compiled) rule of an L-system, with a matching function and a weight
-type LRule = (Int, Plant () -> Maybe (Plant (Maybe Double)))
+-- | Possible action to run on a Stipe in a Rule
+data LRuleAction
+       = EnlargeStipe Double -- ^ Extend this Stipe to the given length
+        | ForkStipe Double [(Angle, Double)] -- ^ Branch this stipe at the given fraction and angle and let it grow to the given lengths
+
+-- | A (compiled) rule of an L-system, with a matching function returning an action and weight
+type LRule = (Plant () -> Maybe (Int, LRuleAction))
 
 -- | An complete LSystem 
 type LSystem = [LRule]
index 4bfa0eb..b6f667f 100644 (file)
@@ -1,28 +1,38 @@
 module Lseed.LSystem where
 
+import Lseed.Constants
 import Lseed.Data
 import Data.Maybe
 import Data.Monoid
 import System.Random
 
 applyLSystem :: RandomGen g => g -> LSystem -> Plant () -> GrowingPlant
-applyLSystem rgen rules plant = if null choices
-                          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
+applyLSystem rgen rules plant = go plant
+  where applyAction (EnlargeStipe newSize) (Stipe () oldSize p')
+               = Stipe (Just newSize) oldSize $
+                  go p'
+       applyAction (ForkStipe pos []) (Stipe () oldSize p') -- No branches
+               = Stipe Nothing oldSize $ go p'
+       applyAction (ForkStipe pos branchSpecs) (Stipe () oldSize p')
+               = preFork . forks branchSpecs . postFork $ go p'
+         where (preFork, postFork) | pos < eps -- Fork at the beginning
+                                   = (id, Stipe Nothing oldSize)
+                                    | 1-pos < eps -- Fork at the end
+                                   = (Stipe Nothing oldSize, id)
+                                    | otherwise -- Fork in the middle
+                                    = (Stipe Nothing (oldSize * pos),
+                                      Stipe Nothing (oldSize * (1-pos)))
+               forks = flip $ foldr (\(angle, newSize) -> Fork Nothing angle (Stipe (Just newSize) 0 (Bud Nothing)))
+       applyAction _ _ = error "Unknown Action or applied to wrong part of a plant"
 
-       go p prev = applyLocal p prev `mappend`
-                   case p of
+       go p = case p of
                        Bud () ->
-                               mempty
-                       Stipe () len p' ->
-                               go p' (prev . (Stipe Nothing len))
+                               Bud Nothing
+                       Stipe () _ _ ->
+                               let choices = mapMaybe (\r -> r p) rules 
+                               in  applyAction (chooseWeighted rgen choices) p
                        Fork () angle p1 p2 ->
-                               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)
+                               Fork Nothing angle (go p1) (go p2)
 
 chooseWeighted rgen list = replicated !! (c-1)
   where replicated = concatMap (\(w,e) -> replicate w e) list
index 0f14c7f..e4a6b26 100644 (file)
@@ -107,31 +107,28 @@ applyGrowth' f = go
        go p                    = error $ "Unexpected data in growing plant: " ++ show p
 
 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 (Stipe () 0 (Bud ()))
+       , Planted 0.3 testLSystem2 (Stipe () 0 (Bud ()))
+       , Planted 0.5 testLSystem3 (Stipe () 0 (Bud ()))
+       , Planted 0.7 testLSystem2 (Stipe () 0 (Bud ()))
+       , Planted 0.9 testLSystem1 (Stipe () 0 (Bud ()))
        ]
 testGarden2 =
-       [ Planted 0.4 testLSystem1 (Bud ())
-       , Planted 0.6 testLSystem1 (Bud ())
+       [ Planted 0.4 testLSystem1 (Stipe () 0 (Bud ()))
+       , Planted 0.6 testLSystem1 (Stipe () 0 (Bud ()))
        ]
 
 testLSystem1 = [
-       (1, \x -> case x of Bud () -> Just (Stipe (Just 1) 0 (Bud Nothing)); _ -> Nothing )
+       (\(Stipe () l _) -> Just (1, EnlargeStipe (l+1)))
        ]
 testLSystem2 = [
-       (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 )
+       (\(Stipe () l _) -> Just (2, EnlargeStipe (l+2))),
+       (\(Stipe () l _) -> Just (1, ForkStipe (0.5) [(pi/4,1)])),
+       (\(Stipe () l _) -> Just (1, ForkStipe (1) [(-pi/4,1)]))
        ]
 testLSystem3 = [
-       (1, \x -> case x of Bud () -> Just (Stipe (Just 3) 0 (Bud Nothing)); _ -> Nothing ),
-       (1, \x -> case x of Bud () -> Just (
-                                       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 )
+       (\(Stipe () l _) -> Just (1, EnlargeStipe (l+2))),
+       (\(Stipe () l _) -> if l >= 1
+                            then Just (1, ForkStipe 1 [ (x * pi/5, 1) | x <- [-2,-1,1,2] ])
+                            else Nothing)
        ]