Implement auto rotate camera when close to walls

2021-09-11 19:55:46 +01:00
parent aa7413a29f
commit f2553ded0e
5 changed files with 52 additions and 69 deletions
@@ -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.
@@ -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 = []
@@ -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]
@@ -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
@@ -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