author Joachim Breitner Fri, 6 Feb 2009 22:33:36 +0000 (23:33 +0100) committer Joachim Breitner Fri, 6 Feb 2009 22:33:36 +0000 (23:33 +0100)

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
@@ -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 ()
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