Big refactor: Move angle into Plant constructor
authorJoachim Breitner <mail@joachim-breitner.de>
Sat, 30 May 2009 11:54:30 +0000 (13:54 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Sat, 30 May 2009 11:54:30 +0000 (13:54 +0200)
This makes a few things easier, I pressume. Especially, the list of
tuples is avoided.

src/Lseed/Data.hs
src/Lseed/Data/Functions.hs
src/Lseed/Geometry.hs
src/Lseed/Grammar/Compile.hs
src/Lseed/LSystem.hs
src/Lseed/Logic.hs
src/Lseed/Renderer/Cairo.hs
src/Lseed/StipeInfo.hs
src/main.hs

index 440bd33..6ef64d4 100644 (file)
@@ -28,14 +28,15 @@ type GrowingPlanted = Planted (Maybe Double)
 
 -- | A plant, which is
 data Plant a 
-       -- | a stipe with a length (factor of stipeLength)
-       --   and a list of plants sprouting at the end, at a given radial angle.
-       = Stipe a Double [ (Double, Plant a) ]
+       -- | a stipe with a length (factor of stipeLength), an angle relative
+       -- to the parent stipe and a list of plants sprouting at the end
+       = Plant { pData :: a
+               , pLength :: Double
+               , pAngle :: Angle
+               , pBranches :: [ 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)
 
@@ -90,14 +91,15 @@ nullObserver = Observer (return ()) (\_ _ -> return ()) (\_ -> return ()) (\_ ->
 
 -- Instances
 instance Functor Plant where
-       fmap f (Stipe x len ps) = Stipe (f x) len (map (second (fmap f)) ps)
+       fmap f (Plant x len ang ps) = Plant (f x) len ang (map (fmap f) ps)
 
 instance Foldable Plant where
-       fold (Stipe x len ps) = x `mappend` (mconcat $ map (fold.snd) ps)
+       fold (Plant x len ang ps) = x `mappend` (mconcat $ map fold ps)
 
 instance Traversable Plant where
-       sequenceA (Stipe x len ps) =
-               Stipe <$> x <*> pure len <*> sequenceA (map (\(a,p) -> (,) a <$> sequenceA p) ps)
+       sequenceA (Plant x len ang ps) =
+               Plant <$> x <*> pure len <*> pure ang <*>
+                       sequenceA (map sequenceA ps)
 
 instance Functor Planted where
        fmap f planted = planted { phenotype = fmap f (phenotype planted) }
index 0af9314..55b7d7f 100644 (file)
@@ -5,23 +5,20 @@ import Data.Monoid
 
 -- | Puts the length of the current segment in the additional information field
 plantPieceLengths :: Plant a -> Plant Double
-plantPieceLengths (Stipe _ len ps) =
-       Stipe len len (mapSprouts plantPieceLengths ps)
+plantPieceLengths (Plant _ len ang ps) =
+       Plant len len ang (map plantPieceLengths ps)
 
 plantLength :: Plant a -> Double
 plantLength = plantTotalSum . plantPieceLengths
 
 plantTotalSum :: Plant Double -> Double
-plantTotalSum = getSum . extractOutmost . subPieceAccumulate . fmap Sum 
-
-extractOutmost :: Plant a -> a
-extractOutmost (Stipe x _ _) = x
+plantTotalSum = getSum . pData . subPieceAccumulate . fmap Sum 
 
 subPieceAccumulate :: Monoid m => Plant m -> Plant m
 subPieceAccumulate p = go p
-  where go (Stipe x len ps) = let ps' = mapSprouts go ps
-                                  x' = x `mappend` (mconcat $ map (extractOutmost.snd) ps')
-                              in  Stipe x' len ps'
+  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'
 
 -- | Apply a function to each Planted in a Garden
 mapGarden :: (Planted a -> Planted b) -> Garden a -> Garden b
index 744c8fc..7e860f8 100644 (file)
@@ -49,10 +49,9 @@ plantedToLines planted = runGeometryGenerator (plantPosition planted, 0) 0 $
                plantToGeometry (phenotype planted)
 
 plantToGeometry :: Plant a -> GeometryGenerator a ()
-plantToGeometry (Stipe x len ps) = do
+plantToGeometry (Plant x len ang ps) = rotated ang $ do
                addLine x ((0,0),(0,len * stipeLength))
-               translated (0,len * stipeLength) $ forM_ ps $ \(angle,p) ->
-                       rotated angle $ plantToGeometry p
+               translated (0,len * stipeLength) $ mapM_ plantToGeometry ps
 
 -- | Lines are annotated with its plant, identified by the extra data
 gardenToLines :: Garden a -> [(Line, a)]
index bfa2837..b7a3d3b 100644 (file)
@@ -16,7 +16,7 @@ compileGrammarRule rule plant =
 
 
 conformsTo :: AnnotatedPlant -> Condition -> Bool
-conformsTo (Stipe si l _) = go
+conformsTo (Plant {pData = si}) = go
   where go (Always b)     = b
        go (c1 `And` c2)  = go c1 && go c2
        go (c1 `Or` c2)   = go c1 || go c2
@@ -37,9 +37,9 @@ conformsTo (Stipe si l _) = go
        doCompare GE = (>=)
 
 grToLAction :: GrammarAction -> AnnotatedPlant -> LRuleAction
-grToLAction (SetLength _ ld) (Stipe _ l _)
+grToLAction (SetLength _ ld) (Plant _ l _ _)
        = EnlargeStipe (calcLengthDescr ld l)
-grToLAction (AddBranches _ frac branches) (Stipe _ l _)
+grToLAction (AddBranches _ frac branches) (Plant _ l _ _)
        = ForkStipe frac $ map (\(angle,length,_) -> (angle, length)) branches
 
 -- | Length reductions are silenty turned into no-ops
index 8ed36cb..2b463c6 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 (Stipe _ oldSize ps) (EnlargeStipe newSize) 
-               = Stipe (Just newSize) oldSize $
-                  mapSprouts go ps
-       applyAction (Stipe _ oldSize ps) (ForkStipe pos [])-- No branches
-               = Stipe Nothing oldSize $
-                 mapSprouts go ps
-       applyAction (Stipe _ oldSize ps) (ForkStipe pos branchSpecs)
+       applyAction (Plant _ oldSize ang ps) (EnlargeStipe newSize) 
+               = Plant (Just newSize) oldSize ang $
+                  map go ps
+       applyAction (Plant _ oldSize ang ps) (ForkStipe pos [])-- No branches
+               = Plant Nothing oldSize ang $
+                 map go ps
+       applyAction (Plant _ oldSize ang ps) (ForkStipe pos branchSpecs)
                | 1-pos < eps -- Fork at the end
-               = Stipe Nothing oldSize $
+               = Plant Nothing oldSize ang $
                        ps' ++
                        newForks
                | otherwise -- Fork not at the end
-               = Stipe Nothing (oldSize * pos) $
-                       [ (0, Stipe Nothing (oldSize * (1-pos)) ps') ] ++
+               = Plant Nothing (oldSize * pos) ang $
+                       [ Plant Nothing (oldSize * (1-pos)) 0 ps' ] ++
                        newForks
-         where newForks = map (\(angle, newSize) -> (angle, Stipe (Just newSize) 0 [])) branchSpecs
-               ps' = mapSprouts go ps
+         where newForks = map (\(angle, newSize) -> Plant (Just newSize) 0 angle []) branchSpecs
+               ps' = map go ps
 
-       noAction (Stipe _ oldSize ps)
-               = Stipe Nothing oldSize $ mapSprouts go ps
+       noAction (Plant _ oldSize ang ps)
+               = Plant Nothing oldSize ang $ map go ps
 
        go :: AnnotatedPlant -> GrowingPlant
        go p = case filter (isValid.snd) $ map (second (applyAction p)) $ mapMaybe ($ p) rules of
@@ -39,8 +39,8 @@ applyLSystem rgen rules plant = go plant
 
        -- Some general checks to rule out unwanted rules
        isValid :: GrowingPlant -> Bool
-       isValid (Stipe newSize oldSize ps) = anglesOk
-         where angles = sort $ map fst ps
+       isValid (Plant newSize oldSize ang 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 432b6d1..0fb2604 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 (Stipe Nothing _    ps) = sum (map (go.snd) ps)
-       go (Stipe (Just l2) l1 ps) = (l2 - l1) + sum (map (go.snd) 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 (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)
+  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)
index da1e3f8..086930c 100644 (file)
@@ -81,14 +81,15 @@ renderPlanted planted = preserve $ do
        renderPlant (phenotype planted)
 
 renderPlant :: Plant a -> Render ()    
-renderPlant (Stipe _ len ps) = do
-       let l = len + sum (map (plantLength.snd) ps)
+renderPlant (Plant _ len ang ps) = preserve $ do
+       rotate ang
+       let l = len + sum (map plantLength ps)
        setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt l))
        moveTo 0 0
        lineTo 0 (len * stipeLength)
        stroke
        translate 0 (len * stipeLength)
-       forM_ ps $ \(angle, p) -> preserve $ rotate angle >> renderPlant p
+       mapM_ renderPlant ps
                
 renderLightedPlanted :: Planted Double -> Render ()
 renderLightedPlanted planted = preserve $ do
@@ -96,7 +97,8 @@ renderLightedPlanted planted = preserve $ do
        renderLightedPlant (phenotype planted)
 
 renderLightedPlant :: Plant Double -> Render ()        
-renderLightedPlant (Stipe intensity len ps) = do
+renderLightedPlant (Plant intensity len ang ps) = preserve $ do
+       rotate ang
        moveTo 0 0
        lineTo 0 (len * stipeLength)
        let normalized = intensity / (len * stipeLength)
@@ -106,7 +108,7 @@ renderLightedPlant (Stipe intensity len ps) = do
                setSourceRGBA 1 1 0 normalized
                stroke
        translate 0 (len * stipeLength)
-       forM_ ps $ \(angle, p) -> preserve $ rotate angle >> renderLightedPlant p
+       mapM_ renderLightedPlant ps
                
 {- Line based rendering deprecated
 
index 3d657ff..dbd15e2 100644 (file)
@@ -5,15 +5,16 @@ 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
+annotatePlant = go 0
+  where go d (Plant light len ang ps) = Plant (StipeInfo
                { siLength    = len
-               , siSubLength = len + sum (map (siSubLength . extractOutmost . snd) ps')
+               , siSubLength = len + sum (map (siSubLength . pData) 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
+               , siSubLight  = light + sum (map (siSubLight . pData) ps')
+               , siAngle     = ang
+               , siDirection = normAngle d'
+               }) len ang ps'
+         where ps' = map (go d') ps
+               d' = (d+ang)
 
 normAngle a = a - fromIntegral (truncate ((a+pi) / (2*pi))) * 2*pi
index 9db46ab..b796844 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 (Plant () 0 0 [])) gs [0..]
          where l = fromIntegral (length gs)