Enforce a minimum angular distance between forks
authorJoachim Breitner <mail@joachim-breitner.de>
Thu, 7 May 2009 23:09:29 +0000 (01:09 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Thu, 7 May 2009 23:09:44 +0000 (01:09 +0200)
examples/testDoubleStipe.txt
src/Lseed/Constants.hs
src/Lseed/Grammar/Parse.hs
src/Lseed/LSystem.hs

index 80965bf..1ef7326 100644 (file)
@@ -4,4 +4,4 @@ GROW TO 2
 
 RULE "invalid"
 WHEN Length > 1
-BRANCH AT 50% ANGLE=0°, LENGTH=1
+BRANCH AT 500% ANGLE=0°, LENGTH=1
index 0e318f8..8e690f5 100644 (file)
@@ -27,6 +27,8 @@ dayLength = 10
 -- | ε
 eps = 1e-9
 
+-- | Minimum radial angular distance between two branches
+minAngle = pi/20
 
 -- | Derived constants
 tickLength = fromIntegral dayLength / fromIntegral ticksPerDay
index 4075c54..98d5cb2 100644 (file)
@@ -83,6 +83,8 @@ pBranch = do
        reserved "BRANCH"
        reserved "AT"
        fraction <- pFloat
+       unless (0 <= fraction && fraction <= 100) $
+               fail "Fork position has to be in between 0% and 100%."
        reservedOp "%"
        reserved "ANGLE"
        reservedOp "="
@@ -96,7 +98,7 @@ pBranch = do
                reserved "TAG"
                reservedOp "="
                pString
-       return (AddBranch fraction angle length mTag)
+       return (AddBranch (fraction/100) angle length mTag)
 
 pGrow :: Parser GrammarAction
 pGrow = do
index 938e23c..cfab6ab 100644 (file)
@@ -5,16 +5,19 @@ import Lseed.Data
 import Data.Maybe
 import Data.Monoid
 import System.Random
+import Control.Arrow (second)
+import Data.List
 
 applyLSystem :: RandomGen g => g -> LSystem -> Plant () -> GrowingPlant
 applyLSystem rgen rules plant = go plant
-  where applyAction (EnlargeStipe newSize) (Stipe () oldSize ps)
+  where applyAction :: Plant () -> LRuleAction -> GrowingPlant
+       applyAction (Stipe () oldSize ps) (EnlargeStipe newSize) 
                = Stipe (Just newSize) oldSize $
                   mapSprouts go ps
-       applyAction (ForkStipe pos []) (Stipe () oldSize ps) -- No branches
+       applyAction (Stipe () oldSize ps) (ForkStipe pos [])-- No branches
                = Stipe Nothing oldSize $
                  mapSprouts go ps
-       applyAction (ForkStipe pos branchSpecs) (Stipe () oldSize ps)
+       applyAction (Stipe () oldSize ps) (ForkStipe pos branchSpecs)
                | 1-pos < eps -- Fork at the end
                = Stipe Nothing oldSize $
                        ps' ++
@@ -29,9 +32,18 @@ applyLSystem rgen rules plant = go plant
        noAction (Stipe () oldSize ps)
                = Stipe Nothing oldSize $ mapSprouts go ps
 
-       go p = case mapMaybe ($ p) rules of
+       go :: Plant () -> GrowingPlant
+       go p = case filter (isValid.snd) $ map (second (applyAction p)) $ mapMaybe ($ p) rules of
                []      -> noAction p
-               choices -> applyAction (chooseWeighted rgen choices) p
+               choices -> chooseWeighted rgen choices
+
+       -- Some general checks to rule out unwanted rules
+       isValid :: GrowingPlant -> Bool
+       isValid (Stipe newSize oldSize ps) = anglesOk
+         where angles = sort $ map fst ps
+               -- Are all angles directed forward and not too close to each other?
+                anglesOk = all (\a -> -pi/2 <= a && a <= pi/2) angles &&
+                           all (> minAngle) (zipWith (flip (-)) angles (tail angles))
 
 chooseWeighted rgen list = replicated !! (c-1)
   where replicated = concatMap (\(w,e) -> replicate w e) list