Tweak gibs

src/Dodge/Base.hs

@@ -283,12 +283,6 @@ collideCircWalls p1 p2 rad
 --  where 
 --    f (a,_) = magV (p1 -.- a)
 --
--- | Looks for first collision of a point with walls.
--- If found, gives point and wall.
-collidePointWallsWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Wall)
-collidePointWallsWall p1 p2 
-    = safeMinimumOn (dist p1 . fst)
-    . IM.mapMaybe ( \wl -> uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> ( , wl ) ) 
 
 -- | Looks for first collision of a point with walls.
 -- If found, gives point and normal of wall.

src/Dodge/Base/Collide.hs

@@ -2,8 +2,10 @@
 {- | Basic collision detection for a moving point -}
 module Dodge.Base.Collide
     ( hasLOS
+    , collidePointWallsWall
     , hasButtonLOS
     , reflectPointWalls
+    , reflectPointWallsDamp
     , ssfold
     , collidePointUpToIndirectMinDist
     , canSeeIndirect
@@ -13,6 +15,7 @@ module Dodge.Base.Collide
     ) where
 import Dodge.Data
 import Dodge.Zone
+import Dodge.Wall.Reflect
 import Geometry
 import FoldableHelp
 
@@ -42,19 +45,36 @@ hasButtonLOS p1 p2 = not . pointHitsWalls p1 p2
 --    . mapMaybe
 --    (\(x,y) -> (, (x,y)) <$> intersectSegSeg p1 p2 x y)
 
+reflectPointWallsDamp :: Float -> Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
+reflectPointWallsDamp x p1 p2 = fmap (f p1 p2) . collidePointWallsWall p1 p2 
+  where
+    f a b (p,wl) = ( p +.+ errorNormalizeV 139 (vNormal (uncurry (-.-) $ _wlLine wl))
+        , reflVelWallDamp x wl (b-.-a)
+        )
+
+-- | Looks for first collision of a point with walls.
+-- If found, gives point and wall.
+-- (This can probably be improved, eg by folding over the walls and on finding a
+-- wall moving the end point to the collision point, but the returns in speed
+-- are probably minimal)
+collidePointWallsWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Wall)
+collidePointWallsWall p1 p2 
+    = safeMinimumOn (dist p1 . fst)
+    . IM.mapMaybe ( \wl -> uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> ( , wl ) ) 
+
 -- | looks for first collision of a point with walls
 -- if found, gives point and reflection velocity
 reflectPointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
-reflectPointWalls p1 p2 ws 
+reflectPointWalls p1 p2
     = safeMinimumOn (dist p1 . fst)
-    $ IM.mapMaybe 
+    . IM.mapMaybe
         (( \(x,y) -> 
             fmap ( (, reflectIn (x -.- y) (p2 -.- p1)) 
                  . (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
                  ) 
                  (intersectSegSeg p1 p2 x y)
          ) 
-        . _wlLine) ws
+        . _wlLine)
 ---- | Looks for first collision of a point with walls.
 ---- If found, gives point and reflection velocity, reflection damped in normal.
 --reflectPointWallsDamped 

src/Dodge/Creature/State.hs

@@ -83,7 +83,6 @@ checkDeath cr w
         $ rotate (_crDir cr)
         (_crCorpse cr)
 
-
 internalUpdate :: Creature -> World -> World
 internalUpdate cr = creatures . ix (_crID cr) %~ 
     ( (crHammerPosition %~ moveHammerUp)

src/Dodge/Prop/Gib.hs

@@ -7,8 +7,11 @@ import Shape
 import Geometry
 import Color
 import LensHelp
-import Dodge.Base.NewID
+import Dodge.RandomHelp
+--import Dodge.Base.NewID
 
+import System.Random
+import Control.Monad.State
 import qualified Linear.Quaternion as Q
 
 aGib :: Prop
@@ -52,25 +55,26 @@ updateGib' w pr
         & pjVelZ -~ 1
         & pjPosZ +~ velz
         & updateWithVel vel
-        & pjQuat *~ (_pjQuatSpin pr)
+        & pjQuat *~ _pjQuatSpin pr
   where
     newposz = _pjPosZ pr + velz
     velz = _pjVelZ pr
     vel  = _pjVel pr
     pos  = _pjPos pr
-    --updateWithVel v = case reflectPointWalls pos (pos + v) $ wallsAlongLine pos (pos +v) w of
-    updateWithVel v = case collidePointAnyWallsReflect pos (pos + v) $ wallsAlongLine pos (pos +v) w of
+    updateWithVel v = case reflectPointWallsDamp 0.5 pos (pos + v) $ wallsAlongLine pos (pos +v) w of
         Nothing -> pjPos +~ v
         Just (p,v') -> (pjPos .~ p) . (pjVel .~ v')
 
 addGibsAt :: Point2 -> World -> World
-addGibsAt p w = w & addg (V2 2 2)
-    & addg (V2 (-2) 2)
-    & addg (V2 (-2) (-2))
-    & addg (V2 (2) (-2))
+addGibsAt p w = foldr addg w (zip vels zspeeds)
   where
-    addg v = plNew props pjID (aGib & pjPos .~ p
+    speeds = replicateM 4 (state (randomR (1,4))) & evalState $ _randGen w
+    dirs = unitVectorAtAngle <$> (randsOnCirc 4 & evalState $ _randGen w)
+    vels = zipWith (*.*) speeds dirs
+    zspeeds = replicateM 4 (state (randomR (1,8))) & evalState $ _randGen w
+    addg (v,zs) = plNew props pjID (aGib & pjPos .~ p
         & pjVel .~ v
         & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+        & pjVelZ .~ zs
         )
   

src/Dodge/RandomHelp.hs

@@ -96,3 +96,10 @@ randInRect w h = do
 maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a)
 maybeTakeOne [] = return Nothing
 maybeTakeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (Just (xs !! i)))
+
+randsOnCirc :: RandomGen g => Int -> State g [Float]
+randsOnCirc i
+    | i <= 0    = error "tried to take <= 0 randsOnCirc"
+    | otherwise = zipWith (+) [x,2*x..] <$> replicateM i (state $ randomR (0,x))
+  where
+    x = 2*pi/fromIntegral i

src/Dodge/Wall/Reflect.hs

@@ -6,6 +6,10 @@ import Dodge.Data
 reflDirWall :: Point2 -> Point2 -> Wall -> Float
 reflDirWall sp ep wl = argV (reflectIn (uncurry (-.-) (_wlLine wl)) (ep -.- sp))
 
+-- point free nonsense
+reflVelWallDamp :: Float -> Wall -> Point2 -> Point2
+reflVelWallDamp x = reflectInParam x . uncurry (-.-) . _wlLine
+
 -- point free nonsense
 reflVelWall :: Wall -> Point2 -> Point2
 reflVelWall = reflectIn . uncurry (-.-) . _wlLine

src/Geometry.hs

@@ -100,9 +100,8 @@ difference x y
 -- | Given vector line direction and a vector movement,
 -- reflects the movement according to the line.
 reflectIn :: Point2 -> Point2 -> Point2
-reflectIn line vec = rotateV angle vec
-  where
-    angle = 2 * angleBetween line vec
+reflectIn line vec = rotateV (2 * angleBetween line vec) vec
+
 -- | Find angle between two points.
 -- Not normalised, ranges from -2*pi to 2*pi.
 angleBetween :: Point2 -> Point2 -> Float