Some cleanup, may have reintroduced leak in autoDoorPane

src/Dodge/Data.hs

@@ -555,6 +555,7 @@ data Wall
         , _wlDraw :: Maybe (Wall -> Drawing)
         , _wlSeen :: Bool
         , _wlIsSeeThrough :: Bool
+        , _wlCastShadow :: Bool
         }
     | Door 
         { _wlLine :: [Point2] , _wlID :: Int 

src/Dodge/LevelGen.hs

@@ -42,82 +42,27 @@ import Data.Tree
 --
 
 
-collidePointAllWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+--collidePointAllWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
-collidePointAllWalls p1 p2 walls = IM.filter f walls
+--collidePointAllWalls p1 p2 walls = IM.filter f walls
-    where f wall
+--    where f wall
-            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
+--            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
-                of Nothing -> False
+--                of Nothing -> False
-                   _       -> True
+--                   _       -> True
-
+--
--- returns walls that collide with lines, and the point of collision
+---- returns walls that collide with lines, and the point of collision
-collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2)
+--collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2)
-collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls
+--collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls
-    where f wall
+--    where f wall
-            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
+--            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
-                of Nothing -> Nothing
+--                of Nothing -> Nothing
-                   Just p  -> Just (wall,p)
+--                   Just p  -> Just (wall,p)
-
+--
-collidePointAllWallsPoints' :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
+--collidePointAllWallsPoints' :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
-collidePointAllWallsPoints' p1 p2 walls = IM.mapMaybe f walls
+--collidePointAllWallsPoints' p1 p2 walls = IM.mapMaybe f walls
-    where f wall
+--    where f wall
-            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
+--            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
-                of Nothing -> Nothing
+--                of Nothing -> Nothing
-                   Just p  -> Just (wall,[p])
+--                   Just p  -> Just (wall,[p])
-
-collidePolygonWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
-collidePolygonWalls (p:ps) walls 
-    = IM.unionsWith f (fmap g (zip (p:ps) (ps ++ [p])))
-    -- = fmap ($ walls) $ zipWith collidePointAllWallsPoints' (init ps) (tail ps)
-        --where f (x,xs) (_,ys) = (x,xs++ys)
-        where f (x,xs) (_,ys) = (x,xs++ys)
-              g (p1,p2) = collidePointAllWallsPoints' p1 p2 walls
-
--- -- assumes that walls meet in corners
--- there appears to be an issue when one wall point is inside and the other exactly on the polygon
--- this is probably an issue with collidePolygonwalls
-existingWallChanges :: [Point2] -> (Wall,[Point2]) -> [Wall]
-existingWallChanges poly (wall,ps) = catMaybes [w1,w2]
-     where wp1 = _wlLine wall !! 0
-           wp2 = _wlLine wall !! 1
-           c1  = head $ sortBy (compare `on` dist wp1) ps
-           c2  = head $ sortBy (compare `on` dist wp2) ps
-           --c1  = last ps
-           --c2  = last ps
-           w1 = if errorPointInPolygon 5 wp1 poly || wp1 == c1
-                    then Nothing
-                    else Just $ wall {_wlLine = [ wp1, c1 ] }
-           w2 = if errorPointInPolygon 6 wp2 poly || wp2 == c2
-                    then Nothing
-                    else Just $ wall {_wlLine = [ c2, wp2 ] }
-
-
-
--- I have no idea why collidePolygonWalls is sometimes dropping an intersection
--- point between the walls and the polygon
--- Trying a workaround
-intersectPolygonWalls :: [Point2] -> IM.IntMap Wall -> [Point2]
-intersectPolygonWalls ps walls = nub $ concat $ IM.elems $ IM.map (intersectSegsWall ps) walls
---intersectPolygonWalls (p:ps) walls = nub $ concat [intersectSegWalls s1 s2 walls | (s1,s2) <- segs]
---    where segs = zip (p:ps) (ps ++ [p])
-
-intersectSegWalls s1 s2 ws = concatMap (intersectSegWall s1 s2) $ IM.elems ws
-
-intersectSegsWall (p:ps) wall = concat [intersectSegWall s1 s2 wall | (s1,s2) <- zip (p:ps) (ps++[p])]
-
--- finds intersection, or any segment points contained in the wall
-intersectSegWall s1 s2 w = catMaybes [myIntersectSegSeg s1 s2 w1 w2
---                                     ,intersectSegPoint w1 w2 s1
---                                     ,intersectSegPoint w1 w2 s2
-                                     ]
-    where w1 = _wlLine w !! 0
-          w2 = _wlLine w !! 1
-
-intersectSegPoint s1 s2 p = if isOnLine s1 s2 p then Just p else Nothing
-
--- new procedure: line by line
--- then remove all walls inside the polygon
-
-
 
 treeTrunk :: [a] -> Tree a -> Tree a
 treeTrunk [] t     = t
@@ -483,14 +428,21 @@ autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
           is = [i..]
 
 mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
-mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
+mkAutoDoor pl pr xs = addSound $ zipWith4 (autoDoorPane [pl,pr])
                                xs
-                               [ [pld,hwd]
+                               [ True
+                               , False
+                               , True
+                               , True
+                               , False
+                               , True
+                               ]
+                               [ [pld,hwd,hw,pl]
                                , [hwd,hwu]
-                               , [hwu,plu]
+                               , [hwu,plu,pl,hw]
-                               , [pru,hwu]
+                               , [pru,hwu,hw,pr]
                                , [hwu,hwd]
-                               , [hwd,prd]
+                               , [hwd,prd,pr,hw]
                                ]
                                [ [plld,pld]
                                , [pld,plu]
@@ -544,19 +496,20 @@ drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2]
                | isJust $ wl ^? doorMech = 1
                | otherwise = 2
 
-autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall
+autoDoorPane :: [Point2] -> Int -> Bool -> [Point2] -> [Point2] -> Wall
-autoDoorPane trigL n [a,b] [a',b'] = AutoDoor
+autoDoorPane trigL n castShad closedPos openPos = AutoDoor
-    { _wlLine = [a,b]
+    { _wlLine = closedPos
     , _wlID = n
     , _doorMech = dm
     , _wlColor = dim $ yellow
---    , _wlDraw = Just drawAutoDoor
     , _wlDraw = Nothing
     , _wlSeen = False
     , _wlIsSeeThrough = False
---    , _doorLine = [a,b,a',b']
+    , _wlCastShadow = castShad
     }
     where 
+        a = closedPos !! 0
+        b = closedPos !! 1
         dm w | crsNearLine 40 trigL w 
                          = flip (foldr changeZonedWall) zoneps
                            $ over walls (IM.adjust openDoor n) w
@@ -565,13 +518,8 @@ autoDoorPane trigL n [a,b] [a',b'] = AutoDoor
         mvP !ep !p = mvPointTowardAtSpeed 2 ep p
         moveToward :: [Point2] -> Wall -> Wall
         moveToward ps w = w & wlLine %~ zipWith mvP ps
-        openDoor :: Wall -> Wall
+        openDoor = moveToward openPos
---        openDoor wl = case _wlLine wl of
+        closeDoor = moveToward closedPos
---                        ((!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]}
         zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
                | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
         changeZonedWall (!x,!y) 

src/Dodge/Prototypes.hs

@@ -36,6 +36,7 @@ basicAutoDoor = AutoDoor { _wlLine = [(0,0),(50,0)]
                    , _wlDraw = Nothing
                    , _wlSeen = False
                    , _wlIsSeeThrough = False
+                   , _wlCastShadow = True
                    }
 basicDoor = Door { _wlLine = [(0,0),(50,0)]
                    , _wlID = 0

src/Dodge/Rendering.hs

@@ -564,9 +564,12 @@ testPic w = blank
 
 wallsForGloom :: World -> [(Point2,Point2,Point2,Point2)]
 wallsForGloom w = map (linePairs . _wlLine) $ filter (not . _wlIsSeeThrough)
+                        $ filter wallCastsShadow
                         $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
     where linePairs (x:y:z:w:_) = (x,y,z,w)
           linePairs (x:y:_) = (x,y,x,y)
+          wallCastsShadow (AutoDoor {_wlCastShadow = b}) = b
+          wallCastsShadow _ = True
 
 wallsForGloom' :: World -> [(Point2,Point2)]
 wallsForGloom' w = map (wallPairBack . _wlLine) $ filter (not . _wlIsSeeThrough)