Some cleanup, may have reintroduced leak in autoDoorPane

2021-03-05 14:14:52 +01:00
parent 5f8b5881e5
commit cb5a83d17a
4 changed files with 46 additions and 93 deletions
@@ -555,6 +555,7 @@ data Wall
        , _wlDraw :: Maybe (Wall -> Drawing)
        , _wlSeen :: Bool
        , _wlIsSeeThrough :: Bool
+        , _wlCastShadow :: Bool
        }
    | Door 
        { _wlLine :: [Point2] , _wlID :: Int 
@@ -42,82 +42,27 @@ import Data.Tree
 --


-collidePointAllWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
-collidePointAllWalls p1 p2 walls = IM.filter f walls
-    where f wall
-            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
-                of Nothing -> False
-                   _       -> True
-
-- returns walls that collide with lines, and the point of collision
-collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2)
-collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls
-    where f wall
-            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
-                of Nothing -> Nothing
-                   Just p  -> Just (wall,p)
-
-collidePointAllWallsPoints' :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
-collidePointAllWallsPoints' p1 p2 walls = IM.mapMaybe f walls
-    where f wall
-            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
-                of Nothing -> Nothing
-                   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
-
-
+--collidePointAllWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+--collidePointAllWalls p1 p2 walls = IM.filter f walls
+--    where f wall
+--            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
+--                of Nothing -> False
+--                   _       -> True
+--
+---- returns walls that collide with lines, and the point of collision
+--collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2)
+--collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls
+--    where f wall
+--            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
+--                of Nothing -> Nothing
+--                   Just p  -> Just (wall,p)
+--
+--collidePointAllWallsPoints' :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
+--collidePointAllWallsPoints' p1 p2 walls = IM.mapMaybe f walls
+--    where f wall
+--            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
+--                of Nothing -> Nothing
+--                   Just p  -> Just (wall,[p])

 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]
-                               , [pru,hwu]
+                               , [hwu,plu,pl,hw]
+                               , [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 trigL n [a,b] [a',b'] = AutoDoor
-    { _wlLine = [a,b]
+autoDoorPane :: [Point2] -> Int -> Bool -> [Point2] -> [Point2] -> Wall
+autoDoorPane trigL n castShad closedPos openPos = AutoDoor
+    { _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 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]}
+        openDoor = moveToward openPos
+        closeDoor = moveToward closedPos
        zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
               | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
        changeZonedWall (!x,!y) 
@@ -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
@@ -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)