More streaming refactoring
This commit is contained in:
+44
-151
@@ -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
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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')
|
||||||
|
|
||||||
|
|||||||
@@ -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
@@ -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
|
||||||
|
|||||||
Reference in New Issue
Block a user