diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index d9e44bfb2..fe2405e54 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -128,6 +128,7 @@ data TempLightSource = TLS data Creature = Creature { _crPos :: Point2 , _crOldPos :: Point2 + , _crVel :: Point2 , _crDir :: Float , _crID :: Int , _crPict :: Creature -> Picture diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index ba9092d69..d7da21066 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -50,19 +50,20 @@ defaultDoor = Door { _wlLine = [(0,0),(50,0)] } defaultCreature :: Creature defaultCreature = Creature - { _crPos = (0,0) + { _crPos = (0,0) , _crOldPos = (0,0) - , _crDir = 0 - , _crID = 1 - , _crPict = const $ onLayer CrLayer $ circleSolid 10 + , _crVel = (0,0) + , _crDir = 0 + , _crID = 1 + , _crPict = const $ onLayer CrLayer $ circleSolid 10 , _crUpdate = \ w f cr -> (f , Just cr) - , _crRad = 10 - , _crMass = 10 - , _crHP = 100 - , _crMaxHP = 150 - , _crInv = IM.empty + , _crRad = 10 + , _crMass = 10 + , _crHP = 100 + , _crMaxHP = 150 + , _crInv = IM.empty , _crInvSel = 0 - , _crState = defaultState + , _crState = defaultState , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10 , _crIsAnimate = True } diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 617d7b20a..6edfb7168 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -45,7 +45,7 @@ update w . wallEvents . set worldEvents id $ _worldEvents w1 w1 - where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) + where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) -- w -- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize -- = insertIMInZone x y wlid wl @@ -76,7 +76,10 @@ updateParticles' w = set particles' (catMaybes ps) w' updateCreatures :: World -> World updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w - where ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w + where + ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' (setOldPos cr)) (id,_randGen w) + $ _creatures w + setOldPos cr = cr & crOldPos .~ _crPos cr wallEvents :: World -> World diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 4624822aa..32bb96116 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -14,23 +14,18 @@ colCrsWalls :: World -> World colCrsWalls w = over creatures (fmap (colCrWall w)) w colCrWall :: World -> Creature -> Creature -colCrWall w c = pushOutFromWall w c - -pushOutFromWall :: World -> Creature -> Creature -pushOutFromWall w c - | p1 == p2 = c - | otherwise = over crPos ( - collideCorners rad p1 wallPoints - . - collideWalls rad p1 ls - . checkPushThroughs rad p1 ls - ) - c - where rad = _crRad c + wallBuffer - p1 = _crOldPos c - p2 = _crPos c - ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w - wallPoints = nub $ concat ls +colCrWall w c + | p1 == p2 = pushOrCrush ls c + | otherwise = c & crPos %~ + collideCorners rad p1 wallPoints + . collideWalls rad p1 ls + . checkPushThroughs rad p1 ls + where + rad = _crRad c + wallBuffer + p1 = _crOldPos c + p2 = _crPos c + ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w + wallPoints = nub $ concat ls -- colCrPushThrough :: World -> Creature -> Creature -- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr @@ -43,23 +38,40 @@ pushOutFromWall w c -- the amount to push creatures out from walls, extra to their radius wallBuffer = 3 --- the following tests whether a moving circle crosses a list of walls, and --- places the circle accordingly. --- It supposes that the circle will only interact with at most two walls. --- the reverse prevents the collision from happening again with the first wall, --- when two walls are collided with +-- the following tests whether or not a point is on a wall, and if so pushes it +-- out from the wall +-- If the resultant push out is itself on another wall, the original point is +-- returned collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2 collideWalls rad cp1 walls cp2 - = case (listToMaybe.mapMaybe (collideWall rad cp1 cp2)) walls of + = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of Nothing -> cp2 - Just cp3 -> case (listToMaybe.reverse.mapMaybe (collideWall rad cp1 cp3)) walls of + Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of Nothing -> cp3 - Just cp4 -> cp4 + Just cp4 -> cp1 + +-- pushes a point out from a list of walls +-- if multiple new points occur, chooses the one closest to the orignal pointjk +pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2 +pushOutFromWalls rad walls p = + fromMaybe p + . listToMaybe + . sortBy (compare `on` dist p) + $ mapMaybe (pushOutFromWall rad p) + walls + +pushOrCrush :: [[Point2]] -> Creature -> Creature +pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of + [] -> cr + [p] -> cr & crPos .~ p + _ -> cr & crState . crDamage %~ ( (Blunt 50 cpos cpos cpos) :) + where + cpos = _crPos cr -- assumes that the wall is orientated -- assumes wall points are different -collideWall :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2) -collideWall rad cp1 cp2 (wp1:wp2:_) +pushOutFromWall :: Float -> Point2 -> [Point2] -> Maybe (Point2) +pushOutFromWall rad cp2 (wp1:wp2:_) | isOnWall = Just newP -- +.+ (1 *.* norm)) | otherwise = Nothing where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2) @@ -70,6 +82,12 @@ collideWall rad cp1 cp2 (wp1:wp2:_) isJust Nothing = False isJust _ = True +pushOutFromCorners :: World -> Creature -> Creature +pushOutFromCorners w cr = cr & crPos .~ newPos + where + newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls + ls = nub . concat . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w + collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2 collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps