Refactor: Simplify Plant datatype
authorJoachim Breitner <mail@joachim-breitner.de>
Thu, 7 May 2009 14:00:00 +0000 (16:00 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Thu, 7 May 2009 14:00:00 +0000 (16:00 +0200)
Ah, type safety is great. I think I did not make mistakes :-)

src/Lseed/Data.hs
src/Lseed/Data/Functions.hs
src/Lseed/Geometry.hs
src/Lseed/LSystem.hs
src/Lseed/Renderer/Cairo.hs
src/main.hs

index 5535408..dfdeb1a 100644 (file)
@@ -4,6 +4,7 @@ module Lseed.Data where
 import Data.Foldable (Foldable, fold)
 import Data.Traversable (Traversable, sequenceA)
 import Control.Applicative ((<$>),(<*>),pure)
+import Control.Arrow (second)
 import Data.Monoid
 
 -- | A list of plants, together with their position in the garden, in the interval [0,1]
@@ -24,23 +25,21 @@ type GrowingPlanted = Planted (Maybe Double)
 
 -- | A plant, which is
 data Plant a 
-       -- | a bud, i.e. the end of a sprout
-       = Bud
        -- | a stipe with a length (factor of stipeLength)
-       --   and more of the plant next
-       | Stipe a Double (Plant a)
-       -- ^ a fork with a sidewise offspring at a radial angle,
-       --   and a straight continuation 
-       | Fork Double (Plant a) (Plant a)
+       --   and a list of plants sprouting at the end, at a given radial angle.
+       = Stipe a Double [ (Double, Plant a) ]
        deriving (Show)
 
+mapSprouts :: (Plant a -> Plant b) -> [ (Double, Plant a) ] -> [ (Double, Plant b) ]
+mapSprouts = map . second
+
 -- | Named variants of a Plant, for more expressive type signatures
 type GrowingPlant = 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
+        | ForkStipe Double [(Angle, Double)] -- ^ 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
@@ -61,23 +60,14 @@ type Angle = Double
 
 -- Instances
 instance Functor Plant where
-       fmap f Bud = Bud
-       fmap f (Stipe x len p1) = Stipe (f x) len (fmap f p1)
-       fmap f (Fork angle p1 p2) = Fork angle (fmap f p1) (fmap f p2)
+       fmap f (Stipe x len ps) = Stipe (f x) len (map (second (fmap f)) ps)
 
 instance Foldable Plant where
-       fold Bud  = mempty
-       fold (Stipe x len p1) = x `mappend` fold p1
-       fold (Fork angle p1 p2) = fold p1 `mappend` fold p2
+       fold (Stipe x len ps) = x `mappend` (mconcat $ map (fold.snd) ps)
 
 instance Traversable Plant where
-       sequenceA Bud =
-               pure Bud
-       sequenceA (Stipe x len p1) =
-               Stipe <$> x <*> pure len <*> sequenceA p1
-       sequenceA (Fork angle p1 p2) =
-               Fork <$> pure angle <*> sequenceA p1 <*> sequenceA p2
-       
+       sequenceA (Stipe x len ps) =
+               Stipe <$> x <*> pure len <*> sequenceA (map (\(a,p) -> (,) a <$> sequenceA p) ps)
 
 instance Functor Planted where
        fmap f planted = planted { phenotype = fmap f (phenotype planted) }
index 5703193..0af9314 100644 (file)
@@ -4,14 +4,9 @@ import Lseed.Data
 import Data.Monoid
 
 -- | Puts the length of the current segment in the additional information field
---   Pieces without length ('Bud', 'Fork') receive a zero.
 plantPieceLengths :: Plant a -> Plant Double
-plantPieceLengths Bud =
-       Bud
-plantPieceLengths (Stipe _ len p1) =
-       Stipe len len (plantPieceLengths p1)
-plantPieceLengths (Fork angle p1 p2) =
-       Fork angle (plantPieceLengths p1) (plantPieceLengths p2)
+plantPieceLengths (Stipe _ len ps) =
+       Stipe len len (mapSprouts plantPieceLengths ps)
 
 plantLength :: Plant a -> Double
 plantLength = plantTotalSum . plantPieceLengths
@@ -19,20 +14,14 @@ plantLength = plantTotalSum . plantPieceLengths
 plantTotalSum :: Plant Double -> Double
 plantTotalSum = getSum . extractOutmost . subPieceAccumulate . fmap Sum 
 
-extractOutmost :: Monoid a =>  Plant a -> a
-extractOutmost Bud = mempty
+extractOutmost :: Plant a -> a
 extractOutmost (Stipe x _ _) = x
-extractOutmost (Fork _ p1 p2) = extractOutmost p1 `mappend` extractOutmost p2
 
 subPieceAccumulate :: Monoid m => Plant m -> Plant m
 subPieceAccumulate p = go p
-  where go Bud = Bud
-        go (Stipe x len p1) = let p1' = go p1
-                                  x' = x `mappend` extractOutmost p1'
-                              in  Stipe x' len p1'
-        go (Fork angle p1 p2) = let p1' = go p1
-                                    p2' = go p2
-                                in  Fork angle p1' p2'
+  where go (Stipe x len ps) = let ps' = mapSprouts go ps
+                                  x' = x `mappend` (mconcat $ map (extractOutmost.snd) ps')
+                              in  Stipe x' len ps'
 
 -- | Apply a function to each Planted in a Garden
 mapGarden :: (Planted a -> Planted b) -> Garden a -> Garden b
index 88a726a..744c8fc 100644 (file)
@@ -49,11 +49,10 @@ plantedToLines planted = runGeometryGenerator (plantPosition planted, 0) 0 $
                plantToGeometry (phenotype planted)
 
 plantToGeometry :: Plant a -> GeometryGenerator a ()
-plantToGeometry Bud = return ()
-plantToGeometry (Stipe x len p) = addLine x ((0,0),(0,len * stipeLength)) >>
-                                 translated (0,len * stipeLength) (plantToGeometry p)
-plantToGeometry (Fork angle p1 p2) = rotated angle (plantToGeometry p1) >>
-                                                   (plantToGeometry p2)
+plantToGeometry (Stipe x len ps) = do
+               addLine x ((0,0),(0,len * stipeLength))
+               translated (0,len * stipeLength) $ forM_ ps $ \(angle,p) ->
+                       rotated angle $ plantToGeometry p
 
 -- | Lines are annotated with its plant, identified by the extra data
 gardenToLines :: Garden a -> [(Line, a)]
index 0198a4a..8038a0c 100644 (file)
@@ -8,36 +8,30 @@ import System.Random
 
 applyLSystem :: RandomGen g => g -> LSystem -> Plant () -> GrowingPlant
 applyLSystem rgen rules plant = go plant
-  where applyAction (EnlargeStipe newSize) (Stipe () oldSize p')
+  where applyAction (EnlargeStipe newSize) (Stipe () oldSize ps)
                = 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 angle (Stipe (Just newSize) 0 Bud))
-       applyAction _ _ = error "Unknown Action or applied to wrong part of a plant"
+                  mapSprouts go ps
+       applyAction (ForkStipe pos []) (Stipe () oldSize ps) -- No branches
+               = Stipe Nothing oldSize $
+                 mapSprouts go ps
+       applyAction (ForkStipe pos branchSpecs) (Stipe () oldSize ps)
+               | 1-pos < eps -- Fork at the end
+               = Stipe Nothing oldSize $
+                       ps' ++
+                       newForks
+               | otherwise -- Fork not at the end
+               = Stipe Nothing (oldSize * pos) $
+                       [ (0, Stipe Nothing (oldSize * (1-pos)) ps') ] ++
+                       newForks
+         where newForks = map (\(angle, newSize) -> (angle, Stipe (Just newSize) 0 [])) branchSpecs
+               ps' = mapSprouts go ps
 
-       noAction (Stipe () oldSize p')
-               = Stipe Nothing oldSize $ go p'
-       noAction _ = error "Unknown Action or applied to wrong part of a plant"
+       noAction (Stipe () oldSize ps)
+               = Stipe Nothing oldSize $ mapSprouts go ps
 
-       go p = case p of
-                       Bud -> Bud
-                       Stipe () _ _ ->
-                               let choices = mapMaybe (\r -> r p) rules 
-                               in  if null choices
-                                    then noAction p
-                                    else applyAction (chooseWeighted rgen choices) p
-                       Fork angle p1 p2 ->
-                               Fork angle (go p1) (go p2)
+       go p = case mapMaybe (\r -> r p) rules of
+               []      -> noAction p
+               choices -> applyAction (chooseWeighted rgen choices) p
 
 chooseWeighted rgen list = replicated !! (c-1)
   where replicated = concatMap (\(w,e) -> replicate w e) list
index 0a5bab0..1d038a0 100644 (file)
@@ -77,21 +77,14 @@ renderPlanted planted = preserve $ do
        renderPlant (phenotype planted)
 
 renderPlant :: Plant a -> Render ()    
-renderPlant Bud = do
-       -- arc 0 0 budSize 0 (2*pi)
-       -- fill
-       return ()
-renderPlant (Stipe _ len p) = do
-       let l = len + plantLength p
+renderPlant (Stipe _ len ps) = do
+       let l = len + sum (map (plantLength.snd) ps)
        setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt l))
        moveTo 0 0
        lineTo 0 (len * stipeLength)
        stroke
        translate 0 (len * stipeLength)
-       renderPlant p
-renderPlant (Fork angle p1 p2) = do
-       preserve $ rotate angle >> renderPlant p1
-       renderPlant p2
+       forM_ ps $ \(angle, p) -> preserve $ rotate angle >> renderPlant p
                
 renderLightedPlanted :: Planted Double -> Render ()
 renderLightedPlanted planted = preserve $ do
@@ -99,8 +92,7 @@ renderLightedPlanted planted = preserve $ do
        renderLightedPlant (phenotype planted)
 
 renderLightedPlant :: Plant Double -> Render ()        
-renderLightedPlant Bud = return ()
-renderLightedPlant (Stipe intensity len p) = do
+renderLightedPlant (Stipe intensity len ps) = do
        moveTo 0 0
        lineTo 0 (len * stipeLength)
        let normalized = intensity / (len * stipeLength)
@@ -110,10 +102,7 @@ renderLightedPlant (Stipe intensity len p) = do
                setSourceRGBA 1 1 0 normalized
                stroke
        translate 0 (len * stipeLength)
-       renderPlant p
-renderLightedPlant (Fork angle p1 p2) = do
-       preserve $ rotate angle >> renderLightedPlant p1
-       renderLightedPlant p2
+       forM_ ps $ \(angle, p) -> preserve $ rotate angle >> renderLightedPlant p
                
 {- Line based rendering deprecated
 
index 39eb923..cf5e1e3 100644 (file)
@@ -45,7 +45,7 @@ readArgs doit = do
          else  do
                plants <- mapM parseFile args
                doit (spread plants)
-  where        spread gs = zipWith (\g p -> Planted ((p + 0.5) / l) g (Stipe () 0 Bud)) gs [0..]
+  where        spread gs = zipWith (\g p -> Planted ((p + 0.5) / l) g (Stipe () 0 [])) gs [0..]
          where l = fromIntegral (length gs)
              
                
@@ -76,10 +76,8 @@ main = readArgs $ \garden -> do
 -- | Calculates the length to be grown
 remainingGrowth :: GrowingPlanted -> Double
 remainingGrowth planted = go (phenotype planted)
-  where go Bud = 0
-        go (Fork _ p1 p2) = go p1 + go p2
-        go (Stipe Nothing _ p) = go p
-       go (Stipe (Just l2) l1 p) = (l2 - l1) +  go p
+  where go (Stipe Nothing _    ps) = sum (map (go.snd) ps)
+       go (Stipe (Just l2) l1 ps) = (l2 - l1) + sum (map (go.snd) ps)
 
 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
 growGarden angle rgen garden = sequence $ zipWith3 growPlanted rgens garden lightings
@@ -118,7 +116,5 @@ applyGrowth r = mapPlanted (applyGrowth' (\a b -> a * (1-r) + b * r))
 
 applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant
 applyGrowth' f = go
-  where go Bud = Bud
-        go (Stipe Nothing l p) = Stipe Nothing l (go p)
-        go (Fork a p1 p2) = Fork a (go p1) (go p2)
-       go (Stipe (Just l2) l1 p) = Stipe (Just l2) (f l1 l2) (go p)
+  where go (Stipe Nothing l ps)    = Stipe Nothing l (mapSprouts go ps)
+       go (Stipe (Just l2) l1 ps) = Stipe (Just l2) (f l1 l2) (mapSprouts go ps)