From 58b2c8a8421d72ab412bff0e6fe6a4e756de4842 Mon Sep 17 00:00:00 2001 From: jgk Date: Tue, 20 Jul 2021 04:34:28 +0200 Subject: [PATCH] Introduce safeMinimumOn --- src/Dodge/Base.hs | 6 ++++-- src/Dodge/Base/Collide.hs | 42 +++++++++++++++++++++++++++---------- src/Dodge/Layout.hs | 7 +++++-- src/Dodge/Render/Picture.hs | 19 +++++++++-------- src/Dodge/Update/Camera.hs | 13 ++++++++---- 5 files changed, 59 insertions(+), 28 deletions(-) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index ef851d758..119f095d3 100644 --- a/src/Dodge/Base.hs +++ b/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 diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index a361f41d1..699610ce2 100644 --- a/src/Dodge/Base/Collide.hs +++ b/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 diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 232b12d2c..3e04f5412 100644 --- a/src/Dodge/Layout.hs +++ b/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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 755c75a27..e37eab7a3 100644 --- a/src/Dodge/Render/Picture.hs +++ b/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 diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 590028935..8e1c613bd 100644 --- a/src/Dodge/Update/Camera.hs +++ b/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]