Improve shadows for static walls

src/Dodge/LevelGen.hs

@@ -33,7 +33,7 @@ import qualified Data.IntMap.Strict as IM
 import qualified Data.Set as S
 import qualified Data.Map as M
 
-import Data.Graph.Inductive
+import Data.Graph.Inductive hiding ((&))
 import Data.Graph.Inductive.NodeMap
 import Data.Tree
 -- }}}
@@ -563,9 +563,12 @@ autoDoorPane trigL n [a,b] [a',b'] = AutoDoor
              | otherwise = flip (foldr changeZonedWall') zoneps
                            $ over walls (IM.adjust closeDoor n) w
         mvP !ep !p = mvPointTowardAtSpeed 2 ep p
+        moveToward :: [Point2] -> Wall -> Wall
+        moveToward ps w = w & wlLine %~ zipWith mvP ps
         openDoor :: Wall -> Wall
-        openDoor wl = case _wlLine wl of
-                        ((!pa):(!pb):_) -> wl {_wlLine = [mvP a' pa, mvP b' pb]}
+--        openDoor wl = case _wlLine wl of
+--                        ((!pa):(!pb):_) -> wl {_wlLine = [mvP a' pa, mvP b' pb]}
+        openDoor = moveToward [a',b']
         closeDoor :: Wall -> Wall
         closeDoor wl = case _wlLine wl of
                         ((!pa):(!pb):_) -> wl {_wlLine = [mvP a pa, mvP b pb]}

src/Dodge/Rendering.hs

@@ -318,9 +318,11 @@ drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps,
         
 
 drawWall :: Wall -> Drawing
+drawWall (Wall {_wlIsSeeThrough = False, _wlLine = ps, _wlColor = c}) 
+        = onLayerL [levLayer WlLayer, 2] $ color c $ polygon $ ps
 drawWall wl = case _wlDraw wl of
-        Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon $ _wlLine wl
-        --Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
+--        Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon $ _wlLine wl
+        Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
         Just d -> d wl
     where 
         (x:y:_) = _wlLine wl
@@ -560,6 +562,12 @@ displayHP n w = translate (halfWidth w-70) (halfHeight w-40) $
 
 testPic w = blank
 
+wallsForGloom :: World -> [(Point2,Point2,Point2,Point2)]
+wallsForGloom w = map (linePairs . _wlLine) $ filter (not . _wlIsSeeThrough)
+                        $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
+    where linePairs (x:y:z:w:_) = (x,y,z,w)
+          linePairs (x:y:_) = (x,y,x,y)
+
 wallsForGloom' :: World -> [(Point2,Point2)]
 wallsForGloom' w = map (wallPairBack . _wlLine) $ filter (not . _wlIsSeeThrough) 
                                 $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w