justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Locate bug in wall zoning

Browse Source
This commit is contained in:
justin
2021-09-11 00:47:52 +01:00
parent c695767fb0
commit 7c62ef4d48
5 changed files with 84 additions and 55 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Zone.hs
+17 -13
View File
@@ -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
src/Dodge/Floor.hs
+19 -19
View File
@@ -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]
src/Dodge/Initialisation.hs
+26 -1
View File
@@ -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)
src/Dodge/LevelGen/DoorPane.hs
+12 -12
View File
@@ -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)
src/Dodge/LevelGen/MoveDoor.hs
+10 -10
View File
@@ -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)