diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 4956a1cd6..01c4f0064 100644 --- a/src/Dodge/Base.hs +++ b/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. diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 575e8b4bc..dc2a4b4d0 100644 --- a/src/Dodge/Base/Collide.hs +++ b/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 diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 9ec7278df..d6271a6e2 100644 --- a/src/Dodge/Creature/State.hs +++ b/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) diff --git a/src/Dodge/Prop/Gib.hs b/src/Dodge/Prop/Gib.hs index 793da30df..842bcd34f 100644 --- a/src/Dodge/Prop/Gib.hs +++ b/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 ) diff --git a/src/Dodge/RandomHelp.hs b/src/Dodge/RandomHelp.hs index 479fa9fb6..83256a49f 100644 --- a/src/Dodge/RandomHelp.hs +++ b/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 diff --git a/src/Dodge/Wall/Reflect.hs b/src/Dodge/Wall/Reflect.hs index f73375af8..f9ea2d9ae 100644 --- a/src/Dodge/Wall/Reflect.hs +++ b/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 diff --git a/src/Geometry.hs b/src/Geometry.hs index 639b1c6cb..7c82dd40f 100644 --- a/src/Geometry.hs +++ b/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