Determine thunk leak when marking seen walls

src/Dodge/Data.hs

@@ -560,8 +560,10 @@ data Wall = Wall
     , _wlPathable :: Bool
     , _wlDraw :: Bool
     , _wlRotateTo :: Bool
-    , _wlBlockID  :: Maybe Int
+    , _wlBlockID  :: Maybe' Int
     }
+-- | Strict maybe
+data Maybe' a = Just' a | Nothing'
 data ForceField = FF 
     { _ffLine :: [Point2] , _ffID :: Int 
     , _ffColor :: Color

src/Dodge/Default/Wall.hs

@@ -14,7 +14,7 @@ defaultWall = Wall
     , _wlPathable = False
     , _wlDraw = True
     , _wlRotateTo = True
-    , _wlBlockID = Nothing
+    , _wlBlockID = Nothing'
     }
 {- Indestructible see-through wall.  -}
 defaultCrystalWall :: Wall

src/Dodge/LevelGen/Block.hs

@@ -4,15 +4,10 @@ module Dodge.LevelGen.Block
     )
     where
 import Dodge.Data
---import Dodge.Data.SoundOrigin
 import Dodge.Base
 import Dodge.Zone
---import Dodge.SoundLogic
---import Dodge.SoundLogic.LoadSound
---import Dodge.WorldEvent.Sound
 import Dodge.LevelGen.Pathing
 import Dodge.Default.Wall
---import Dodge.RandomHelp
 import Geometry
 import qualified IntMapHelp as IM
 import Color
@@ -40,13 +35,13 @@ addBlock (p:ps) hp col isSeeThrough hps w
     lns = zip (p:ps) (ps ++ [p])
     i = IM.newKey $ _walls w
     is = [i.. i + length lns-1]
-    panes = IM.fromList $ zip is $ zipWith 
+    panes = IM.fromList $ zipWith 
-        (\j (a,b) -> defaultWall 
+        (\j (a,b) -> (,) j defaultWall 
             { _wlLine = (a,b)
             , _wlID = j
             , _wlColor = col
             , _wlIsSeeThrough = isSeeThrough
-            , _wlBlockID = Just blid
+            , _wlBlockID = Just' blid
             }
         ) is lns
     wallInZone wl 
@@ -59,7 +54,6 @@ addBlock (p:ps) hp col isSeeThrough hps w
         ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
 addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
----- TODO add block list to world
 putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> (Int,World)
 putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
   where 

src/Dodge/LevelGen/LineBlock.hs

@@ -19,7 +19,7 @@ putLineBlock
     -> World 
     -> (Int, World)
 putLineBlock basePane blockWidth depth a b w = (,) 0 
-    $ removePathsCrossing a b $ foldr insertBlock (insertBlocks' w) listBlocks
+    $ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
   where 
     d = dist a b
     rot = argV (b -.- a)
@@ -33,9 +33,9 @@ putLineBlock basePane blockWidth depth a b w = (,) 0
     linesAt p = makeLoopPairs $ cornersAt p
     k = IM.newKey $ _walls w
     blid = IM.newKey $ _blocks w
-    insertBlock' i = over blocks 
+    insertBlock i = over blocks $ IM.insert (i+blid) Block 
-        $ IM.insert (i+blid) Block {_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
+        {_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
-    insertBlocks' = flip (foldr insertBlock') is
+    insertBlocks = flip (foldr insertBlock) is
     ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
     visibilityAt i 
         | i == 0             = [ True,True,False,True]
@@ -45,14 +45,12 @@ putLineBlock basePane blockWidth depth a b w = (,) 0
         | i == 0             = ksAtI 1
         | i == numBlocks - 1 = ksAtI $ numBlocks - 2
         | otherwise          = ksAtI (i-1) ++ ksAtI (i+1)
-    makeBlockAt :: Point2 -> Int -> [Wall]
+    makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
-    makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
     makePane i visStatus k' ps = basePane 
         {_wlID = k'
-        ,_wlBlockID = Just $ i + blid
+        ,_wlBlockID = Just' $ i + blid
         ,_wlLine = ps
         ,_wlDraw = visStatus
         }
-    listBlocks = concat $ zipWith makeBlockAt blockCenPs is
+    listWalls = concat $ zipWith makeWallAt blockCenPs is
-    insertBlock :: Wall -> World -> World
+    insertWall wl = over walls $ IM.insert (_wlID wl) wl
-    insertBlock wl = over walls $ IM.insert (_wlID wl) wl

src/Dodge/Update.hs

@@ -11,7 +11,6 @@ import Dodge.Config.Data
 import Dodge.Base
 import Dodge.Zone
 import Dodge.WallCreatureCollisions
---import Dodge.LevelGen.Block
 import Dodge.Update.Camera
 import Dodge.SoundLogic
 import Dodge.Inventory
@@ -178,12 +177,14 @@ ppEvents :: World -> World
 ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w
 
 updateSeenWalls :: World -> World
-updateSeenWalls w = foldl' (flip markSeen) w wallsToUpdate
+updateSeenWalls w = foldl' markWallSeen w wallsToUpdate
   where 
     vPos = _cameraViewFrom w
     wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
                              $ nRays 20
-    markSeen i = set (walls . ix i . wlSeen) True
+
+markWallSeen :: World -> Wall -> World
+markWallSeen w wl = w & walls . ix (_wlID wl) . wlSeen .~ True
 
 --setTestStringIO :: IO World -> IO World
 --setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
@@ -301,15 +302,14 @@ rotateToOverlappingWall w = case theWall of
     theWall = overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w)
 
 {-
-Finds the IDs of visible walls from a point to another point.  -}
+Finds the visible walls from a point to another point.  -}
-visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
+visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
 visibleWalls p1 p2 ws 
-    = map fst 
+    = takeUntil _wlIsSeeThrough 
-    . takeUntil (_wlIsSeeThrough . snd) 
     . map snd 
     . sortOn (dist p1 . fromJust . fst) 
     . filter ((/=) Nothing . fst) 
     . map f 
     $ IM.toList ws
   where 
-    f (i,wl) = (uncurry intersectSegSeg (_wlLine wl) p1 p2, (i,wl))
+    f (i,wl) = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl)

src/Dodge/WorldEvent/DamageBlock.hs

@@ -6,8 +6,8 @@ import Control.Lens
 
 damageBlocksBy :: Int -> Wall -> World -> World
 damageBlocksBy x wl = case _wlBlockID wl of
-    Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
+    Just' blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
-    Nothing   -> id
+    Nothing'   -> id
   where
     reduceHeadBy y (z:zs) = z - y : zs
     reduceHeadBy _ [] = []