From 3c2df2542acfd854cd68f4b86df064c56355d470 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 24 Jun 2022 23:37:01 +0100 Subject: [PATCH] More streaming refactoring --- src/Dodge/Base/Collide.hs | 195 ++++++--------------------- src/Dodge/Config/Data.hs | 1 + src/Dodge/Creature/Action.hs | 8 +- src/Dodge/Floor.hs | 13 +- src/Dodge/Item/Equipment/Booster.hs | 3 +- src/Dodge/Item/Weapon/BatteryGuns.hs | 5 +- src/Dodge/Item/Weapon/Shatter.hs | 9 +- src/Dodge/Prop/Moving.hs | 4 +- src/Dodge/Render/ShapePicture.hs | 19 ++- src/Dodge/Update.hs | 37 +++-- 10 files changed, 96 insertions(+), 198 deletions(-) diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index e0503dab2..d85cae2ff 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -3,9 +3,10 @@ module Dodge.Base.Collide ( hasLOS , collidePointWallsWall + , collidePointWallsFilterStream + , reflectPointWallsDamp , hasButtonLOS , reflectPointWalls - , reflectPointWallsDamp , ssfold , collidePointUpToIndirectMinDist , canSeeIndirect @@ -35,6 +36,7 @@ module Dodge.Base.Collide , nearestCrInRad , nearestCrInTri , nearestCrInFront + , allVisibleWalls ) where import Dodge.Data import Dodge.Zone @@ -50,6 +52,7 @@ import qualified FoldlHelp as L import Data.Monoid import Streaming import qualified Streaming.Prelude as S +--import qualified Data.Map.Lazy as M -- note the use of Lazy, the idea being interoperation with Streaming hasLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasLOS #-} @@ -72,13 +75,14 @@ hasButtonLOS p1 p2 = not -- = safeMinimumOn (dist p1 . fst) -- . mapMaybe -- (\(x,y) -> (, (x,y)) <$> intersectSegSeg p1 p2 x y) - -reflectPointWallsDamp :: Float -> Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) -reflectPointWallsDamp x p1 p2 = fmap (f p1 p2) . collidePointWallsWall p1 p2 - where - f a b (p,wl) = ( p +.+ errorNormalizeV 139 (vNormal (uncurry (-.-) $ _wlLine wl)) - , reflVelWallDamp x wl (b-.-a) +reflectPointWallsDamp :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2) +reflectPointWallsDamp t x sp ep w = do + wl <- mwl + return (p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl))) + , reflVelWallDamp x wl (ep -.- sp) ) + where + (p, mwl) = collidePointWallsFilterStream t sp ep w -- | Looks for first collision of a point with walls. -- If found, gives point and wall. @@ -120,38 +124,46 @@ reflectPointWalls p1 p2 -- . _wlLine -- ) ws -- | Test if a point collides with walls -pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool -pointHitsWalls p1 p2 - = any $ isJust . uncurry (intersectSegSeg p1 p2) . _wlLine +-- this COULD be written in terms of collidePointWallsFilterStream, TODO test +-- whether this is actually faster collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> Stream (Of Wall) Identity () -> Bool collidePointTestFilter t sp ep = runIdentity . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine) . S.filter t ---furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 ---furthestPointWalkable p1 p2 ws --- = fromMaybe p2 --- . safeMinimumOn (dist p1) --- $ IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine) ws +collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall) +collidePointWallsFilterStream t sp ep = runIdentity + . S.fold_ findPoint (ep, Nothing) id + . S.filter t + . wallsAlongLineStream sp ep + where + findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl ---collideDirectionIndirect --- :: Float -- ^max distance to look --- -> Point2 -- ^start point --- -> Point2 -- ^point in direction --- -> IM.IntMap Wall --- -> Float ---{-# INLINE collideDirectionIndirect #-} ---collideDirectionIndirect d p1 p2 wls --- = fromMaybe d --- $ --- ( L.fold --- . L.prefilter wlIsOpaque --- . L.premapMaybe (fmap (dist p1) . uncurry (intersectSegSeg p1 p3) . _wlLine) --- ) L.minimum --- wls --- where --- p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1) +--visibleWallWalls' :: Point2 -> Point2 -> World -> M.Map Float Wall +--visibleWallWalls' sp ep = L.purely S.fold L.map . visibleWallWalls sp ep + +--orderStreamOn :: Ord b => (a -> b) -> Stream (Of a) Identity () -> Identity (Of (M.Map b a) ()) +orderStreamOn :: Ord a => (b -> a) -> Stream (Of b) Identity () -> Stream (Of b) Identity () +orderStreamOn f = S.each . runIdentity . L.purely S.fold_ L.map . S.map g + where + g x = (f x,x) + +visibleWallWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity () +visibleWallWalls sp ep = + join + . fmap (S.take 1) + . S.span (not . wlIsOpaque . snd) + . orderStreamOn (dist sp . fst) + . S.mapMaybe f + . wallsAlongLineStream sp ep + where + f wl = uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl) + +allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity () +allVisibleWalls w = concats $ S.subst (flip (visibleWallWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20) + where + vPos = _cameraViewFrom w wlIsOpaque :: Wall -> Bool wlIsOpaque wl = case _wlOpacity wl of @@ -192,40 +204,6 @@ ssfold :: Foldable t => (a -> Bool) -> (a -> b -> a) -> a -> t b -> a {-# INLINABLE ssfold #-} ssfold p f a0 xs = foldr (\x g a -> if p a then a else g (f a x)) id xs a0 ---collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 ---{-# INLINE collidePointIndirect #-} ---collidePointIndirect p1 p2 = test . foldr f p2 . IM.filter wlIsOpaque --- where --- f wl p = fromMaybe p $ uncurry (intersectSegSeg p1 p) $ _wlLine wl --- test p | p == p2 = Nothing --- | otherwise = Just p - -collidePointIndirect' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 -{-# INLINE collidePointIndirect' #-} -collidePointIndirect' p1 p2 - = L.fold - . L.prefilter wlIsOpaque - . L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine) - $ L.minimumOn (dist p1) - ---{- | Checks to see whether someone can fire bullets effectively between two points. --- - Not sure if this needs vision as well, need to make this uniform. -} ---collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 ---collidePointFire p1 p2 ws --- = safeMinimumOn (dist p1) --- . IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine ) --- $ IM.filter (\wl -> not (_wlFireThrough wl) || wlIsOpaque wl) ws ---{- | Checks to see whether someone can fire bullets effectively between two points. --- - Not sure if this needs vision as well, need to make this uniform. -} ---collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool ---collidePointFireVision p1 p2 ws --- = any ( isJust . uncurry (intersectSegSeg p1 p2) . _wlLine) --- $ IM.filter theTest ws --- where --- theTest wl = not (_wlFireThrough wl) || wlIsOpaque wl - --- the reason for using the dashed version is the hope that this will short --- circuit hasLOSIndirect :: Point2 -> Point2 -> World -> Bool hasLOSIndirect p1 p2 = not . collidePointTestFilter wlIsOpaque p1 p2 @@ -242,95 +220,12 @@ canSee i j w = hasLOS p1 p2 w p1 = _crPos (_creatures w IM.! i) p2 = _crPos (_creatures w IM.! j) ---canSeePoint :: Int -> Point2 -> World -> Bool ---canSeePoint i p w = hasLOS p1 p w --- where --- p1 = _crPos (_creatures w IM.! i) - ---pathToPointFireable :: Int -> Point2 -> World -> Bool ---pathToPointFireable i p w --- = not --- . pointHitsWalls (_crPos $ _creatures w IM.! i) p --- $ IM.filter (not . _wlFireThrough ) $ wallsAlongLine p1 p w --- where --- p1 = _crPos (_creatures w IM.! i) - ---canSeePointAll :: Int -> Point2 -> World -> Bool ---canSeePointAll i targPos w --- = all (flip (canSeePoint i) w . (\p -> targPos +.+ radius *.* p) . toV2) [(1,0),(0,1),(-1,0),(0,-1)] --- where --- cr = _creatures w IM.! i --- radius = _crRad cr - ---canSeeAny :: Int -> Int -> World -> Bool ---canSeeAny fromID toID w --- = any (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p) . toV2) [(1,0),(0,1),(-1,0),(0,-1)] --- where --- cr = _creatures w IM.! toID --- cpos = _crPos cr --- radius = _crRad cr - ---canSeeAll :: Int -> Int -> World -> Bool ---canSeeAll fromID toID w --- = all (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p) . toV2) [(1,0),(0,1),(-1,0),(0,-1)] --- where --- cr = _creatures w IM.! toID --- cpos = _crPos cr --- radius = _crRad cr - ---canWalk :: Int -> Int -> World -> Bool ---canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w --- where --- ipos = _crPos (_creatures w IM.! i) --- jpos = _crPos (_creatures w IM.! j) - canSeeIndirect :: Int -> Int -> World -> Bool canSeeIndirect i j w = hasLOSIndirect ipos jpos w where ipos = _crPos (_creatures w IM.! i) jpos = _crPos (_creatures w IM.! j) ---canSeeFire :: Point2 -> Point2 -> World -> Bool ---canSeeFire p p' w = not $ collidePointFireVision p p' $ wallsAlongLine p p' w - ---canSeeFireVision :: Int -> Int -> World -> Bool ---canSeeFireVision i j w = canSeeFire ipos jpos w --- where --- ipos = _crPos (_creatures w IM.! i) --- jpos = _crPos (_creatures w IM.! j) ---{- | Test whether both of the outside lines between two creatures are blocked -} ---canSeeFireVisionAny :: Int -> Int -> World -> Bool ---canSeeFireVisionAny i j w --- = not --- $ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj) --- (wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w) --- && collidePointFireVision (ipos -.- ni) (jpos -.- nj) --- (wallsAlongLine (ipos -.- ni) (jpos -.- nj) w) --- where --- icr = _creatures w IM.! i --- jcr = _creatures w IM.! j --- ipos = _crPos icr --- jpos = _crPos jcr --- n = normalizeV $ vNormal $ ipos -.- jpos --- ni = _crRad icr *.* n --- nj = _crRad jcr *.* n ---{- | Test whether either of the outside lines between two creatures are blocked -} ---canSeeFireVisionAll :: Int -> Int -> World -> Bool ---canSeeFireVisionAll i j w --- = not --- $ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj) --- (wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w) --- || collidePointFireVision (ipos -.- ni) (jpos -.- nj) --- (wallsAlongLine (ipos -.- ni) (jpos -.- nj) w) --- where --- icr = _creatures w IM.! i --- jcr = _creatures w IM.! j --- ipos = _crPos icr --- jpos = _crPos jcr --- n = normalizeV $ vNormal $ ipos -.- jpos --- ni = _crRad icr *.* n --- nj = _crRad jcr *.* n - wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall) wallsOnLineHit p1 p2 = IM.mapMaybe f where @@ -341,8 +236,6 @@ wallsOnCirc p r = IM.filter f where f wl = uncurry circOnSeg (_wlLine wl) p r ---wallNormal :: Wall -> Point2 ---wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine -- | Looks for overlap of a circle with walls. -- If found, gives wall overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index da6fa6124..762e2adc4 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -39,6 +39,7 @@ data DebugBool | Close_shape_culling | Show_bound_box | Bound_box_screen + | Show_wall_search_rays deriving (Generic, Eq,Ord,Bounded, Enum, Show) data ResFactor = FullRes | HalfRes | QuarterRes deriving (Generic, Show, Eq, Ord, Enum, Bounded) diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 06893f09e..32410cc43 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -29,7 +29,7 @@ import Dodge.Creature.Stance.Data import Dodge.WorldEvent.Shockwave import Dodge.Data import Dodge.Base -import Dodge.Zone +--import Dodge.Zone import Dodge.SoundLogic --import Dodge.WorldEvent import Dodge.Inventory @@ -172,7 +172,7 @@ blinkActionFail cr w = w cid = _crID cr p1 = mouseWorldPos w cpos = _crPos cr - p2 = reflectPointWalls cpos p1 $ wallsAlongLine cpos p1 w + p2 = reflectPointWallsDamp (const True) 1 cpos p1 w r = 1.5 * _crRad cr p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2 @@ -193,7 +193,7 @@ blinkAction cr w = w cid = _crID cr p1 = mouseWorldPos w cpos = _crPos cr - p2 = reflectPointWalls cpos p1 $ wallsAlongLine cpos p1 w + p2 = reflectPointWallsDamp (const True) 1 cpos p1 w r = 1.5 * _crRad cr p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2 @@ -215,7 +215,7 @@ unsafeBlinkAction cr w Damage ENTERREMENT 10000 mwp mwp mwp NoDamageEffect where success = fromMaybe True $ do - (_,wl) <- collidePointWallsWall mwp cpos $ wallsAlongLine mwp cpos w + wl <- snd $ collidePointWallsFilterStream (const True) mwp cpos w return (isLHS mwp `uncurry` _wlLine wl) distR = 120 distortionBulge = diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index db364a356..dfdb18a57 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -41,15 +41,16 @@ initialAnoTree :: Annotation initialAnoTree = OnwardList $ intersperse (AnTree corDoor) [ IntAnno $ AnTree . startRoom + , AnRoom $ roomCCrits 10 , AnRoom slowDoorRoom , AnTree firstBreather , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward --- ] --- ---extraAnoList :: [Annotation] ---extraAnoList = ----- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) --- [ AnRoom $ roomCCrits 10 + ] + +extraAnoList :: [Annotation] +extraAnoList = +-- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) + [ AnRoom $ roomCCrits 10 , AnRoom $ roomCCrits 10 , AnTree $ tToBTree "spawners" <$> spawnerRoom , AnRoom pistolerRoom diff --git a/src/Dodge/Item/Equipment/Booster.hs b/src/Dodge/Item/Equipment/Booster.hs index dc569bca5..a73b5eaff 100644 --- a/src/Dodge/Item/Equipment/Booster.hs +++ b/src/Dodge/Item/Equipment/Booster.hs @@ -3,7 +3,6 @@ module Dodge.Item.Equipment.Booster ) where import Dodge.Data import Dodge.Base -import Dodge.Zone import Dodge.Default.Weapon import Geometry import qualified IntMapHelp as IM @@ -27,7 +26,7 @@ boostPoint x cr w = case mayp2 of cpos = _crPos cr r = 1.5 * _crRad cr p1 = cpos +.+ x *.* squashNormalizeV (mouseWorldPos w -.- cpos) - mayp2 = reflectPointWalls cpos p1 $ wallsAlongLine cpos p1 w + mayp2 = reflectPointWallsDamp (const True) 1 cpos p1 w boostSelfL :: Float -- ^ boost amount diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index ad54d5709..a6712c29e 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -36,7 +36,7 @@ import Dodge.Default.Weapon --import Dodge.Item.Attachment --import Dodge.WorldEvent.HelperParticle import Dodge.Base -import Dodge.Zone +--import Dodge.Zone import Geometry import Picture import Shape @@ -447,8 +447,7 @@ aTractorBeam _ cr w = w & plNew props pjID (tractorBeamAt spos outpos dir power) spos = cpos +.+ (_crRad cr + 10) *.* unitVectorAtAngle dir xpos = cpos +.+ 400 *.* unitVectorAtAngle dir dir = _crDir cr - outpos = collidePointWalls' cpos xpos - $ wallsAlongLine cpos xpos w + outpos = fst $ collidePointWallsFilterStream (const True) cpos xpos w power = _attractionPower . _itParams $ _crInv cr IM.! crSel cr tractorBeamAt :: Point2 -> Point2 -> Float -> Point2 -> Prop diff --git a/src/Dodge/Item/Weapon/Shatter.hs b/src/Dodge/Item/Weapon/Shatter.hs index 139001066..8a64b8e32 100644 --- a/src/Dodge/Item/Weapon/Shatter.hs +++ b/src/Dodge/Item/Weapon/Shatter.hs @@ -6,7 +6,7 @@ import Dodge.Wall.Damage --import Dodge.SoundLogic import Dodge.Block.Debris import Dodge.Base.Collide -import Dodge.Zone +--import Dodge.Zone import Dodge.Creature.HandPos --import Dodge.ChainEffect import Dodge.Default.Weapon @@ -24,7 +24,7 @@ import Shape --import Sound.Data import LensHelp -import qualified Data.IntMap.Strict as IM +--import qualified Data.IntMap.Strict as IM shatterGun :: Item shatterGun = defaultWeapon @@ -46,9 +46,8 @@ shatterGunSPic _ = noPic $ colorSH blue $ xa = 1 xb = 9 shootShatter :: Item -> Creature -> World -> World -shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ collidePointWallsWall sp ep - $ IM.filter canshatter - $ wallsAlongLine sp ep w +shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ sequence + $ collidePointWallsFilterStream canshatter sp ep w where canshatter wl = case _wlOpacity wl of Opaque -> True diff --git a/src/Dodge/Prop/Moving.hs b/src/Dodge/Prop/Moving.hs index 44fd68d5e..58b4bece5 100644 --- a/src/Dodge/Prop/Moving.hs +++ b/src/Dodge/Prop/Moving.hs @@ -3,7 +3,7 @@ module Dodge.Prop.Moving , fallSmallBounceDamage , fallSmallBounce ) where -import Dodge.Zone +--import Dodge.Zone import Dodge.Base import Dodge.Data --import Dodge.Damage @@ -58,7 +58,7 @@ fallSmallBounce' w pr velz = _pjVelZ pr vel = _pjVel pr pos = _prPos pr - updateWithVel v = case reflectPointWallsDamp 0.5 pos (pos + v) $ wallsAlongLine pos (pos +v) w of + updateWithVel v = case reflectPointWallsDamp (const True) 0.5 pos (pos + v) w of Nothing -> prPos +~ v Just (p,v') -> (prPos .~ p) . (pjVel .~ v') diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 22aafb689..ad2cb385a 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -22,11 +22,13 @@ import Shape import Picture import Sound.Data import Geometry.ConvexPoly +--import Dodge.Base.Collide import qualified Data.IntMap.Strict as IM -- Lazy? import qualified Data.Map.Strict as M import Control.Lens import Data.Maybe +import qualified Streaming.Prelude as S -- TODO only filter out shapes outside the range of the furthest shown light source worldSPic :: Configuration -> World -> SPic @@ -76,15 +78,24 @@ extraPics cfig w = pictures (_decorations w) <> drawWallIDs cfig w <> drawPathing cfig w <> drawCrInfo cfig w - <> drawBoundingBox cfig w + <> cfigdraw Show_bound_box drawBoundingBox + <> cfigdraw Show_wall_search_rays (const drawWallSearchRays) + where + cfigdraw boption draw + | debugOn boption cfig = draw cfig w + | otherwise = mempty + +drawWallSearchRays :: World -> Picture +drawWallSearchRays w = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls w + where + f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5) + <> line [_cameraViewFrom w, p] testPic :: Configuration -> World -> Picture testPic _ _ = mempty drawBoundingBox :: Configuration -> World -> Picture -drawBoundingBox cfig w - | debugOn Show_bound_box cfig = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x] - | otherwise = mempty +drawBoundingBox cfig w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x] where (x:xs) = cullBox cfig w diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index a76e6ee99..74bb74f09 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -34,6 +34,8 @@ import Control.Applicative --import qualified Data.Set as S --import Data.Monoid --import System.Random +import qualified Streaming.Prelude as S +--import Streaming {- For most menus the only way to change the world is using event handling. -} updateUniverse :: Universe -> Universe @@ -286,19 +288,24 @@ ppEvents :: World -> World ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w -- this is not working correctly, maybe a problem with wallsAlongLine +--updateSeenWalls :: World -> World +--updateSeenWalls w = foldl' markWallSeen w wallsToUpdate +-- where +-- vPos = _cameraViewFrom w +-- wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w) +-- $ nRays 20 updateSeenWalls :: World -> World -updateSeenWalls w = foldl' markWallSeen w wallsToUpdate +updateSeenWalls w = runIdentity $ S.fold_ f w id (S.map (_wlID . snd) $ allVisibleWalls w) where - vPos = _cameraViewFrom w - wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w) - $ nRays 20 --- wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ _walls w) + f w' i = w' & walls . ix i . wlSeen .~ True + +-- wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w) -- $ nRays 20 -markWallSeen :: World -> Wall -> World -markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w } - where - mw wl' = wl' {_wlSeen = True} +--markWallSeen :: World -> Wall -> World +--markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w } +-- where +-- mw wl' = wl' {_wlSeen = True} checkEndGame :: World -> World checkEndGame w = case _deathDelay w of @@ -398,18 +405,6 @@ crCrSpring c1 c2 w overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec massT = _crMass c1 + _crMass c2 -{- Finds the visible walls from a point to another point. -} -visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall] -visibleWalls p1 p2 ws - = takeUntil wlIsOpaque - . map snd - . sortOn (dist p1 . fromJust . fst) - . filter (isJust . fst) - . map f - $ IM.elems ws - where - f wl = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl) - updateDelayedEvents :: World -> World updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents w) in neww & delayedEvents .~ catMaybes newde