justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Various performance improvements

Browse Source
This commit is contained in:
justin
2021-09-23 15:27:37 +01:00
parent 7b6904b51f
commit 85edd98d62
17 changed files with 137 additions and 81 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+39 -8
View File
@@ -16,6 +16,7 @@ import FoldableHelp
import Control.Lens
import qualified Control.Foldl as L
import Data.Monoid
import Data.Maybe
--import Data.Bifunctor
--import qualified Data.IntSet as IS
@@ -213,22 +214,52 @@ overlapCircWallsReturnWall p rad
where
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.
-- 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 f
-- note that the "intersection" point is the center of the circle flush against the wall
collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
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
(( \(x:y:_) -> fmap
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
. (+.+ normalizeV (vNormal (x -.- y)))
)
(intersectSegSeg p1 p2 x y)
)
. shiftByRad . _wlLine
) ws
where
f (a,_) = magV (p1 -.- a)
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
[a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
@@ -356,7 +387,7 @@ nearestCrInTri
-> World -> Maybe Creature
nearestCrInTri p dir x w
= safeMinimumOn (dist p . _crPos)
$ IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
$ IM.filter (\cr -> pointInPolygon (_crPos cr) tri) $ _creatures w
where
tri =
[p
@@ -373,7 +404,7 @@ nearestCrInFront
-> World -> Maybe Creature
nearestCrInFront p dir x w
= safeMinimumOn (dist p . _crPos)
$ IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
$ IM.filter (\cr -> pointInPolygon (_crPos cr) rec) $ _creatures w
where
rec = [p, pR, pR1, pL1, pL ]
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)
{- | Test whether a creature is in a polygon. -}
crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr = errorPointInPolygon 3 (_crPos cr)
crInPolygon cr = pointInPolygon (_crPos cr)
{- | Transform coordinates from world position to screen coordinates. -}
worldPosToScreenNorm :: World -> Point2 -> Point2
src/Dodge/Base/Collide.hs
+41 -6
View File
@@ -90,17 +90,50 @@ collideDirectionIndirect d p1 p2 wls
where
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
{-# 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.prefilter (not . _wlIsSeeThrough)
. L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine)
$ 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.
- 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
Nothing -> True
-- the reason for using the dashed version is the hope that this will short
-- circuit
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
Nothing -> True
src/Dodge/Creature/Picture.hs
+3 -4
View File
@@ -51,11 +51,10 @@ basicCrShape
-> Creature
-> Shape
basicCrShape col cr = tr $ mconcat
[ rotdir $ _spShape $ drawEquipment cr
, translateSHz 25 . dm . rotdir $ scalp cr
[ rotdir . _spShape $ drawEquipment cr
, rotdir . dm . translateSHz 25 $ scalp cr
, rotdir . dm $ upperBody col cr
, dm . rotmdir $ feet cr
, dm . rotdir $ upperBody col cr
, rotdir $ _spShape $ drawEquipment cr
]
where
dm = damageModSH cr
src/Dodge/Default/World.hs
+1 -1
View File
@@ -101,4 +101,4 @@ youLight =
,_tlsTime = 0
}
where
f (V2 x y) = V3 x y 10
f (V2 x y) = V3 x y 100
src/Dodge/Item/Weapon.hs
+2 -2
View File
@@ -802,7 +802,7 @@ moveRemoteBomb itid time pID w
-- this is hacky, should use a version of collidePointWalls' that collides
-- circles and walls
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
setV v = set (projectiles . ix pID . pjVel) v
updateV = maybe id (setV . snd) hitWl
@@ -978,7 +978,7 @@ moveRemoteShell cid itid pj w
(frict,g) = randomR (0.6,0.9) $ _randGen w
(sparkD,_) = randomR (-0.5,0.5) $ _randGen 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
r1 = _randGen w & evalState (randInCirc 10)
smokeGen = shellTrailCloud $ addZ 20 $ oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)
src/Dodge/Item/Weapon/Grenade.hs
+1 -1
View File
@@ -45,7 +45,7 @@ moveGrenade time dir pID w = case hitWl of
pj = _projectiles w IM.! pID
oldPos = _pjPos pj
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
setV v = set (projectiles .ix pID.pjVel) v
updateV = maybe id (setV . snd) hitWl
src/Dodge/Item/Weapon/Launcher.hs
+1 -1
View File
@@ -179,7 +179,7 @@ moveShell pj w
projectileExplosion = _pjPayload pj
newPos = oldPos +.+ vel
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
reduceSpinBy :: Float -> Projectile -> World -> World
src/Dodge/Item/Weapon/TriggerType.hs
+1 -1
View File
@@ -317,7 +317,7 @@ withMuzFlareI f it cr w =
$ f it cr w
where
--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,
- rotation amount given by wpSpread -}
randSpreadDir :: ChainEffect
src/Dodge/LightSources.hs
+3 -3
View File
@@ -42,10 +42,10 @@ tLight
:: Int
-> Float -- ^ maximal radius
-> Point3
-> Point2
-> Point3
-> TempLightSource
tLight t rmax col (V2 x y) = TLS
{ _tlsPos = V3 x y 1
tLight t rmax col (V3 x y z) = TLS
{ _tlsPos = V3 x y z
, _tlsRad = rmax
, _tlsIntensity = col
, _tlsUpdate = upF
src/Dodge/Render/HUD.hs
+13 -9
View File
@@ -34,7 +34,8 @@ hudDrawings w = pictures
drawInventory :: World -> Picture
drawInventory w = displayInv 0 w `appendPic` subInventoryDisplay w
drawInventory w = subInventoryDisplay w
`appendPic` displayInv 0 w
subInventoryDisplay :: World -> Picture
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
renderItemMapAt :: Float -> Float -> World -> IM.IntMap Item -> Picture
--{-# INLINE renderItemMapAt #-}
{-# INLINE renderItemMapAt #-}
renderItemMapAt tx ty w = concatMapPic (uncurry $ listItemAt tx ty w) . IM.toList
displayInv :: Int -> World -> Picture
@@ -187,19 +188,22 @@ listItemAt
-> Int -- ^ y offset (discrete)
-> Item -- ^ The item
-> Picture
--{-# INLINE listItemAt #-}
listItemAt xoff yoff w yint item
{-# INLINE listItemAt #-}
listItemAt xoff yoff w yint
= winScale w
. translate (xoff + 15 - hw) (yoff + hh - (20 * (fromIntegral yint+1)))
. scale 0.1 0.1
. dShadCol col
$ text s
. itemText
where
hw = halfWidth w
hh = halfHeight w
(s,col) = case item of
NoItem -> ("----", greyN 0.5)
_ -> (_itInvDisplay item item , _itInvColor item)
itemText :: Item -> Picture
{-# 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
:: Float -- ^ Width
src/Dodge/Render/Picture.hs
+6 -5
View File
@@ -32,7 +32,6 @@ worldPictures w = pictures
,concatMapPic (dbArg _ptDraw) $ _particles w
,testPic w
,concatMapPic (_spPicture . floorItemSPic) $ _floorItems w
,concatMapPic (crDraw w) $ _creatures w
,concatMapPic clDraw $ _clouds w
,concatMapPic ppDraw $ _pressPlates 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
-- towards the center of sight
lineOnScreenCone :: World -> Point2 -> Point2 -> Bool
lineOnScreenCone w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
lineOnScreenCone w p1 p2 = pointInPolygon p1 sp
|| pointInPolygon p2 sp
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where
sp' = screenPolygon w
vp = _cameraViewFrom w
@@ -160,8 +160,9 @@ lineOnScreenCone w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
lineOnScreen :: World -> Point2 -> Point2 -> Bool
lineOnScreen w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
lineOnScreen w p1 p2 = pointInPolygon p1 sp
|| pointInPolygon p2 sp
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where
sp = screenPolygon w
sps = zip sp (tail sp ++ [head sp])
src/Dodge/Update.hs
+2 -1
View File
@@ -199,7 +199,8 @@ updateCloud w c
oldPos2 = stripZ oldPos
newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
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
finalVel = addZ nvz $ maybe newVel2 snd hitWl
src/Dodge/Update/Camera.hs
+12 -30
View File
@@ -26,7 +26,7 @@ import qualified Data.IntMap.Strict as IM
import qualified SDL
--import Data.Monoid
--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 where your avatar's view is from. -}
updateCamera :: World -> World
@@ -163,46 +163,28 @@ autoZoomCam w = over cameraZoom changeZoom w
theScopeZoom = fromMaybe 1 $ yourItem w ^? itAttachment . scopeZoom
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
findMax curMax pout = max curMax $ dist p $ collidePointUpToIndirectMinDist p pout curMax wos
hw = halfWidth w
hh = halfHeight w
winFac = min hw hh
vdists = map (flip (collideDirectionIndirect maxViewDistance p) wos)
vps
vps = concatMap _grViewpoints grs
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
wos = wallsOnScreen w
---- | Find the furthest viewable distance from a given point in the world
--farWallDist :: Point2 -> World -> Float
----{-# INLINE farWallDist #-}
--farWallDist cpos w
-- = getMin
-- . uncurry (<>)
-- $ bimap (toScale hw) (toScale hh)
-- $ sconcat
-- $ NEL.map distsMaybeTo viewTestValues
--farWallDist p w = (winFac /) $ fromMaybe maxViewDistance
-- $ L.fold (L.premap (dist p) L.maximum) vdists
-- where
-- wos = wallsOnScreen w
-- camRot = _cameraRot w
-- hw = halfWidth w
-- hh = halfHeight w
-- toScale x = Min . (x /) . (+ 50) . maybe maxViewDistance getMax . getAp
-- distsMaybeTo x = (valueAtWidth x,valueAtHeight x)
-- valueAtHeight h = cpiv (cpos +.+ x) <> cpiv (cpos -.- x)
-- where
-- x = rotateV camRot $ V2 maxViewDistance h
-- cpiv p = Ap $ Max . horSize <$> collidePointIndirect cpos p wos
-- 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]
-- winFac = min hw hh
-- vdists :: [Point2]
-- vdists = map (flip (collidePointUpToIndirect p) wos) vps
-- vps = concatMap _grViewpoints grs
-- grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
-- wos = wallsOnScreen w
maxViewDistance :: Float
maxViewDistance = 800
src/Dodge/WorldEvent.hs
+1 -1
View File
@@ -58,5 +58,5 @@ damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
= over crHP (\hp -> hp - dam) 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 :)
src/Dodge/WorldEvent/ThingsHit.hs
+5 -4
View File
@@ -2,6 +2,11 @@
Find which objects lie upon a line.
-}
module Dodge.WorldEvent.ThingsHit
( thingsHit
, thingsHitLongLine
, thingsHitExceptCr
, thingsHitExceptCrLongLine
)
where
import Dodge.Data
import Dodge.Base
@@ -80,7 +85,3 @@ thingsHitLongLine sp ep w
hitPoint wl = uncurry (intersectSegSeg sp ep) (_wlLine wl)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
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
src/Dodge/Zone.hs
+5 -3
View File
@@ -100,10 +100,13 @@ wallsDoubleScreen w
ys = [y - n .. y + n]
wallsOnScreen :: World -> IM.IntMap Wall
{-# INLINABLE wallsOnScreen #-}
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
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
Just val -> val
_ -> IM.empty
@@ -113,7 +116,6 @@ wallsOnScreen w
xs = [x - n .. x + n]
ys = [y - n .. y + n]
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
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
src/Geometry.hs
+1 -1
View File
@@ -81,7 +81,7 @@ pointInOrOnPolygon _ _ = undefined
-- | Test whether a point is strictly inside a polygon.
-- Supposes the points in the polygon are listed in anticlockwise order.
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
-- | Debug version of 'pointInPolygon'.
errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool