From 7c62ef4d4825601f570dc884ca212c71e22a1155 Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 11 Sep 2021 00:47:52 +0100 Subject: [PATCH] Locate bug in wall zoning --- src/Dodge/Base/Zone.hs | 30 +++++++++++++++------------ src/Dodge/Floor.hs | 38 +++++++++++++++++----------------- src/Dodge/Initialisation.hs | 27 +++++++++++++++++++++++- src/Dodge/LevelGen/DoorPane.hs | 24 ++++++++++----------- src/Dodge/LevelGen/MoveDoor.hs | 20 +++++++++--------- 5 files changed, 84 insertions(+), 55 deletions(-) diff --git a/src/Dodge/Base/Zone.hs b/src/Dodge/Base/Zone.hs index 3b366f302..94dbd3d79 100644 --- a/src/Dodge/Base/Zone.hs +++ b/src/Dodge/Base/Zone.hs @@ -133,20 +133,21 @@ zoneOfSight w = where (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraViewFrom w] +-- TODO sort out zoning of walls properly wallsDoubleScreen :: World -> IM.IntMap Wall -wallsDoubleScreen w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is] - = foldl' (flip $ IM.union . \i -> innerFold (f i (_wallsZone w))) IM.empty xs - where - innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys - - f i m = case IM.lookup i m of - Just val -> val - _ -> IM.empty - (x,y) = zoneOfPoint $ _cameraCenter w - n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2 - wh = max (getWindowX w) (getWindowY w) - xs = [x - n .. x + n] - ys = [y - n .. y + n] +wallsDoubleScreen w = _walls w +-- = foldl' (flip $ IM.union . \i -> innerFold (f i (_wallsZone w))) IM.empty xs +-- where +-- innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys +-- +-- f i m = case IM.lookup i m of +-- Just val -> val +-- _ -> IM.empty +-- (x,y) = zoneOfPoint $ _cameraCenter w +-- n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2 +-- wh = max (getWindowX w) (getWindowY w) +-- xs = [x - n .. x + n] +-- ys = [y - n .. y + n] wallsOnScreen :: World -> IM.IntMap Wall wallsOnScreen w -- = wallsNearZones (zoneOfScreen w) w @@ -220,3 +221,6 @@ wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<- f i m = case IM.lookup i m of Just val -> val _ -> IM.empty + +flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a +flattenIMIMIM = IM.unions . IM.map IM.unions diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index ed702f585..504d5366e 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -50,27 +50,27 @@ initialRoomTree = do let t' = padCorridors struct t = treeFromTrunk [[StartRoom] --- ,[Corridor] --- ,[Corridor] --- ,[SpecificRoom roomCCrits] --- ,[Corridor] --- ,[Corridor] --- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 --- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit --- ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit --- ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit --- ]++) --- ] --- --,[Corridor] --- --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 --- -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) --- -- ] --- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 --- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) --- ] ,[Corridor] ,[Corridor] - --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30] + ,[SpecificRoom roomCCrits] + ,[Corridor] + ,[Corridor] + ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 + & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit + ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit + ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit + ]++) + ] + --,[Corridor] + --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 + -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) + -- ] + ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 + & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) + ] + ,[Corridor] + ,[Corridor] +-- --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30] ,[SpecificRoom $ pure . Right <$> pure (twinSlowDoorRoom 30 80 200 40)] ,[Corridor] ,[DoorAno] diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 244277dd4..4198843fd 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -2,7 +2,7 @@ module Dodge.Initialisation where import Dodge.Default.World import Dodge.Data import Dodge.Creature ---import Dodge.Base +import Dodge.Base.Zone import Dodge.Floor import Dodge.Layout import Dodge.Story @@ -11,6 +11,7 @@ import Dodge.SoundLogic import Dodge.SoundLogic.Synonyms --import Dodge.Creature.Perception import Geometry.Data +--import Picture --import Dodge.GameRoom --import Geometry @@ -18,6 +19,9 @@ import System.Random import qualified Data.Set as S import qualified Data.IntMap.Strict as IM import qualified Data.Map as M +import Data.Maybe +import Control.Lens +import Data.List (partition) --import Data.List (sortOn) firstWorld :: IO World @@ -52,8 +56,29 @@ initialWorld = defaultWorld , _menuLayers = [TerminalScreen 300 rezText'] , _worldState = M.empty } +-- TODO delete this duplicate +wallsAndWindows + :: World + -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)] ) +wallsAndWindows w + = (map f wls, map f $ filter (fromMaybe True . (^? blVisible)) wins) + where + f wl = (_wlLine wl, _wlColor wl) + (wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w testStringInit :: World -> [String] testStringInit _ = [] +--testStringInit = mapMaybe f . IM.elems . wallsDoubleScreen +-- where +-- f (dr@Door{}) = Just . show $ _wlLine dr +-- f _ = Nothing +--testStringInit = map show . filter ((== col) . snd) . fst . wallsAndWindows +-- where +-- col = dim $ dim $ bright red +--testStringInit = mapMaybe f . IM.elems . flattenIMIMIM . _wallsZone +-- where +-- f (dr@Door{}) = Just . show $ _wlLine dr +-- f _ = Nothing +--testStringInit _ = [] --testStringInit w = [show . length $ newSounds w] --testStringInit w = (show . _crPos $ _creatures w IM.! 0) -- : (map show . _grBound . last $ sortOn _grName grs) diff --git a/src/Dodge/LevelGen/DoorPane.hs b/src/Dodge/LevelGen/DoorPane.hs index 67d6e481f..b02c89c1c 100644 --- a/src/Dodge/LevelGen/DoorPane.hs +++ b/src/Dodge/LevelGen/DoorPane.hs @@ -52,26 +52,26 @@ rectanglePairs wdth a b = norm = wdth *.* normalizeV ( vNormal (b -.- a)) mkSingleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall] -mkSingleDoor c isPathable cond hingep hw speed is - = addSoundToDoor (head is) pld hwd +mkSingleDoor c isPathable cond hingep edgep speed is + = addSoundToDoor (head is) (fst $ head theDoor) (fst $ head shiftedDoor) $ zipWith3 (linearPane c isPathable cond speed) is theDoor - (map (bimap shiftLeft shiftLeft) theDoor) + shiftedDoor where - theDoor = rectanglePairs 9 hingep hw - shiftLeft = (+.+ (hingep -.- hw)) - norm = 9 *.* normalizeV ( vNormal (hw -.- hingep)) - pld = hingep -.- norm - hwd = hw -.- norm + theDoor = rectanglePairs 9 hingep edgep + shiftedDoor = map (bimap shiftLeft shiftLeft) theDoor + shiftLeft = (+.+ (hingep -.- edgep)) mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall] mkDoubleDoor c isPathable cond pl pr speed is - = addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond speed) - is - (leftDoor ++ rightDoor) - (map shiftLeft leftDoor ++ map shiftRight rightDoor) + = addSoundToDoor (head is) (fst $ head leftDoor) (fst $ head shiftedDoor) + $ zipWith3 (linearPane c isPathable cond speed) + is + (leftDoor ++ rightDoor) + shiftedDoor where + shiftedDoor = map shiftLeft leftDoor ++ map shiftRight rightDoor leftDoor = [ (pld +.+ perp,hwd) , (hwd, hwu) diff --git a/src/Dodge/LevelGen/MoveDoor.hs b/src/Dodge/LevelGen/MoveDoor.hs index 408cb6515..50c828bdc 100644 --- a/src/Dodge/LevelGen/MoveDoor.hs +++ b/src/Dodge/LevelGen/MoveDoor.hs @@ -16,20 +16,20 @@ import qualified Data.IntMap.Strict as IM import Control.Lens -- This deserves a clean up -mvP :: Point2 -> Point2 -> Point2 +mvP :: Float -> Point2 -> Point2 -> Point2 {-# INLINE mvP #-} -mvP !ep !p = mvPointTowardAtSpeed 2 ep p +mvP !speed !ep !p = mvPointTowardAtSpeed speed ep p -mvPs :: (Point2,Point2) -> (Point2,Point2) -> (Point2,Point2) +mvPs :: Float -> (Point2,Point2) -> (Point2,Point2) -> (Point2,Point2) {-# INLINE mvPs #-} -mvPs (!ex,!ey) (!sx,!sy) = (mvP ex sx,mvP ey sy) +mvPs !speed (!ex,!ey) (!sx,!sy) = (mvP speed ex sx,mvP speed ey sy) moveDoorToward :: Float -> (Point2,Point2) -> Wall -> Wall {-# INLINE moveDoorToward #-} ---moveDoorToward speed (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey) -moveDoorToward speed (ex,ey) wls = wls & wlLine %~ bimap (f ex) (f ey) - where - f !p = mvPointTowardAtSpeed speed p +moveDoorToward speed (ex,ey) wls = wls & wlLine %~ mvPs speed (ex,ey) +--moveDoorToward !speed !(!ex,!ey) wls = wls & wlLine %~ bimap (f ex) (f ey) +-- where +-- f !p = mvPointTowardAtSpeed speed p zoneps :: (Point2, Point2) -> [(Int,Int)] {-# INLINE zoneps #-} @@ -61,7 +61,7 @@ changeZonedWall changeZonedWall eff n (x,y) = over wallsZone $ adjustIMZone eff x y n addSoundToDoor :: Int -> Point2 -> Point2 -> [Wall] -> [Wall] -addSoundToDoor _ _ _ [] = error "When creating door tried to add sound to nothing" +addSoundToDoor _ _ _ [] = error "When creating door tried to add sound to nothing" addSoundToDoor i pld hwd (x:ys) = f x : ys where f wl = over doorMech g wl @@ -71,4 +71,4 @@ addSoundToDoor i pld hwd (x:ys) = f x : ys = soundFrom (WallSound i) wp doorSound (Just 1) $ dm w | otherwise = dm w where - wp = snd $ _wlLine (_walls w IM.! i) + wp = fst $ _wlLine (_walls w IM.! i)