Introduce safeMinimumOn

src/Dodge/Base.hs

@@ -95,6 +95,9 @@ wallsOnCirc p r = IM.filter f
   where 
     f wl = uncurry circOnSeg (_wlLine wl) p r
 
+wallsOnScreen :: World -> IM.IntMap Wall
+wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
+
 allWalls :: World -> IM.IntMap Wall
 allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w
 
@@ -202,8 +205,7 @@ reflectPointCreature p1 p2 cr = case collidePointCirc p1 p2 (_crRad cr) (_crPos
 {- | TODO: determine precisely what this does. -}
 reflectPointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
 reflectPointCreatures p1 p2 cs 
-    = listToMaybe 
-    . sortOn f
+    = safeMinimumOn f
     . IM.elems 
     $ IM.mapMaybe (reflectPointCreature p1 p2) cs
   where 

src/Dodge/Base/Collide.hs

@@ -6,20 +6,44 @@ import Dodge.Data
 import Dodge.Base.Zone
 import Geometry
 
-import Data.List
+--import Data.List
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
+-- | A version of 'minimum' where the comparison is done on some extracted value.
+--   Returns Nothing if the list is empty. Only calls the function once per element.
+--
+-- > safeMinimumOn id [] == Nothing
+-- > safeMinimumOn length ["test","extra","a"] == Just "a"
+safeMinimumOn :: (Ord b) => (a -> b) -> [a] -> Maybe a
+safeMinimumOn _ [] = Nothing
+safeMinimumOn f (x:xs) = g x (f x) xs
+    where
+        g v _  [] = Just v
+        g v mv (y:ys) | my < mv = g y my ys
+                      | otherwise = g v mv ys
+            where my = f y
+
 hasLOS :: Point2 -> Point2 -> World -> Bool
 {-# INLINE hasLOS #-}
 hasLOS p1 p2 w = not $ pointHitsWalls p1 p2 $ wallsAlongLine p1 p2 w
+
+hitPointLines
+    :: Point2
+    -> Point2
+    -> [(Point2,Point2)]
+    -> Maybe (Point2,(Point2,Point2))
+hitPointLines p1 p2
+    = safeMinimumOn (dist p1 . fst)
+    . mapMaybe
+    (\(x,y) -> (, (x,y)) <$> (intersectSegSeg' p1 p2 x y))
+
 -- | 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 
-    = listToMaybe 
-    . sortOn (dist p1 . fst)
+    = safeMinimumOn (dist p1 . fst)
     . IM.elems 
     $ IM.mapMaybe 
         (( \(x,y) -> 
@@ -38,8 +62,7 @@ reflectPointWallsDamped
     -> IM.IntMap Wall 
     -> Maybe (Point2,Point2)
 reflectPointWallsDamped dfact p1 p2 ws 
-    = listToMaybe 
-    . sortOn (dist p1 . fst)
+    = safeMinimumOn (dist p1 . fst)
     . IM.elems 
     $ IM.mapMaybe 
         (( \(x,y) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1)) 
@@ -60,16 +83,14 @@ collidePointWalkable p1 p2 ws
 furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
 furthestPointWalkable p1 p2 ws 
     = fromMaybe p2
-    . listToMaybe
-    . sortOn (dist p1) 
+    . safeMinimumOn (dist p1) 
     . IM.elems 
     $ IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine) ws
 
 collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
 {-# INLINE collidePointIndirect #-}
 collidePointIndirect p1 p2 ws 
-    = listToMaybe 
-    . sortOn (dist p1) 
+    = safeMinimumOn (dist p1) 
     . IM.elems 
     . IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine) 
     $ IM.filter (not . _wlIsSeeThrough) ws
@@ -77,8 +98,7 @@ collidePointIndirect p1 p2 ws
  - Not sure if this needs vision as well, need to make this uniform. -}
 collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
 collidePointFire p1 p2 ws 
-    = listToMaybe 
-    . sortOn (dist p1) 
+    = safeMinimumOn (dist p1) 
     . IM.elems 
     . IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine ) 
     $ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))) ws

src/Dodge/Layout.hs

@@ -28,8 +28,8 @@ import Data.Graph.Inductive.Graph (labNodes)
 import qualified Data.Map as M
 
 generateLevelFromRoomList :: State StdGen [Room] -> World -> World
-generateLevelFromRoomList gr w = initializeStaticWalls
-    . updateWallZoning 
+generateLevelFromRoomList gr w = updateWallZoning 
+--    . initializeStaticWalls
     . placeSpots plmnts
 --    . addRoomPolyDecorations rs
 --    . addRoomLinkDecorations rs
@@ -61,8 +61,11 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
 
 initializeStaticWalls :: World -> World
 initializeStaticWalls w = w & staticWalls %~ (\wls' -> foldr wallToWall wls' wls)
+    & walls %~ IM.filter (not . wlIsWall)
   where
     wls = [wl | wl@Wall{} <- (IM.elems $ _walls w)]
+    wlIsWall Wall{} = True
+    wlIsWall _ = False
 
 wallToWall :: Wall -> IM.IntMap (IM.IntMap [Wall']) -> IM.IntMap (IM.IntMap [Wall'])
 wallToWall wl wls = foldr f wls is

src/Dodge/Render/Picture.hs

@@ -74,9 +74,6 @@ wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
         | wl ^? blVisible == Just False = False
         | otherwise = onScreen wl
 
-wallsOnScreen :: World -> IM.IntMap Wall
-wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
-
 drawWallFloor :: Wall -> Picture
 drawWallFloor wl = if _wlIsSeeThrough wl
     then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y]
@@ -203,21 +200,25 @@ drawFFShadow w ff
                 , y]
 
 wallsPointsAndCols :: World -> [((Point2,Point2),Point4)]
-wallsPointsAndCols w = map f . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
+wallsPointsAndCols w 
+    = (map f . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w)
   where 
     f wl = (_wlLine wl, _wlColor wl)
 
+staticWallsOnScreen :: World -> [((Point2,Point2),Point4)]
+staticWallsOnScreen w 
+    = map f 
+    . concat 
+    $ catMaybes [IM.lookup x (_staticWalls w) >>= IM.lookup y | (x,y) <- zoneOfDoubleScreen w]
+  where
+    f wl = (_wlLine' wl, _wlColor' wl)
+
 wallsWindows :: World -> [((Point2,Point2),Point4)]
 wallsWindows w = map f . filter (fromMaybe True . (^? blVisible)) .
                      filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
   where 
     f wl = (_wlLine wl, _wlColor wl)
 
-wallsForShadows :: World -> [(Point2,Point2)]
-wallsForShadows w = map _wlLine 
-                        . filter (not . _wlIsSeeThrough)
-                        . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
-
 lightsForGloom :: World -> [(Point3,Float,Float)]
 lightsForGloom w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
   where 

src/Dodge/Update/Camera.hs

@@ -98,7 +98,10 @@ zoomOutLongGun w
     --currentCursorDisplacement = fromJust $ _itAttachment wp
 
 rotCam :: World -> World
-rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . autoZoomCam
+rotCam = rotateCameraL 
+    . rotateCameraR 
+    . zoomCamIn . zoomCamOut 
+    . autoZoomCam
 
 rotateCameraL :: World -> World
 rotateCameraL w 
@@ -150,13 +153,15 @@ autoZoomCam w = over cameraZoom changeZoom w
     scZoom = fromMaybe 1 $ yourItem w ^? itAttachment . _Just . scopeZoom
 
 farWallDist :: Point2 -> World -> Float
+{-# INLINE farWallDist #-}
 farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (verticalMax+50) )
   where
     horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays
     verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays
--- TODO: fix wallsAlongLine and use instead of checking against all walls
---    h p = fromMaybe p $ collidePointIndirect cpos p $ wallsAlongLine cpos p w
-    h p = fromMaybe p . collidePointIndirect cpos p $ _walls w
+    --h p = fromMaybe p $ collidePointIndirect cpos p $ wallsAlongLine cpos p w
+    --h p = fromMaybe p . collidePointIndirect cpos p $ _walls w
+    wos = wallsOnScreen w
+    h p = fromMaybe p $ collidePointIndirect cpos p wos
     h' x p = dotV (rotateV camRot x) (p -.- cpos)
     camRot = _cameraRot w
     rRays = rotF [( maxViewDistance,y) | y <- zs]