Implement auto rotate camera when close to walls

src/Dodge/Base.hs

@@ -15,9 +15,7 @@ import qualified IntMapHelp as IM
 import FoldableHelp
 
 import Control.Lens
---import Control.Monad.State
+import qualified Control.Foldl as L
---import Data.List
---import Data.Function
 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.

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 = []

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]

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

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