Calculate and render light polygons
authorJoachim Breitner <mail@joachim-breitner.de>
Fri, 6 Feb 2009 22:33:36 +0000 (23:33 +0100)
committerJoachim Breitner <mail@joachim-breitner.de>
Fri, 6 Feb 2009 22:33:36 +0000 (23:33 +0100)
src/Lseed/Geometry.hs
src/Lseed/Geometry/Generator.hs
src/Lseed/Renderer/Cairo.hs

index 74c8f2c..6a4d7c7 100644 (file)
@@ -30,11 +30,11 @@ crossPoint ((x1,y1),(x2,y2)) ((x3,y3),(x4,y4)) =
            denom = a1*b2 - a2*b1
        in if abs denom > eps
            then let x = (b1*c2 - b2*c1)/denom
-                   y = (a2*c1 - a1*c2)/denom
-               in if  x1 <= x && x <= x2 &&
-                      y1 <= y && y <= y2 &&
-                      x3 <= x && x <= x4 &&
-                      y3 <= y && y <= y4
+                   y = (a2*c1 - a1*c2)/denom
+               in if  x1 <= x && x <= x2 &&
+                      y1 <= y && y <= y2 &&
+                      x3 <= x && x <= x4 &&
+                      y3 <= y && y <= y4
                   then Just (x,y)
                    else Nothing
            else Nothing
@@ -56,8 +56,18 @@ gardenToLines :: Garden -> [(Line, Double)]
 gardenToLines = concatMap (\planted -> map (\line -> (line, plantPosition planted)) (plantedToLines planted))
 
 -- | Add lightning from a given angle
-lightenLines :: forall a. (Ord a, Show a) => Double -> [(Line, a)] -> [(Line, a, Double)]
-lightenLines angle lines = lighted
+lightenLines :: (Ord a, Show a) => Double -> [(Line, a)] -> [(Line, a, Double)]
+lightenLines angle lines = let (lighted,_) = allKindsOfStuffWithAngle angle lines
+                           in lighted
+
+lightPolygons :: (Ord a, Show a) => 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)]
+                           , [(Point,Point,Point,Point,Double)] )
+allKindsOfStuffWithAngle angle lines = (lighted, polygons)
   where projectLine :: Line -> (Double, Double)
         projectLine (p1, p2) = (projectPoint p1, projectPoint p2)
        projectPoint :: Point -> Double
@@ -94,6 +104,19 @@ lightenLines angle lines = lighted
        intervals = zip crossings (tail crossings)
 
        unlighted = map (\(l,i) -> (l,i,0)) lines
+       
+       unprojectPoint x (p1@(x1,y1),p2@(x2,y2)) = 
+               let t = (x - projectPoint p1) /
+                       (projectPoint p2 - projectPoint p1)
+               in (x1 + t * (x2-x1), y1 + t * (y2-y1))
+
+       lineAtRay x l = let (x1',x2') = projectLine l
+                      in x1' <= x && x <= x2' || x2' <= x && x <= x1'
+
+       aboveFirst x l1 l2 =
+               let (_,y1) = unprojectPoint x l1
+                   (_,y2) = unprojectPoint x l2
+               in y2 `compare` y1
 
        lighted :: [(Line, a, Double)]
        lighted = foldl go unlighted intervals
@@ -102,23 +125,49 @@ lightenLines angle lines = lighted
                        mid = (x1 + x2) / 2
                        -- Light intensity
                        width = (x2 - x1) * sin angle
-                       (curlines, otherlines) = partition (\(l,_,_) ->
-                                       let (x1',x2') = projectLine l
-                                        in x1' <= mid && mid <= x2' ||
-                                           x2' <= mid && mid <= x1'
-                                       ) llines
-                       sorted = sortBy aboveFirst curlines
-                       crossPoint (p1@(x1,y1),p2@(x2,y2)) = 
-                               let t = (mid - projectPoint p1) /
-                                        (projectPoint p2 - projectPoint p1)
-                               in (x1 + t * (x2-x1), y1 + t * (y2-y1))
-                       aboveFirst (l1,_,_) (l2,_,_) =
-                               let (_,y1) = crossPoint l1
-                                   (_,y2) = crossPoint l2
-                               in y2 `compare` y1
+                       (curlines, otherlines) = partition (\(l,_,_) -> lineAtRay mid l)
+                                                          llines
+                       sorted = sortBy (\(l1,_,_) (l2,_,_) -> aboveFirst mid l1 l2)
+                                        curlines
                        curlines' = snd $ mapAccumL shine 1 sorted
                        shine intensity (l,i,amount) = ( intensity * lightFalloff
                                                       , (l,i,amount + intensity * width))
+
+       polygons = concatMap go intervals
+         where go (x1,x2) = if null sorted then [nothingPoly] else lightedPolys
+                 where mid = (x1 + x2) / 2
+                       curlines = filter (lineAtRay mid) (map fst lines)
+                       sorted = sortBy (aboveFirst mid) curlines
+                       ceiling = ((0,10),(1,10))
+                       floor = ((0,0),(1,0))
+                       nothingPoly = let p1 = unprojectPoint x1 ceiling
+                                          p2 = unprojectPoint x1 floor
+                                          p3 = unprojectPoint x2 floor
+                                          p4 = unprojectPoint x2 ceiling
+                                      in (p1,p2,p3,p4,1)
+                       firstPoly = let p1 = unprojectPoint x1 ceiling
+                                        p2 = unprojectPoint x1 (head sorted)
+                                        p3 = unprojectPoint x2 (head sorted)
+                                        p4 = unprojectPoint x2 ceiling
+                                    in (p1,p2,p3,p4)
+                       lastPoly =  let p1 = unprojectPoint x1 (last sorted)
+                                        p2 = unprojectPoint x1 floor
+                                        p3 = unprojectPoint x2 floor
+                                        p4 = unprojectPoint x2 (last sorted)
+                                    in (p1,p2,p3,p4)
+                       polys = zipWith (\l1 l2 ->
+                                         let p1 = unprojectPoint x1 l1
+                                             p2 = unprojectPoint x1 l2
+                                             p3 = unprojectPoint x2 l2
+                                             p4 = unprojectPoint x2 l1
+                                        in (p1,p2,p3,p4)) sorted (tail sorted)
+                       polys' = [firstPoly] ++ polys ++ [lastPoly]
+                       lightedPolys = snd $ mapAccumL shine (1*lightFalloff) polys'
+                       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
index 1c3ead9..b97b4f7 100644 (file)
@@ -34,7 +34,7 @@ translated p (GeometryGenerator act) = do
 
 rotated :: Double -> GeometryGenerator a -> GeometryGenerator a
 rotated r (GeometryGenerator act) = 
-       GeometryGenerator $ local (\(p,r') -> (p, r' + r)) act
+       GeometryGenerator $ local (\(p,r') -> (p, r' - r)) act
 
 addLine :: Line -> GeometryGenerator ()
 addLine (p1,p2) = do
index 39917c6..78d0a60 100644 (file)
@@ -51,9 +51,10 @@ initRenderer = do
 render :: Garden -> Render ()
 render garden = do
        renderGround
-       -- mapM_ (renderPlanted) garden
+       -- mapM_ renderLightedLine (lightenLines (pi/3) (gardenToLines garden))
+       mapM_ renderLightedPoly (lightPolygons (pi/3) (gardenToLines garden))
        -- mapM_ renderLine (gardenToLines garden)
-       mapM_ renderLightedLine (lightenLines (pi/2) (gardenToLines garden))
+       mapM_ (renderPlanted) garden
 
 renderPlanted :: Planted -> Render ()
 renderPlanted planted = preserve $ do
@@ -95,6 +96,15 @@ renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
        setLineWidth (0.5*stipeWidth)
        stroke
        
+renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
+       when (intensity > 0) $ do
+               moveTo x1 (y1+groundLevel)
+               lineTo x2 (y2+groundLevel)
+               lineTo x3 (y3+groundLevel)
+               lineTo x4 (y4+groundLevel)
+               closePath
+               setSourceRGBA 1 1 0 intensity
+               fill
 
 renderGround :: Render ()
 renderGround = do