Implement various matchable features
authorJoachim Breitner <mail@joachim-breitner.de>
Sun, 10 May 2009 21:37:36 +0000 (23:37 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Sun, 10 May 2009 21:37:48 +0000 (23:37 +0200)
src/Lseed/Data.hs
src/Lseed/Grammar.hs
src/Lseed/Grammar/Compile.hs
src/Lseed/Grammar/Parse.hs
src/Lseed/LSystem.hs
src/Lseed/StipeInfo.hs [new file with mode: 0644]
src/main.hs

index dfdeb1a..a0568e5 100644 (file)
@@ -12,6 +12,7 @@ type Garden a = [ Planted a ]
 
 -- | Named variants of a garden, for more expressive type signatures
 type GrowingGarden = Garden (Maybe Double)
+type AnnotatedGarden = Garden StipeInfo
 
 -- | A plant with metainformatoin
 data Planted a = Planted
@@ -36,6 +37,18 @@ mapSprouts = map . second
 -- | Named variants of a Plant, for more expressive type signatures
 type GrowingPlant = Plant (Maybe Double)
 
+data StipeInfo = StipeInfo
+       { siLength    :: Double -- ^ a bit redundant, but what shells
+       , siSubLength :: Double
+       , siLight     :: Double
+       , siSubLight  :: Double
+       , siAngle     :: Angle
+       , siDirection :: Angle
+       }
+       deriving (Show)
+
+type AnnotatedPlant = Plant StipeInfo
+
 -- | Possible action to run on a Stipe in a Rule
 data LRuleAction
        = EnlargeStipe Double -- ^ Extend this Stipe to the given length
@@ -43,7 +56,7 @@ data LRuleAction
        deriving (Show)
 
 -- | A (compiled) rule of an L-system, with a matching function returning an action and weight
-type LRule = (Plant () -> Maybe (Int, LRuleAction))
+type LRule = (AnnotatedPlant -> Maybe (Int, LRuleAction))
 
 -- | An complete LSystem 
 type LSystem = [LRule]
index 69d199c..2990b06 100644 (file)
@@ -31,9 +31,9 @@ data GrammarRule = GrammarRule
 
 data Matchable
        = MatchLight
-       | MatchTotalLight
+       | MatchSubLight
        | MatchLength
-       | MatchTotalLength
+       | MatchSubLength
        | MatchDirection
        | MatchAngle
        deriving (Read,Show)
index 5666ecc..773eab5 100644 (file)
@@ -15,16 +15,20 @@ compileGrammarRule rule plant =
        else Nothing
 
 
-conformsTo :: Plant () -> Condition -> Bool
-conformsTo (Stipe () l _) = go
+conformsTo :: AnnotatedPlant -> Condition -> Bool
+conformsTo (Stipe si l _) = go
   where go (Always b)     = b
        go (c1 `And` c2)  = go c1 && go c2
        go (c1 `Or` c2)   = go c1 || go c2
        go (UserTagIs ut) = error "UserTags are not supported yet"
        go (NumCond what how val) = doCompare how (getMatchable what) val
        
-       getMatchable MatchLength = l
-       getMatchable m           = error $ "Matchable " ++ show m ++ " not supported yet"
+       getMatchable MatchLength    = siLength si
+       getMatchable MatchSubLength = siSubLength si
+       getMatchable MatchLight     = siLight si
+       getMatchable MatchSubLight  = siSubLight si
+       getMatchable MatchDirection = siDirection si
+       getMatchable MatchAngle     = siAngle si
 
        doCompare LE = (<=)
        doCompare Less = (<)
@@ -32,10 +36,10 @@ conformsTo (Stipe () l _) = go
        doCompare Greater = (>)
        doCompare GE = (>=)
 
-grToLAction :: [GrammarAction] -> Plant () -> LRuleAction
-grToLAction [SetLength ld _] (Stipe () l _)
+grToLAction :: [GrammarAction] -> AnnotatedPlant -> LRuleAction
+grToLAction [SetLength ld _] (Stipe _ l _)
        = EnlargeStipe (calcLengthDescr ld l)
-grToLAction acts  (Stipe () l _)
+grToLAction acts  (Stipe _ l _)
        | all isAddBranch acts
        = case nub (map addBranchAngle acts) of
            [frac] -> ForkStipe frac $ map (\(AddBranch _ angle length _) -> (angle, length)) acts
index 98d5cb2..f465ced 100644 (file)
@@ -10,7 +10,8 @@ import Lseed.Grammar
 
 -- The lexer
 lexer       = P.makeTokenParser $ javaStyle
-       { P.reservedNames = ["RULE", "WHEN", "Tag", "Light", "Branch", "At", "Length", "Angle",
+       { P.reservedNames = ["RULE", "WHEN", "Tag", "Light", "Branch", "At",
+                            "Length", "Light", "Sublength", "Sublight", "Direction", "Angle",
                             "BY", "TO", "IMPORTANCE", "WEIGHT"]
        }
 
@@ -88,7 +89,7 @@ pBranch = do
        reservedOp "%"
        reserved "ANGLE"
        reservedOp "="
-       angle <- pAngle
+       angle <- pFloat
        comma
        reserved "LENGTH"
        reservedOp "="
@@ -115,16 +116,15 @@ pGrow = do
                value <- pFloat
                return (Absolute value)
                
--- \194\176 is a utf8-°
-pAngle :: Parser Double
-pAngle = do
-       value <- pFloat
-       (reservedOp "\194\176" >> return (value / 180 * pi)) <|> return value
 
 pMatchable =
        choice $ map (\(a,b) -> const b `fmap` reserved a) $
                [ ("LIGHT", MatchLight)
                , ("LENGTH", MatchLength)
+               , ("SUBLENGTH", MatchSubLength)
+               , ("SUBLIGHT", MatchSubLight)
+               , ("ANGLE", MatchAngle)
+               , ("DIRECTION", MatchDirection)
                ]
 
 pCmp = 
@@ -137,6 +137,14 @@ pCmp =
                ]
 
 pString = identifier <|> stringLiteral
-pFloat = try (fromIntegral `fmap` integer) <|> float
+
+pFloat = do value <- try (do 
+                       i <- fromIntegral `fmap` integer
+                       notFollowedBy (char '.')
+                       return i
+                    )  <|> float
+           (deg >> return (value / 180 * pi)) <|> return value
+
+deg = reservedOp "\194\176"
        
 nl = char '\n'
index 235b651..8ed36cb 100644 (file)
@@ -8,16 +8,16 @@ import System.Random
 import Control.Arrow (second)
 import Data.List
 
-applyLSystem :: RandomGen g => g -> LSystem -> Plant () -> GrowingPlant
+applyLSystem :: RandomGen g => g -> LSystem -> AnnotatedPlant -> GrowingPlant
 applyLSystem rgen rules plant = go plant
-  where applyAction :: Plant () -> LRuleAction -> GrowingPlant
-       applyAction (Stipe () oldSize ps) (EnlargeStipe newSize) 
+  where applyAction :: AnnotatedPlant -> LRuleAction -> GrowingPlant
+       applyAction (Stipe _ oldSize ps) (EnlargeStipe newSize) 
                = Stipe (Just newSize) oldSize $
                   mapSprouts go ps
-       applyAction (Stipe () oldSize ps) (ForkStipe pos [])-- No branches
+       applyAction (Stipe _ oldSize ps) (ForkStipe pos [])-- No branches
                = Stipe Nothing oldSize $
                  mapSprouts go ps
-       applyAction (Stipe () oldSize ps) (ForkStipe pos branchSpecs)
+       applyAction (Stipe _ oldSize ps) (ForkStipe pos branchSpecs)
                | 1-pos < eps -- Fork at the end
                = Stipe Nothing oldSize $
                        ps' ++
@@ -29,10 +29,10 @@ applyLSystem rgen rules plant = go plant
          where newForks = map (\(angle, newSize) -> (angle, Stipe (Just newSize) 0 [])) branchSpecs
                ps' = mapSprouts go ps
 
-       noAction (Stipe () oldSize ps)
+       noAction (Stipe _ oldSize ps)
                = Stipe Nothing oldSize $ mapSprouts go ps
 
-       go :: Plant () -> GrowingPlant
+       go :: AnnotatedPlant -> GrowingPlant
        go p = case filter (isValid.snd) $ map (second (applyAction p)) $ mapMaybe ($ p) rules of
                []      -> noAction p
                choices -> chooseWeighted rgen choices
diff --git a/src/Lseed/StipeInfo.hs b/src/Lseed/StipeInfo.hs
new file mode 100644 (file)
index 0000000..3d657ff
--- /dev/null
@@ -0,0 +1,19 @@
+module Lseed.StipeInfo where
+
+import Lseed.Data
+import Lseed.Data.Functions
+import Lseed.Geometry
+
+annotatePlant :: Plant Double -> AnnotatedPlant
+annotatePlant = go 0 0
+  where go a d (Stipe light len ps) = Stipe (StipeInfo
+               { siLength    = len
+               , siSubLength = len + sum (map (siSubLength . extractOutmost . snd) ps')
+               , siLight     = light
+               , siSubLight  = light + sum (map (siSubLight . extractOutmost . snd) ps')
+               , siAngle     = a
+               , siDirection = normAngle d
+               }) len ps'
+         where ps' = map (\(a',p) -> (a', go a' (d+a') p)) ps
+
+normAngle a = a - fromIntegral (truncate ((a+pi) / (2*pi))) * 2*pi
index cf3c036..961fe5c 100644 (file)
@@ -7,6 +7,7 @@ import Lseed.Grammar.Parse
 import Lseed.LSystem
 import Lseed.Constants
 import Lseed.Geometry
+import Lseed.StipeInfo
 import Data.List
 import Control.Concurrent
 import Control.Monad
@@ -82,16 +83,19 @@ remainingGrowth planted = go (phenotype planted)
 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
 growGarden angle rgen garden = sequence $ zipWith growPlanted garden' lightings
   where lightings = map (plantTotalSum . phenotype) $ lightenGarden angle garden'
-       garden' = applyGenome rgen garden
+       garden' = applyGenome angle rgen garden
 
 -- | For all Growing plants that are done, find out the next step
-applyGenome :: (RandomGen g) => g -> GrowingGarden -> GrowingGarden 
-applyGenome rgen garden = zipWith applyGenome' rgens garden
+applyGenome :: (RandomGen g) => Angle -> g -> GrowingGarden -> GrowingGarden 
+applyGenome angle rgen garden = zipWith3 applyGenome' rgens garden lGarden
   where rgens = unfoldr (Just . split) rgen
-       applyGenome' rgen planted =
+       lGarden = lightenGarden angle garden
+       applyGenome' rgen planted lPlanted =
                if   remainingGrowth planted < eps
-               then planted { phenotype = applyLSystem rgen (genome planted)
-                                                            (finishGrowth (phenotype planted))
+               then planted { phenotype = applyLSystem rgen
+                                                       (genome planted)
+                                                       (annotatePlant (phenotype lPlanted))
+                    -- here, we throw away the last eps of growth. Is that a problem?
                             }
                else planted