From cb5a83d17a16d05c41dc2093a94151932b0bde46 Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 5 Mar 2021 14:14:52 +0100 Subject: [PATCH] Some cleanup, may have reintroduced leak in autoDoorPane --- src/Dodge/Data.hs | 1 + src/Dodge/LevelGen.hs | 134 ++++++++++++---------------------------- src/Dodge/Prototypes.hs | 1 + src/Dodge/Rendering.hs | 3 + 4 files changed, 46 insertions(+), 93 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 17bf245ce..789cdf425 100644 --- a/src/Dodge/Data.hs +++ b/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 diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 7c9e49400..97bae8c20 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -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) diff --git a/src/Dodge/Prototypes.hs b/src/Dodge/Prototypes.hs index ee3d84dd5..63a124edf 100644 --- a/src/Dodge/Prototypes.hs +++ b/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 diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index 45616c7be..c798cb6f9 100644 --- a/src/Dodge/Rendering.hs +++ b/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)