From 899cf6ef8193563c8a36ce6c644905b6d1c592a9 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 24 Sep 2021 11:31:08 +0100 Subject: [PATCH] Remove wall corner collision test for creatures --- package.yaml | 4 +-- src/Dodge/Base.hs | 13 ++++++-- src/Dodge/Item/Weapon.hs | 2 +- src/Dodge/Room/Foreground.hs | 10 +++--- src/Dodge/Update.hs | 3 +- src/Dodge/WallCreatureCollisions.hs | 27 ++++++---------- src/Geometry.hs | 4 +-- src/Geometry/Intersect.hs | 6 ++-- src/Render.hs | 4 +-- src/Shader/Poke.hs | 50 ++++++----------------------- 10 files changed, 47 insertions(+), 76 deletions(-) diff --git a/package.yaml b/package.yaml index 6c927b7bf..537d3d1e5 100644 --- a/package.yaml +++ b/package.yaml @@ -68,10 +68,10 @@ executables: - -threaded - -O2 - -rtsopts - - -eventlog + # - -eventlog - -with-rtsopts=+RTS - -with-rtsopts=-N - - -with-rtsopts=-l + #- -with-rtsopts=-l - -flate-dmd-anal - -fno-liberate-case - -fno-state-hack diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index d2b8cfcac..f1dfdf317 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -217,8 +217,8 @@ overlapCircWallsReturnWall p rad -- | 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 +collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) +collidePointAnyWallsReflect p1 p2 = getFirst . foldMap (First . findPoint . _wlLine) where @@ -226,6 +226,15 @@ collidePointAnyWalls p1 p2 Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1)) Nothing -> Nothing +-- | Looks for collision of a point with walls. +-- If found, gives collision point +-- If not found, returns point +collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 +collidePointWalls p1 p2 + = foldr findPoint p2 . fmap _wlLine + where + findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y + -- | Looks for first collision of a circle with walls. -- If found, gives point and reflection velocity, reflection damped in normal. -- note that the "intersection" point is the center of the circle flush against the wall diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 79c29915d..7f5344458 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -165,7 +165,7 @@ teslaGunPic :: SPic teslaGunPic = ( colorSH blue $ upperPrismPoly 5 (rectNESW xb y xa (-y)) - ++ (upperPrismPoly 5 $ rectNESW (-xa) y (-xb) (-y)) + ++ upperPrismPoly 5 (rectNESW (-xa) y (-xb) (-y)) , mempty ) where diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 0351b870d..43b62ca0e 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -42,8 +42,8 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints lhsPoints = divideLineExact d (pa -.- yN) (pb +.+ yN) findDiPoint p = head . sortOn (dist p) $ catMaybes [intersectLineLine' p (p +.+ diVec) pax pbx - ,intersectSegLine' pa pax p (p +.+ diVec) - ,intersectSegLine' pb pbx p (p +.+ diVec) + ,intersectSegLine pa pax p (p +.+ diVec) + ,intersectSegLine pb pbx p (p +.+ diVec) ] yN = d * 0.5 *.* normalizeV (pa -.- pb) @@ -67,7 +67,7 @@ girderZ w x y = setDepth 50 $ color red $ pictures $ yt = y -.- n ps = divideLineExact (w*2) xb yb dia = rotateV (pi/4) n - ps' = map (\p -> intersectSegLine' xt yt p (p +.+ dia)) ps + ps' = map (\p -> intersectSegLine xt yt p (p +.+ dia)) ps ls = catMaybes $ zipWith (fmap . (,)) ps ps' girderV :: Color -> Float -> Point2 -> Point2 -> Picture girderV col w x y = setDepth 50 $ color col $ pictures $ @@ -84,7 +84,7 @@ girderV col w x y = setDepth 50 $ color col $ pictures $ yt = y -.- n ps = divideLineExact (w*2) xb yb (as,_) = evenOddSplit ps - f a = map (\p -> intersectSegLine' xt yt p (p +.+ rotateV a n)) + f a = map (\p -> intersectSegLine xt yt p (p +.+ rotateV a n)) as' = catMaybes $ zipWith (fmap . (,)) as $ f (pi/4) as bs' = catMaybes $ zipWith (fmap . (,)) as $ f (3*pi/4) as girder :: Color -> Float -> Point2 -> Point2 -> Picture @@ -103,7 +103,7 @@ girder col w x y = pictures $ xt = x -.- n yt = y -.- n ps = divideLineExact (w*2) xb yb - ps' = map (\p -> intersectSegLine' xt yt p (p +.+ n)) ps + ps' = map (\p -> intersectSegLine xt yt p (p +.+ n)) ps ls = catMaybes $ zipWith (fmap . (,)) ps ps' diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index a448d1a83..2d723ae49 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -34,7 +34,6 @@ import qualified Data.Map as M import Control.Lens import Data.Monoid import System.Random ---import Data.Bifunctor update :: World -> World update = (frameClock +~ 1) . functionalUpdate @@ -200,7 +199,7 @@ updateCloud w c newPos@(V3 _ _ npz) = oldPos +.+.+ newVel newPos2 = stripZ newPos -- the following only tests for the first collision with a wall - hitWl = collidePointAnyWalls oldPos2 newPos2 $ wallsNearPoint newPos2 w + hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w finalPos = addZ npz $ maybe newPos2 fst hitWl finalVel = addZ nvz $ maybe newVel2 snd hitWl diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index cd7d3d464..eadfd07f5 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -5,6 +5,7 @@ import Dodge.Data.DamageType import Dodge.Creature.State.Data import Dodge.Debug.Flag.Data import Dodge.Zone +import Dodge.Base import Geometry import Data.List @@ -21,15 +22,16 @@ colCrWall w c | noclipIsOn && _crID c == 0 = c -- for noclip | p1 == p2 = pushOrCrush ls c | otherwise = c & crPos %~ - collideCorners rad wallPoints - . collideWalls rad p1 ls - . checkPushThroughs p1 ls +-- collideCorners rad wallPoints + collideWalls rad p1 ls + . flip (collidePointWalls p1) wls -- check push throughs where rad = _crRad c + wallBuffer p1 = _crOldPos c p2 = _crPos c ls = IM.elems $ _wlLine <$> wallsNearPoint p2 w - wallPoints = nub $ concatMap (\(x,y) -> [x,y]) ls + wls = wallsNearPoint p2 w + --wallPoints = map fst ls noclipIsOn = _noClip $ _debugFlags w -- the amount to push creatures out from walls, extra to their radius @@ -40,11 +42,12 @@ wallBuffer = 0 -- out from the wall -- this is then repeated if the point ends up on a new wall collideWalls :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2 -collideWalls rad cp1 wls cp2 = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) wls of +collideWalls rad cp1 wls cp2 = case (listToMaybe . mapMaybe (pushOutFromWall rad cp2)) wls of Nothing -> cp2 - Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) wls of + Just cp3 -> case (listToMaybe . reverse . mapMaybe (pushOutFromWall rad cp3)) wls of Nothing -> cp3 - Just cp4 -> 0.5 *.* (cp4 +.+ cp1) +-- Just cp4 -> 0.5 *.* (cp4 +.+ cp1) + Just _ -> cp1 -- pushes a point out from a list of walls -- if multiple new points occur, chooses the one closest to the orignal point @@ -92,13 +95,3 @@ intersectCirclePoint rad p cCen | dist cCen p > rad = cCen | otherwise = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p)) -checkPushThroughs :: Point2 -> [(Point2,Point2)] -> Point2 -> Point2 -checkPushThroughs cp1 wls cp2 - = fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough cp1 cp2)) wls - -checkPushThrough :: Point2 -> Point2 -> (Point2,Point2) -> Maybe Point2 -checkPushThrough cp1 cp2 (wp1,wp2) - | isPushedThrough = intersectSegSeg cp1 cp2 wp1 wp2 - | otherwise = Nothing - where - isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg cp1 cp2 wp1 wp2) diff --git a/src/Geometry.hs b/src/Geometry.hs index 5477a8a93..10c8189cc 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -169,7 +169,7 @@ circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool {-# INLINE circOnSegNoEndpoints #-} circOnSegNoEndpoints !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) where - y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) + y = intersectSegLine p1 p2 c (c +.+ vNormal (p1 -.- p2)) isJustTrue (Just True) = True isJustTrue _ = False -- | Test whether a circle is on a segment by intersecting a normal and testing @@ -179,7 +179,7 @@ circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) where - y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) + y = intersectSegLine p1 p2 c (c +.+ vNormal (p1 -.- p2)) isJustTrue (Just True) = True isJustTrue _ = False -- | Find the difference between two Nums. diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 97cf88b20..5fe2a526f 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -62,9 +62,9 @@ intersectSegLineext (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) -- | Intersect a segment with a line. -intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 -{-# INLINE intersectSegLine' #-} -intersectSegLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) +intersectSegLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +{-# INLINE intersectSegLine #-} +intersectSegLine (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) | den == 0 = Nothing | den > 0 && (t' < 0 || t' > den) = Nothing diff --git a/src/Render.hs b/src/Render.hs index ec6e9df49..44647eda2 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -75,8 +75,8 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do nullPtr cullFace $= Just Back --draw caps on the near plane as required - currentProgram $= Just (_shadProg $ lcShad) - uniform (head $ _shadUnis $ lcShad) + currentProgram $= Just (_shadProg lcShad) + uniform (head $ _shadUnis lcShad) $= Vector3 x y z bindVertexArrayObject $= Just (_vao $ _shadVAO lcShad) glDrawElements diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 152b261aa..9c47340bf 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -25,7 +25,7 @@ import qualified Data.Vector.Fusion.Stream.Monadic as VS import Control.Monad.Primitive --import Control.Parallel.Strategies --import System.Environment -import Control.Monad.Parallel as MP +--import Control.Monad.Parallel as MP --import Control.Monad --import qualified Data.DList as DL @@ -68,25 +68,22 @@ pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort -> (Int,Int,Int) -> [ShapeV] -> IO (Int,Int,Int) -{-# INLINE pokeTopPrism #-} pokeTopPrism size ptr iptr ieptr (nv,ni,nei) svs = do - MP.bindM3 (\a b c -> return (a,b,c)) - (VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) ) - (UV.foldM (pokeTopPrismIndex nv iptr) ni (memoTopPrismIndices V.! (size - 2)) ) - (UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) ) --- ni' <- UV.foldM (pokeTopPrismIndex nv iptr) ni (memoTopPrismIndices V.! (size - 2)) --- nei' <- UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) --- nv' <- VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) --- return (nv',ni',nei') +-- MP.bindM3 (\a b c -> return (a,b,c)) +-- (VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) ) +-- (UV.foldM (pokeTopPrismIndex nv iptr) ni (memoTopPrismIndices V.! (size - 2)) ) +-- (UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) ) + ni' <- UV.foldM (pokeTopPrismIndex nv iptr) ni (memoTopPrismIndices V.! (size - 2)) + nei' <- UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) + nv' <- VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) + return (nv',ni',nei') pokeTopPrismEdgeIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int -{-# INLINE pokeTopPrismEdgeIndex #-} pokeTopPrismEdgeIndex nv iptr ni ioff = do pokeElemOff iptr ni (fromIntegral $ nv + ioff) return (ni + 1) pokeTopPrismIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int -{-# INLINE pokeTopPrismIndex #-} pokeTopPrismIndex nv iptr ni ioff = do pokeElemOff iptr ni (fromIntegral $ nv + ioff) return (ni + 1) @@ -152,7 +149,7 @@ pokeLayVerxs -> UMV.MVector (PrimState IO) Int -> Picture -> IO () -pokeLayVerxs vbos counts vxs = VS.mapM_ (pokeLayVerx vbos counts) $ VS.fromList vxs +pokeLayVerxs vbos counts = VS.mapM_ (pokeLayVerx vbos counts) . VS.fromList pokeLayVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO () --{-# INLINE pokeLayVerx #-} @@ -198,33 +195,6 @@ pokeArrayOff :: Ptr Float -> Int -> [Float] -> IO () {-# INLINE pokeArrayOff #-} pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i)) ---pokeTwoOff --- :: Ptr Float --- -> Int --- -> (Float,Float) --- -> IO () ---{-# INLINE pokeTwoOff #-} ---pokeTwoOff ptr n (x,y) = do --- pokeElemOff ptr (2*n+0) x --- pokeElemOff ptr (2*n+1) y ---pokeThreeOff --- :: Ptr Float --- -> Int --- -> (Float,Float,Float) --- -> IO () ---{-# INLINE pokeThreeOff #-} ---pokeThreeOff ptr n (x,y,z) = do --- pokeElemOff ptr (3*n+0) x --- pokeElemOff ptr (3*n+1) y --- pokeElemOff ptr (3*n+2) z ---pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO () ---{-# INLINE pokeFourOff #-} ---pokeFourOff ptr n (x,y,z,w) = do --- pokeElemOff ptr (4*n+0) x --- pokeElemOff ptr (4*n+1) y --- pokeElemOff ptr (4*n+2) z --- pokeElemOff ptr (4*n+3) w - pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int pokePoint33s ptr = VS.foldlM' (pokePoint33 ptr) 0 . VS.fromList