From b1a49bbdc3a2277ea6e63c1ac70f7bff79f22f14 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 19 Nov 2021 00:35:04 +0000 Subject: [PATCH] Identify broken wall collisions --- src/Dodge/Base.hs | 6 ++++ src/Dodge/Data.hs | 1 + src/Dodge/Default/Wall.hs | 1 + src/Dodge/Particle/Bullet/Spawn.hs | 8 ++--- src/Dodge/Particle/Bullet/Update.hs | 21 +++++++----- src/Dodge/Particle/Spark.hs | 2 +- src/Dodge/Placement/Instance/Wall.hs | 17 ++++++++-- src/Dodge/Room/Corridor.hs | 8 +++-- src/Dodge/Room/RoadBlock.hs | 2 +- src/Dodge/Room/Start.hs | 13 ++++++-- src/Dodge/WorldEvent.hs | 2 +- src/Dodge/WorldEvent/ThingsHit.hs | 49 +++++++++++++++++++++++++++- src/Geometry.hs | 6 +++- 13 files changed, 112 insertions(+), 24 deletions(-) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 91794f2e6..1047b92da 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -68,6 +68,12 @@ wallsOnLine p1 p2 ws = hitWalls hitPoint w = uncurry (intersectSegSeg p1 p2) (_wlLine w) hitWalls = filter (isJust . hitPoint) (IM.elems ws) +wallsOnLine3D :: Point3 -> Point3 -> IM.IntMap Wall -> [Wall] +wallsOnLine3D = undefined +-- where +-- hitPoint w = uncurry (intersectSegSeg p1 p2) (_wlLine w) +-- hitWalls = filter (isJust . hitPoint) (IM.elems ws) + wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall wallsOnCirc p r = IM.filter f where diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index e6eb83bf4..b1b78fef5 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -638,6 +638,7 @@ data Wall = Wall , _wlDraw :: Bool , _wlRotateTo :: Bool , _wlStructure :: WallStructure + , _wlHeight :: Float } data Opacity = SeeThrough diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index 0c8be1c90..7558e5e05 100644 --- a/src/Dodge/Default/Wall.hs +++ b/src/Dodge/Default/Wall.hs @@ -18,6 +18,7 @@ defaultWall = Wall , _wlRotateTo = True , _wlStructure = StandaloneWall , _wlWalkable = False + , _wlHeight = 100 } {- Indestructible see-through wall. -} defaultCrystalWall :: Wall diff --git a/src/Dodge/Particle/Bullet/Spawn.hs b/src/Dodge/Particle/Bullet/Spawn.hs index 432c9db24..d24a3c60c 100644 --- a/src/Dodge/Particle/Bullet/Spawn.hs +++ b/src/Dodge/Particle/Bullet/Spawn.hs @@ -21,7 +21,7 @@ aGenBulAt -> Particle aGenBulAt maycid pos vel hiteff width = BulletPt { _ptDraw = drawBul - , _ptUpdate = mvGenBullet + , _ptUpdate = mvBullet , _btVel' = vel , _btColor' = V4 2 2 2 2 , _btTrail' = [pos] @@ -40,7 +40,7 @@ aDelayedBulAt -> Particle aDelayedBulAt vfact maycid pos vel hiteff width = BulletPt { _ptDraw = drawBul - , _ptUpdate = \w -> resetVel . mvGenBullet w + , _ptUpdate = \w -> resetVel . mvBullet w , _btVel' = vfact *.* vel , _btColor' = V4 2 2 2 2 , _btTrail' = [pos] @@ -50,7 +50,7 @@ aDelayedBulAt vfact maycid pos vel hiteff width = BulletPt , _btHitEffect' = hiteff } where - resetVel = second $ fmap $ (ptUpdate .~ mvGenBullet) . (btVel' .~ vel) + resetVel = second $ fmap $ (ptUpdate .~ mvBullet) . (btVel' .~ vel) aCurveBulAt :: Maybe Int -- ^ Pass-through creature id @@ -63,7 +63,7 @@ aCurveBulAt -> Particle aCurveBulAt maycid col pos control targ hiteff width = BulletPt { _ptDraw = drawBul - , _ptUpdate = \w -> mvGenBullet w . setVel + , _ptUpdate = \w -> mvBullet w . setVel , _btVel' = V2 0 0 , _btColor' = col , _btTrail' = [pos] diff --git a/src/Dodge/Particle/Bullet/Update.hs b/src/Dodge/Particle/Bullet/Update.hs index f093dedd8..a1797f191 100644 --- a/src/Dodge/Particle/Bullet/Update.hs +++ b/src/Dodge/Particle/Bullet/Update.hs @@ -1,27 +1,30 @@ +{-# LANGUAGE TupleSections #-} {- Bullet update. -} module Dodge.Particle.Bullet.Update - ( mvGenBullet + ( mvBullet ) where import Dodge.Data --import Dodge.Base import Dodge.WorldEvent.ThingsHit --import Picture import Geometry +--import Geometry.Vector3D import Control.Lens {- Update for a generic bullet. -} -mvGenBullet :: World -> Particle -> (World, Maybe Particle) -mvGenBullet w bt - | t <= 0 = (w, Nothing) - | t < 4 = (w, Just $ bt - & btPassThrough' .~ Nothing - & btTrail' .~ (p:p:ps) - & btTimer' -~ 1 - ) +mvBullet :: World -> Particle -> (World, Maybe Particle) +mvBullet w bt + | t <= 0 = wAnd Nothing + | t < 4 = wAnd $ Just $ bt + & btPassThrough' .~ Nothing + & btTrail' .~ (p:p:ps) + & btTimer' -~ 1 +-- | otherwise = hiteff bt (thingsHitExceptCr3D' mcr (addZ 20 p) (addZ 20 (p +.+ vel)) w) w | otherwise = hiteff bt (thingsHitExceptCr mcr p (p +.+ vel) w) w where + wAnd = (w,) mcr = _btPassThrough' bt (p:ps) = _btTrail' bt vel = _btVel' bt diff --git a/src/Dodge/Particle/Spark.hs b/src/Dodge/Particle/Spark.hs index bdfd55ce7..a962ff9b1 100644 --- a/src/Dodge/Particle/Spark.hs +++ b/src/Dodge/Particle/Spark.hs @@ -24,7 +24,7 @@ colSpark' randDir time col pos baseDir w = w dir = a + baseDir spark = BulletPt { _ptDraw = drawBul - , _ptUpdate = mvGenBullet + , _ptUpdate = mvBullet , _btVel' = rotateV dir (V2 5 0) , _btColor' = col , _btTrail' = [pos] diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index 65d6c6d38..d2955de7c 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -9,14 +9,27 @@ import Color import Data.List import Control.Lens -lowWall :: [Point2] -> Placement -lowWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 30 ps) + +heightWall :: Float -> [Point2] -> Placement +heightWall h ps = ps0j (PutForeground . colorSH col $ upperPrismPoly h ps) $ sps0 $ PutWall ps theWall where col = _wlColor defaultWall theWall = defaultWall { _wlOpacity = SeeAbove , _wlDraw = False + , _wlHeight = h + } + +midWall :: [Point2] -> Placement +midWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 50 ps) + $ sps0 $ PutWall ps theWall + where + col = _wlColor defaultWall + theWall = defaultWall + { _wlOpacity = SeeAbove + , _wlDraw = False + , _wlHeight = 50 } diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index 56ea6a685..ba2fa7a07 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -32,9 +32,13 @@ corridor = defaultRoom keyholeCorridor :: Room keyholeCorridor = corridor { _rmPath = [] - , _rmPmnts = [ lowWall $ rectNSEW 50 30 0 15 - , lowWall $ rectNSEW 50 30 25 40] + , _rmPmnts = + [ midWall $ rectNSEW top bot 0 15 + , midWall $ rectNSEW top bot 25 40] } + where + top = 55 + bot = 25 corridorN :: Room corridorN = defaultRoom diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index 172a6354f..9598aa412 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -98,7 +98,7 @@ lasTunnel = defaultRoom , _rmBound = polys , _rmLinks = [(V2 20 190,1.5* pi),(V2 0 20,0.5* pi)] , _rmPmnts = [putLasTurret & plSpot .~ PS (V2 10 240) (1.5*pi) - , lowWall (rectNSEW 65 40 0 25) + , midWall (rectNSEW 65 40 0 25) , mntLS vShape (V2 50 10) (V3 40 20 50) ] } diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 99f3e7ba5..47b4ef6ca 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -16,6 +16,8 @@ import Dodge.Room.RoadBlock import Dodge.Placement.Instance import Dodge.Layout.Tree.Polymorphic import Dodge.Item.Random +import Dodge.Item.Weapon.BulletGuns +import Dodge.Item.Weapon.Utility --import Dodge.LevelGen.Data import Geometry.Data import Padding @@ -31,8 +33,15 @@ import System.Random minigunfakeout :: RandomGen g => State g (Tree (Either Room Room)) minigunfakeout = do rcol <- rezColor - ncor <- state $ randomR (1,5) - return $ ([Left $ rezBox rcol,Left door] ++ replicate ncor (Left corridor) + ncor <- state $ randomR (1,3) + roomwithmini <- randomiseAllLinks $ roomRectAutoLinks 150 150 + & rmPmnts %~ ([plRRpt 0 (PutFlIt miniGun),plRRpt 0 (PutFlIt shrinkGun)]++) + return $ ([Left $ rezBox rcol + ,Left door + ,Left roomwithmini + ,Left door + ] + ++ replicate ncor (Left corridor) ++ [Left keyholeCorridor,Left corridor]) `treeFromPost` Right door diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs index b17bccdd8..7a87d728c 100644 --- a/src/Dodge/WorldEvent.hs +++ b/src/Dodge/WorldEvent.hs @@ -32,7 +32,7 @@ createBarrelSpark pos dir maycid time colid w where spark = BulletPt { _ptDraw = drawBul - , _ptUpdate = mvGenBullet + , _ptUpdate = mvBullet , _btVel' = rotateV dir (V2 5 0) , _btColor' = numColor colid , _btTrail' = [pos] diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 386b49182..16662d871 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -6,6 +6,7 @@ module Dodge.WorldEvent.ThingsHit , thingHit , thingsHitLongLine , thingsHitExceptCr + , thingsHitExceptCr3D' , thingsHitExceptCrLongLine ) where @@ -13,12 +14,14 @@ import Dodge.Data import Dodge.Base import Dodge.Zone import Geometry +import Geometry.Vector3D import qualified Data.IntMap.Strict as IM import Data.List import Data.Maybe +import Data.Bifunctor {- List those objects that appear on a line. -} -thingsHit +thingsHit :: Point2 -- ^ Line start point -> Point2 -- ^ Line end point -> World @@ -41,8 +44,52 @@ thingsHit sp ep w _ -> IM.empty wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls) hitPoint w' = uncurry (intersectSegSeg sp ep) (_wlLine w') +{- List those objects that appear on a line. -} +thingsHit3D + :: Point3 -- ^ Line start point + -> Point3 -- ^ Line end point + -> World + -> [(Point3, Either Creature Wall)] +thingsHit3D sp ep w + | sp == ep = [] + | otherwise = sortOn (dist3 sp . fst) (crs ++ wls) + where + hitCrs = IM.elems + $ IM.filter (\cr -> circOnSeg (stripZ sp) (stripZ ep) (_crPos cr) (_crRad cr)) + $ _creatures w + crPs = map (\cr -> ssaTriPoint (stripZ ep) (_crPos cr) (stripZ sp) (_crRad cr)) hitCrs + crs = zip (map (addZ 20) crPs) (map Left hitCrs) + hitWls = wallsOnLine (stripZ sp) (stripZ ep) + (IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] + , b<-[y-1,y,y+1]]) + (x,y) = zoneOfPoint (0.5 *.* (stripZ sp +.+ stripZ ep)) + f i m = case IM.lookup i m of + Just val -> val + _ -> IM.empty + wls = zip (map (addZ 20 . fromJust . hitPoint) hitWls) (map Right hitWls) + hitPoint w' = uncurry (intersectSegSeg (stripZ sp) (stripZ ep)) (_wlLine w') thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall) thingHit sp ep = listToMaybe . thingsHit sp ep +thingsHitExceptCr3D' + :: Maybe Int -- ^ A possible creature ID + -> Point3 -- ^ Line start point + -> Point3 -- ^ Line end point + -> World + -> [(Point2, Either Creature Wall)] +thingsHitExceptCr3D' mcid sp ep = fmap (first stripZ) . thingsHitExceptCr3D mcid sp ep +{- List objects that appear on a line. +Can filter out a creature. -} +thingsHitExceptCr3D + :: Maybe Int -- ^ A possible creature ID + -> Point3 -- ^ Line start point + -> Point3 -- ^ Line end point + -> World + -> [(Point3, Either Creature Wall)] +thingsHitExceptCr3D Nothing sp ep = thingsHit3D sp ep +thingsHitExceptCr3D (Just cid) sp ep = filter crNotCid . thingsHit3D sp ep + where + crNotCid (_,Left cr) = _crID cr /= cid + crNotCid _ = True {- List objects that appear on a line. Can filter out a creature. -} thingsHitExceptCr diff --git a/src/Geometry.hs b/src/Geometry.hs index abe84bdad..d2b32d08e 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -184,12 +184,16 @@ circOnSegNoEndpoints !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < -- the distance to the endpoints of the segment. circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool {-# INLINE circOnSeg #-} -circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad +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)) isJustTrue (Just True) = True isJustTrue _ = False +cylinderOnSeg :: Point3 -> Point3 -> Point3 -> Float -> Bool +{-# INLINE cylinderOnSeg #-} +cylinderOnSeg = undefined -- | Find the difference between two Nums. difference :: (Ord a, Num a) => a -> a -> a difference x y