Store light information in original Garden, using ST. Use that for drawing
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 9 Feb 2009 22:34:39 +0000 (23:34 +0100)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 9 Feb 2009 22:34:39 +0000 (23:34 +0100)
src/Lseed/Data.hs
src/Lseed/Data/Functions.hs
src/Lseed/Geometry.hs
src/Lseed/Geometry/Generator.hs
src/Lseed/Renderer/Cairo.hs

index b1957b9..45fdeb5 100644 (file)
@@ -56,3 +56,9 @@ instance Traversable Plant where
 
 instance Functor Planted where
        fmap f planted = planted { phenotype = fmap f (phenotype planted) }
+
+instance Foldable Planted where
+       fold planted = fold (phenotype planted)
+
+instance Traversable Planted where
+       sequenceA planted = (\x -> planted { phenotype = x }) <$> sequenceA (phenotype planted)
index 428cd57..1ed38c0 100644 (file)
@@ -14,13 +14,16 @@ plantPieceLengths (Fork _ angle p1 p2) =
        Fork 0 angle (plantPieceLengths p1) (plantPieceLengths p2)
 
 plantSubpieceLength :: Plant a -> Plant Double
-plantSubpieceLength = fmap getSum . subPieceAccumulate . fmap Sum . plantPieceLengths
+plantSubpieceLength = subPieceSum . plantPieceLengths
 
 extractOutmost :: Plant a -> a
 extractOutmost (Bud x) = x
 extractOutmost (Stipe x _ _) = x
 extractOutmost (Fork x _ _ _) = x
 
+subPieceSum :: Plant Double -> Plant Double
+subPieceSum = fmap getSum . subPieceAccumulate . fmap Sum 
+
 subPieceAccumulate :: Monoid m => Plant m -> Plant m
 subPieceAccumulate p = go p
   where go (Bud x) = (Bud x)
index 4974a71..b57681c 100644 (file)
@@ -6,7 +6,13 @@ import Lseed.Constants
 import Lseed.Geometry.Generator
 import Data.List
 import Data.Maybe
+import Data.Ord
 import qualified Data.Map as M
+import Control.Monad hiding (mapM,forM)
+import Data.Traversable (mapM,forM)
+import Prelude hiding (mapM)
+import Control.Monad.ST
+import Data.STRef
 
 import Debug.Trace
 
@@ -41,37 +47,32 @@ crossPoint ((x1,y1),(x2,y2)) ((x3,y3),(x4,y4)) =
            else Nothing
 
 
-plantedToLines :: Planted a -> [Line]
+plantedToLines :: Planted a -> [(Line, a)]
 plantedToLines planted = runGeometryGenerator (plantPosition planted, 0) 0 $
                plantToGeometry (phenotype planted)
 
-plantToGeometry :: Plant a -> GeometryGenerator ()
+plantToGeometry :: Plant a -> GeometryGenerator ()
 plantToGeometry (Bud _) = return ()
-plantToGeometry (Stipe _ len p) = addLine ((0,0),(0,len * stipeLength)) >>
+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)
 
--- | Lines are annotated with its plant, identified by the position
-gardenToLines :: Garden a -> [(Line, Double)]
-gardenToLines = concatMap (\planted -> map (\line -> (line, plantPosition planted)) (plantedToLines planted))
+-- | Lines are annotated with its plant, identified by the extra data
+gardenToLines :: Garden a -> [(Line, a)]
+gardenToLines = concatMap (\planted -> plantedToLines planted)
 
 -- | Add lightning from a given angle
-lightenLines :: (Ord a, Show a) => Double -> [(Line, a)] -> [(Line, a, Double)]
+lightenLines :: Double -> [(Line, a)] -> [(Line, a, Double)]
 lightenLines angle lines = let (lighted,_) = allKindsOfStuffWithAngle angle lines
                            in lighted
 
-totalLight :: (Ord a, Show a) => Double -> [(Line, a)] -> [(a, Double)]
-totalLight angle lines = M.toList (foldl add M.empty lighted)
-  where lighted = lightenLines angle lines
-        add m (_,i,a) = M.insertWith (+) i a m
-
-lightPolygons :: (Ord a, Show a) => Double -> [(Line, a)] -> [(Point,Point,Point,Point,Double)]
+lightPolygons :: Double -> [(Line, a)] -> [(Point,Point,Point,Point,Double)]
 lightPolygons angle lines = let (_,polygons) = allKindsOfStuffWithAngle angle lines
                            in polygons
 
-allKindsOfStuffWithAngle :: forall a. (Ord a, Show a) => Double -> [(Line, a)] ->
-                           (  [(Line, a, Double)]
+allKindsOfStuffWithAngle :: forall a. Double -> [(Line, a)] ->
+                           ( [(Line, a, Double)]
                            , [(Point,Point,Point,Point,Double)] )
 allKindsOfStuffWithAngle angle lines = (lighted, polygons)
   where projectLine :: Line -> (Double, Double)
@@ -81,7 +82,7 @@ allKindsOfStuffWithAngle angle lines = (lighted, polygons)
        
        -- False means Beginning of Line
        sweepPoints :: [(Double, Bool, (Line, a))]
-       sweepPoints = sort $ concatMap (\l@((p1,p2),i) -> 
+       sweepPoints = sortBy (comparing (\(a,b,_)->(a,b))) $ concatMap (\l@((p1,p2),i) -> 
                        if projectPoint p1 == projectPoint p2
                        then []
                        else if projectPoint p1 < projectPoint p2
@@ -173,19 +174,13 @@ allKindsOfStuffWithAngle angle lines = (lighted, polygons)
                        shine intensity (p1,p2,p3,p4) = ( intensity * lightFalloff
                                                        , (p1,p2,p3,p4,intensity))
 
-
-                     
-{-
--- Yay, this is a sweep-line-algorithm from Kognitive Systeme, whe would have guessed
-mergeLines lines = catMaybes $ snd $ mapAccumL step (Nothing, 0) points
- where points = sort $ concatMap (
-                \(p1,p2) -> if p1 < p2 then [(p1,False),(p2,True)] else [(p2,False),(p1,True)]
-                ) lines
-       step (Nothing, 0) (p, False) = ((Just p, 1),    Nothing)
-       step (Nothing, 0) (p, True)  = error $ "End before start, point " ++ show p
-       step (Just p1, 1) (p2,True)  = ((Nothing, 0),   Just (p1,p2))
-       step (Just p1, n) (_, False) = ((Just p1, n+1), Nothing)
-       step (Just p1, n) (_, True)  = ((Just p1, n-1), Nothing)
-
-
--}
+-- | Annotates each piece of the garden with the amount of line it attacts
+lightenGarden :: Double -> Garden a -> Garden Double
+lightenGarden angle garden = runST $ do
+       gardenWithPointers <- mapM (mapM (const (newSTRef 0))) garden
+       let linesWithPointers = gardenToLines gardenWithPointers
+       let lightedLines = lightenLines angle linesWithPointers
+       -- Update intensity via the STRef
+       forM_ lightedLines $ \(_,stRef,intencity) -> modifySTRef stRef (+ intencity)
+       -- Undo the STRefs
+       mapM (mapM readSTRef) gardenWithPointers
index b97b4f7..47b46d9 100644 (file)
@@ -17,32 +17,32 @@ type Point = (Double, Double)
 type Line  = (Point, Point)
 
 
-newtype GeometryGenerator a = GeometryGenerator (ReaderT (Point, Double) (Writer [Line]) a)
+newtype GeometryGenerator x a = GeometryGenerator (ReaderT (Point, Double) (Writer [(Line, x)]) a)
  deriving (Monad)
 
-transformed :: Point -> GeometryGenerator Point
+transformed :: Point -> GeometryGenerator Point
 transformed (x,y) = GeometryGenerator $ do
        ((bx,by),r) <- ask
        let (x', y') = (cos r * x + sin r *y, -sin r * x + cos r *y)
        return (bx + x', by + y')
 
-translated :: Point -> GeometryGenerator a -> GeometryGenerator a
+translated :: Point -> GeometryGenerator x a -> GeometryGenerator x a
 translated p (GeometryGenerator act) = do
        (x',y') <- transformed p
        GeometryGenerator $
                local (\(_,r) -> ((x',y'),r)) act
 
-rotated :: Double -> GeometryGenerator a -> GeometryGenerator a
+rotated :: Double -> GeometryGenerator x a -> GeometryGenerator x a
 rotated r (GeometryGenerator act) = 
        GeometryGenerator $ local (\(p,r') -> (p, r' - r)) act
 
-addLine :: Line -> GeometryGenerator ()
-addLine (p1,p2) = do
+addLine :: x -> Line -> GeometryGenerator x ()
+addLine (p1,p2) = do
        p1' <- transformed p1
        p2' <- transformed p2
-       GeometryGenerator $ tell [(p1', p2')]
+       GeometryGenerator $ tell [((p1', p2'),x)]
 
        
-runGeometryGenerator :: Point -> Double -> GeometryGenerator () -> [Line]
+runGeometryGenerator :: Point -> Double -> GeometryGenerator x () -> [(Line, x)]
 runGeometryGenerator p r (GeometryGenerator gen) = 
        execWriter (runReaderT gen (p,r))
index 0a357c6..0ccf46f 100644 (file)
@@ -61,10 +61,11 @@ initRenderer = do
 render :: Double -> Garden a -> Render ()
 render angle garden = do
        renderGround
-       -- mapM_ renderLightedLine (lightenLines (pi/3) (gardenToLines garden))
        mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))
+       --mapM_ renderLightedLine (lightenLines angle (gardenToLines garden))
        -- mapM_ renderLine (gardenToLines garden)
-       mapM_ (renderPlanted) garden
+       mapM_ renderLightedPlanted (lightenGarden angle garden)
+       mapM_ renderPlanted garden
 
        renderInfo angle garden
 
@@ -88,6 +89,30 @@ renderPlant (Fork _ angle p1 p2) = do
        preserve $ rotate angle >> renderPlant p1
        renderPlant p2
                
+renderLightedPlanted :: Planted Double -> Render ()
+renderLightedPlanted planted = preserve $ do
+       translate (plantPosition planted) 0
+       renderLightedPlant (phenotype planted)
+
+renderLightedPlant :: Plant Double -> Render ()        
+renderLightedPlant (Bud _) = return ()
+renderLightedPlant (Stipe intensity len p) = do
+       moveTo 0 0
+       lineTo 0 (len * stipeLength)
+       let normalized = intensity / (len * stipeLength)
+       when (normalized > 0) $ do
+               liftIO $ print normalized
+               setLineWidth (2*stipeWidth)
+               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
+               
+{- Line based rendering deprecated
+
 renderLine (l@((x1,y1),(x2,y2)), _) = do
        setSourceRGB 0 1 0 
        setLineWidth (0.5*stipeWidth)
@@ -100,12 +125,13 @@ renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
        lineTo x2 y2
        let normalized = intensity / lineLength l
        when (normalized > 0) $ do
-               setLineWidth (3*stipeWidth)
-               setSourceRGB normalized normalized 0
+               setLineWidth (1.5*stipeWidth)
+               setSourceRGBA 1 1 0 normalized
                strokePreserve
        setSourceRGB 0 1 0 
        setLineWidth (0.5*stipeWidth)
        stroke
+-}
        
 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
        when (intensity > 0) $ do
@@ -118,11 +144,11 @@ renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
                fill
 
 renderInfo angle garden = do
-       let withLight = totalLight angle (gardenToLines garden)
-       forM_ garden $ \planted -> do
+       let gardenWithLight = lightenGarden angle garden
+       forM_ gardenWithLight $ \planted -> do
                let x = plantPosition planted
                let text1 = printf "Light: %.2f" $
-                               fromMaybe 0 (lookup x withLight)
+                               extractOutmost (subPieceSum (phenotype planted))
                let text2 = printf "Size: %.2f" $
                                extractOutmost $ plantSubpieceLength (phenotype planted)
                preserve $ do