Zoning/streaming refactor

src/Dodge/Base/Collide.hs

@@ -27,8 +27,8 @@ module Dodge.Base.Collide
     , collidePointWalls'
 --    , collidePointWallsL
     , collidePointWallsFilt
-    , overlapCircWallsReturnWall
+    , overlapCircWalls
-    , overlapCircWallsReturnWall'
+    , overlapCircWallsClosest
     , collideCircCrsPoint
     , collideCircCreatures
     , collidePointCreatures
@@ -49,6 +49,7 @@ import FoldableHelp
 
 --import Data.List
 import Data.Maybe
+import Data.Function (on)
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Control.Monad
@@ -234,30 +235,10 @@ wallsOnLineHit p1 p2 = IM.mapMaybe f
     f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
 
 wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall
-wallsOnCirc p r = IM.filter f
+wallsOnCirc p r = IM.filter (uncurry (circOnSeg p r) . _wlLine)
-  where 
-    f wl = uncurry circOnSeg (_wlLine wl) p r
 
 wallsOnCirc' :: Point2 -> Float -> [Wall] -> [Wall]
-wallsOnCirc' p r = filter f
+wallsOnCirc' p r = filter $ uncurry (circOnSeg p r) . _wlLine
-  where 
-    f wl = uncurry circOnSeg (_wlLine wl) p r
-
--- | Looks for overlap of a circle with walls.
--- If found, gives wall
-overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall
-overlapCircWallsReturnWall p rad
-    = L.fold (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine))
-  where 
-    f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b
-
--- | Looks for overlap of a circle with walls.
--- If found, gives wall
-overlapCircWallsReturnWall' :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe Wall
-overlapCircWallsReturnWall' p rad
-    = runIdentity . L.purely S.fold_ (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine))
-  where 
-    f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b
 
 -- | Looks for any collision of a circle with walls.
 -- If found, gives point and reflection velocity, reflection damped in normal.
@@ -332,6 +313,18 @@ collideCircWallsList p1 p2 rad
         ,b +.+ rad *.* normalizeV (b -.-a)
         ]
 
+overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity () 
+    -> Stream (Of (Point2,Wall)) Identity ()
+overlapCircWalls p r = S.mapMaybe dointersect
+  where
+    dointersect wl = f (_wlLine wl) <&> (,wl)
+    f (a,b) = intersectSegSeg p (p -.- r *.* vNormal (normalizeV (a -.- b))) a b
+
+overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall)
+overlapCircWallsClosest p r = runIdentity
+    . L.purely S.fold_ (L.minimumBy (compare `on` (dist p . fst)))
+    . overlapCircWalls p r
+
 -- | Looks for first collision of a circle with walls.
 -- If found, gives point and reflection velocity, reflection damped in normal.
 collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
@@ -414,7 +407,7 @@ collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
 {- | Test if a circle collides with any wall. 
  - Note no check on whether the wall is walkable. -}
 circOnSomeWall :: Point2 -> Float -> World -> Bool
-circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg' p rad) . _wlLine)
+circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine)
     . wallsNearPoint p
 --    = any (\(x,y) -> circOnSeg x y p rad) 
 --    . fmap _wlLine 
@@ -427,12 +420,12 @@ crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures
 {- | Produce an unordered list of creatures on a line. -}
 crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
 crsOnLine p1 p2
-    = IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
+    = IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr))
     . _creatures
 {- | Produce an unordered list of creatures on a wide line. -}
 crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature
 crsOnThickLine thickness p1 p2
-    = IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
+    = IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr + thickness))
     . _creatures
 {- | Find 'Maybe' the closest creature to a point, within a circle.
  -}

src/Dodge/Beam.hs

@@ -10,7 +10,7 @@ import Geometry
 import LensHelp
 import Picture
 import RandomHelp
-import Dodge.Zone
+--import Dodge.Zone
 import Dodge.Base.Collide
 import Shape
 
@@ -114,7 +114,6 @@ defaultArcStep itparams w (ArcStep p dir _) = do
             . filter (\cr -> dist center (_crPos cr) < csize)
             . IM.elems
             $ _creatures w
-        wlsnearpoint = wallsNearPoint' p w
         mwl = listToMaybe
             . sortOn (dist p . fst)
             . mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w)

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -479,12 +479,12 @@ updateTractor pj w
 
 tractFlIt :: Point2 -> Point2 -> Point2 -> FloorItem -> FloorItem
 tractFlIt q p1 outpos it 
-    | circOnSeg p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1
+    | segOnCirc p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1
     | otherwise = it
 
 tractCr :: Point2 -> Point2 -> Point2 -> Creature -> Creature
 tractCr q p1 outpos cr
-    | circOnSeg p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1
+    | segOnCirc p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1
     | otherwise = cr
 
 tractorPullPos :: Point2 -> Point2 -> Point2 -> Point2

src/Dodge/Render/MenuScreen.hs

@@ -58,7 +58,7 @@ drawOptions u title ops off footer = pictures $
     , drawFooterText cfig red footer
     ] ++
     zipWith (\s vpos -> placeString (-hw + 50) vpos 0.2 s) 
-        (ops'') 
+        ops''
         [hh-100,hh-150 ..]
 --    ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] | 
 --            y <- map (+75) [0,50..hh*2]]

src/Dodge/Update/Camera.hs

@@ -142,10 +142,18 @@ ifConfigWallRotate cfig w
     | otherwise = w
 
 rotateToOverlappingWall :: World -> World
-rotateToOverlappingWall w = maybe w dowallrotate
+rotateToOverlappingWall w = maybe 
-    $ overlapCircWallsReturnWall' p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w)
+    id 
+    (doWallRotate . snd)
+    (overlapCircWallsClosest p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w))
+    w
+  where
+    cr = you w
+    p = _crPos (you w)
+
+doWallRotate :: Wall -> World -> World
+doWallRotate wl' w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w
   where
-    dowallrotate wl' = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w
     rotateUsing a
         | b - b' > 0.01        = w & cameraRot +~ 0.01
         | b - b' < negate 0.01 = w & cameraRot -~ 0.01
@@ -154,8 +162,6 @@ rotateToOverlappingWall w = maybe w dowallrotate
         --b = a * (2 / pi)
         b = a * (4 / pi)
         b' = fromIntegral (round b :: Int)
-    cr = you w
-    p = _crPos cr
 
 rotateCameraBy :: Float -> World -> World
 rotateCameraBy x w = w 

src/Dodge/WallCreatureCollisions.hs

@@ -16,7 +16,7 @@ import Data.Monoid
 import Data.Maybe
 import Data.Function
 import Control.Lens
-import qualified Data.IntMap.Strict as IM
+--import qualified Data.IntMap.Strict as IM
 
 import qualified Streaming.Prelude as S
 
@@ -84,7 +84,7 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
 -- note the inclusion of endpoints in circOnSeg
 crOnWall :: Creature -> World -> Bool
 crOnWall cr = runIdentity
-    . S.any_ (uncurry (circOnSeg' p r) . _wlLine)
+    . S.any_ (uncurry (circOnSeg p r) . _wlLine)
     . S.filter (not . _wlWalkable) 
     . wallsNearPoint p
   where

src/Dodge/WorldEvent/Explosion.hs

@@ -10,7 +10,7 @@ module Dodge.WorldEvent.Explosion
 import Dodge.Data
 import Dodge.LightSource
 --import Dodge.Default
-import Dodge.Zone
+--import Dodge.Zone
 import Dodge.Base.Collide
 import Dodge.WorldEvent.SpawnParticle
 --import Dodge.WorldEvent.Flash

src/Dodge/WorldEvent/Shockwave.hs

@@ -12,8 +12,9 @@ import Geometry
 import Picture
 import LensHelp
 
-import Data.Foldable
+--import Data.Foldable
 import qualified Data.IntMap.Strict as IM
+import qualified Streaming.Prelude as S
 -- currently very effective against walls
 makeShockwaveAt 
     :: [Int]    -- ^ IDs of invulnerable creatures.
@@ -52,7 +53,7 @@ mvShockwave
     :: [Int]    -- ^ IDs of invulnerable creatures.
     -> World -> Particle -> (World, Maybe Particle)
 mvShockwave is w pt 
-    | _ptTimer pt <= 0 = (       w , Nothing)
+    | _ptTimer pt <= 0 = (        w , Nothing)
     | otherwise         = (doDams w , Just $ pt & ptTimer -~ 1)
   where 
     r    = _ptRad pt
@@ -62,10 +63,15 @@ mvShockwave is w pt
     t    = _ptTimer pt
     tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt)
     rad = r - (3/4) * r * tFraction
-    doDams = over creatures (IM.map damCr) 
+    doDams w' = over creatures (IM.map damCr) 
-        . flip (foldl' (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))) 
+        . runIdentity
-        hitBlocks
+        $ S.fold_
-    hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w 
+            (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))
+            w'
+            id
+            hitBlocks
+    hitBlocks = S.map snd . overlapCircWalls p rad $ wallsAlongCirc' p rad w 
+        -- this is not expansive enough
     damCr cr 
         | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr  = cr
         | otherwise = cr & crState . csDamage .:~

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -96,7 +96,7 @@ moveFlame rotd w pt
         , _ptCrIgnore = Nothing
         , _ptVel = speed *.* vel    }
     dodamage = damageInArea closeCrs closeWls pt
-    closeWls wl = uncurry circOnSeg (_wlLine wl) ep 5
+    closeWls wl = uncurry segOnCirc (_wlLine wl) ep 5
     closeCrs cr = dist ep (_crPos cr) 
                     < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
                                 + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
@@ -197,7 +197,7 @@ damageInRadius :: Float -> Particle -> World -> World
 damageInRadius size pt = damageInArea isClose closeWls pt
   where
     p = _ptPos pt
-    closeWls wl = uncurry circOnSeg (_wlLine wl) p size
+    closeWls wl = uncurry segOnCirc (_wlLine wl) p size
     isClose cr = dist p (_crPos cr) < _crRad cr + size
 
 damageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Particle -> World -> World

src/Dodge/Zone.hs

@@ -7,6 +7,7 @@ module Dodge.Zone
     , zoneSize
     , zoneOfPoint
     , wallsAlongCirc
+    , wallsAlongCirc'
     , wallsOnScreen
     , lookLookups
     , zoneAroundPoint
@@ -92,6 +93,8 @@ zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
 --zoneOfLineIntMap = ddaExt zoneSize
 zoneOfLineIntMap = ddaSq zoneSize
 
+zoneOfCirc p = S.map (uncurry V2) . S.each . zoneOfCircle p
+
 zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
 zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
 
@@ -188,6 +191,11 @@ wallsAlongCirc p r w =  IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y)
         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
+    f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
+
 wallsNearPoint' :: Point2 -> World -> [Wall]
 wallsNearPoint' p = runIdentity . S.toList_ . wallsNearPoint p
 

src/Geometry.hs

@@ -84,19 +84,19 @@ circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenorma
 -- | Test whether a circle is on a segment by intersecting a normal and testing
 -- the distance to the endpoints of the segment.
 -- Perhaps a better order of arguments.
-circOnSeg' :: Point2 -> Float -> Point2 -> Point2 -> Bool
+circOnSeg :: Point2 -> Float -> Point2 -> Point2 -> Bool
-{-# INLINE circOnSeg' #-}
+{-# INLINE circOnSeg #-}
-circOnSeg' !c !rad !p1 !p2 = magV (p1 -.- c) <= rad 
+circOnSeg !c !rad !p1 !p2 = magV (p1 -.- c) <= rad 
     || magV (p2 -.- c) <= rad
     || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
   where 
     thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
 
--- | Test whether a circle is on a segment by intersecting a normal and testing
+-- | Test whether a segment intersects a circle by intersecting a normal and testing
 -- the distance to the endpoints of the segment.
-circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool
+segOnCirc :: Point2 -> Point2 -> Point2 -> Float -> Bool
-{-# INLINE circOnSeg #-}
+{-# INLINE segOnCirc #-}
-circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad 
+segOnCirc !p1 !p2 !c !rad = magV (p1 -.- c) <= rad 
     || magV (p2 -.- c) <= rad
     || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
   where