Add UserTag support
authorJoachim Breitner <mail@joachim-breitner.de>
Sat, 30 May 2009 12:13:18 +0000 (14:13 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Sat, 30 May 2009 12:13:18 +0000 (14:13 +0200)
(untested yet, but compiles)

13 files changed:
src/Lseed/Data.hs
src/Lseed/Data/Functions.hs
src/Lseed/Geometry.hs
src/Lseed/Grammar.hs
src/Lseed/Grammar/Compile.hs
src/Lseed/LSystem.hs
src/Lseed/Logic.hs
src/Lseed/Renderer/Cairo.hs
src/Lseed/StipeInfo.hs
src/dbclient.hs
src/dbscorer.hs
src/fastScorer.hs
src/main.hs

index 6ef64d4..e6b5577 100644 (file)
@@ -33,10 +33,14 @@ data Plant a
        = Plant { pData :: a
                , pLength :: Double
                , pAngle :: Angle
+               , pUserTag :: UserTag
                , pBranches :: [ Plant a ]
                }
        deriving (Show)
 
+-- | A straight, untagged plant with length zero and no branches.
+inititalPlant = Plant () 0 0 "" []
+
 -- | Named variants of a Plant, for more expressive type signatures
 type GrowingPlant = Plant (Maybe Double)
 
@@ -54,8 +58,8 @@ 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
-        | ForkStipe Double [(Angle, Double)] -- ^ Branch this stipe at the given fraction and angles and let it grow to the given lengths
+       = 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
        deriving (Show)
 
 -- | A (compiled) rule of an L-system, with a matching function returning an action and weight
@@ -74,6 +78,9 @@ data ScreenContent = ScreenContent
 -- | Light angle
 type Angle = Double
 
+-- | User Tag
+type UserTag = String
+
 -- | Main loop observers
 data Observer = Observer
        -- | Called once, before the main loop starts
@@ -91,14 +98,16 @@ nullObserver = Observer (return ()) (\_ _ -> return ()) (\_ -> return ()) (\_ ->
 
 -- Instances
 instance Functor Plant where
-       fmap f (Plant x len ang ps) = Plant (f x) len ang (map (fmap f) ps)
+       fmap f p = p { pData = f (pData p)
+                    , pBranches = map (fmap f) (pBranches p)
+                    }
 
 instance Foldable Plant where
-       fold (Plant x len ang ps) = x `mappend` (mconcat $ map fold ps)
+       fold p = pData p `mappend` (mconcat $ map fold (pBranches p))
 
 instance Traversable Plant where
-       sequenceA (Plant x len ang ps) =
-               Plant <$> x <*> pure len <*> pure ang <*>
+       sequenceA (Plant x len ang ut ps) =
+               Plant <$> x <*> pure len <*> pure ang <*> pure ut <*>
                        sequenceA (map sequenceA ps)
 
 instance Functor Planted where
index 55b7d7f..d44860d 100644 (file)
@@ -5,8 +5,8 @@ import Data.Monoid
 
 -- | Puts the length of the current segment in the additional information field
 plantPieceLengths :: Plant a -> Plant Double
-plantPieceLengths (Plant _ len ang ps) =
-       Plant len len ang (map plantPieceLengths ps)
+plantPieceLengths (Plant _ len ang ut ps) =
+       Plant len len ang ut (map plantPieceLengths ps)
 
 plantLength :: Plant a -> Double
 plantLength = plantTotalSum . plantPieceLengths
@@ -16,9 +16,9 @@ plantTotalSum = getSum . pData . subPieceAccumulate . fmap Sum
 
 subPieceAccumulate :: Monoid m => Plant m -> Plant m
 subPieceAccumulate p = go p
-  where go (Plant x len ang ps) = let ps' = map go ps
-                                      x' = x `mappend` (mconcat $ map pData ps')
-                                  in  Plant x' len ang ps'
+  where go (Plant x len ang ut ps) = let ps' = map go ps
+                                         x' = x `mappend` (mconcat $ map pData ps')
+                                     in  Plant x' len ang ut ps'
 
 -- | Apply a function to each Planted in a Garden
 mapGarden :: (Planted a -> Planted b) -> Garden a -> Garden b
index 7e860f8..1be4e04 100644 (file)
@@ -49,7 +49,7 @@ plantedToLines planted = runGeometryGenerator (plantPosition planted, 0) 0 $
                plantToGeometry (phenotype planted)
 
 plantToGeometry :: Plant a -> GeometryGenerator a ()
-plantToGeometry (Plant x len ang ps) = rotated ang $ do
+plantToGeometry (Plant x len ang ps) = rotated ang $ do
                addLine x ((0,0),(0,len * stipeLength))
                translated (0,len * stipeLength) $ mapM_ plantToGeometry ps
 
index 5befeb9..1036e78 100644 (file)
@@ -10,8 +10,6 @@ type GrammarFile = [ GrammarRule ]
 type Priority = Int
 type Weight = Int
 
-type UserTag = String
-
 defaultPriority :: Priority
 defaultPriority = 0
 
@@ -56,7 +54,7 @@ data Condition
         
 data GrammarAction
        = SetLength (Maybe UserTag) LengthDescr
-       | AddBranches (Maybe UserTag) Double [(Angle, Double, (Maybe UserTag))]
+       | AddBranches (Maybe UserTag) Double [(Angle, Double, Maybe UserTag)]
        deriving (Read,Show)
 
 data LengthDescr = Absolute Double
index b7a3d3b..21ef502 100644 (file)
@@ -4,6 +4,7 @@ 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
@@ -37,10 +38,11 @@ conformsTo (Plant {pData = si}) = go
        doCompare GE = (>=)
 
 grToLAction :: GrammarAction -> AnnotatedPlant -> LRuleAction
-grToLAction (SetLength _ ld) (Plant _ l _ _)
-       = EnlargeStipe (calcLengthDescr ld l)
-grToLAction (AddBranches _ frac branches) (Plant _ l _ _)
-       = ForkStipe frac $ map (\(angle,length,_) -> (angle, length)) branches
+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
 
 -- | Length reductions are silenty turned into no-ops
 calcLengthDescr :: LengthDescr -> Double -> Double
index 2b463c6..7158749 100644 (file)
@@ -11,26 +11,26 @@ import Data.List
 applyLSystem :: RandomGen g => g -> LSystem -> AnnotatedPlant -> GrowingPlant
 applyLSystem rgen rules plant = go plant
   where applyAction :: AnnotatedPlant -> LRuleAction -> GrowingPlant
-       applyAction (Plant _ oldSize ang ps) (EnlargeStipe newSize) 
-               = Plant (Just newSize) oldSize ang $
+       applyAction (Plant _ oldSize ang _ ps) (EnlargeStipe ut newSize) 
+               = Plant (Just newSize) oldSize ang ut $
                   map go ps
-       applyAction (Plant _ oldSize ang ps) (ForkStipe pos [])-- No branches
-               = Plant Nothing oldSize ang $
+       applyAction (Plant _ oldSize ang _ ps) (ForkStipe ut pos [])-- No branches
+               = Plant Nothing oldSize ang ut $
                  map go ps
-       applyAction (Plant _ oldSize ang ps) (ForkStipe pos branchSpecs)
+       applyAction (Plant _ oldSize ang _ ps) (ForkStipe ut pos branchSpecs)
                | 1-pos < eps -- Fork at the end
-               = Plant Nothing oldSize ang $
+               = Plant Nothing oldSize ang ut $
                        ps' ++
                        newForks
                | otherwise -- Fork not at the end
-               = Plant Nothing (oldSize * pos) ang $
-                       [ Plant Nothing (oldSize * (1-pos)) 0 ps' ] ++
+               = Plant Nothing (oldSize * pos) ang ut $
+                       [ Plant Nothing (oldSize * (1-pos)) 0 ut ps' ] ++
                        newForks
-         where newForks = map (\(angle, newSize) -> Plant (Just newSize) 0 angle []) branchSpecs
+         where newForks = map (\(angle, newSize, ut) -> Plant (Just newSize) 0 angle ut []) branchSpecs
                ps' = map go ps
 
-       noAction (Plant _ oldSize ang ps)
-               = Plant Nothing oldSize ang $ map go ps
+       noAction (Plant _ oldSize ang ut ps)
+               = Plant Nothing oldSize ang ut $ map go ps
 
        go :: AnnotatedPlant -> GrowingPlant
        go p = case filter (isValid.snd) $ map (second (applyAction p)) $ mapMaybe ($ p) rules of
@@ -39,7 +39,7 @@ applyLSystem rgen rules plant = go plant
 
        -- Some general checks to rule out unwanted rules
        isValid :: GrowingPlant -> Bool
-       isValid (Plant newSize oldSize ang ps) = anglesOk
+       isValid (Plant newSize oldSize ang ut ps) = anglesOk
          where angles = sort $ map pAngle ps
                -- Are all angles not too close to each other?
                 anglesOk = all (> minAngle) (zipWith (flip (-)) angles (tail angles))
index 0fb2604..e951f41 100644 (file)
@@ -32,8 +32,8 @@ lightAngle diff = pi/100 + diff * (98*pi/100)
 -- | Calculates the length to be grown
 remainingGrowth :: GrowingPlanted -> Double
 remainingGrowth planted = go (phenotype planted)
-  where go (Plant Nothing   _  _ ps) = sum (map go ps)
-       go (Plant (Just l2) l1 _ ps) = (l2 - l1) + sum (map go ps)
+  where go (Plant Nothing   _  _ ps) = sum (map go ps)
+       go (Plant (Just l2) l1 _ ps) = (l2 - l1) + sum (map go ps)
 
 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
 growGarden angle rgen garden = sequence $ zipWith growPlanted garden' lightings
@@ -80,5 +80,5 @@ applyGrowth r = mapPlanted (applyGrowth' (\a b -> a * (1-r) + b * r))
 
 applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant
 applyGrowth' f = go
-  where go (Plant Nothing   l  ang ps) = Plant Nothing   l         ang (map go ps)
-       go (Plant (Just l2) l1 ang ps) = Plant (Just l2) (f l1 l2) ang (map go ps)
+  where go (Plant Nothing   l  ang ut ps) = Plant Nothing   l         ang ut (map go ps)
+       go (Plant (Just l2) l1 ang ut ps) = Plant (Just l2) (f l1 l2) ang ut (map go ps)
index 086930c..5ebe63b 100644 (file)
@@ -81,7 +81,7 @@ renderPlanted planted = preserve $ do
        renderPlant (phenotype planted)
 
 renderPlant :: Plant a -> Render ()    
-renderPlant (Plant _ len ang ps) = preserve $ do
+renderPlant (Plant _ len ang ut ps) = preserve $ do
        rotate ang
        let l = len + sum (map plantLength ps)
        setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt l))
@@ -97,7 +97,7 @@ renderLightedPlanted planted = preserve $ do
        renderLightedPlant (phenotype planted)
 
 renderLightedPlant :: Plant Double -> Render ()        
-renderLightedPlant (Plant intensity len ang ps) = preserve $ do
+renderLightedPlant (Plant intensity len ang ut ps) = preserve $ do
        rotate ang
        moveTo 0 0
        lineTo 0 (len * stipeLength)
index dbd15e2..229caed 100644 (file)
@@ -6,14 +6,14 @@ import Lseed.Geometry
 
 annotatePlant :: Plant Double -> AnnotatedPlant
 annotatePlant = go 0
-  where go d (Plant light len ang ps) = Plant (StipeInfo
+  where go d (Plant light len ang ut ps) = Plant (StipeInfo
                { siLength    = len
                , siSubLength = len + sum (map (siSubLength . pData) ps')
                , siLight     = light
                , siSubLight  = light + sum (map (siSubLight . pData) ps')
                , siAngle     = ang
                , siDirection = normAngle d'
-               }) len ang ps'
+               }) len ang ut ps'
          where ps' = map (go d') ps
                d' = (d+ang)
 
index 9eb91d2..cd63adc 100644 (file)
@@ -11,7 +11,7 @@ import Text.Printf
 
 getGarden = spread <$> map (either (error.show) compileGrammarFile . parseGrammar "" . dbcCode)
                   <$> getCodeToRun
-  where spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g (Stipe () 0 [])) gs [0..]
+  where spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g inititalPlant) gs [0..]
          where l = fromIntegral (length gs)
 
 main = do
index 0d749d6..d8666fa 100644 (file)
@@ -10,7 +10,7 @@ import Text.Printf
 
 getGarden = spread <$> map compileDBCode
                   <$> getCodeToRun
-  where spread gs = zipWith (\(u,g) p -> Planted ((fromIntegral p + 0.5) / l) u g (Stipe () 0 [])) gs [0..]
+  where spread gs = zipWith (\(u,g) p -> Planted ((fromIntegral p + 0.5) / l) u g inititalPlant) gs [0..]
          where l = fromIntegral (length gs)
 
 compileDBCode dbc =
index 1554561..24af2ee 100644 (file)
@@ -25,7 +25,7 @@ readArgs doit = do
          else  do
                genomes <- mapM parseFile args
                doit (spread genomes)
-  where        spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g (Stipe () 0 [])) gs [0..]
+  where        spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g inititalPlant) gs [0..]
          where l = fromIntegral (length gs)
              
 
index b796844..b0b9687 100644 (file)
@@ -25,9 +25,8 @@ readArgs doit = do
          else  do
                genomes <- mapM parseFile args
                doit (spread genomes)
-  where        spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g (Plant () 0 0 [])) gs [0..]
+  where        spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g inititalPlant) gs [0..]
          where l = fromIntegral (length gs)
-             
                
 main = readArgs $ \garden -> do
        obs <- cairoObserver