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

Remove wall corner collision test for creatures

Browse Source
This commit is contained in:
justin
2021-09-24 11:31:08 +01:00
parent 1883e0785e
commit 899cf6ef81
10 changed files with 47 additions and 76 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
+2 -2
View File
@@ -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
src/Dodge/Base.hs
+11 -2
View File
@@ -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
src/Dodge/Item/Weapon.hs
+1 -1
View File
@@ -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
src/Dodge/Room/Foreground.hs
+5 -5
View File
@@ -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'
src/Dodge/Update.hs
+1 -2
View File
@@ -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
src/Dodge/WallCreatureCollisions.hs
+10 -17
View File
@@ -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)
src/Geometry.hs
+2 -2
View File
@@ -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.
src/Geometry/Intersect.hs
+3 -3
View File
@@ -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
src/Render.hs
+2 -2
View File
@@ -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
src/Shader/Poke.hs
+10 -40
View File
@@ -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