From 4327e94e0426ac8989b7cf02180d271552808d8b Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 2 Apr 2021 14:08:12 +0200 Subject: [PATCH] Move inner wall creation --- src/Dodge/Layout.hs | 4 +-- src/Dodge/LevelGen.hs | 2 +- src/Dodge/LevelGen/InnerWalls.hs | 46 +++++++++++++++++++++++++++++++ src/Dodge/LevelGen/StaticWalls.hs | 36 ------------------------ 4 files changed, 49 insertions(+), 39 deletions(-) create mode 100644 src/Dodge/LevelGen/InnerWalls.hs diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index a1461cd9e..e421ed7c5 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -64,8 +64,8 @@ makePath = concat . map _rmPath . flatten -- consider nubbing walls after dividing them wallsFromTree :: Tree Room -> IM.IntMap Wall wallsFromTree t = - createInnerWalls - . divideWalls +-- createInnerWalls + divideWalls . assignKeys . foldr cutWalls [] -- $ map (map (g . roundPoint2)) -- . map (map roundPoint2) diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 05bdeecd6..11fa8a064 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -3,7 +3,7 @@ module Dodge.LevelGen ( module Dodge.LevelGen , cutWalls - , createInnerWalls +-- , createInnerWalls , pairsToGraph , makeButton , makeSwitch diff --git a/src/Dodge/LevelGen/InnerWalls.hs b/src/Dodge/LevelGen/InnerWalls.hs new file mode 100644 index 000000000..343cd0a1d --- /dev/null +++ b/src/Dodge/LevelGen/InnerWalls.hs @@ -0,0 +1,46 @@ +module Dodge.LevelGen.InnerWalls + where +import Dodge.Data +import Dodge.Base + +import Geometry + +import Control.Lens +import qualified Data.IntMap as IM + +------------------------------------------------------------------------------------ +-- idea: create inner walls to draw and to cast shadows +createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall +createInnerWalls wls = IM.map (createInnerWall wls) wls + +createInnerWall :: IM.IntMap Wall -> Wall -> Wall +createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR] + where wl0 = _wlLine wl !! 0 + wl1 = _wlLine wl !! 1 + wlLeft = findWallLeft wl walls + wlRight = findWallRight wl walls + wlN = normalizeV $ vNormal $ wl1 -.- wl0 + rN = normalizeV $ vNormal $ (_wlLine wlRight !! 1) -.- (_wlLine wlRight !! 0) + lN = normalizeV $ vNormal $ (_wlLine wlLeft !! 1) -.- (_wlLine wlLeft !! 0) + wlR = wl0 +.+ 20 *.* normalizeV (wlN +.+ rN) + wlL = wl1 +.+ 20 *.* normalizeV (wlN +.+ lN) + +findWallLeft :: Wall -> IM.IntMap Wall -> Wall +findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of + [w] -> w + wls -> error $ "findWallLeft: " ++ show (map _wlID wls) + ++ " wlLines: "++ show (map _wlLine wls) + +findWallRight :: Wall -> IM.IntMap Wall -> Wall +findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of + [w] -> w + wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++ + show (_wlLine wl) ++ "\nhas a right corner with and only with the walls " + ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls) + ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem" + +findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall +findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls + +findWallsRight :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall +findWallsRight x wls = IM.filter (\wl -> dist x (_wlLine wl !! 1) < 1) wls diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 192104f16..562a0edac 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -164,39 +164,3 @@ removeWallsInPolygon ps walls = filter (not . cond) walls cond wall = pointInsidePolygon (fst wall) ps && pointInsidePolygon (snd wall) ps ------------------------------------------------------------------------------------- --- idea: create inner walls to draw and to cast shadows -createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall -createInnerWalls wls = IM.map (createInnerWall wls) wls - -createInnerWall :: IM.IntMap Wall -> Wall -> Wall -createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR] - where wl0 = _wlLine wl !! 0 - wl1 = _wlLine wl !! 1 - wlLeft = findWallLeft wl walls - wlRight = findWallRight wl walls - wlN = normalizeV $ vNormal $ wl1 -.- wl0 - rN = normalizeV $ vNormal $ (_wlLine wlRight !! 1) -.- (_wlLine wlRight !! 0) - lN = normalizeV $ vNormal $ (_wlLine wlLeft !! 1) -.- (_wlLine wlLeft !! 0) - wlR = wl0 +.+ 20 *.* normalizeV (wlN +.+ rN) - wlL = wl1 +.+ 20 *.* normalizeV (wlN +.+ lN) - -findWallLeft :: Wall -> IM.IntMap Wall -> Wall -findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of - [w] -> w - wls -> error $ "findWallLeft: " ++ show (map _wlID wls) - ++ " wlLines: "++ show (map _wlLine wls) - -findWallRight :: Wall -> IM.IntMap Wall -> Wall -findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of - [w] -> w - wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++ - show (_wlLine wl) ++ "\nhas a right corner with and only with the walls " - ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls) - ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem" - -findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall -findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls - -findWallsRight :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall -findWallsRight x wls = IM.filter (\wl -> dist x (_wlLine wl !! 1) < 1) wls