Various performance improvements
This commit is contained in:
+39
-8
@@ -16,6 +16,7 @@ import FoldableHelp
|
|||||||
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import qualified Control.Foldl as L
|
import qualified Control.Foldl as L
|
||||||
|
import Data.Monoid
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
--import Data.Bifunctor
|
--import Data.Bifunctor
|
||||||
--import qualified Data.IntSet as IS
|
--import qualified Data.IntSet as IS
|
||||||
@@ -213,22 +214,52 @@ overlapCircWallsReturnWall p rad
|
|||||||
where
|
where
|
||||||
f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b
|
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.
|
||||||
|
-- note that in this version the circle can overlap the wall
|
||||||
|
collidePointAnyWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||||
|
collidePointAnyWalls p1 p2
|
||||||
|
= getFirst
|
||||||
|
. foldMap (First . findPoint . _wlLine)
|
||||||
|
where
|
||||||
|
findPoint (x,y) = case intersectSegSeg p1 p2 x y of
|
||||||
|
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||||
|
Nothing -> Nothing
|
||||||
|
|
||||||
-- | Looks for first collision of a circle with walls.
|
-- | Looks for first collision of a circle with walls.
|
||||||
-- If found, gives point and reflection velocity, reflection damped in normal.
|
-- If found, gives point and reflection velocity, reflection damped in normal.
|
||||||
collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
-- note that the "intersection" point is the center of the circle flush against the wall
|
||||||
collideCircWalls p1 p2 rad ws
|
collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||||
= safeMinimumOn f
|
collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Left p2)
|
||||||
|
where
|
||||||
|
findPoint wl eip = maybe eip Right $ doReflection (getp eip) $ shiftByRad $ _wlLine wl
|
||||||
|
getp (Left p) = p
|
||||||
|
getp (Right (p,_)) = p
|
||||||
|
doReflection p (x,y) = case intersectSegSeg p1 p x y of
|
||||||
|
Nothing -> Nothing
|
||||||
|
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||||
|
shiftByRad (a,b) =
|
||||||
|
(g $ a +.+ rad *.* normalizeV (a -.-b)
|
||||||
|
,g $ b +.+ rad *.* normalizeV (b -.-a)
|
||||||
|
)
|
||||||
|
where
|
||||||
|
g = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
|
||||||
|
|
||||||
|
-- | 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)
|
||||||
|
collideCircWalls'' p1 p2 rad ws
|
||||||
|
= safeMinimumOn (dist p1 . fst)
|
||||||
$ IM.mapMaybe
|
$ IM.mapMaybe
|
||||||
(( \(x:y:_) -> fmap
|
(( \(x:y:_) -> fmap
|
||||||
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||||
. (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
|
. (+.+ normalizeV (vNormal (x -.- y)))
|
||||||
)
|
)
|
||||||
(intersectSegSeg p1 p2 x y)
|
(intersectSegSeg p1 p2 x y)
|
||||||
)
|
)
|
||||||
. shiftByRad . _wlLine
|
. shiftByRad . _wlLine
|
||||||
) ws
|
) ws
|
||||||
where
|
where
|
||||||
f (a,_) = magV (p1 -.- a)
|
|
||||||
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
|
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
|
||||||
[a +.+ rad *.* normalizeV (a -.-b)
|
[a +.+ rad *.* normalizeV (a -.-b)
|
||||||
,b +.+ rad *.* normalizeV (b -.-a)
|
,b +.+ rad *.* normalizeV (b -.-a)
|
||||||
@@ -356,7 +387,7 @@ nearestCrInTri
|
|||||||
-> World -> Maybe Creature
|
-> World -> Maybe Creature
|
||||||
nearestCrInTri p dir x w
|
nearestCrInTri p dir x w
|
||||||
= safeMinimumOn (dist p . _crPos)
|
= safeMinimumOn (dist p . _crPos)
|
||||||
$ IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
|
$ IM.filter (\cr -> pointInPolygon (_crPos cr) tri) $ _creatures w
|
||||||
where
|
where
|
||||||
tri =
|
tri =
|
||||||
[p
|
[p
|
||||||
@@ -373,7 +404,7 @@ nearestCrInFront
|
|||||||
-> World -> Maybe Creature
|
-> World -> Maybe Creature
|
||||||
nearestCrInFront p dir x w
|
nearestCrInFront p dir x w
|
||||||
= safeMinimumOn (dist p . _crPos)
|
= safeMinimumOn (dist p . _crPos)
|
||||||
$ IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
|
$ IM.filter (\cr -> pointInPolygon (_crPos cr) rec) $ _creatures w
|
||||||
where
|
where
|
||||||
rec = [p, pR, pR1, pL1, pL ]
|
rec = [p, pR, pR1, pL1, pL ]
|
||||||
pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
|
pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
|
||||||
@@ -382,7 +413,7 @@ nearestCrInFront p dir x w
|
|||||||
pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
|
pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
|
||||||
{- | Test whether a creature is in a polygon. -}
|
{- | Test whether a creature is in a polygon. -}
|
||||||
crInPolygon :: Creature -> [Point2] -> Bool
|
crInPolygon :: Creature -> [Point2] -> Bool
|
||||||
crInPolygon cr = errorPointInPolygon 3 (_crPos cr)
|
crInPolygon cr = pointInPolygon (_crPos cr)
|
||||||
|
|
||||||
{- | Transform coordinates from world position to screen coordinates. -}
|
{- | Transform coordinates from world position to screen coordinates. -}
|
||||||
worldPosToScreenNorm :: World -> Point2 -> Point2
|
worldPosToScreenNorm :: World -> Point2 -> Point2
|
||||||
|
|||||||
@@ -90,17 +90,50 @@ collideDirectionIndirect d p1 p2 wls
|
|||||||
where
|
where
|
||||||
p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1)
|
p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1)
|
||||||
|
|
||||||
|
collidePointUpToIndirect
|
||||||
|
:: Point2 -- ^start point
|
||||||
|
-> Point2 -- ^end point
|
||||||
|
-> IM.IntMap Wall
|
||||||
|
-> Point2
|
||||||
|
{-# INLINE collidePointUpToIndirect #-}
|
||||||
|
collidePointUpToIndirect p1 p2 = foldr f p2 . IM.filter (not . _wlIsSeeThrough)
|
||||||
|
where
|
||||||
|
f wl x = fromMaybe x . uncurry (intersectSegSeg p1 x) $ _wlLine wl
|
||||||
|
|
||||||
|
collidePointUpToIndirectMinDist
|
||||||
|
:: Point2 -- ^start point
|
||||||
|
-> Point2 -- ^end point
|
||||||
|
-> Float -- ^minimal possible distance
|
||||||
|
-> IM.IntMap Wall
|
||||||
|
-> Point2
|
||||||
|
{-# INLINE collidePointUpToIndirectMinDist #-}
|
||||||
|
collidePointUpToIndirectMinDist p1 p2 md = ssfold prop f p2 . IM.filter (not . _wlIsSeeThrough)
|
||||||
|
where
|
||||||
|
f x wl = fromMaybe x . uncurry (intersectSegSeg p1 x) $ _wlLine wl
|
||||||
|
prop p3 = dist p1 p3 < md
|
||||||
|
|
||||||
|
-- from haskell-cafe
|
||||||
|
-- short circuit a fold when a given property is satisfied
|
||||||
|
-- the fold builds a function that is then called on a0
|
||||||
|
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
|
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||||
{-# INLINE collidePointIndirect #-}
|
{-# INLINE collidePointIndirect #-}
|
||||||
collidePointIndirect p1 p2
|
collidePointIndirect p1 p2 = test . foldr f p2 . IM.filter (not . _wlIsSeeThrough)
|
||||||
|
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.fold
|
||||||
. L.prefilter (not . _wlIsSeeThrough)
|
. L.prefilter (not . _wlIsSeeThrough)
|
||||||
. L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine)
|
. L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine)
|
||||||
$ L.minimumOn (dist p1)
|
$ L.minimumOn (dist p1)
|
||||||
--collidePointIndirect p1 p2
|
|
||||||
-- = safeMinimumOn (dist p1)
|
|
||||||
-- . IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine)
|
|
||||||
-- . IM.filter (not . _wlIsSeeThrough)
|
|
||||||
|
|
||||||
{- | Checks to see whether someone can fire bullets effectively between two points.
|
{- | 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. -}
|
- Not sure if this needs vision as well, need to make this uniform. -}
|
||||||
@@ -120,8 +153,10 @@ collidePointFireVision p1 p2 ws
|
|||||||
Just _ -> not $ _wlIsSeeThrough wl
|
Just _ -> not $ _wlIsSeeThrough wl
|
||||||
Nothing -> True
|
Nothing -> True
|
||||||
|
|
||||||
|
-- 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 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w of
|
hasLOSIndirect p1 p2 w = case collidePointIndirect' p1 p2 $ wallsAlongLine p1 p2 w of
|
||||||
Just _ -> False
|
Just _ -> False
|
||||||
Nothing -> True
|
Nothing -> True
|
||||||
|
|
||||||
|
|||||||
@@ -51,11 +51,10 @@ basicCrShape
|
|||||||
-> Creature
|
-> Creature
|
||||||
-> Shape
|
-> Shape
|
||||||
basicCrShape col cr = tr $ mconcat
|
basicCrShape col cr = tr $ mconcat
|
||||||
[ rotdir $ _spShape $ drawEquipment cr
|
[ rotdir . _spShape $ drawEquipment cr
|
||||||
, translateSHz 25 . dm . rotdir $ scalp cr
|
, rotdir . dm . translateSHz 25 $ scalp cr
|
||||||
|
, rotdir . dm $ upperBody col cr
|
||||||
, dm . rotmdir $ feet cr
|
, dm . rotmdir $ feet cr
|
||||||
, dm . rotdir $ upperBody col cr
|
|
||||||
, rotdir $ _spShape $ drawEquipment cr
|
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
dm = damageModSH cr
|
dm = damageModSH cr
|
||||||
|
|||||||
@@ -101,4 +101,4 @@ youLight =
|
|||||||
,_tlsTime = 0
|
,_tlsTime = 0
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
f (V2 x y) = V3 x y 10
|
f (V2 x y) = V3 x y 100
|
||||||
|
|||||||
@@ -802,7 +802,7 @@ moveRemoteBomb itid time pID w
|
|||||||
-- this is hacky, should use a version of collidePointWalls' that collides
|
-- this is hacky, should use a version of collidePointWalls' that collides
|
||||||
-- circles and walls
|
-- circles and walls
|
||||||
invShift x = x -.- 5 *.* normalizeV (_pjVel pj)
|
invShift x = x -.- 5 *.* normalizeV (_pjVel pj)
|
||||||
hitWl = collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w
|
hitWl = collideCircWalls'' oldPos newPos 4 $ wallsNearPoint newPos w
|
||||||
finalPos = maybe newPos (invShift . fst) hitWl
|
finalPos = maybe newPos (invShift . fst) hitWl
|
||||||
setV v = set (projectiles . ix pID . pjVel) v
|
setV v = set (projectiles . ix pID . pjVel) v
|
||||||
updateV = maybe id (setV . snd) hitWl
|
updateV = maybe id (setV . snd) hitWl
|
||||||
@@ -978,7 +978,7 @@ moveRemoteShell cid itid pj w
|
|||||||
(frict,g) = randomR (0.6,0.9) $ _randGen w
|
(frict,g) = randomR (0.6,0.9) $ _randGen w
|
||||||
(sparkD,_) = randomR (-0.5,0.5) $ _randGen w
|
(sparkD,_) = randomR (-0.5,0.5) $ _randGen w
|
||||||
hitCr = fst <$> collideCircCrsPoint oldPos newPos 4 w
|
hitCr = fst <$> collideCircCrsPoint oldPos newPos 4 w
|
||||||
hitWl = fst <$> collideCircWalls oldPos newPos 2 (wallsNearPoint newPos w)
|
hitWl = fst <$> collideCircWalls'' oldPos newPos 2 (wallsNearPoint newPos w)
|
||||||
thingHit = hitCr <|> hitWl
|
thingHit = hitCr <|> hitWl
|
||||||
r1 = _randGen w & evalState (randInCirc 10)
|
r1 = _randGen w & evalState (randInCirc 10)
|
||||||
smokeGen = shellTrailCloud $ addZ 20 $ oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)
|
smokeGen = shellTrailCloud $ addZ 20 $ oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)
|
||||||
|
|||||||
@@ -45,7 +45,7 @@ moveGrenade time dir pID w = case hitWl of
|
|||||||
pj = _projectiles w IM.! pID
|
pj = _projectiles w IM.! pID
|
||||||
oldPos = _pjPos pj
|
oldPos = _pjPos pj
|
||||||
newPos = _pjVel pj +.+ oldPos
|
newPos = _pjVel pj +.+ oldPos
|
||||||
hitWl = collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w
|
hitWl = collideCircWalls'' oldPos newPos 4 $ wallsNearPoint newPos w
|
||||||
finalPos = maybe newPos fst hitWl
|
finalPos = maybe newPos fst hitWl
|
||||||
setV v = set (projectiles .ix pID.pjVel) v
|
setV v = set (projectiles .ix pID.pjVel) v
|
||||||
updateV = maybe id (setV . snd) hitWl
|
updateV = maybe id (setV . snd) hitWl
|
||||||
|
|||||||
@@ -179,7 +179,7 @@ moveShell pj w
|
|||||||
projectileExplosion = _pjPayload pj
|
projectileExplosion = _pjPayload pj
|
||||||
newPos = oldPos +.+ vel
|
newPos = oldPos +.+ vel
|
||||||
hitCr = fst <$> collideCircCrsPoint oldPos newPos 4 w
|
hitCr = fst <$> collideCircCrsPoint oldPos newPos 4 w
|
||||||
hitWl = fst <$> collideCircWalls oldPos newPos 2 (wallsNearPoint newPos w)
|
hitWl = fst <$> collideCircWalls'' oldPos newPos 2 (wallsNearPoint newPos w)
|
||||||
thingHit = hitCr <|> hitWl
|
thingHit = hitCr <|> hitWl
|
||||||
|
|
||||||
reduceSpinBy :: Float -> Projectile -> World -> World
|
reduceSpinBy :: Float -> Projectile -> World -> World
|
||||||
|
|||||||
@@ -317,7 +317,7 @@ withMuzFlareI f it cr w =
|
|||||||
$ f it cr w
|
$ f it cr w
|
||||||
where
|
where
|
||||||
--pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
|
--pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
|
||||||
pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
|
pos2 = addZ 35 $ _crPos cr +.+ (2.5 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
|
||||||
{- | Applies the effect to a randomly rotated creature,
|
{- | Applies the effect to a randomly rotated creature,
|
||||||
- rotation amount given by wpSpread -}
|
- rotation amount given by wpSpread -}
|
||||||
randSpreadDir :: ChainEffect
|
randSpreadDir :: ChainEffect
|
||||||
|
|||||||
@@ -42,10 +42,10 @@ tLight
|
|||||||
:: Int
|
:: Int
|
||||||
-> Float -- ^ maximal radius
|
-> Float -- ^ maximal radius
|
||||||
-> Point3
|
-> Point3
|
||||||
-> Point2
|
-> Point3
|
||||||
-> TempLightSource
|
-> TempLightSource
|
||||||
tLight t rmax col (V2 x y) = TLS
|
tLight t rmax col (V3 x y z) = TLS
|
||||||
{ _tlsPos = V3 x y 1
|
{ _tlsPos = V3 x y z
|
||||||
, _tlsRad = rmax
|
, _tlsRad = rmax
|
||||||
, _tlsIntensity = col
|
, _tlsIntensity = col
|
||||||
, _tlsUpdate = upF
|
, _tlsUpdate = upF
|
||||||
|
|||||||
+13
-9
@@ -34,7 +34,8 @@ hudDrawings w = pictures
|
|||||||
|
|
||||||
|
|
||||||
drawInventory :: World -> Picture
|
drawInventory :: World -> Picture
|
||||||
drawInventory w = displayInv 0 w `appendPic` subInventoryDisplay w
|
drawInventory w = subInventoryDisplay w
|
||||||
|
`appendPic` displayInv 0 w
|
||||||
|
|
||||||
subInventoryDisplay :: World -> Picture
|
subInventoryDisplay :: World -> Picture
|
||||||
subInventoryDisplay w = case _inventoryMode w of
|
subInventoryDisplay w = case _inventoryMode w of
|
||||||
@@ -104,7 +105,7 @@ invHead :: World -> String -> Picture
|
|||||||
invHead w s = winScale w . translate (-130) (halfHeight w - 40) . dShadCol white . scale 0.4 0.4 $ text s
|
invHead w s = winScale w . translate (-130) (halfHeight w - 40) . dShadCol white . scale 0.4 0.4 $ text s
|
||||||
|
|
||||||
renderItemMapAt :: Float -> Float -> World -> IM.IntMap Item -> Picture
|
renderItemMapAt :: Float -> Float -> World -> IM.IntMap Item -> Picture
|
||||||
--{-# INLINE renderItemMapAt #-}
|
{-# INLINE renderItemMapAt #-}
|
||||||
renderItemMapAt tx ty w = concatMapPic (uncurry $ listItemAt tx ty w) . IM.toList
|
renderItemMapAt tx ty w = concatMapPic (uncurry $ listItemAt tx ty w) . IM.toList
|
||||||
|
|
||||||
displayInv :: Int -> World -> Picture
|
displayInv :: Int -> World -> Picture
|
||||||
@@ -187,19 +188,22 @@ listItemAt
|
|||||||
-> Int -- ^ y offset (discrete)
|
-> Int -- ^ y offset (discrete)
|
||||||
-> Item -- ^ The item
|
-> Item -- ^ The item
|
||||||
-> Picture
|
-> Picture
|
||||||
--{-# INLINE listItemAt #-}
|
{-# INLINE listItemAt #-}
|
||||||
listItemAt xoff yoff w yint item
|
listItemAt xoff yoff w yint
|
||||||
= winScale w
|
= winScale w
|
||||||
. translate (xoff + 15 - hw) (yoff + hh - (20 * (fromIntegral yint+1)))
|
. translate (xoff + 15 - hw) (yoff + hh - (20 * (fromIntegral yint+1)))
|
||||||
. scale 0.1 0.1
|
. scale 0.1 0.1
|
||||||
. dShadCol col
|
. itemText
|
||||||
$ text s
|
|
||||||
where
|
where
|
||||||
hw = halfWidth w
|
hw = halfWidth w
|
||||||
hh = halfHeight w
|
hh = halfHeight w
|
||||||
(s,col) = case item of
|
|
||||||
NoItem -> ("----", greyN 0.5)
|
itemText :: Item -> Picture
|
||||||
_ -> (_itInvDisplay item item , _itInvColor item)
|
{-# INLINE itemText #-}
|
||||||
|
--itemText NoItem = dShadCol (greyN 0.5) $ text "----"
|
||||||
|
--itemText it = dShadCol (_itInvColor it) $ text (_itInvDisplay it it)
|
||||||
|
itemText NoItem = text "----"
|
||||||
|
itemText it = color (_itInvColor it) $ text (_itInvDisplay it it)
|
||||||
|
|
||||||
openCursorAt
|
openCursorAt
|
||||||
:: Float -- ^ Width
|
:: Float -- ^ Width
|
||||||
|
|||||||
@@ -32,7 +32,6 @@ worldPictures w = pictures
|
|||||||
,concatMapPic (dbArg _ptDraw) $ _particles w
|
,concatMapPic (dbArg _ptDraw) $ _particles w
|
||||||
,testPic w
|
,testPic w
|
||||||
,concatMapPic (_spPicture . floorItemSPic) $ _floorItems w
|
,concatMapPic (_spPicture . floorItemSPic) $ _floorItems w
|
||||||
,concatMapPic (crDraw w) $ _creatures w
|
|
||||||
,concatMapPic clDraw $ _clouds w
|
,concatMapPic clDraw $ _clouds w
|
||||||
,concatMapPic ppDraw $ _pressPlates w
|
,concatMapPic ppDraw $ _pressPlates w
|
||||||
,concatMapPic btDraw $ _buttons w
|
,concatMapPic btDraw $ _buttons w
|
||||||
@@ -149,8 +148,9 @@ wallShadowsToDraw w
|
|||||||
-- cannot only test if walls are on screen, but also if they are on the cone
|
-- cannot only test if walls are on screen, but also if they are on the cone
|
||||||
-- towards the center of sight
|
-- towards the center of sight
|
||||||
lineOnScreenCone :: World -> Point2 -> Point2 -> Bool
|
lineOnScreenCone :: World -> Point2 -> Point2 -> Bool
|
||||||
lineOnScreenCone w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|
lineOnScreenCone w p1 p2 = pointInPolygon p1 sp
|
||||||
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
|| pointInPolygon p2 sp
|
||||||
|
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
||||||
where
|
where
|
||||||
sp' = screenPolygon w
|
sp' = screenPolygon w
|
||||||
vp = _cameraViewFrom w
|
vp = _cameraViewFrom w
|
||||||
@@ -160,8 +160,9 @@ lineOnScreenCone w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
|
|||||||
|
|
||||||
|
|
||||||
lineOnScreen :: World -> Point2 -> Point2 -> Bool
|
lineOnScreen :: World -> Point2 -> Point2 -> Bool
|
||||||
lineOnScreen w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|
lineOnScreen w p1 p2 = pointInPolygon p1 sp
|
||||||
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
|| pointInPolygon p2 sp
|
||||||
|
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
||||||
where
|
where
|
||||||
sp = screenPolygon w
|
sp = screenPolygon w
|
||||||
sps = zip sp (tail sp ++ [head sp])
|
sps = zip sp (tail sp ++ [head sp])
|
||||||
|
|||||||
+2
-1
@@ -199,7 +199,8 @@ updateCloud w c
|
|||||||
oldPos2 = stripZ oldPos
|
oldPos2 = stripZ oldPos
|
||||||
newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
|
newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
|
||||||
newPos2 = stripZ newPos
|
newPos2 = stripZ newPos
|
||||||
hitWl = collideCircWalls oldPos2 newPos2 5 $ wallsNearPoint newPos2 w
|
-- the following only tests for the first collision with a wall
|
||||||
|
hitWl = collidePointAnyWalls oldPos2 newPos2 $ wallsNearPoint newPos2 w
|
||||||
finalPos = addZ npz $ maybe newPos2 fst hitWl
|
finalPos = addZ npz $ maybe newPos2 fst hitWl
|
||||||
finalVel = addZ nvz $ maybe newVel2 snd hitWl
|
finalVel = addZ nvz $ maybe newVel2 snd hitWl
|
||||||
|
|
||||||
|
|||||||
+12
-30
@@ -26,7 +26,7 @@ import qualified Data.IntMap.Strict as IM
|
|||||||
import qualified SDL
|
import qualified SDL
|
||||||
--import Data.Monoid
|
--import Data.Monoid
|
||||||
--import Data.Semigroup
|
--import Data.Semigroup
|
||||||
import qualified Control.Foldl as L
|
--import qualified Control.Foldl as L
|
||||||
{- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
|
{- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
|
||||||
update where your avatar's view is from. -}
|
update where your avatar's view is from. -}
|
||||||
updateCamera :: World -> World
|
updateCamera :: World -> World
|
||||||
@@ -163,46 +163,28 @@ autoZoomCam w = over cameraZoom changeZoom w
|
|||||||
theScopeZoom = fromMaybe 1 $ yourItem w ^? itAttachment . scopeZoom
|
theScopeZoom = fromMaybe 1 $ yourItem w ^? itAttachment . scopeZoom
|
||||||
|
|
||||||
farWallDist' :: Point2 -> World -> Float
|
farWallDist' :: Point2 -> World -> Float
|
||||||
farWallDist' p w = (winFac /) $ fromMaybe maxViewDistance $ L.fold L.maximum vdists
|
farWallDist' p w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
|
||||||
where
|
where
|
||||||
|
findMax curMax pout = max curMax $ dist p $ collidePointUpToIndirectMinDist p pout curMax wos
|
||||||
hw = halfWidth w
|
hw = halfWidth w
|
||||||
hh = halfHeight w
|
hh = halfHeight w
|
||||||
winFac = min hw hh
|
winFac = min hw hh
|
||||||
vdists = map (flip (collideDirectionIndirect maxViewDistance p) wos)
|
|
||||||
vps
|
|
||||||
vps = concatMap _grViewpoints grs
|
vps = concatMap _grViewpoints grs
|
||||||
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
|
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
|
||||||
wos = wallsOnScreen w
|
wos = wallsOnScreen w
|
||||||
---- | Find the furthest viewable distance from a given point in the world
|
|
||||||
--farWallDist :: Point2 -> World -> Float
|
--farWallDist :: Point2 -> World -> Float
|
||||||
----{-# INLINE farWallDist #-}
|
--farWallDist p w = (winFac /) $ fromMaybe maxViewDistance
|
||||||
--farWallDist cpos w
|
-- $ L.fold (L.premap (dist p) L.maximum) vdists
|
||||||
-- = getMin
|
|
||||||
-- . uncurry (<>)
|
|
||||||
-- $ bimap (toScale hw) (toScale hh)
|
|
||||||
-- $ sconcat
|
|
||||||
-- $ NEL.map distsMaybeTo viewTestValues
|
|
||||||
-- where
|
-- where
|
||||||
-- wos = wallsOnScreen w
|
|
||||||
-- camRot = _cameraRot w
|
|
||||||
-- hw = halfWidth w
|
-- hw = halfWidth w
|
||||||
-- hh = halfHeight w
|
-- hh = halfHeight w
|
||||||
-- toScale x = Min . (x /) . (+ 50) . maybe maxViewDistance getMax . getAp
|
-- winFac = min hw hh
|
||||||
-- distsMaybeTo x = (valueAtWidth x,valueAtHeight x)
|
-- vdists :: [Point2]
|
||||||
-- valueAtHeight h = cpiv (cpos +.+ x) <> cpiv (cpos -.- x)
|
-- vdists = map (flip (collidePointUpToIndirect p) wos) vps
|
||||||
-- where
|
-- vps = concatMap _grViewpoints grs
|
||||||
-- x = rotateV camRot $ V2 maxViewDistance h
|
-- grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
|
||||||
-- cpiv p = Ap $ Max . horSize <$> collidePointIndirect cpos p wos
|
-- wos = wallsOnScreen w
|
||||||
-- horSize = abs . dotV rv . (-.- cpos)
|
|
||||||
-- rv = rotateV camRot (V2 1 0)
|
|
||||||
-- valueAtWidth h = cpih (cpos +.+ x) <> cpih (cpos -.- x)
|
|
||||||
-- where
|
|
||||||
-- x = rotateV camRot $ V2 h maxViewDistance
|
|
||||||
-- cpih p = Ap $ Max . verSize <$> collidePointIndirect cpos p wos
|
|
||||||
-- verSize = abs . dotV rh . (-.- cpos)
|
|
||||||
-- rh = rotateV camRot (V2 0 1)
|
|
||||||
--viewTestValues :: NEL.NonEmpty Float
|
|
||||||
--viewTestValues = NEL.fromList [-maxViewDistance,negate $ 0.75*maxViewDistance..maxViewDistance]
|
|
||||||
|
|
||||||
maxViewDistance :: Float
|
maxViewDistance :: Float
|
||||||
maxViewDistance = 800
|
maxViewDistance = 800
|
||||||
|
|||||||
@@ -58,5 +58,5 @@ damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
|
|||||||
= over crHP (\hp -> hp - dam) cr
|
= over crHP (\hp -> hp - dam) cr
|
||||||
| otherwise = cr
|
| otherwise = cr
|
||||||
|
|
||||||
makeTLight :: Int -> Float -> Point3 -> Point2 -> World -> World
|
makeTLight :: Int -> Float -> Point3 -> Point3 -> World -> World
|
||||||
makeTLight i rad col p = tempLightSources %~ (tLight i rad col p :)
|
makeTLight i rad col p = tempLightSources %~ (tLight i rad col p :)
|
||||||
|
|||||||
@@ -2,6 +2,11 @@
|
|||||||
Find which objects lie upon a line.
|
Find which objects lie upon a line.
|
||||||
-}
|
-}
|
||||||
module Dodge.WorldEvent.ThingsHit
|
module Dodge.WorldEvent.ThingsHit
|
||||||
|
( thingsHit
|
||||||
|
, thingsHitLongLine
|
||||||
|
, thingsHitExceptCr
|
||||||
|
, thingsHitExceptCrLongLine
|
||||||
|
)
|
||||||
where
|
where
|
||||||
import Dodge.Data
|
import Dodge.Data
|
||||||
import Dodge.Base
|
import Dodge.Base
|
||||||
@@ -80,7 +85,3 @@ thingsHitLongLine sp ep w
|
|||||||
hitPoint wl = uncurry (intersectSegSeg sp ep) (_wlLine wl)
|
hitPoint wl = uncurry (intersectSegSeg sp ep) (_wlLine wl)
|
||||||
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
|
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
|
||||||
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
|
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
|
||||||
|
|
||||||
thingsHitOnPath :: [Point2] -> World -> [ [ ( Point2, Either3 Creature Wall ForceField ) ] ]
|
|
||||||
thingsHitOnPath [] _ = error "tried to find thingsHitOnPath containing no points"
|
|
||||||
thingsHitOnPath ps w = zipWith (\ a b -> thingsHit a b w) ps $ tail ps
|
|
||||||
|
|||||||
+5
-3
@@ -100,10 +100,13 @@ wallsDoubleScreen w
|
|||||||
ys = [y - n .. y + n]
|
ys = [y - n .. y + n]
|
||||||
|
|
||||||
wallsOnScreen :: World -> IM.IntMap Wall
|
wallsOnScreen :: World -> IM.IntMap Wall
|
||||||
|
{-# INLINABLE wallsOnScreen #-}
|
||||||
wallsOnScreen w
|
wallsOnScreen w
|
||||||
= foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
|
-- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
|
||||||
|
= foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
|
||||||
where
|
where
|
||||||
innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
|
--innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
|
||||||
|
innerFold m = foldr (IM.union . \ j -> f j m) IM.empty ys
|
||||||
f i m = case IM.lookup i m of
|
f i m = case IM.lookup i m of
|
||||||
Just val -> val
|
Just val -> val
|
||||||
_ -> IM.empty
|
_ -> IM.empty
|
||||||
@@ -113,7 +116,6 @@ wallsOnScreen w
|
|||||||
xs = [x - n .. x + n]
|
xs = [x - n .. x + n]
|
||||||
ys = [y - n .. y + n]
|
ys = [y - n .. y + n]
|
||||||
|
|
||||||
|
|
||||||
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
|
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
|
||||||
wallsNearZones is w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
|
wallsNearZones is w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
|
||||||
= foldl' (flip $ IM.union . \(a,b) -> f b (f a (_znObjects $ _wallsZone w))) IM.empty is
|
= foldl' (flip $ IM.union . \(a,b) -> f b (f a (_znObjects $ _wallsZone w))) IM.empty is
|
||||||
|
|||||||
+1
-1
@@ -81,7 +81,7 @@ pointInOrOnPolygon _ _ = undefined
|
|||||||
-- | Test whether a point is strictly inside a polygon.
|
-- | Test whether a point is strictly inside a polygon.
|
||||||
-- Supposes the points in the polygon are listed in anticlockwise order.
|
-- Supposes the points in the polygon are listed in anticlockwise order.
|
||||||
pointInPolygon :: Point2 -> [Point2] -> Bool
|
pointInPolygon :: Point2 -> [Point2] -> Bool
|
||||||
pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x])
|
pointInPolygon !p (x:xs) = all (\l -> uncurry isLHS l p) $ zip (x:xs) (xs ++ [x])
|
||||||
pointInPolygon _ [] = False
|
pointInPolygon _ [] = False
|
||||||
-- | Debug version of 'pointInPolygon'.
|
-- | Debug version of 'pointInPolygon'.
|
||||||
errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
|
errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
|
||||||
|
|||||||
Reference in New Issue
Block a user