Identify broken wall collisions

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 

src/Dodge/Data.hs

@@ -638,6 +638,7 @@ data Wall = Wall
     , _wlDraw       :: Bool
     , _wlRotateTo   :: Bool
     , _wlStructure  :: WallStructure
+    , _wlHeight     :: Float
     }
 data Opacity
     = SeeThrough

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

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]

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)
+mvBullet :: World -> Particle -> (World, Maybe Particle)
-mvGenBullet w bt 
+mvBullet w bt 
-    | t <= 0 = (w, Nothing)
+    | t <= 0 = wAnd Nothing
-    | t <  4 = (w, Just $ bt
+    | t <  4 = wAnd $ Just $ bt
-                    & btPassThrough' .~ Nothing
+        & btPassThrough' .~ Nothing
-                    & btTrail' .~ (p:p:ps)
+        & btTrail' .~ (p:p:ps)
-                    & btTimer' -~ 1                      
+        & 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

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]

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
         }
 
 

src/Dodge/Room/Corridor.hs

@@ -32,9 +32,13 @@ corridor = defaultRoom
 keyholeCorridor :: Room
 keyholeCorridor = corridor
     { _rmPath  = []
-    , _rmPmnts = [ lowWall $ rectNSEW 50 30 0 15
+    , _rmPmnts = 
-        , lowWall $ rectNSEW 50 30 25 40]
+        [ midWall $ rectNSEW top bot 0  15
+        , midWall $ rectNSEW top bot 25 40]
     }
+  where
+    top = 55
+    bot = 25
     
 corridorN :: Room
 corridorN = defaultRoom

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)
         ]
     }

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)
+    ncor <- state $ randomR (1,3)
-    return $ ([Left $ rezBox rcol,Left door] ++ replicate ncor (Left corridor)
+    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
 

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]

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 

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