Remove wall corner collision test for creatures

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

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)
+collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collidePointAnyWalls p1 p2 
+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

@@ -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

@@ -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 pa pax p (p +.+ diVec)
-        ,intersectSegLine' pb pbx 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

@@ -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

@@ -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
+--        collideCorners rad wallPoints
-        . collideWalls rad p1 ls 
+         collideWalls rad p1 ls 
-        . checkPushThroughs 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
@@ -44,7 +46,8 @@ collideWalls rad cp1 wls cp2 = case (listToMaybe.mapMaybe (pushOutFromWall rad c
     Nothing -> cp2
     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

@@ -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

@@ -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
+intersectSegLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
-{-# INLINE intersectSegLine' #-}
+{-# INLINE intersectSegLine #-}
-intersectSegLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
+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

@@ -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)
+        currentProgram $= Just (_shadProg lcShad)
-        uniform (head $  _shadUnis $ lcShad)
+        uniform (head $  _shadUnis lcShad)
             $= Vector3 x y z
         bindVertexArrayObject $= Just (_vao $ _shadVAO lcShad)
         glDrawElements

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))
+--    MP.bindM3 (\a b c -> return (a,b,c))
-        (VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) )
+--        (VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) )
-        (UV.foldM (pokeTopPrismIndex nv iptr)      ni  (memoTopPrismIndices     V.! (size - 2)) )
+--        (UV.foldM (pokeTopPrismIndex nv iptr)      ni  (memoTopPrismIndices     V.! (size - 2)) )
-        (UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) )
+--        (UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) )
---    ni'  <- UV.foldM (pokeTopPrismIndex nv iptr)      ni  (memoTopPrismIndices     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))
+    nei' <- UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2))
---    nv'  <- VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs)
+    nv'  <- VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs)
---    return (nv',ni',nei')
+    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