Big refactor: Get rid of Lseed
authorJoachim Breitner <mail@joachim-breitner.de>
Sun, 7 Jun 2009 21:41:41 +0000 (23:41 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Sun, 7 Jun 2009 21:41:41 +0000 (23:41 +0200)
Apply Grammar directly to the plant in question

src/Lseed/Data.hs
src/Lseed/Grammar.hs [deleted file]
src/Lseed/Grammar/Compile.hs [deleted file]
src/Lseed/Grammar/Parse.hs
src/Lseed/LSystem.hs
src/Lseed/Logic.hs
src/main.hs

index 7e49c7b..63f58ca 100644 (file)
@@ -8,6 +8,12 @@ import Control.Arrow (second)
 import Data.Monoid
 import System.Time (ClockTime)
 
+-- | User Tag
+type UserTag = String
+
+-- | Light angle
+type Angle = Double
+
 -- | A list of plants, together with their position in the garden, in the interval [0,1]
 type Garden a = [ Planted a ]
 
@@ -19,7 +25,7 @@ type AnnotatedGarden = Garden StipeInfo
 data Planted a = Planted
        { plantPosition :: Double -- ^ Position in the garden, interval [0,1]
        , plantOwner    :: Integer -- ^ Id of the user that owns this plant
-       , genome        :: LSystem -- ^ Lsystem in use
+       , genome        :: GrammarFile -- ^ Lsystem in use
        , phenotype     :: Plant a -- ^ Actual current form of the plant
        }
 
@@ -63,19 +69,6 @@ data GrowthState = NoGrowth
 type GrowingPlant = Plant GrowthState
 type AnnotatedPlant = Plant StipeInfo
 
--- | Possible action to run on a Stipe in a Rule
-data LRuleAction
-       = EnlargeStipe UserTag Double -- ^ Extend this Stipe to the given length
-        | ForkStipe UserTag Double [(Angle, Double, UserTag)] -- ^ Branch this stipe at the given fraction and angles and let it grow to the given lengths
-       | DoBlossom UserTag -- ^ Start a to grow a new seed
-       deriving (Show)
-
--- | A (compiled) rule of an L-system, with a matching function returning an action and weight
-type LRule = (AnnotatedPlant -> Maybe (Int, LRuleAction))
-
--- | An complete LSystem 
-type LSystem = [LRule]
-
 -- | Representation of what is on screen
 data ScreenContent = ScreenContent
        { scGarden     :: AnnotatedGarden
@@ -83,12 +76,6 @@ data ScreenContent = ScreenContent
        , scTime       :: String
        }
 
--- | Light angle
-type Angle = Double
-
--- | User Tag
-type UserTag = String
-
 -- | Main loop observers
 data Observer = Observer
        -- | Called once, before the main loop starts
@@ -104,6 +91,67 @@ data Observer = Observer
        }
 nullObserver = Observer (return ()) (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ())
 
+
+-- | A complete grammar file
+type GrammarFile = [ GrammarRule ]
+
+type Priority = Int
+type Weight = Int
+
+defaultPriority :: Priority
+defaultPriority = 0
+
+defaultWeight :: Weight
+defaultWeight = 1
+
+-- | A single Rule. For now, only single branches
+--   can be matched, not whole subtree structures
+data GrammarRule = GrammarRule
+       { grName :: String
+       , grPriority :: Priority
+       , grWeight :: Weight
+       , grCondition :: Condition
+       , grAction :: GrammarAction
+       }
+       deriving (Read,Show)
+
+data Matchable
+       = MatchLight
+       | MatchSubLight
+       | MatchLength
+       | MatchSubLength
+       | MatchDirection
+       | MatchAngle
+       deriving (Read,Show)
+
+data Cmp
+       = LE
+       | Less
+       | Equals
+       | Greater
+       | GE 
+       deriving (Read,Show)
+
+data Condition
+       = Always Bool -- constant conditions
+       | Condition `And` Condition
+       | Condition `Or` Condition
+       | UserTagIs String
+       | NumCond Matchable Cmp Double
+       deriving (Read,Show)
+        
+data GrammarAction
+       = SetLength (Maybe UserTag) LengthDescr
+       | AddBranches (Maybe UserTag) Double [(Angle, Double, Maybe UserTag)]
+       | Blossom (Maybe UserTag)
+       deriving (Read,Show)
+
+data LengthDescr = Absolute Double
+                | Additional Double
+                 | AdditionalRelative Double -- ^ in Percent
+       deriving (Read,Show)
+
+
 -- Instances
 instance Functor Plant where
        fmap f p = p { pData = f (pData p)
diff --git a/src/Lseed/Grammar.hs b/src/Lseed/Grammar.hs
deleted file mode 100644 (file)
index 0c5e8db..0000000
+++ /dev/null
@@ -1,65 +0,0 @@
--- | Grammer-like representation for a plant genome
-module Lseed.Grammar where
-
-import Lseed.Data
-import Data.List
-
--- | A complete grammar file
-type GrammarFile = [ GrammarRule ]
-
-type Priority = Int
-type Weight = Int
-
-defaultPriority :: Priority
-defaultPriority = 0
-
-defaultWeight :: Weight
-defaultWeight = 1
-
--- | A single Rule. For now, only single branches
---   can be matched, not whole subtree structures
-data GrammarRule = GrammarRule
-       { grName :: String
-       , grPriority :: Priority
-       , grWeight :: Weight
-       , grCondition :: Condition
-       , grAction :: GrammarAction
-       }
-       deriving (Read,Show)
-
-data Matchable
-       = MatchLight
-       | MatchSubLight
-       | MatchLength
-       | MatchSubLength
-       | MatchDirection
-       | MatchAngle
-       deriving (Read,Show)
-
-data Cmp
-       = LE
-       | Less
-       | Equals
-       | Greater
-       | GE 
-       deriving (Read,Show)
-
-data Condition
-       = Always Bool -- constant conditions
-       | Condition `And` Condition
-       | Condition `Or` Condition
-       | UserTagIs String
-       | NumCond Matchable Cmp Double
-       deriving (Read,Show)
-        
-data GrammarAction
-       = SetLength (Maybe UserTag) LengthDescr
-       | AddBranches (Maybe UserTag) Double [(Angle, Double, Maybe UserTag)]
-       | Blossom (Maybe UserTag)
-       deriving (Read,Show)
-
-data LengthDescr = Absolute Double
-                | Additional Double
-                 | AdditionalRelative Double -- ^ in Percent
-       deriving (Read,Show)
-
diff --git a/src/Lseed/Grammar/Compile.hs b/src/Lseed/Grammar/Compile.hs
deleted file mode 100644 (file)
index d47bf30..0000000
+++ /dev/null
@@ -1,54 +0,0 @@
--- | Code to turn a 'Lseed.Grammar' into a 'LSystem'
-module Lseed.Grammar.Compile where
-
-import Lseed.Data
-import Lseed.Grammar
-import Data.List (nub)
-import Data.Maybe(fromMaybe)
-
-compileGrammarFile :: GrammarFile -> LSystem
-compileGrammarFile = map compileGrammarRule
-
-compileGrammarRule :: GrammarRule -> LRule
-compileGrammarRule rule plant = 
-       if   plant `conformsTo` grCondition rule
-       then Just ({- grPriority rule, -}grWeight rule, grToLAction (grAction rule) plant)
-       else Nothing
-
-
-conformsTo :: AnnotatedPlant -> Condition -> Bool
-conformsTo (Plant {pData = si, pUserTag = ut}) = 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') = ut' == ut
-       go (NumCond what how val) = doCompare how (getMatchable what) val
-       
-       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 = (<)
-       doCompare Equals = (==)
-       doCompare Greater = (>)
-       doCompare GE = (>=)
-
-grToLAction :: GrammarAction -> AnnotatedPlant -> LRuleAction
-grToLAction (SetLength mut ld) (Plant { pLength = l, pUserTag = oldUt })
-       = EnlargeStipe (fromMaybe oldUt mut) (calcLengthDescr ld l)
-grToLAction (AddBranches mut frac branches) (Plant { pLength = l, pUserTag = oldUt })
-       = ForkStipe (fromMaybe oldUt mut) frac $
-               map (\(a,b,c) -> (a,b,fromMaybe oldUt c)) branches
-grToLAction (Blossom mut) (Plant { pLength = l, pUserTag = oldUt })
-       = DoBlossom (fromMaybe oldUt mut)
-
--- | Length reductions are silenty turned into no-ops
-calcLengthDescr :: LengthDescr -> Double -> Double
-calcLengthDescr (Absolute val) l  = max l val
-calcLengthDescr (Additional val) l = max l (l + val)
-calcLengthDescr (AdditionalRelative val) l = max l (l + l * (val/100))
-
index 4bace5f..b0cd673 100644 (file)
@@ -7,7 +7,6 @@ import Text.Parsec.Expr
 import Control.Monad
 
 import Lseed.Data
-import Lseed.Grammar
 
 -- The lexer
 lexer       = P.makeTokenParser $ javaStyle
index 73685cb..50c675a 100644 (file)
@@ -8,37 +8,50 @@ import System.Random
 import Control.Arrow (second)
 import Data.List
 
-applyLSystem :: RandomGen g => g -> LSystem -> AnnotatedPlant -> GrowingPlant
+applyLSystem :: RandomGen g => g -> GrammarFile -> AnnotatedPlant -> GrowingPlant
 applyLSystem rgen rules plant = go plant
-  where applyAction :: AnnotatedPlant -> LRuleAction -> GrowingPlant
-       applyAction (Plant _ oldSize ang _ ps) (DoBlossom ut)
-               = Plant (GrowingSeed 0) oldSize ang ut $
-                  map go ps
-       applyAction (Plant _ oldSize ang _ ps) (EnlargeStipe ut newSize) 
-               = Plant (EnlargingTo newSize) oldSize ang ut $
-                  map go ps
-       applyAction (Plant _ oldSize ang _ ps) (ForkStipe ut pos [])-- No branches
-               = Plant NoGrowth oldSize ang ut $
-                 map go ps
-       applyAction (Plant _ oldSize ang _ ps) (ForkStipe ut pos branchSpecs)
-               | 1-pos < eps -- Fork at the end
-               = Plant NoGrowth oldSize ang ut $
-                       ps' ++
-                       newForks
-               | otherwise -- Fork not at the end
-               = Plant NoGrowth (oldSize * pos) ang ut $
-                       [ Plant NoGrowth (oldSize * (1-pos)) 0 ut ps' ] ++
-                       newForks
-         where newForks = map (\(angle, newSize, ut) -> Plant (EnlargingTo newSize) 0 angle ut []) branchSpecs
+  where go :: AnnotatedPlant -> GrowingPlant
+       go p@(Plant { pUserTag = oldUt
+                   , pLength = oldSize
+                   , pAngle = ang
+                   , pBranches = ps
+                   })
+               = case filter (isValid.snd) $
+                       map applyRule $
+                       filter (\r -> p `conformsTo` grCondition r) $
+                       rules
+               of
+               []      -> noAction
+               choices -> chooseWeighted rgen choices
+         where applyRule :: GrammarRule -> (Int, GrowingPlant)
+               applyRule r = (grWeight r, applyAction (grAction r))
+         
+               applyAction :: GrammarAction -> GrowingPlant
+               applyAction (SetLength mut ld)
+                       = p { pData    = EnlargingTo (calcLengthDescr ld oldSize)
+                           , pUserTag = fromMaybe oldUt mut
+                           , pBranches = ps'
+                           }
+               applyAction (AddBranches mut pos branches) 
+                       | 1-pos < eps -- Fork at the end
+                       = p { pData = NoGrowth
+                           , pUserTag = ut
+                           , pBranches = ps' ++ newForks}
+                       | otherwise -- Fork not at the end
+                       = Plant NoGrowth (oldSize * pos) ang ut $
+                         [ Plant NoGrowth (oldSize * (1-pos)) 0 ut ps' ] ++
+                         newForks
+                where  ut = fromMaybe oldUt mut
+                       newForks = map (\(angle, newSize, ut) -> Plant (EnlargingTo newSize) 0 angle (fromMaybe oldUt ut) []) branches
+               applyAction (Blossom mut) 
+                       = p { pData = GrowingSeed 0
+                           , pBranches = ps'
+                           }
+       
+               noAction = p { pData = NoGrowth, pBranches = ps' }
+               
                ps' = map go ps
 
-       noAction (Plant _ oldSize ang ut ps)
-               = Plant NoGrowth oldSize ang ut $ map go ps
-
-       go :: AnnotatedPlant -> GrowingPlant
-       go p = case filter (isValid.snd) $ map (second (applyAction p)) $ mapMaybe ($ p) rules of
-               []      -> noAction p
-               choices -> chooseWeighted rgen choices
 
        -- Some general checks to rule out unwanted rules
        isValid :: GrowingPlant -> Bool
@@ -50,3 +63,33 @@ applyLSystem rgen rules plant = go plant
 chooseWeighted rgen list = replicated !! (c-1)
   where replicated = concatMap (\(w,e) -> replicate w e) list
         (c,_) = randomR (1, length replicated) rgen
+
+
+
+conformsTo :: AnnotatedPlant -> Condition -> Bool
+conformsTo (Plant {pData = si, pUserTag = ut}) = 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') = ut' == ut
+       go (NumCond what how val) = doCompare how (getMatchable what) val
+       
+       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 = (<)
+       doCompare Equals = (==)
+       doCompare Greater = (>)
+       doCompare GE = (>=)
+
+-- | Length reductions are silenty turned into no-ops
+calcLengthDescr :: LengthDescr -> Double -> Double
+calcLengthDescr (Absolute val) l  = max l val
+calcLengthDescr (Additional val) l = max l (l + val)
+calcLengthDescr (AdditionalRelative val) l = max l (l + l * (val/100))
+
index 389a470..b5ec02c 100644 (file)
@@ -3,8 +3,6 @@ module Lseed.Logic where
 
 import Lseed.Data
 import Lseed.Data.Functions
-import Lseed.Grammar
-import Lseed.Grammar.Compile
 import Lseed.Grammar.Parse
 import Lseed.LSystem
 import Lseed.Constants
index ff8fff3..3579e14 100644 (file)
@@ -1,6 +1,5 @@
 import Lseed.Data
 import Lseed.Data.Functions
-import Lseed.Grammar.Compile
 import Lseed.Grammar.Parse
 import Lseed.Constants
 import Lseed.Mainloop
@@ -14,7 +13,7 @@ import Lseed.Renderer.Cairo
 parseFile filename = do
        content <- readFile filename
        let result = parseGrammar filename content
-       return $ either (error.show) compileGrammarFile result
+       return $ either (error.show) id result
 
 readArgs doit = do
        args <- getArgs