No data in Bud or Fork
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 2 Mar 2009 20:44:51 +0000 (21:44 +0100)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 2 Mar 2009 20:44:51 +0000 (21:44 +0100)
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 8089a50..04fc454 100644 (file)
@@ -25,13 +25,13 @@ type GrowingPlanted = Planted (Maybe Double)
 -- | A plant, which is
 data Plant a 
        -- | a bud, i.e. the end of a sprout
-       = Bud a
+       = 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)
+       | Fork Double (Plant a) (Plant a)
        deriving (Show)
 
 -- | Named variants of a Plant, for more expressive type signatures
@@ -60,22 +60,22 @@ type Angle = Double
 
 -- Instances
 instance Functor Plant where
-       fmap f (Bud x) = Bud (f x)
+       fmap f Bud = Bud
        fmap f (Stipe x len p1) = Stipe (f x) len (fmap f p1)
-       fmap f (Fork x angle p1 p2) = Fork (f x) angle (fmap f p1) (fmap f p2)
+       fmap f (Fork angle p1 p2) = Fork angle (fmap f p1) (fmap f p2)
 
 instance Foldable Plant where
-       fold (Bud x) = x
+       fold Bud  = mempty
        fold (Stipe x len p1) = x `mappend` fold p1
-       fold (Fork x angle p1 p2) = x `mappend` fold p1 `mappend` fold p2
+       fold (Fork angle p1 p2) = fold p1 `mappend` fold p2
 
 instance Traversable Plant where
-       sequenceA (Bud x) =
-               Bud <$> x
+       sequenceA Bud =
+               pure Bud
        sequenceA (Stipe x len p1) =
                Stipe <$> x <*> pure len <*> sequenceA p1
-       sequenceA (Fork angle p1 p2) =
-               Fork <$> x <*> pure angle <*> sequenceA p1 <*> sequenceA p2
+       sequenceA (Fork angle p1 p2) =
+               Fork <$> pure angle <*> sequenceA p1 <*> sequenceA p2
        
 
 instance Functor Planted where
index c40904e..5703193 100644 (file)
@@ -6,36 +6,33 @@ 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 0
+plantPieceLengths Bud =
+       Bud
 plantPieceLengths (Stipe _ len p1) =
        Stipe len len (plantPieceLengths p1)
-plantPieceLengths (Fork angle p1 p2) =
-       Fork angle (plantPieceLengths p1) (plantPieceLengths p2)
+plantPieceLengths (Fork angle p1 p2) =
+       Fork angle (plantPieceLengths p1) (plantPieceLengths p2)
 
-plantSubpieceLength :: Plant a -> Plant Double
-plantSubpieceLength = subPieceSum . plantPieceLengths
+plantLength :: Plant a -> Double
+plantLength = plantTotalSum . plantPieceLengths
 
-extractOutmost :: Plant a -> a
-extractOutmost (Bud x) = x
-extractOutmost (Stipe x _ _) = x
-extractOutmost (Fork x _ _ _) = x
+plantTotalSum :: Plant Double -> Double
+plantTotalSum = getSum . extractOutmost . subPieceAccumulate . fmap Sum 
 
-subPieceSum :: Plant Double -> Plant Double
-subPieceSum = fmap getSum . subPieceAccumulate . fmap Sum 
+extractOutmost :: Monoid a =>  Plant a -> a
+extractOutmost Bud = mempty
+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 x) = (Bud x)
+  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 x angle p1 p2) = let p1' = go p1
-                                      p2' = go p2
-                                      x' = x `mappend`
-                                           extractOutmost p1' `mappend`
-                                          extractOutmost p2'
-                                  in  Fork x' angle p1' p2'
+        go (Fork angle p1 p2) = let p1' = go p1
+                                    p2' = go p2
+                                in  Fork angle p1' p2'
 
 -- | Apply a function to each Planted in a Garden
 mapGarden :: (Planted a -> Planted b) -> Garden a -> Garden b
index a13db2b..88a726a 100644 (file)
@@ -49,11 +49,11 @@ plantedToLines planted = runGeometryGenerator (plantPosition planted, 0) 0 $
                plantToGeometry (phenotype planted)
 
 plantToGeometry :: Plant a -> GeometryGenerator a ()
-plantToGeometry (Bud _) = return ()
+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 (Fork angle p1 p2) = rotated angle (plantToGeometry p1) >>
+                                                   (plantToGeometry p2)
 
 -- | Lines are annotated with its plant, identified by the extra data
 gardenToLines :: Garden a -> [(Line, a)]
index b6f667f..14aed1c 100644 (file)
@@ -22,17 +22,16 @@ applyLSystem rgen rules plant = go plant
                                     | otherwise -- Fork in the middle
                                     = (Stipe Nothing (oldSize * pos),
                                       Stipe Nothing (oldSize * (1-pos)))
-               forks = flip $ foldr (\(angle, newSize) -> Fork Nothing angle (Stipe (Just newSize) 0 (Bud Nothing)))
+               forks = flip $ foldr (\(angle, newSize) -> Fork angle (Stipe (Just newSize) 0 Bud))
        applyAction _ _ = error "Unknown Action or applied to wrong part of a plant"
 
        go p = case p of
-                       Bud () ->
-                               Bud Nothing
+                       Bud -> Bud
                        Stipe () _ _ ->
                                let choices = mapMaybe (\r -> r p) rules 
                                in  applyAction (chooseWeighted rgen choices) p
-                       Fork () angle p1 p2 ->
-                               Fork Nothing angle (go p1) (go p2)
+                       Fork angle p1 p2 ->
+                               Fork angle (go p1) (go p2)
 
 chooseWeighted rgen list = replicated !! (c-1)
   where replicated = concatMap (\(w,e) -> replicate w e) list
index b939508..57ae2bb 100644 (file)
@@ -77,7 +77,7 @@ renderPlanted planted = preserve $ do
        renderPlant (phenotype planted)
 
 renderPlant :: Plant a -> Render ()    
-renderPlant (Bud _) = do
+renderPlant Bud = do
        -- arc 0 0 budSize 0 (2*pi)
        -- fill
        return ()
@@ -87,7 +87,7 @@ renderPlant (Stipe _ len p) = do
        stroke
        translate 0 (len * stipeLength)
        renderPlant p
-renderPlant (Fork angle p1 p2) = do
+renderPlant (Fork angle p1 p2) = do
        preserve $ rotate angle >> renderPlant p1
        renderPlant p2
                
@@ -97,7 +97,7 @@ renderLightedPlanted planted = preserve $ do
        renderLightedPlant (phenotype planted)
 
 renderLightedPlant :: Plant Double -> Render ()        
-renderLightedPlant (Bud _) = return ()
+renderLightedPlant Bud = return ()
 renderLightedPlant (Stipe intensity len p) = do
        moveTo 0 0
        lineTo 0 (len * stipeLength)
@@ -109,7 +109,7 @@ renderLightedPlant (Stipe intensity len p) = do
                stroke
        translate 0 (len * stipeLength)
        renderPlant p
-renderLightedPlant (Fork angle p1 p2) = do
+renderLightedPlant (Fork angle p1 p2) = do
        preserve $ rotate angle >> renderLightedPlant p1
        renderLightedPlant p2
                
@@ -150,9 +150,9 @@ renderInfo angle garden = do
        forM_ gardenWithLight $ \planted -> do
                let x = plantPosition planted
                let text1 = printf "Light: %.2f" $
-                               extractOutmost (subPieceSum (phenotype planted))
+                               plantTotalSum (phenotype planted)
                let text2 = printf "Size: %.2f" $
-                               extractOutmost $ plantSubpieceLength (phenotype planted)
+                               plantLength (phenotype planted)
                preserve $ do
                        scale 1 (-1)
                        setSourceRGB 0 0 0
index e4a6b26..5a6a8e3 100644 (file)
@@ -56,16 +56,14 @@ main = do
 -- | Calculates the length to be grown
 remainingGrowth :: GrowingPlanted -> Double
 remainingGrowth planted = go (phenotype planted)
-  where go (Bud Nothing) = 0
+  where go Bud = 0
+        go (Fork _ p1 p2) = go p1 + go p2
         go (Stipe Nothing _ p) = go p
-        go (Fork Nothing _ p1 p2) = go p1 + go p2
        go (Stipe (Just l2) l1 p) = (l2 - l1) +  go p
-       go p                    = error $ "Unexpected data in growing plant: " ++ show p
-
 
 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
 growGarden angle rgen garden = sequence $ zipWith3 growPlanted rgens garden lightings
-  where lightings = map (extractOutmost . subPieceSum . phenotype) $ lightenGarden angle garden
+  where lightings = map (plantTotalSum . phenotype) $ lightenGarden angle garden
         rgens = unfoldr (Just . split) rgen
 
 -- | Applies an L-System to a Plant, putting the new length in the additional
@@ -80,7 +78,7 @@ growPlanted rgen planted light =
                        else planted
            remainingLength = remainingGrowth planted'
        in  if remainingLength > eps
-            then let sizeOfPlant = extractOutmost $ plantSubpieceLength (phenotype planted)
+            then let sizeOfPlant = plantLength (phenotype planted)
                      lightAvailable = light - costPerLength * sizeOfPlant^2
                      allowedGrowths = max 0 $
                                       (growthPerDayAndLight * lightAvailable + growthPerDay) /
@@ -100,22 +98,21 @@ applyGrowth r = mapPlanted (applyGrowth' (\a b -> a * (1-r) + b * r))
 
 applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant
 applyGrowth' f = go
-  where go (Bud Nothing) = Bud Nothing
+  where go Bud = Bud
         go (Stipe Nothing l p) = Stipe Nothing l (go p)
-        go (Fork Nothing a p1 p2) = Fork Nothing a (go p1) (go p2)
+        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)
-       go p                    = error $ "Unexpected data in growing plant: " ++ show p
 
 testGarden =
-       [ Planted 0.1 testLSystem1 (Stipe () 0 (Bud ()))
-       , Planted 0.3 testLSystem2 (Stipe () 0 (Bud ()))
-       , Planted 0.5 testLSystem3 (Stipe () 0 (Bud ()))
-       , Planted 0.7 testLSystem2 (Stipe () 0 (Bud ()))
-       , Planted 0.9 testLSystem1 (Stipe () 0 (Bud ()))
+       [ Planted 0.1 testLSystem1 (Stipe () 0 Bud)
+       , Planted 0.3 testLSystem2 (Stipe () 0 Bud)
+       , Planted 0.5 testLSystem3 (Stipe () 0 Bud)
+       , Planted 0.7 testLSystem2 (Stipe () 0 Bud)
+       , Planted 0.9 testLSystem1 (Stipe () 0 Bud)
        ]
 testGarden2 =
-       [ Planted 0.4 testLSystem1 (Stipe () 0 (Bud ()))
-       , Planted 0.6 testLSystem1 (Stipe () 0 (Bud ()))
+       [ Planted 0.4 testLSystem1 (Stipe () 0 Bud)
+       , Planted 0.6 testLSystem1 (Stipe () 0 Bud)
        ]
 
 testLSystem1 = [