Continue to refactor zoning to be more stream-based

src/Dodge/Base.hs

@@ -128,7 +128,7 @@ mvPointToward !ep !p
     | otherwise     = p +.+ normalizeV (ep -.- p)
 
 vecBetweenSpeed :: Float -> Point2 -> Point2 -> Point2
-vecBetweenSpeed s sp ep
+vecBetweenSpeed !s !sp !ep
     | dist sp ep < s = ep -.- sp
     | otherwise = s *.* normalizeV (ep -.- sp)
 

src/Dodge/Block.hs

@@ -32,7 +32,7 @@ unshadowBlock wlid w = case w ^? walls . ix wlid of
         & walls . ix wlid . wlDraw .~ True
         & wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
       where
-        (x,y) = zoneOfPoint $ uncurry midPoint (_wlLine wl)
+        V2 x y = wallZoneOfPoint $ uncurry midPoint (_wlLine wl)
     Nothing -> w
 
 checkBlockHP :: Block -> World -> World

src/Dodge/Data.hs

@@ -1454,7 +1454,7 @@ data Room = Room
         -> Room     -- ^ parent room
         -> Room
     , _rmPos        :: [RoomPos]
-    , _rmPath       :: [(Point2, Point2)]
+    , _rmPath       :: S.Set (Point2, Point2)
     , _rmPmnts      :: [Placement]
     , _rmInPmnt     :: [InPlacement]
     , _rmOutPmnt    :: [OutPlacement]

src/Dodge/Debug.hs

@@ -61,6 +61,6 @@ debugWallZoningPic w = setLayer BloomLayer $ zonesPic `appendPic` wallsPic
         $ wallsAlongLine sp ep w
     drawTheWall (a,b) = thickLine 20 [a,b]
     zonesPic = setDepth 20 $ drawDDA zones
-    zones = ddaExt zoneSize sp ep
+    zones = ddaExt wallZoneSize sp ep
     sp = _crPos $ you w
     ep = mouseWorldPos w

src/Dodge/Default/Room.hs

@@ -8,20 +8,20 @@ import qualified Data.Set as S
 
 defaultRoom :: Room
 defaultRoom = Room
-    { _rmPolys  = []
+    { _rmPolys  = mempty
-    , _rmLinks  = []
+    , _rmLinks  = mempty
     , _rmLinkEff = const . const . const . const id
-    , _rmPos    = []
+    , _rmPos    = mempty
-    , _rmPath   = []
+    , _rmPath   = mempty
-    , _rmPmnts  = []
+    , _rmPmnts  = mempty
-    , _rmInPmnt   = []
+    , _rmInPmnt   = mempty
-    , _rmOutPmnt    = []
+    , _rmOutPmnt    = mempty
-    , _rmBound      = []
+    , _rmBound      = mempty
     , _rmFloor      = InheritFloor
     , _rmName       = "defaultRoom"
     , _rmShift      = (V2 0 0 , 0)
-    , _rmViewpoints = []
+    , _rmViewpoints = mempty
-    , _rmRandPSs    = []
+    , _rmRandPSs    = mempty
 --    , _rmLabel      = Nothing
 --    , _rmTakeFrom   = Nothing
     , _rmStartWires = IM.empty

src/Dodge/Graph.hs

@@ -14,13 +14,14 @@ import Data.Graph
 import Data.Maybe
 import qualified Data.Graph.Inductive.Graph as F
 import qualified Data.Graph.Inductive.PatriciaTree as F
+import qualified Data.Set as S
 import Data.Bifunctor
 
-pairsToIncidence :: Ord a => [(a,a)] -> [(a,[a])]
+pairsToIncidence :: Ord a => S.Set (a,a) -> [(a,[a])]
 pairsToIncidence 
     = map (first head . unzip)
     . groupOn fst
-    . sort
+    . S.toAscList -- TODO check that the lexicographic sorting is correct for groupOn fst
 
 incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a]
 incidenceToFunction xs a = fromMaybe [] $ lookup a xs
@@ -28,7 +29,7 @@ incidenceToFunction xs a = fromMaybe [] $ lookup a xs
 mkNode :: (a,[a]) -> (a,a,[a])
 mkNode (x,xs) = (x,x,xs)
 
-pairsToSCC :: Ord a => [(a,a)] -> [SCC a]
+pairsToSCC :: Ord a => S.Set (a,a) -> [SCC a]
 pairsToSCC = stronglyConnComp . map mkNode . pairsToIncidence
 
 graphToEdges :: forall a b . F.Gr a b -> [(a,a)]

src/Dodge/Item/Weapon/SonicGuns.hs

@@ -84,37 +84,38 @@ drawSonicWave pt = foldMap (color (_ptColor pt) . setLayer BloomNoZWrite . setDe
 mvSonicWave :: World -> Particle -> (World, Maybe Particle)
 mvSonicWave w pt
     | _ptTimer pt <= 0 = (w,Nothing)
-    | otherwise = (w, Just pt')
+    | otherwise = (w, Just $ pt & ptTimer -~ 1)
-  where
+--    | otherwise = (w, Just pt')
-    mvPointDir (p,a) = case wallsHit p ep w of
+--  where
-        [] -> Just ((ep, a), (True,True))
+--    mvPointDir (p,a) = case wallsHit p ep w of
-        (hp,wl):_ -> reflectShockLine wl p hp ep
+--        [] -> Just ((ep, a), (True,True))
-      where
+--        (hp,wl):_ -> reflectShockLine wl p hp ep
-        ep = p +.+ 5 *.* unitVectorAtAngle a
+--      where
-    dividePointDir (x:y:xs) = f x y ++ dividePointDir (y:xs)
+--        ep = p +.+ 5 *.* unitVectorAtAngle a
-    dividePointDir xs = xs
+--    dividePointDir (x:y:xs) = f x y ++ dividePointDir (y:xs)
-    f (p,a) (q,b)
+--    dividePointDir xs = xs
-        | dist p q > 10 = [(p,a),(0.5 *.* (p +.+ q),mixAngles 0.5 a b)]
+--    f (p,a) (q,b)
-        | otherwise = [(p,a)]
+--        | dist p q > 10 = [(p,a),(0.5 *.* (p +.+ q),mixAngles 0.5 a b)]
-    combineClose ((p,a):(q,b):pairs)
+--        | otherwise = [(p,a)]
-        | dist p q < 5 = combineClose (( 0.5 *.* (p+.+q), mixa) : pairs)
+--    combineClose ((p,a):(q,b):pairs)
-        | otherwise = (p,a) : combineClose ((q,b):pairs)
+--        | dist p q < 5 = combineClose (( 0.5 *.* (p+.+q), mixa) : pairs)
-      where
+--        | otherwise = (p,a) : combineClose ((q,b):pairs)
-        mixa = mixAngles 0.5 a b
+--      where
-    combineClose pairs = pairs
+--        mixa = mixAngles 0.5 a b
-    pt' = pt & ptTimer -~ 10
+--    combineClose pairs = pairs
-        -- & ptPointDirs %~ (map dividePointDir . filter (not . null) . dosplit . map mvPointDir)
+--    pt' = pt & ptTimer -~ 10
-        & ptPointDirs %~ (map (dividePointDir . combineClose) . filter (not . null) 
+--        -- & ptPointDirs %~ (map dividePointDir . filter (not . null) . dosplit . map mvPointDir)
-            . concatMap (dosplit . map mvPointDir))
+--        & ptPointDirs %~ (map (dividePointDir . combineClose) . filter (not . null) 
-    --    & ptPointDirs %~ (filter (not . null) . concatMap (dosplit . map mvPointDir))
+--            . concatMap (dosplit . map mvPointDir))
-    dosplit :: [Maybe ((Point2,Float),(Bool,Bool))] -> [[(Point2,Float)]]
+--    --    & ptPointDirs %~ (filter (not . null) . concatMap (dosplit . map mvPointDir))
-    dosplit (x:xs) = case x of
+--    dosplit :: [Maybe ((Point2,Float),(Bool,Bool))] -> [[(Point2,Float)]]
-        Nothing -> [] : dosplit xs
+--    dosplit (x:xs) = case x of
-        Just (pair,(True,True))  -> overHead (pair:) $ dosplit xs
+--        Nothing -> [] : dosplit xs
-        Just (pair,(False,True)) -> [] : overHead (pair:) (dosplit xs)
+--        Just (pair,(True,True))  -> overHead (pair:) $ dosplit xs
-        Just (pair,(True,False)) -> [pair] : dosplit xs
+--        Just (pair,(False,True)) -> [] : overHead (pair:) (dosplit xs)
-        Just (_,(False,False)) -> [] : dosplit xs
+--        Just (pair,(True,False)) -> [pair] : dosplit xs
-    dosplit [] = [[]]
+--        Just (_,(False,False)) -> [] : dosplit xs
+--    dosplit [] = [[]]
 
 overHead :: (a -> a) -> [a] -> [a]
 overHead f (x:xs) = f x: xs

src/Dodge/Item/Weapon/UseEffect.hs

@@ -14,6 +14,7 @@ import LensHelp
 
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
+import qualified Streaming.Prelude as S
 {- | Creates an outwardly increasing circle that draws creatures, even those behind walls.  -}
 aSonarPulse :: Creature -> World -> World
 aSonarPulse = aRadarPulse crBlips (blipAt 8) (withAlpha 0.2 green)
@@ -122,9 +123,9 @@ itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _floorItems
     f q = dist p q <= r && dist p q > r - 4
 
 wallBlips :: Point2 -> Float -> World -> [Point2]
-wallBlips p r w = mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
+wallBlips p r w = runIdentity . S.toList_ $ S.mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
-        $ map (over wlLine swp) (IM.elems $ wallsAlongCirc p r w)
+        $ S.map (over wlLine swp) (wallsAlongCirc' p r w)
-                      ++ IM.elems (wallsAlongCirc p r w)
+                      <> wallsAlongCirc' p r w
   where
     swp (a,b) = (b,a)
 

src/Dodge/Layout.hs

@@ -21,7 +21,6 @@ import qualified IntMapHelp as IM
 import Tile
 import RandomHelp
 
-import qualified Data.Set as S
 import Data.List (nubBy)
 import Data.Traversable
 import Control.Lens
@@ -47,7 +46,7 @@ generateLevelFromRoomList gr' w = initWallZoning
         }
   where
     path = pairsToGraph dist pairPath
-    pairPath = S.fromList $ concatMap _rmPath rs
+    pairPath = foldMap _rmPath rs
     rs = map doRoomShift $ IM.elems rs'
     rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
 

src/Dodge/Path.hs

@@ -27,7 +27,7 @@ makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     nb <- walkableNodeNear b
     sp na nb (_pathGraph w)
   where
-    nodesNear p = concat $ lookLookups (zoneAroundPoint p) (_pathPoints w)
+    nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
     walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
 
 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
@@ -92,5 +92,5 @@ removePathsCrossing a b w = w
     & pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph)
   where 
     pg' = S.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
-    insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+    insertPoint pp@(_,p) = uncurryV insertInZoneWith (wallZoneOfPoint p) (++) [pp]
     newGraph = pairsToGraph dist pg'

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -43,13 +43,14 @@ addBlock (p:ps) wl bl w = w
             }
         ) is lns
     wallInZone wl'
-        | uncurry dist (_wlLine wl') <= 2*zoneSize 
+        | uncurry dist (_wlLine wl') <= 2*wallZoneSize 
             = insertIMInZone x y wlid wl'
         | otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips
       where 
-        (x,y) = zoneOfPoint $ uncurry midPoint (_wlLine wl)
+        V2 x y = wallZoneOfPoint $ uncurry midPoint (_wlLine wl)
         wlid  = _wlID wl
-        ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
+        ips = map (unv2 . wallZoneOfPoint) $ uncurry (divideLine (2*wallZoneSize)) (_wlLine wl)
+        unv2 (V2 x y) = (x,y)
 addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
 placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)

src/Dodge/Render/ShapePicture.hs

@@ -108,7 +108,7 @@ drawInspectWalls w = foldMap (drawInspectWall w)
 drawInspectWall :: World -> Wall -> Picture
 drawInspectWall _ wl = setLayer DebugLayer $ 
         color rose (thickLine 3 [a,b])
-    <> foldMap (drawZone zoneSize)
+    <> foldMap (drawZone wallZoneSize)
         (runIdentity $ S.toList_ $ zoneOfWall wl)
   where
     (a,b) = _wlLine wl 

src/Dodge/Render/Walls.hs

@@ -10,6 +10,7 @@ import ShapePicture
 import Control.Lens
 --import Data.Maybe
 import qualified Control.Foldl as L
+import qualified Streaming.Prelude as S
 --import Data.List
 --import qualified Data.IntMap.Strict as IM
 wallsToDrawStreams
@@ -20,11 +21,14 @@ wallsToDrawStreams cfig w
     = ( wls, wins,spic)
   where
     f wl = (_wlLine wl, _wlColor wl)
-    (wls, wins, spic) = L.fold ((,,)
+    (wls, wins, spic) = runIdentity $ L.purely S.fold_ 
+        ((,,)
         <$> L.prefilter wlOpaqueDraw (L.premap f L.list)
         <*> L.prefilter wlSeeThroughDraw (L.premap f L.list)
         <*> L.premap getWallSPic L.mconcat
-        ) (wallsDoubleScreen cfig w)
+        ) (S.concat $ S.mapMaybe g $ zoneOfSight wallZoneSize w)
+    g (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
+    
 wlOpaqueDraw :: Wall -> Bool
 wlOpaqueDraw wl = wlIsOpaque wl && _wlDraw wl
 wlSeeThroughDraw :: Wall -> Bool

src/Dodge/Room/Airlock.hs

@@ -24,7 +24,7 @@ airlock0 :: Room
 airlock0 = defaultRoom
     { _rmPolys = [ rectNSWE 100 0 0 40 , switchcut]
     , _rmLinks = muout lnks ++ muin [last lnks]
-    , _rmPath  = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20  5) ]
+    , _rmPath  = foldMap doublePairSet [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20  5) ]
     , _rmPmnts    = 
         [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
             $ \btid -> Just $ putDoubleDoorThen thewall (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2
@@ -49,7 +49,7 @@ airlockSimple = defaultRoom
     { _rmPolys =
         [ rectNSWE 120 0 0 180 ]
     , _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
-    , _rmPath  = concatMap (doublePair. (V2 90 30,) . fst) lnks
+    , _rmPath  = foldMap (doublePairSet . (V2 90 30,) . fst) lnks
     , _rmPmnts = 
         [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
             $ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps)
@@ -72,7 +72,7 @@ airlockZ = defaultRoom
     { _rmPolys =
         [ rectNSWE 120 0 0 180 ]
     , _rmLinks = muout[(V2 0 30,pi/2)] ++ muin[(V2 180 30,1.5*pi) ]
-    , _rmPath  = []
+    , _rmPath  = mempty
 --         [(V2 0 40,V2 40 0)
 --         ,(V2 40 0,V2 0 40)
 --         ]
@@ -109,10 +109,7 @@ airlock90 = defaultRoom
             ]
         ]
     , _rmLinks = muout[(V2 0 40,pi/2)] ++ muin[(V2 40 0,pi) ]
-    , _rmPath  = 
+    , _rmPath  = doublePairSet (V2 0 40,V2 40 0)
-         [(V2 0 40,V2 40 0)
-         ,(V2 40 0,V2 0 40)
-         ]
     , _rmPmnts    = 
         [ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id)
             $ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
@@ -137,7 +134,7 @@ airlockCrystal :: Room
 airlockCrystal = defaultRoom
     { _rmPolys = [ rectNSWE 140 0 0 40 , switchcutout ]
     , _rmLinks = muout[(V2 20 130,0) ] ++ muin[(V2 20  0 ,pi) ]
-    , _rmPath  = [ ]
+    , _rmPath  = mempty
     , _rmPmnts    = 
         [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
             $ \btid -> jsps0 $ PutDoor col (cond btid) pss

src/Dodge/Room/BlinkAcross.hs

@@ -44,7 +44,7 @@ blinkAcrossChallenge = do
 
 emptyCorridor :: Room
 emptyCorridor = corridor & rmPolys .~ []
-    & rmPath .~ []
+    & rmPath .~ mempty
     & rmPmnts .~ []
     & rmRandPSs .~ [psRandRanges (10,30) (30,60) (0,2*pi)]
     & rmName .~ "WalledCorridor"

src/Dodge/Room/Boss.hs

@@ -92,7 +92,7 @@ roomCross x y = defaultRoom
         ] ++
         [uncurry inLink (V2 (y-20) (-x),pi)
         ]
-    , _rmPath  = []
+    , _rmPath  = mempty
     , _rmPmnts = 
         [ spanLightI (V2 (x+5) x) (V2 (x+5) (-x))
         , spanLightI (V2 (-x-5) x) (V2 (-x-5) (-x))
@@ -118,7 +118,7 @@ roomShuriken x y =
         corner = defaultRoom
             { _rmPolys  = ps
             , _rmLinks  = [toBothLnk (V2 (x-1) (y-20),negate $ pi/2)]
-            , _rmPath   = []
+            , _rmPath   = mempty
             , _rmPmnts  = [mntLS iShape (V2 x x) (V3 (x-20) x 70)]
             , _rmBound  = ps
             }
@@ -143,7 +143,7 @@ roomTwistCross x y z =
         corner = defaultRoom
             { _rmPolys  = ps
             , _rmLinks  = [toBothLnk (V2 z (y-20), pi/2)]
-            , _rmPath   = []
+            , _rmPath   = mempty
             , _rmPmnts  = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)]
             , _rmBound  = map (expandPolyCorners 10) ps
             }

src/Dodge/Room/Corridor.hs

@@ -20,7 +20,7 @@ corridor :: Room
 corridor = defaultRoom
     { _rmPolys = [poly]
     , _rmLinks = lnks'
-    , _rmPath  = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
+    , _rmPath  = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks
     , _rmPmnts = [ spanLightI (V2 0 39.5) (V2 40 39.5) ]
     , _rmBound = [ rectNSWE 50 30 (-5) 45 ]
     , _rmFloor = Tiled [makeTileFromPoly poly 2]  
@@ -43,7 +43,7 @@ corridor = defaultRoom
         ]
 keyholeCorridor :: Room
 keyholeCorridor = corridor
-    { _rmPath  = []
+    { _rmPath  = mempty
     , _rmPmnts = 
         [ midWall $ rectNSWE top bot 15 0 
         , midWall $ rectNSWE top bot 40 25]
@@ -65,7 +65,7 @@ corridorN = defaultRoom
     where lnks = [uncurry outLink (V2 20 70  ,0)
                  ,uncurry inLink (V2 20 10  ,pi)
                  ]
-          pth = doublePair (V2 20 70,V2 20 10)
+          pth = doublePairSet (V2 20 70,V2 20 10)
 corridorWallN :: Room
 corridorWallN = defaultRoom
     { _rmPolys = [rectNSWE 70 0 0 40
@@ -79,15 +79,16 @@ corridorWallN = defaultRoom
     lnks = [uncurry outLink(V2 20 70  ,0)
                  ,uncurry inLink(V2 20 10  ,pi)
                  ]
-    pth = doublePair (V2 20 70,V2 20 10)
+    pth = doublePairSet (V2 20 70,V2 20 10)
 
+-- this should be combined with tWest
 tEast :: Room
 tEast = defaultRoom
     { _rmPolys = [rectNSWE 80 0  (-20) 20
                  ,rectNSWE 80 40 (-40) 40
                  ]
     , _rmLinks = lnks'
-    , _rmPath  = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
+    , _rmPath  = foldMap (doublePairSet . (,) (V2 0 60) . fst) lnks
     , _rmPmnts    = []
     , _rmBound = [ rectNSWE 70 10 0 40 ]
     , _rmName = "tEast"
@@ -109,7 +110,7 @@ tWest = defaultRoom
                  ,rectNSWE 80 40 (-40) 40
                  ]
     , _rmLinks = lnks
-    , _rmPath  = concatMap (doublePair . (V2 0 60 ,) . _rlPos) lnks
+    , _rmPath  = foldMap (doublePairSet . (V2 0 60 ,) . _rlPos) lnks
     , _rmPmnts    = []
     , _rmBound = [ rectNSWE 70 10 0 40 ]
     , _rmName = "tWest"

src/Dodge/Room/Door.hs

@@ -18,7 +18,7 @@ door :: Room
 door = defaultRoom
     { _rmPolys = [rectNSWE 40 0 0 40]
     , _rmLinks = init lnks ++ [last lnks]
-    , _rmPath  = [(V2 20 35,V2 20 5)]
+    , _rmPath  = doublePairSet (V2 20 35,V2 20 5)
 -- door extends into side walls (for shadows as rendered 12/03)
     , _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
     , _rmName = "autoDoor"
@@ -33,7 +33,7 @@ triggerDoorRoom :: Int -> Room
 triggerDoorRoom inplid = defaultRoom
     { _rmPolys  = [rectNSWE 40 0 0 40]
     , _rmLinks  = [uncurry outLink (V2 20 35,0) ,uncurry inLink(V2 20  5,pi) ]
-    , _rmPath   = [(V2 20 35,V2 20 5)]
+    , _rmPath   = doublePairSet (V2 20 35,V2 20 5)
     , _rmInPmnt = [InPlacement f inplid]
     , _rmName   = "triggerDoorRoom"
 -- door extends into side walls (for shadows as rendered 12/03/21)

src/Dodge/Room/Link.hs

@@ -22,7 +22,7 @@ import Data.Tile
 import Dodge.RoomLink
 
 import Control.Lens
---import qualified Data.Set as S
+import qualified Data.Set as S
 
 restrictRMInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room
 restrictRMInLinksPD f = rmLinks %~ restrictLinkType InLink f
@@ -40,7 +40,7 @@ shiftRoomBy :: (Point2,Float) -> Room -> Room
 shiftRoomBy shift r = r
     & rmPolys %~ fmap (map (shiftPointBy shift))
     & rmLinks %~ fmap (shiftLinkBy shift)
-    & rmPath  %~ map (shiftPathBy shift)
+    & rmPath  %~ S.map (shiftPathBy shift)
     & rmBound %~ fmap (map (shiftPointBy shift))
     & rmShift %~ shiftPosDirBy shift
     & rmFloor . tiles %~ map 
@@ -54,7 +54,7 @@ moveRoomBy :: (Point2,Float) -> Room -> Room
 moveRoomBy shift r = r
     & rmPolys %~ fmap (map (shiftPointBy shift))
     & rmLinks %~ fmap (shiftLinkBy shift)
-    & rmPath  %~ map (shiftPathBy shift)
+    & rmPath  %~ S.map (shiftPathBy shift)
     & rmBound %~ fmap (map (shiftPointBy shift))
     & rmPmnts %~ map (shiftPlacement shift)
     & rmFloor . tiles %~ map 

src/Dodge/Room/LongDoor.hs

@@ -43,7 +43,7 @@ twinSlowDoorRoom w h x = defaultRoom
         [ (V2 w (h/2) , negate $ pi/2)
         , (V2 (-w) (h/2) , pi/2) ]
         ++ [uncurry inLink (V2 0 (-h), pi) ]
-    , _rmPath   = []
+    , _rmPath   = mempty
     , _rmPmnts     = 
         [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
             $ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h))

src/Dodge/Room/Ngon.hs

@@ -19,7 +19,7 @@ roomNgon :: Int -> Float -> Room
 roomNgon n x = defaultRoom
     { _rmPolys = [poly]
     , _rmLinks = map toBothLnk lnks -- muout (init lnks) ++ muin[last lnks]
-    , _rmPath  = [] -- TODO
+    , _rmPath  = mempty -- TODO
     , _rmPmnts = [mntLightLnkCond $ resetPLUse $ rprBool $ const . isInLnk]
     , _rmBound = [poly]
     , _rmFloor = Tiled [makeTileFromPoly poly 9]

src/Dodge/Room/Path.hs

@@ -19,6 +19,7 @@ import Data.Bifunctor
 import Data.Maybe
 import qualified Data.Tuple.Extra as Tup
 import qualified Control.Foldl as L
+import qualified Data.Set as S
 
 createPathGrid :: Room -> Room
 createPathGrid rm = rm
@@ -35,13 +36,12 @@ createPathGrid rm = rm
         <*> L.premap sndV2 L.minimum 
         <*> L.premap sndV2 L.maximum
 
--- ?TODO? : make this minimumOn
+linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> S.Set (Point2,Point2)
-linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
+linksAndPath lnks subpth = S.fromList subpth <> foldMap linkClosest lnks
-linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
   where 
-    linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ map fst subpth)
+    linkClosest (p,_) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
 
-linksAndPath' :: [RoomLink] -> [(Point2,Point2)] -> [(Point2,Point2)]
+linksAndPath' :: [RoomLink] -> [(Point2,Point2)] -> S.Set (Point2,Point2)
 linksAndPath' = linksAndPath . map lnkPosDir
 
 testCrossWalls

src/Dodge/Room/Procedural.hs

@@ -49,7 +49,7 @@ roomRect x y xn yn = defaultRoom
     { _rmPolys = [rectNSWE  y 0 0 x ]
     , _rmLinks = lnks
     , _rmName  = "rect"
-    , _rmPath  = concatMap doublePair pth
+    , _rmPath  = foldMap doublePairSet pth
     --, _rmPos   = map (roomposat (RoomPosOnPath S.empty)) posps
     --    ++ map (roomposat (RoomPosOffPath S.empty)) interposps
     , _rmPos   = map makeonpos posps'
@@ -131,7 +131,7 @@ combineRooms :: Room -> Room -> Room
 combineRooms r r' = defaultRoom
     { _rmPolys  = _rmPolys r ++ _rmPolys r'
     , _rmLinks  = _rmLinks r ++ _rmLinks r'
-    , _rmPath   = map clampPath $ _rmPath  r ++ _rmPath  r'
+    , _rmPath   = S.map clampPath $ _rmPath  r <> _rmPath  r'
     , _rmPmnts  = _rmPmnts r ++ _rmPmnts r'
     , _rmBound  = _rmBound r ++ _rmBound r'
     , _rmPos    = _rmPos r ++ _rmPos r'
@@ -163,7 +163,7 @@ quarterRoomTri w = do
     pure $ defaultRoom
         { _rmPolys  = [ [V2 0 0,V2 w w,V2 (-w) w] ]
         , _rmLinks  = [toBothLnk (V2 0 w, 0)]
-        , _rmPath   = concatMap doublePair
+        , _rmPath   = foldMap doublePairSet
             [(V2 0 w,V2 0 (w-20))
             ,(V2 0 (w-20),V2 (w-20) (w-20))
             ,(V2 0 (w-20),V2 (55-w) (w-20))
@@ -199,7 +199,7 @@ quarterRoomSquare w = do
             [ (V2 (w/2) (3*w/2), negate $ pi/4)
             , (V2 (negate $ w/2) (3*w/2), pi/4)
             ]
-        , _rmPath   = concatMap doublePair
+        , _rmPath   = foldMap doublePairSet
             [(V2 (0.5*w) (1.5*w),V2 (0.5*w-20) (1.5*w-20))
             ,(V2 (-0.5*w) (1.5*w),V2 (-0.5*w+20) (1.5*w-20))
             ,(V2 0 (2*w-40),V2 (-0.5*w+20) (1.5*w-20))
@@ -249,7 +249,7 @@ centerVaultRoom w h d = return $ defaultRoom
         ,outLink (V2 w    0) (-pi/2)
         ,outLink (V2 (-w) 0) (pi/2) 
         , inLink (V2 0   (-h)) pi ]
-    , _rmPath   = []
+    , _rmPath   = mempty
     , _rmPmnts     = 
         [sps0 $ PutWall (reverse $ rectNSWE   d  (d - 30) (d - 30)   d ) defaultWall
         ,sps0 $ PutWall (reverse $ rectNSWE   d  (d - 30) (30 - d) (-d)) defaultWall

src/Dodge/Room/RoadBlock.hs

@@ -35,7 +35,7 @@ litCorridor90 = do
         , _rmLinks = 
             [ outLink (V2 40 (h - 80)) (-pi/2)
             , inLink  (V2 20       0 )   pi      ]
-        , _rmPath  = concatMap doublePair 
+        , _rmPath  = foldMap doublePairSet
             [( V2  20   0     , V2 20 (h-40) )
             ,( V2   0  (h-40) , V2 20 (h-40) )
             ,( V2  40  (h-40) , V2 20 (h-40) )

src/Dodge/Room/Room.hs

@@ -60,7 +60,7 @@ roomPadCut :: [Point2] -> Point2 -> Room
 roomPadCut ps p = defaultRoom
     { _rmPolys = [ps]
     , _rmLinks = muout [(p,0)] ++ muin [(V2 0 0,pi)]
-    , _rmPath  = [(V2 0 0,p)]
+    , _rmPath  = doublePairSet (V2 0 0,p)
     }
 
 branchWith :: Room -> [Tree Room] -> Tree Room
@@ -220,7 +220,7 @@ deadEndRoom :: Room
 deadEndRoom = defaultRoom
     { _rmPolys = [rectNSWE 40 (-20) (-20) 20 ]
     , _rmLinks = muout (init lnks) ++ muin [last lnks]
-    , _rmPath  = []
+    , _rmPath  = mempty
     , _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp]
     , _rmBound = [rectNSWE 20 (-20) (-30) 30]
     , _rmName  = "deadEndRoom"

src/Dodge/Room/Treasure.hs

@@ -27,7 +27,7 @@ triLootRoom w h = pure $ defaultRoom
                   , base
                   ]
     , _rmLinks  = [uncurry inLink(V2 0 (-80) , pi)]
-    , _rmPath   = doublePair (V2 0 (-80) , V2 0 (h/2))
+    , _rmPath   = doublePairSet (V2 0 (-80) , V2 0 (h/2))
     , _rmPmnts     =
         [sPS (V2 (15-w)    15 )  0 $ PutID 0
         ,sPS (V2 (w-15)    15 ) pi $ PutID 0

src/Dodge/Update.hs

@@ -366,14 +366,14 @@ crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
     cs = creaturesNearPoint (_crPos c) w
 
 crCrSpring :: Creature -> Creature -> World -> World
-crCrSpring c1 c2 w 
+crCrSpring c1 c2
-    | id1 == id2 = w
+    | id1 == id2    = id
-    | vec == V2 0 0 = w
+    | vec == V2 0 0 = id
-    | diff >= comRad = w
+    | diff >= comRad = id
-    | otherwise = over creatures
+    | otherwise = creatures %~
         ( over (ix id1 . crPos) (+.+ overlap1)
         . over (ix id2 . crPos) (-.- overlap2)
-        ) w
+        )
   where 
     id1  = _crID c1
     id2  = _crID c2

src/Dodge/Update/Camera.hs

@@ -221,12 +221,6 @@ gameRoomViewpoints p gr = S.each (_grViewpoints gr)
 
 farWallDistDirection :: Point2 -> World -> Maybe (Float,Float,Float,Float)
 farWallDistDirection p w = boundPoints
---    runIdentity $ L.purely S.fold_ ((,,,) 
---    <$> L.premap (^?! _2) L.maximum
---    <*> L.premap (^?! _2) L.minimum
---    <*> L.premap (^?! _1) L.maximum
---    <*> L.premap (^?! _1) L.minimum
---    )
     $ S.map f vps
   where
     f q = runIdentity (S.fold_ findPoint q (rotateV (negate $ _cameraRot w) . (-.- p)) (wls q))

src/Dodge/Wall/Zone.hs

@@ -11,11 +11,7 @@ import Streaming
 import qualified Streaming.Prelude as S
 
 zoneOfWall :: Wall -> Stream (Of (V2 Int)) Identity ()
-zoneOfWall = uncurry zoneOfLineStream . _wlLine
+zoneOfWall = uncurry (zoneOfSeg wallZoneSize) . _wlLine
---    | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ]
---    | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline
---  where
---    wlline = _wlLine wl
 
 insertWallInZones :: Wall -> World -> World
 insertWallInZones wl = wallsZone . znObjects

src/Dodge/WorldEvent/ThingsHit.hs

@@ -4,7 +4,7 @@ Find which objects lie upon a line.
  -}
 module Dodge.WorldEvent.ThingsHit
     ( thingsHit
-    , wallsHit
+--    , wallsHit
     , thingHit
     , thingsHitExceptCr
     )
@@ -57,18 +57,18 @@ thingsHitExceptCr (Just cid) sp ep = S.filter crNotCid . thingsHit sp ep
     crNotCid (_,Left cr) = _crID cr /= cid
     crNotCid _ = True
 
-wallsHit
+--wallsHit
-    :: Point2    -- ^ Line start point
+--    :: Point2    -- ^ Line start point
-    -> Point2    -- ^ Line end point
+--    -> Point2    -- ^ Line end point
-    -> World 
+--    -> World 
-    -> [(Point2, Wall)]
+--    -> [(Point2, Wall)]
-wallsHit sp ep w 
+--wallsHit sp ep w 
-    | sp == ep  = []
+--    | sp == ep  = []
-    | otherwise = sortOn (dist sp . fst) wls
+--    | otherwise = sortOn (dist sp . fst) wls
-  where 
+--  where 
-    wls = IM.elems $ wallsOnLineHit sp ep 
+--    wls = IM.elems $ wallsOnLineHit sp ep 
-        $ IM.unions [f b $ f a $ _znObjects $ _wallsZone w 
+--        $ IM.unions [f b $ f a $ _znObjects $ _wallsZone w 
-            | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+--            | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-       -- $ _walls w
+--       -- $ _walls w
-    (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
+--    V2 x y = wallZoneOfPoint (0.5 *.* (sp +.+ ep))
-    f i = fromMaybe IM.empty . IM.lookup i
+--    f i = fromMaybe IM.empty . IM.lookup i

src/Dodge/Zone.hs

@@ -1,25 +1,19 @@
 module Dodge.Zone
     ( crZoneOfPoint
-    , zoneOfLineIntMap
     , wallsNearPoint
     , wallsNearPoint'
     , wallsAlongLine
-    , zoneSize
-    , zoneOfPoint
-    , wallsAlongCirc
     , wallsAlongCirc'
-    , wallsOnScreen
     , lookLookups
-    , zoneAroundPoint
+    , zoneOfSeg
-    , floorHun
+    , zoneNearPointIP
-    , zoneOfLine
-    , zoneOfLineStream
-    , wallsDoubleScreen
     , cloudZoneOfPoint
     , cloudsNearPoint
     , wallsNearZones
+    , wallZoneSize
     , zoneOfSight
     , flattenIMIMIM
+    , wallZoneOfPoint
     , creaturesNearPointI
     , creaturesNearPoint
     , creatureNearPoint
@@ -28,11 +22,12 @@ module Dodge.Zone
     )
     where
 import Dodge.Data
-import Dodge.Base.Window
+--import Dodge.Base.Window
 import Geometry
 import Geometry.Zone
 import qualified FoldlHelp as L
 
+import qualified Data.Set as Set
 import qualified Streaming.Prelude as S
 import Streaming
 import Data.Maybe
@@ -45,103 +40,93 @@ import Control.Lens
 --flattenZones ::  Zone (IM.IntMap a) -> IM.IntMap a
 --flattenZones = flattenIMIMIM . _znObjects
 
-zoneSize :: Float
+wallZoneSize :: Float
-zoneSize = 50
+wallZoneSize = 50
-
-floorHun :: Float -> Int
-floorHun x = floor $ x / zoneSize
 
 sizeZoneOfPoint :: Float -> Point2 -> (Int,Int)
 sizeZoneOfPoint s (V2 x y) = (f x, f y)
   where
     f = floor . (/ s)
 
-zoneOfPoint :: Point2 -> (Int,Int)
+wallZoneOfPoint :: Point2 -> V2 Int 
-zoneOfPoint (V2 x y) = (floorHun x, floorHun y)
+wallZoneOfPoint (V2 x y) = V2 (divTo wallZoneSize x) (divTo wallZoneSize y)
 
 cloudZoneOfPoint :: Point2 -> (Int,Int)
 cloudZoneOfPoint = sizeZoneOfPoint 20
 
+creatureZoneSize :: Float
+creatureZoneSize = 15
+
 crZoneOfPoint :: Point2 -> (Int,Int)
-crZoneOfPoint = sizeZoneOfPoint 15
+crZoneOfPoint = sizeZoneOfPoint creatureZoneSize
 
-zoneNearPoint :: Point2 -> [(Int,Int)]
+zoneOfSeg :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
-zoneNearPoint (V2 x' y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-  where 
-    x = floorHun x'
-    y = floorHun y'
-
-zoneAroundPoint :: Point2 -> [(Int,Int)]
-zoneAroundPoint (V2 x' y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
-  where 
-    x = floorHun x'
-    y = floorHun y'
-
-zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
-zoneOfLine (V2 aa ab) (V2 ba bb) 
-    = nub 
-    . concatMap f 
-    $ digitalLine (zoneOfPoint (V2 aa ab)) (zoneOfPoint (V2 ba bb))
-  where 
-    f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
-    --f (x,y) = [(p,r) | p <-[x-2..x+2] , r<-[y-2..y+2]]
-
-zoneOfLineStream :: Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
 --zoneOfLineStream = ddaSqStream zoneSize
-zoneOfLineStream = ddaStream zoneSize
+zoneOfSeg = ddaStream
-
-zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
---{-# INLINE zoneOfLineIntMap #-}
---zoneOfLineIntMap = ddaExt zoneSize
-zoneOfLineIntMap = ddaSq zoneSize
 
 zoneOfCirc :: Monad m => Point2 -> Float -> Stream (Of (V2 Int)) m ()
-zoneOfCirc p = S.map (uncurry V2) . S.each . zoneOfCircle p
+zoneOfCirc p = S.each . zoneOfCircle p
 
-zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
+zoneOfCircle :: Point2 -> Float -> Set.Set (V2 Int)
-zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
+zoneOfCircle p r = foldMap zoneNearPointS $ divideCircle (1.5 * wallZoneSize) p r
 
-zoneOfSight :: Configuration -> World -> [(Int,Int)]
+zoneNearPointS :: Point2 -> Set.Set (V2 Int)
-zoneOfSight cfig w = 
+zoneNearPointS p = Set.fromList [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
-    [(a,b) 
+  where
+    V2 x y = wallZoneOfPoint p
+
+zoneNearPointIP :: Point2 -> [(Int,Int)]
+zoneNearPointIP p = [(a,b) | a <- [x-1..x+1] , b <- [y-1..y+1] ]
+  where
+    V2 x y = wallZoneOfPoint p
+
+zoneNearPoint :: Point2 -> Stream (Of (V2 Int)) Identity ()
+zoneNearPoint p = S.each [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
+  where
+    V2 x y = wallZoneOfPoint p
+
+zoneOfSight :: Float -> World -> Stream (Of (V2 Int)) Identity () --(Int,Int)]
+zoneOfSight x w = S.each
+    [V2 a b 
         | a <- [minimum xs .. maximum xs]
         , b <- [minimum ys .. maximum ys]
     ]
   where 
-    (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon cfig w ++ [_cameraViewFrom w]
+    --(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon cfig w -- ++ [_cameraViewFrom w]
+    (xs,ys) = unzip $ map (sizeZoneOfPoint x) $ _boundBox w -- ++ [_cameraViewFrom w]
 
-wallsDoubleScreen :: Configuration -> World -> IM.IntMap Wall
+--wallsDoubleScreen :: Configuration -> World -> IM.IntMap Wall
-wallsDoubleScreen cfig w
+--wallsDoubleScreen cfig w
-    -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
+--    -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-    -- for some reason (TODO diagnose) the foldl' version causes errors
+--    -- for some reason (TODO diagnose) the foldl' version causes errors
-    = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
+--    = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-  where 
+--  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 (_windowX cfig) (_windowY cfig)
-    xs = [x - n .. x + n]
-    ys = [y - n .. y + n]
-
-wallsOnScreen :: Configuration -> World -> IM.IntMap Wall
-{-# INLINABLE wallsOnScreen #-}
-wallsOnScreen cfig w
-   -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-    = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-  where 
 --    innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
-    innerFold m = foldr (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))
+--    wh = max (_windowX cfig) (_windowY cfig)
-    wh = max (_windowX cfig) (_windowY cfig)
+--    xs = [x - n .. x + n]
-    xs = [x - n .. x + n]
+--    ys = [y - n .. y + n]
-    ys = [y - n .. y + n]
+
+--wallsOnScreen :: Configuration -> World -> IM.IntMap Wall
+--{-# INLINABLE wallsOnScreen #-}
+--wallsOnScreen cfig w
+--   -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
+--    = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
+--  where 
+--    --innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
+--    innerFold m = foldr (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))
+--    wh = max (_windowX cfig) (_windowY cfig)
+--    xs = [x - n .. x + n]
+--    ys = [y - n .. y + n]
 
 wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
 wallsNearZones is w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
@@ -168,17 +153,10 @@ cloudsNearPoint p w = S.each . f $ w ^? cloudsZone . znObjects . ix x . ix y
 
 -- TODO check whether/when nubbing of walls is necessary
 wallsAlongLine :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
-wallsAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfLineStream sp ep
+wallsAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg wallZoneSize sp ep
   where
     f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
 
-wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
-wallsAlongCirc p r w =  IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y) <- zoneOfCircle p r]
-  where 
-    f i m = case IM.lookup i m of 
-        Just val -> val
-        _ -> IM.empty
-
 wallsAlongCirc' :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
 wallsAlongCirc' p r w = S.concat $ S.mapMaybe f $ zoneOfCirc p r
   where
@@ -190,7 +168,7 @@ wallsNearPoint' p = runIdentity . S.toList_ . wallsNearPoint p
 wallsNearPoint :: Point2 -> World -> Stream (Of Wall) Identity ()
 wallsNearPoint p w = S.concat $ S.mapMaybe f $ S.each [V2 a b | a <- [x-1,x,x+1], b <- [y-1,y,y+1]]
   where
-    (x,y) = zoneOfPoint p
+    V2 x y = wallZoneOfPoint p
     f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
 --    IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
 --  where 
@@ -218,15 +196,7 @@ creaturesNearPointI n p w =  IM.unions
     (x,y) = crZoneOfPoint p
     f i m = fromMaybe IM.empty $ IM.lookup i m
 
--- possible BUG, occurs when used in thingsHitLongLine
+creaturesAlongLine :: Point2 -> Point2 -> World -> Stream (Of Creature) Identity ()
-creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
+creaturesAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg creatureZoneSize sp ep
---creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b]
---    where f i m = case IM.lookup i m of Just val -> val
---                                        _        -> IM.empty
-
-creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty (zoneOfLineIntMap a b)
   where
-    g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s))
+    f (V2 i j) = w ^? creaturesZone . znObjects . ix i . ix j
-    f i = fromMaybe IM.empty . IM.lookup i
---    f i m = case IM.lookup i m of Just val -> val
---                                  _        -> IM.empty

src/Geometry.hs

@@ -29,6 +29,7 @@ import Geometry.LHS
 import ListHelp
 --import Geometry.ConvexPoly
 
+import qualified Data.Set as S
 --import Data.Maybe
 --import Data.List
 -- | Return a point a distance away from a first point towards a second point.
@@ -122,6 +123,10 @@ angleBetween v1 v2 = argV v1 - argV v2
 doublePair :: (a,a) -> [(a,a)]
 doublePair (x,y) = [(x,y),(y,x)]
 
+-- this shouldn't be here
+doublePairSet :: Ord a => (a,a) -> S.Set (a,a)
+doublePairSet (x,y) = S.fromList [(x,y),(y,x)]
+
 doubleV2 :: V2 a -> [V2 a]
 doubleV2 (V2 x y) = [V2 x y,V2 y x]
 -- split a list into triples, forms triangles from a polygon

src/Geometry/Zone.hs

@@ -9,6 +9,7 @@ module Geometry.Zone
     , ddaStreamY
     , xIntercepts
     , yIntercepts
+    , divTo
     ) where
 import Geometry.Data
 

src/Loop.hs

@@ -20,8 +20,6 @@ setupLoop
     :: Int                  -- ^ Target seconds per frame
     -> T.Text               -- ^ Window title
     -> WindowConfig
---    -> (Int,Int)            -- ^ The window size.
---    -> Maybe (Int,Int)            -- ^ The window position.
     -> (world -> IO ())    -- ^ Function for cleaning up parameters, applied when exiting loop.
     -> IO world             -- ^ Initial simulation state.
     -> (world -> IO world)   -- ^ update, called once per frame. Allows for side effects such as rendering.
@@ -39,7 +37,7 @@ setupLoop spf title winconfig paramCleanup ioStartWorld sideEffects eventFn = do
             $ \_   -> bracket 
                 ioStartWorld
                 paramCleanup 
-                $ doLoop spf window sideEffects eventFn
+                (doLoop spf window sideEffects eventFn)
 -- | The internal loop.
 doLoop
     :: Int      -- ^ target msec per frame
@@ -48,18 +46,11 @@ doLoop
     -> (world -> Event -> IO (Maybe world)) -- ^ SDL Event handling.
     -> world    -- ^ Current simulation state.
     -> IO ()
-doLoop 
+doLoop spf window worldSideEffects eventFn startWorld = do
-    spf
-    window 
-    worldSideEffects 
-    eventFn 
-    startWorld
-  = do
     startTicks <- ticks
     worldAfterSimStep <- worldSideEffects startWorld
     glSwapWindow window
-    events <- pollEvents
+    maybeUpdatedWorld <- pollEvents >>= foldM (applyEventIO eventFn) (Just worldAfterSimStep)
-    maybeUpdatedWorld <- foldM (applyEventIO eventFn) (Just worldAfterSimStep) events
     case maybeUpdatedWorld of
         Just updatedWorld -> do 
             performGC