Refactor wall zoning, remove streaming
This commit is contained in:
+94
-26
@@ -43,7 +43,9 @@ import Dodge.Zone
|
||||
import Dodge.Zoning
|
||||
import Dodge.Base.Wall
|
||||
import Geometry
|
||||
import FoldableHelp
|
||||
|
||||
import Data.List (sortOn)
|
||||
import Data.Maybe
|
||||
import qualified IntMapHelp as IM
|
||||
import Control.Lens
|
||||
@@ -52,11 +54,19 @@ import StreamingHelp
|
||||
import qualified Streaming.Prelude as S
|
||||
import qualified Data.IntSet as IS
|
||||
|
||||
--collidePoint :: Point2 -> Point2
|
||||
-- -> StreamOf Wall
|
||||
-- -> (Point2, Maybe Wall)
|
||||
--{-# INLINE collidePoint #-}
|
||||
--collidePoint sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
|
||||
-- where
|
||||
-- findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
|
||||
|
||||
collidePoint :: Point2 -> Point2
|
||||
-> StreamOf Wall
|
||||
-> [Wall]
|
||||
-> (Point2, Maybe Wall)
|
||||
{-# INLINE collidePoint #-}
|
||||
collidePoint sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
|
||||
collidePoint sp ep = foldl' findPoint (ep, Nothing)
|
||||
where
|
||||
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
|
||||
|
||||
@@ -94,10 +104,10 @@ doBounce x sp ep (p, mwl) = mwl <&> \wl ->
|
||||
)
|
||||
|
||||
bounceBall :: Float -> Point2 -> Point2 -> Float
|
||||
-> StreamOf Wall
|
||||
-> [Wall]
|
||||
-> Maybe (Point2,Point2)
|
||||
{-# INLINE bounceBall #-}
|
||||
bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r
|
||||
bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
|
||||
|
||||
bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
|
||||
{-# INLINE bouncePoint #-}
|
||||
@@ -105,45 +115,93 @@ bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
|
||||
|
||||
-- this COULD be written in terms of collidePointWallsFilterStream, TODO test
|
||||
-- whether this is actually faster
|
||||
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
|
||||
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
|
||||
{-# INLINE collidePointTestFilter #-}
|
||||
collidePointTestFilter t sp ep = runIdentity
|
||||
. S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
||||
. S.filter t
|
||||
collidePointTestFilter t sp ep
|
||||
= any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
||||
. filter t
|
||||
|
||||
---- this COULD be written in terms of collidePointWallsFilterStream, TODO test
|
||||
---- whether this is actually faster
|
||||
--collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
|
||||
--{-# INLINE collidePointTestFilter #-}
|
||||
--collidePointTestFilter t sp ep = runIdentity
|
||||
-- . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
||||
-- . S.filter t
|
||||
|
||||
collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
|
||||
{-# INLINE collidePointWallsFilterStream #-}
|
||||
collidePointWallsFilterStream t sp ep = collidePoint sp ep
|
||||
. S.filter t
|
||||
. filter t
|
||||
. wlsNearSeg sp ep
|
||||
|
||||
overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
|
||||
-> StreamOf (Point2,Wall)
|
||||
--overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
|
||||
-- -> StreamOf (Point2,Wall)
|
||||
--{-# INLINE overlapSegWalls #-}
|
||||
--overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
||||
|
||||
overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2,Wall)]
|
||||
{-# INLINE overlapSegWalls #-}
|
||||
overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
||||
overlapSegWalls sp ep = mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
||||
|
||||
visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall)
|
||||
visibleWalls :: Point2 -> Point2 -> World -> [(Point2,Wall)]
|
||||
{-# INLINE visibleWalls #-}
|
||||
visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap
|
||||
( S.span (not . wlIsOpaque . snd)
|
||||
. sortStreamOn (dist sp . fst)
|
||||
visibleWalls sp ep = takeUntil (not . wlIsOpaque . snd)
|
||||
. sortOn (dist sp . fst)
|
||||
. overlapSegWalls sp ep
|
||||
. wlsNearSeg sp ep )
|
||||
. wlsNearSeg sp ep
|
||||
|
||||
allVisibleWalls :: World -> StreamOf (Point2,Wall)
|
||||
--visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall)
|
||||
--{-# INLINE visibleWalls #-}
|
||||
--visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap
|
||||
-- ( S.span (not . wlIsOpaque . snd)
|
||||
-- . sortStreamOn (dist sp . fst)
|
||||
-- . overlapSegWalls sp ep
|
||||
-- . wlsNearSeg sp ep )
|
||||
|
||||
allVisibleWalls :: World -> [(Point2,Wall)]
|
||||
{-# INLINE allVisibleWalls #-}
|
||||
allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
|
||||
allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays 20
|
||||
where
|
||||
vPos = _cameraViewFrom w
|
||||
|
||||
--allVisibleWalls :: World -> StreamOf (Point2,Wall)
|
||||
--{-# INLINE allVisibleWalls #-}
|
||||
--allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
|
||||
-- where
|
||||
-- vPos = _cameraViewFrom w
|
||||
|
||||
overlapCircWalls :: Point2 -> Float -> StreamOf Wall
|
||||
-> StreamOf (Point2,Wall)
|
||||
--overlapCircWalls :: Point2 -> Float -> StreamOf Wall
|
||||
-- -> StreamOf (Point2,Wall)
|
||||
--{-# INLINE overlapCircWalls #-}
|
||||
--overlapCircWalls p r = S.mapMaybe dointersect
|
||||
-- where
|
||||
-- dointersect wl = f (_wlLine wl) <&> (,wl)
|
||||
-- f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
|
||||
|
||||
overlapCircWalls :: Point2 -> Float -> [Wall]
|
||||
-> [(Point2,Wall)]
|
||||
{-# INLINE overlapCircWalls #-}
|
||||
overlapCircWalls p r = S.mapMaybe dointersect
|
||||
overlapCircWalls p r = mapMaybe dointersect
|
||||
where
|
||||
dointersect wl = f (_wlLine wl) <&> (,wl)
|
||||
f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
|
||||
|
||||
-- | note that this does not push the circle away from the wall at all
|
||||
collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall)
|
||||
{-# INLINE collideCircWalls #-}
|
||||
collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
|
||||
where
|
||||
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
|
||||
. shiftbyrad
|
||||
. _wlLine $ wl
|
||||
shiftbyrad (a,b) = bimap f f
|
||||
(a +.+ rad *.* normalizeV (a -.-b)
|
||||
,b +.+ rad *.* normalizeV (b -.-a)
|
||||
)
|
||||
where
|
||||
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
|
||||
|
||||
-- | note that this does not push the circle away from the wall at all
|
||||
collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
|
||||
-> (Point2, Maybe Wall)
|
||||
@@ -160,18 +218,28 @@ collideCircWallsStream sp ep rad = runIdentity . S.fold_ findPoint (ep, Nothing)
|
||||
where
|
||||
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
|
||||
|
||||
overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
|
||||
overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2,Wall)
|
||||
{-# INLINE overlapCircWallsClosest #-}
|
||||
overlapCircWallsClosest p r = minStreamOn (dist p . fst)
|
||||
overlapCircWallsClosest p r = safeMinimumOn (dist p . fst)
|
||||
. overlapCircWalls p r
|
||||
|
||||
--overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
|
||||
--{-# INLINE overlapCircWallsClosest #-}
|
||||
--overlapCircWallsClosest p r = minStreamOn (dist p . fst)
|
||||
-- . overlapCircWalls p r
|
||||
|
||||
{- | Test if a circle collides with any wall.
|
||||
- Note no check on whether the wall is walkable. -}
|
||||
circOnSomeWall :: Point2 -> Float -> World -> Bool
|
||||
{-# INLINE circOnSomeWall #-}
|
||||
circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine)
|
||||
circOnSomeWall p rad = any (uncurry (circOnSeg p rad) . _wlLine)
|
||||
. wlsNearPoint p
|
||||
|
||||
--circOnSomeWall :: Point2 -> Float -> World -> Bool
|
||||
--{-# INLINE circOnSomeWall #-}
|
||||
--circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine)
|
||||
-- . wlsNearPoint p
|
||||
|
||||
circOnAnyCr :: Point2 -> Float -> World -> Bool
|
||||
{-# INLINE circOnAnyCr #-}
|
||||
circOnAnyCr p r w = IS.foldr f False $ crIXsNearPoint p w
|
||||
@@ -226,5 +294,5 @@ anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
|
||||
(w ^? creatures . ix cid)
|
||||
|| bl
|
||||
|
||||
hitWl = collideCircWallsStream sp ep rad $ wlsNearPoint ep w
|
||||
hitWl = collideCircWalls sp ep rad $ wlsNearPoint ep w
|
||||
-- this should probably be wallsOnLine or something
|
||||
|
||||
Reference in New Issue
Block a user