justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup

Browse Source
This commit is contained in:
justin
2022-06-25 21:45:17 +01:00
parent c56e53d33f
commit 4eaa31bf32
9 changed files with 24 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+6 -6
View File
@@ -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
src/Dodge/Data.hs
+3 -3
View File
@@ -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]
src/Dodge/Debug.hs
+1 -1
View File
@@ -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
src/Dodge/Default/World.hs
+1 -1
View File
@@ -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
src/Dodge/Floor.hs
+1 -1
View File
@@ -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
]
src/Dodge/Layout.hs
+2 -1
View File
@@ -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
src/Dodge/Path.hs
+6 -5
View File
@@ -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'
src/Dodge/Update/Camera.hs
+1 -1
View File
@@ -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
src/Dodge/Zone.hs
+3 -4
View File
@@ -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