Locate bug in wall zoning

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]
+wallsDoubleScreen w = _walls w
-    = foldl' (flip $ IM.union . \i -> innerFold (f i (_wallsZone w))) IM.empty xs
+--    = foldl' (flip $ IM.union . \i -> innerFold (f i (_wallsZone w))) IM.empty xs
-  where 
+--  where 
-    innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
+--    innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
-
+--
-    f i m = case IM.lookup i m of 
+--    f i m = case IM.lookup i m of 
-        Just val -> val
+--        Just val -> val
-        _        -> IM.empty
+--        _        -> IM.empty
-    (x,y) = zoneOfPoint $ _cameraCenter w
+--    (x,y) = zoneOfPoint $ _cameraCenter w
-    n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
+--    n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
-    wh = max (getWindowX w) (getWindowY w)
+--    wh = max (getWindowX w) (getWindowY w)
-    xs = [x - n .. x + n]
+--    xs = [x - n .. x + n]
-    ys = [y - n .. y + 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

@@ -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

@@ -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

@@ -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 
+mkSingleDoor c isPathable cond hingep edgep speed is 
-    = addSoundToDoor (head is) pld hwd 
+    = 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
+    theDoor = rectanglePairs 9 hingep edgep
-    shiftLeft  = (+.+ (hingep -.- hw))
+    shiftedDoor = map (bimap shiftLeft shiftLeft) theDoor
-    norm = 9 *.* normalizeV ( vNormal (hw -.- hingep))
+    shiftLeft  = (+.+ (hingep -.- edgep))
-    pld = hingep -.- norm
-    hwd = hw -.- norm
 
 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)
+    = addSoundToDoor (head is) (fst $ head leftDoor) (fst $ head shiftedDoor)
+    $ zipWith3 (linearPane c isPathable cond speed)
         is
         (leftDoor ++ rightDoor)
-    (map shiftLeft leftDoor ++ map shiftRight rightDoor)
+        shiftedDoor
   where 
+    shiftedDoor = map shiftLeft leftDoor ++ map shiftRight rightDoor
     leftDoor = 
         [ (pld +.+ perp,hwd)
         , (hwd,         hwu)

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 %~ mvPs speed (ex,ey)
-moveDoorToward speed (ex,ey) wls = wls & wlLine %~ bimap (f ex) (f ey)
+--moveDoorToward !speed !(!ex,!ey) wls = wls & wlLine %~ bimap (f ex) (f ey)
-  where
+--  where
-    f !p = mvPointTowardAtSpeed speed p
+--    f !p = mvPointTowardAtSpeed speed p
 
 zoneps :: (Point2, Point2) -> [(Int,Int)]
 {-# INLINE zoneps #-}
@@ -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)