More streaming refactoring

This commit is contained in:
2022-06-24 23:37:01 +01:00
parent 0270d423fd
commit 3c2df2542a
10 changed files with 96 additions and 198 deletions
+44 -151
View File
@@ -3,9 +3,10 @@
module Dodge.Base.Collide module Dodge.Base.Collide
( hasLOS ( hasLOS
, collidePointWallsWall , collidePointWallsWall
, collidePointWallsFilterStream
, reflectPointWallsDamp
, hasButtonLOS , hasButtonLOS
, reflectPointWalls , reflectPointWalls
, reflectPointWallsDamp
, ssfold , ssfold
, collidePointUpToIndirectMinDist , collidePointUpToIndirectMinDist
, canSeeIndirect , canSeeIndirect
@@ -35,6 +36,7 @@ module Dodge.Base.Collide
, nearestCrInRad , nearestCrInRad
, nearestCrInTri , nearestCrInTri
, nearestCrInFront , nearestCrInFront
, allVisibleWalls
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Zone import Dodge.Zone
@@ -50,6 +52,7 @@ import qualified FoldlHelp as L
import Data.Monoid import Data.Monoid
import Streaming import Streaming
import qualified Streaming.Prelude as S 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 hasLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOS #-} {-# INLINE hasLOS #-}
@@ -72,13 +75,14 @@ hasButtonLOS p1 p2 = not
-- = safeMinimumOn (dist p1 . fst) -- = safeMinimumOn (dist p1 . fst)
-- . mapMaybe -- . mapMaybe
-- (\(x,y) -> (, (x,y)) <$> intersectSegSeg p1 p2 x y) -- (\(x,y) -> (, (x,y)) <$> intersectSegSeg p1 p2 x y)
reflectPointWallsDamp :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
reflectPointWallsDamp :: Float -> Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) reflectPointWallsDamp t x sp ep w = do
reflectPointWallsDamp x p1 p2 = fmap (f p1 p2) . collidePointWallsWall p1 p2 wl <- mwl
where return (p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
f a b (p,wl) = ( p +.+ errorNormalizeV 139 (vNormal (uncurry (-.-) $ _wlLine wl)) , reflVelWallDamp x wl (ep -.- sp)
, reflVelWallDamp x wl (b-.-a)
) )
where
(p, mwl) = collidePointWallsFilterStream t sp ep w
-- | Looks for first collision of a point with walls. -- | Looks for first collision of a point with walls.
-- If found, gives point and wall. -- If found, gives point and wall.
@@ -120,38 +124,46 @@ reflectPointWalls p1 p2
-- . _wlLine -- . _wlLine
-- ) ws -- ) ws
-- | Test if a point collides with walls -- | 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 :: (Wall -> Bool) -> Point2 -> Point2 -> Stream (Of Wall) Identity () -> Bool
collidePointTestFilter t sp ep = runIdentity collidePointTestFilter t sp ep = runIdentity
. S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine) . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
. S.filter t . S.filter t
--furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
--furthestPointWalkable p1 p2 ws collidePointWallsFilterStream t sp ep = runIdentity
-- = fromMaybe p2 . S.fold_ findPoint (ep, Nothing) id
-- . safeMinimumOn (dist p1) . S.filter t
-- $ IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine) ws . wallsAlongLineStream sp ep
where
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
--collideDirectionIndirect --visibleWallWalls' :: Point2 -> Point2 -> World -> M.Map Float Wall
-- :: Float -- ^max distance to look --visibleWallWalls' sp ep = L.purely S.fold L.map . visibleWallWalls sp ep
-- -> Point2 -- ^start point
-- -> Point2 -- ^point in direction --orderStreamOn :: Ord b => (a -> b) -> Stream (Of a) Identity () -> Identity (Of (M.Map b a) ())
-- -> IM.IntMap Wall orderStreamOn :: Ord a => (b -> a) -> Stream (Of b) Identity () -> Stream (Of b) Identity ()
-- -> Float orderStreamOn f = S.each . runIdentity . L.purely S.fold_ L.map . S.map g
--{-# INLINE collideDirectionIndirect #-} where
--collideDirectionIndirect d p1 p2 wls g x = (f x,x)
-- = fromMaybe d
-- $ visibleWallWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity ()
-- ( L.fold visibleWallWalls sp ep =
-- . L.prefilter wlIsOpaque join
-- . L.premapMaybe (fmap (dist p1) . uncurry (intersectSegSeg p1 p3) . _wlLine) . fmap (S.take 1)
-- ) L.minimum . S.span (not . wlIsOpaque . snd)
-- wls . orderStreamOn (dist sp . fst)
-- where . S.mapMaybe f
-- p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1) . 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 :: Wall -> Bool
wlIsOpaque wl = case _wlOpacity wl of wlIsOpaque wl = case _wlOpacity wl of
@@ -192,40 +204,6 @@ ssfold :: Foldable t => (a -> Bool) -> (a -> b -> a) -> a -> t b -> a
{-# INLINABLE ssfold #-} {-# INLINABLE ssfold #-}
ssfold p f a0 xs = foldr (\x g a -> if p a then a else g (f a x)) id xs a0 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 :: Point2 -> Point2 -> World -> Bool
hasLOSIndirect p1 p2 = not hasLOSIndirect p1 p2 = not
. collidePointTestFilter wlIsOpaque p1 p2 . collidePointTestFilter wlIsOpaque p1 p2
@@ -242,95 +220,12 @@ canSee i j w = hasLOS p1 p2 w
p1 = _crPos (_creatures w IM.! i) p1 = _crPos (_creatures w IM.! i)
p2 = _crPos (_creatures w IM.! j) 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 :: Int -> Int -> World -> Bool
canSeeIndirect i j w = hasLOSIndirect ipos jpos w canSeeIndirect i j w = hasLOSIndirect ipos jpos w
where where
ipos = _crPos (_creatures w IM.! i) ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j) 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 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
wallsOnLineHit p1 p2 = IM.mapMaybe f wallsOnLineHit p1 p2 = IM.mapMaybe f
where where
@@ -341,8 +236,6 @@ wallsOnCirc p r = IM.filter f
where where
f wl = uncurry circOnSeg (_wlLine wl) p r f wl = uncurry circOnSeg (_wlLine wl) p r
--wallNormal :: Wall -> Point2
--wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine
-- | Looks for overlap of a circle with walls. -- | Looks for overlap of a circle with walls.
-- If found, gives wall -- If found, gives wall
overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall
+1
View File
@@ -39,6 +39,7 @@ data DebugBool
| Close_shape_culling | Close_shape_culling
| Show_bound_box | Show_bound_box
| Bound_box_screen | Bound_box_screen
| Show_wall_search_rays
deriving (Generic, Eq,Ord,Bounded, Enum, Show) deriving (Generic, Eq,Ord,Bounded, Enum, Show)
data ResFactor = FullRes | HalfRes | QuarterRes data ResFactor = FullRes | HalfRes | QuarterRes
deriving (Generic, Show, Eq, Ord, Enum, Bounded) deriving (Generic, Show, Eq, Ord, Enum, Bounded)
+4 -4
View File
@@ -29,7 +29,7 @@ import Dodge.Creature.Stance.Data
import Dodge.WorldEvent.Shockwave import Dodge.WorldEvent.Shockwave
import Dodge.Data import Dodge.Data
import Dodge.Base import Dodge.Base
import Dodge.Zone --import Dodge.Zone
import Dodge.SoundLogic import Dodge.SoundLogic
--import Dodge.WorldEvent --import Dodge.WorldEvent
import Dodge.Inventory import Dodge.Inventory
@@ -172,7 +172,7 @@ blinkActionFail cr w = w
cid = _crID cr cid = _crID cr
p1 = mouseWorldPos w p1 = mouseWorldPos w
cpos = _crPos cr cpos = _crPos cr
p2 = reflectPointWalls cpos p1 $ wallsAlongLine cpos p1 w p2 = reflectPointWallsDamp (const True) 1 cpos p1 w
r = 1.5 * _crRad cr r = 1.5 * _crRad cr
p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2 p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2
@@ -193,7 +193,7 @@ blinkAction cr w = w
cid = _crID cr cid = _crID cr
p1 = mouseWorldPos w p1 = mouseWorldPos w
cpos = _crPos cr cpos = _crPos cr
p2 = reflectPointWalls cpos p1 $ wallsAlongLine cpos p1 w p2 = reflectPointWallsDamp (const True) 1 cpos p1 w
r = 1.5 * _crRad cr r = 1.5 * _crRad cr
p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2 p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2
@@ -215,7 +215,7 @@ unsafeBlinkAction cr w
Damage ENTERREMENT 10000 mwp mwp mwp NoDamageEffect Damage ENTERREMENT 10000 mwp mwp mwp NoDamageEffect
where where
success = fromMaybe True $ do 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) return (isLHS mwp `uncurry` _wlLine wl)
distR = 120 distR = 120
distortionBulge = distortionBulge =
+7 -6
View File
@@ -41,15 +41,16 @@ initialAnoTree :: Annotation
initialAnoTree = OnwardList initialAnoTree = OnwardList
$ intersperse (AnTree corDoor) $ intersperse (AnTree corDoor)
[ IntAnno $ AnTree . startRoom [ IntAnno $ AnTree . startRoom
, AnRoom $ roomCCrits 10
, AnRoom slowDoorRoom , AnRoom slowDoorRoom
, AnTree firstBreather , AnTree firstBreather
, AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
-- ] ]
--
--extraAnoList :: [Annotation] extraAnoList :: [Annotation]
--extraAnoList = extraAnoList =
---- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) -- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
-- [ AnRoom $ roomCCrits 10 [ AnRoom $ roomCCrits 10
, AnRoom $ roomCCrits 10 , AnRoom $ roomCCrits 10
, AnTree $ tToBTree "spawners" <$> spawnerRoom , AnTree $ tToBTree "spawners" <$> spawnerRoom
, AnRoom pistolerRoom , AnRoom pistolerRoom
+1 -2
View File
@@ -3,7 +3,6 @@ module Dodge.Item.Equipment.Booster
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Base import Dodge.Base
import Dodge.Zone
import Dodge.Default.Weapon import Dodge.Default.Weapon
import Geometry import Geometry
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
@@ -27,7 +26,7 @@ boostPoint x cr w = case mayp2 of
cpos = _crPos cr cpos = _crPos cr
r = 1.5 * _crRad cr r = 1.5 * _crRad cr
p1 = cpos +.+ x *.* squashNormalizeV (mouseWorldPos w -.- cpos) p1 = cpos +.+ x *.* squashNormalizeV (mouseWorldPos w -.- cpos)
mayp2 = reflectPointWalls cpos p1 $ wallsAlongLine cpos p1 w mayp2 = reflectPointWallsDamp (const True) 1 cpos p1 w
boostSelfL boostSelfL
:: Float -- ^ boost amount :: Float -- ^ boost amount
+2 -3
View File
@@ -36,7 +36,7 @@ import Dodge.Default.Weapon
--import Dodge.Item.Attachment --import Dodge.Item.Attachment
--import Dodge.WorldEvent.HelperParticle --import Dodge.WorldEvent.HelperParticle
import Dodge.Base import Dodge.Base
import Dodge.Zone --import Dodge.Zone
import Geometry import Geometry
import Picture import Picture
import Shape 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 spos = cpos +.+ (_crRad cr + 10) *.* unitVectorAtAngle dir
xpos = cpos +.+ 400 *.* unitVectorAtAngle dir xpos = cpos +.+ 400 *.* unitVectorAtAngle dir
dir = _crDir cr dir = _crDir cr
outpos = collidePointWalls' cpos xpos outpos = fst $ collidePointWallsFilterStream (const True) cpos xpos w
$ wallsAlongLine cpos xpos w
power = _attractionPower . _itParams $ _crInv cr IM.! crSel cr power = _attractionPower . _itParams $ _crInv cr IM.! crSel cr
tractorBeamAt :: Point2 -> Point2 -> Float -> Point2 -> Prop tractorBeamAt :: Point2 -> Point2 -> Float -> Point2 -> Prop
+4 -5
View File
@@ -6,7 +6,7 @@ import Dodge.Wall.Damage
--import Dodge.SoundLogic --import Dodge.SoundLogic
import Dodge.Block.Debris import Dodge.Block.Debris
import Dodge.Base.Collide import Dodge.Base.Collide
import Dodge.Zone --import Dodge.Zone
import Dodge.Creature.HandPos import Dodge.Creature.HandPos
--import Dodge.ChainEffect --import Dodge.ChainEffect
import Dodge.Default.Weapon import Dodge.Default.Weapon
@@ -24,7 +24,7 @@ import Shape
--import Sound.Data --import Sound.Data
import LensHelp import LensHelp
import qualified Data.IntMap.Strict as IM --import qualified Data.IntMap.Strict as IM
shatterGun :: Item shatterGun :: Item
shatterGun = defaultWeapon shatterGun = defaultWeapon
@@ -46,9 +46,8 @@ shatterGunSPic _ = noPic $ colorSH blue $
xa = 1 xa = 1
xb = 9 xb = 9
shootShatter :: Item -> Creature -> World -> World shootShatter :: Item -> Creature -> World -> World
shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ collidePointWallsWall sp ep shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ sequence
$ IM.filter canshatter $ collidePointWallsFilterStream canshatter sp ep w
$ wallsAlongLine sp ep w
where where
canshatter wl = case _wlOpacity wl of canshatter wl = case _wlOpacity wl of
Opaque -> True Opaque -> True
+2 -2
View File
@@ -3,7 +3,7 @@ module Dodge.Prop.Moving
, fallSmallBounceDamage , fallSmallBounceDamage
, fallSmallBounce , fallSmallBounce
) where ) where
import Dodge.Zone --import Dodge.Zone
import Dodge.Base import Dodge.Base
import Dodge.Data import Dodge.Data
--import Dodge.Damage --import Dodge.Damage
@@ -58,7 +58,7 @@ fallSmallBounce' w pr
velz = _pjVelZ pr velz = _pjVelZ pr
vel = _pjVel pr vel = _pjVel pr
pos = _prPos 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 Nothing -> prPos +~ v
Just (p,v') -> (prPos .~ p) . (pjVel .~ v') Just (p,v') -> (prPos .~ p) . (pjVel .~ v')
+15 -4
View File
@@ -22,11 +22,13 @@ import Shape
import Picture import Picture
import Sound.Data import Sound.Data
import Geometry.ConvexPoly import Geometry.ConvexPoly
--import Dodge.Base.Collide
import qualified Data.IntMap.Strict as IM -- Lazy? import qualified Data.IntMap.Strict as IM -- Lazy?
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Control.Lens import Control.Lens
import Data.Maybe import Data.Maybe
import qualified Streaming.Prelude as S
-- TODO only filter out shapes outside the range of the furthest shown light source -- TODO only filter out shapes outside the range of the furthest shown light source
worldSPic :: Configuration -> World -> SPic worldSPic :: Configuration -> World -> SPic
@@ -76,15 +78,24 @@ extraPics cfig w = pictures (_decorations w)
<> drawWallIDs cfig w <> drawWallIDs cfig w
<> drawPathing cfig w <> drawPathing cfig w
<> drawCrInfo 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 :: Configuration -> World -> Picture
testPic _ _ = mempty testPic _ _ = mempty
drawBoundingBox :: Configuration -> World -> Picture drawBoundingBox :: Configuration -> World -> Picture
drawBoundingBox cfig w drawBoundingBox cfig w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x]
| debugOn Show_bound_box cfig = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x]
| otherwise = mempty
where where
(x:xs) = cullBox cfig w (x:xs) = cullBox cfig w
+16 -21
View File
@@ -34,6 +34,8 @@ import Control.Applicative
--import qualified Data.Set as S --import qualified Data.Set as S
--import Data.Monoid --import Data.Monoid
--import System.Random --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. -} {- For most menus the only way to change the world is using event handling. -}
updateUniverse :: Universe -> Universe updateUniverse :: Universe -> Universe
@@ -286,19 +288,24 @@ ppEvents :: World -> World
ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w
-- this is not working correctly, maybe a problem with wallsAlongLine -- 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 :: World -> World
updateSeenWalls w = foldl' markWallSeen w wallsToUpdate updateSeenWalls w = runIdentity $ S.fold_ f w id (S.map (_wlID . snd) $ allVisibleWalls w)
where where
vPos = _cameraViewFrom w f w' i = w' & walls . ix i . wlSeen .~ True
wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
$ nRays 20 -- wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
-- wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ _walls w)
-- $ nRays 20 -- $ nRays 20
markWallSeen :: World -> Wall -> World --markWallSeen :: World -> Wall -> World
markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w } --markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w }
where -- where
mw wl' = wl' {_wlSeen = True} -- mw wl' = wl' {_wlSeen = True}
checkEndGame :: World -> World checkEndGame :: World -> World
checkEndGame w = case _deathDelay w of 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 overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
massT = _crMass c1 + _crMass c2 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 :: World -> World
updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents w) updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents w)
in neww & delayedEvents .~ catMaybes newde in neww & delayedEvents .~ catMaybes newde