From 4eaa31bf32f8a612554d63a5796fe0a667fde159 Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 25 Jun 2022 21:45:17 +0100 Subject: [PATCH] Cleanup --- src/Dodge/Base/Collide.hs | 12 ++++++------ src/Dodge/Data.hs | 6 +++--- src/Dodge/Debug.hs | 2 +- src/Dodge/Default/World.hs | 2 +- src/Dodge/Floor.hs | 2 +- src/Dodge/Layout.hs | 3 ++- src/Dodge/Path.hs | 11 ++++++----- src/Dodge/Update/Camera.hs | 2 +- src/Dodge/Zone.hs | 7 +++---- 9 files changed, 24 insertions(+), 23 deletions(-) diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index d8cbcf9c2..5efaa1f79 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -59,13 +59,13 @@ hasLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasLOS #-} hasLOS p1 p2 = not . collidePointTestFilter (const True) p1 p2 - . wallsAlongLineStream p1 p2 + . wallsAlongLine p1 p2 hasButtonLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasButtonLOS #-} hasButtonLOS p1 p2 = not . collidePointTestFilter (not . _wlTouchThrough) p1 p2 - . wallsAlongLineStream p1 p2 + . wallsAlongLine p1 p2 --hitPointLines -- :: Point2 @@ -137,7 +137,7 @@ collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> collidePointWallsFilterStream t sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id . S.filter t - . wallsAlongLineStream sp ep + . wallsAlongLine sp ep where findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl @@ -155,7 +155,7 @@ visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap ( S.span (not . wlIsOpaque . snd) . orderStreamOn (dist sp . fst) . S.mapMaybe f - . wallsAlongLineStream sp ep ) + . wallsAlongLine sp ep ) where f wl = uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl) @@ -206,12 +206,12 @@ ssfold p f a0 xs = foldr (\x g a -> if p a then a else g (f a x)) id xs a0 hasLOSIndirect :: Point2 -> Point2 -> World -> Bool hasLOSIndirect p1 p2 = not . collidePointTestFilter wlIsOpaque p1 p2 - . wallsAlongLineStream p1 p2 + . wallsAlongLine p1 p2 isWalkable :: Point2 -> Point2 -> World -> Bool isWalkable p1 p2 = not . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 - . wallsAlongLineStream p1 p2 + . wallsAlongLine p1 p2 canSee :: Int -> Int -> World -> Bool canSee i j w = hasLOS p1 p2 w diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index fffda028d..b54a5cf13 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -141,9 +141,9 @@ data World = World , _foregroundShape :: Shape , _corpses :: IM.IntMap Corpse , _clickMousePos :: Point2 - , _pathGraph :: ~(Gr Point2 Float) - , _pathGraphP :: ~[(Point2,Point2)] - , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) + , _pathGraph :: Gr Point2 Float + , _pathGraphP :: S.Set (Point2,Point2) + , _pathPoints :: IM.IntMap (IM.IntMap [(Int,Point2)]) , _hud :: HUD , _lightSources :: IM.IntMap LightSource , _tempLightSources :: [TempLightSource] diff --git a/src/Dodge/Debug.hs b/src/Dodge/Debug.hs index b9c4c5b3f..55ca5dcfa 100644 --- a/src/Dodge/Debug.hs +++ b/src/Dodge/Debug.hs @@ -58,7 +58,7 @@ debugWallZoningPic w = setLayer BloomLayer $ zonesPic `appendPic` wallsPic where --wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls wallsPic = setDepth 25 . color yellow . runIdentity . S.foldMap_ (drawTheWall . _wlLine) - $ wallsAlongLineStream sp ep w + $ wallsAlongLine sp ep w drawTheWall (a,b) = thickLine 20 [a,b] zonesPic = setDepth 20 $ drawDDA zones zones = ddaExt zoneSize sp ep diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index b8d40bb1c..04abc1dc7 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -71,7 +71,7 @@ defaultWorld = World -- , _menuLayers = [] , _clickMousePos = V2 0 0 , _pathGraph = Data.Graph.Inductive.Graph.empty - , _pathGraphP = [] + , _pathGraphP = mempty , _pathPoints = IM.empty , _hud = HUD { _hudElement = DisplayInventory NoSubInventory diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index dfdb18a57..83078b91a 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -41,8 +41,8 @@ initialAnoTree :: Annotation initialAnoTree = OnwardList $ intersperse (AnTree corDoor) [ IntAnno $ AnTree . startRoom - , AnRoom $ roomCCrits 10 , AnRoom slowDoorRoom + , AnRoom $ roomCCrits 10 , AnTree firstBreather , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward ] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 8c72ffbb5..dcddd9100 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -26,6 +26,7 @@ import Color import Shape --import Padding +import qualified Data.Set as S import Data.List (nubBy) import Data.Traversable import Control.Lens @@ -52,7 +53,7 @@ generateLevelFromRoomList gr' w = initWallZoning } where path = pairsToGraph dist pairPath - pairPath = concatMap _rmPath rs + pairPath = S.fromList $ concatMap _rmPath rs rs = map doRoomShift $ IM.elems rs' rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 72a0b277d..95c76674b 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -17,6 +17,7 @@ import Data.Maybe import Data.List import qualified Data.IntMap.Strict as IM import Data.Graph.Inductive hiding ((&)) +import qualified Data.Set as S --import Data.Graph.Inductive.PatriciaTree --import Data.Graph.Inductive.Graph hiding ((&)) @@ -78,11 +79,11 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a -- [] -> return Nothing -- _ -> return $ Just $ ns !! i -- -pairsToGraph :: (Ord a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b +pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> S.Set (a,a) -> Gr a b pairsToGraph f pairs = - let nodes' = nub (map fst pairs ++ map snd pairs) - pairs' = map (\(x,y)->(x,y,f x y)) pairs - in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes' >> insMapEdgesM pairs' + let nodes' = S.map fst pairs `S.union` S.map snd pairs + pairs' = S.map (\(x,y)->(x,y,f x y)) pairs + in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (S.toList nodes') >> insMapEdgesM (S.toList pairs') removePathsCrossing :: Point2 -> Point2 -> World -> World removePathsCrossing a b w = w @@ -90,6 +91,6 @@ removePathsCrossing a b w = w & pathGraphP .~ pg' & pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph) where - pg' = filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w + pg' = S.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] newGraph = pairsToGraph dist pg' diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index a8f101580..90407dd0b 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -233,7 +233,7 @@ farWallDistDirection p w = runIdentity $ L.purely S.fold_ ((,,,) $ S.map f vps where f q = runIdentity (S.fold_ findPoint q (rotateV (negate $ _cameraRot w) . (-.- p)) (wls q)) - wls q = S.filter wlIsOpaque $ wallsAlongLineStream p q w + wls q = S.filter wlIsOpaque $ wallsAlongLine p q w findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine vps = streamViewpoints p w diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index e48247c29..f2e2f3dfe 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -2,8 +2,7 @@ module Dodge.Zone ( crZoneOfPoint , zoneOfLineIntMap , wallsNearPoint --- , wallsAlongLine - , wallsAlongLineStream + , wallsAlongLine , zoneSize , zoneOfPoint , wallsAlongCirc @@ -176,8 +175,8 @@ cloudsNearPoint p w = f (IM.lookup x (_znObjects $ _cloudsZone w) >>= IM.lookup -- Just val -> val -- _ -> IM.empty -wallsAlongLineStream :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity () -wallsAlongLineStream sp ep w = S.concat $ S.mapMaybe f $ zoneOfLineStream sp ep +wallsAlongLine :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity () +wallsAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfLineStream sp ep where f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j