diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 5381ae885..db0f6153b 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -15,9 +15,7 @@ import qualified IntMapHelp as IM import FoldableHelp import Control.Lens ---import Control.Monad.State ---import Data.List ---import Data.Function +import qualified Control.Foldl as L import Data.Maybe --import Data.Bifunctor --import qualified Data.IntSet as IS @@ -219,7 +217,15 @@ collidePointFF = undefined -- ip = intersectSegSeg p1 p2 p3 p4 -- ref = (_ffDeflect ff) <*> Just g <*> Just (p2 -.- p1) <*> Just ff -- f p = (p, (ref, _ffID ff)) --- + +-- | Looks for first collision of a circle with walls. +-- If found, gives wall +collideCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall +collideCircWallsReturnWall p rad ws + = L.fold (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine)) + ws + where + f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b -- | Looks for first collision of a circle with walls. -- If found, gives point and reflection velocity, reflection damped in normal. diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index a7f05c63c..8de01af6b 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -29,15 +29,15 @@ defaultWorld = World , _cameraZoom = 1 , _cameraViewFrom = V2 0 0 , _creatures = IM.empty - , _creaturesZone = Zone IM.empty 15 + , _creaturesZone = Zone IM.empty , _creatureGroups = IM.empty , _clouds = [] - , _cloudsZone = Zone IM.empty 20 + , _cloudsZone = Zone IM.empty , _itemPositions = IM.empty , _projectiles = IM.empty , _particles = [] , _walls = IM.empty - , _wallsZone = Zone IM.empty 50 + , _wallsZone = Zone IM.empty , _forceFields = IM.empty , _floorItems = IM.empty , _floorTiles = [] @@ -50,7 +50,7 @@ defaultWorld = World , _buttons = IM.empty , _sounds = M.empty , _playingSounds = M.empty - , _corpses = Zone IM.empty 50 + , _corpses = Zone IM.empty , _decorations = IM.empty , _storedLevel = Nothing , _menuLayers = [] diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index e676ffd11..fb3d278e1 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -60,6 +60,7 @@ functionalUpdate w = case _menuLayers w of . ppEvents . updateCamera . colCrsWalls + . rotateToOverlappingWall . simpleCrSprings . zoneCreatures . updateWalls @@ -250,6 +251,24 @@ crCrSpring c1 c2 w overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec massT = _crMass c1 + _crMass c2 + +rotateToOverlappingWall :: World -> World +rotateToOverlappingWall w = case theWall of + Nothing -> w + Just wl -> rotateUsing ( (argV . uncurry (-.-) $ _wlLine wl) - camrot) + where + camrot = _cameraRot w + rotateUsing a + | b - b' > 0.01 = w & cameraRot +~ 0.01 + | b - b' < negate 0.01 = w & cameraRot -~ 0.01 + | otherwise = w + where + b = a * (2 / pi) + b' = fromIntegral $ (round b :: Int) + cr = you w + p = _crPos cr + theWall = collideCircWallsReturnWall p (_crRad cr + 5) (wallsNearPoint p w) + {- Finds the IDs of visible walls from a point to another point. -} visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int] diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 450b4c39e..3ac9c0117 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -1,4 +1,22 @@ module Dodge.Zone + ( crZoneOfPoint + , zoneOfLineIntMap + , wallsNearPoint + , wallsAlongLine + , zoneSize + , zoneOfPoint + , wallsAlongCirc + , wallsOnScreen + , lookLookups + , zoneAroundPoint + , floorHun + , zoneOfLine + , wallsDoubleScreen + , cloudZoneOfPoint + , cloudsNearPoint + , wallsNearZones + , zoneOfSight + ) where import Dodge.Data import Dodge.Zone.Data @@ -8,7 +26,6 @@ import Geometry.Zone import Data.Maybe import Data.List -import Data.Bifunctor import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS @@ -44,14 +61,6 @@ zoneAroundPoint (V2 x' y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]] x = floorHun x' y = floorHun y' -zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet -zoneAroundPoint' i (V2 x' y') = IM.fromSet (const ys) xs - where - x = floorHun x' - y = floorHun y' - xs = IS.fromAscList [x-i..x+i] - ys = IS.fromAscList [y-i..y+i] - zoneOfLine :: Point2 -> Point2 -> [(Int,Int)] zoneOfLine (V2 aa ab) (V2 ba bb) = nub @@ -64,43 +73,9 @@ zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet --{-# INLINE zoneOfLineIntMap #-} zoneOfLineIntMap = ddaExt zoneSize -expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet ---{-# INLINE expandLine #-} -expandLine xs = IM.map expandSet - $ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im] - where - im = IM.fromListWith IS.union $ map (second IS.singleton) xs - -- the second was suggested by hlint, but it increases laziness, so might - -- not be ideal - expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s - where - mk = IS.findMax s - zoneOfCircle :: Point2 -> Float -> [(Int,Int)] zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r --- looking at this again, I am not convinced it deals correctly with the --- rotation of the world -zoneOfScreen :: World -> [(Int,Int)] -zoneOfScreen w = - [(a,b) - | a <- [x - n .. x + n] - , b <- [y - n .. y + n] - ] - where - (x,y) = zoneOfPoint $ _cameraCenter w - n = ceiling $ wh / (_cameraZoom w * zoneSize) - wh = max (getWindowX w) (getWindowY w) - -zoneOfDoubleScreen :: World -> [(Int,Int)] -zoneOfDoubleScreen w = (,) <$> xs <*> ys - where - (x,y) = zoneOfPoint $ _cameraCenter w - n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2 - wh = max (getWindowX w) (getWindowY w) - xs = [x - n .. x + n] - ys = [y - n .. y + n] - zoneOfSight :: World -> [(Int,Int)] zoneOfSight w = [(a,b) @@ -147,12 +122,6 @@ wallsNearZones is w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is] Just val -> val _ -> IM.empty -ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a -ixZone z (V2 x y) = z IM.! floorHun x IM.! floorHun y - -ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a] -ixNZ z p = lookLookups (zoneNearPoint p) z - lookLookup :: Int -> Int -> IM.IntMap (IM.IntMap a) -> Maybe a lookLookup i j z = case IM.lookup i z of Just z' -> IM.lookup j z' @@ -183,13 +152,6 @@ wallsAlongLine a b w = IM.foldlWithKey' g IM.empty kps Just val -> val _ -> IM.empty -wallsNearZone :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall -{-# INLINE wallsNearZone #-} -wallsNearZone im w = IM.foldrWithKey' g IM.empty im - where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _wallsZone w) s)) - f i m = case IM.lookup i m of Just val -> val - _ -> IM.empty - wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall wallsAlongCirc p r w = IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y) <- zoneOfCircle p r] where f i m = case IM.lookup i m of Just val -> val @@ -202,6 +164,3 @@ wallsNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1 f i m = case IM.lookup i m of Just val -> val _ -> IM.empty - -flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a -flattenIMIMIM = IM.unions . IM.map IM.unions diff --git a/src/Dodge/Zone/Data.hs b/src/Dodge/Zone/Data.hs index a6197ebce..c4c490e94 100644 --- a/src/Dodge/Zone/Data.hs +++ b/src/Dodge/Zone/Data.hs @@ -5,9 +5,8 @@ module Dodge.Zone.Data import Control.Lens import qualified Data.IntMap.Strict as IM -data Zone a = Zone +newtype Zone a = Zone { _znObjects :: IM.IntMap (IM.IntMap a) - , _znSize :: Float } makeLenses ''Zone