104 lines
3.1 KiB
Haskell
104 lines
3.1 KiB
Haskell
module Dodge.RoomLink where
|
|
import Dodge.LevelGen.Data
|
|
import Geometry
|
|
|
|
import Data.List (partition)
|
|
import qualified Data.Set as S
|
|
import Control.Lens
|
|
|
|
restrictLinkType :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink]
|
|
restrictLinkType rlt f = map g
|
|
where
|
|
g rl | f $ rlPosDir rl = rl
|
|
| otherwise = rl & rlType %~ S.delete rlt
|
|
|
|
getLinksOfType :: RoomLinkType -> [RoomLink] -> [RoomLink]
|
|
getLinksOfType lt = filter (S.member lt . _rlType)
|
|
|
|
restrictInLinks :: ((Point2,Float) -> Bool) -> Room -> Room
|
|
restrictInLinks f = rmLinks %~ restrictLinkType InLink f
|
|
|
|
restrictOutLinks :: ((Point2,Float) -> Bool) -> Room -> Room
|
|
restrictOutLinks f = rmLinks %~ restrictLinkType OutLink f
|
|
|
|
setInLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
|
|
setInLinks = setLinkType InLink
|
|
|
|
setLinkType :: RoomLinkType -> (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
|
|
setLinkType rlt f = map g
|
|
where
|
|
g rl | f rl = rl & rlType %~ S.insert rlt
|
|
| otherwise = rl & rlType %~ S.delete rlt
|
|
|
|
setLinkTypePD :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink]
|
|
setLinkTypePD rlt f = map g
|
|
where
|
|
g rl | f $ rlPosDir rl = rl & rlType %~ S.insert rlt
|
|
| otherwise = rl & rlType %~ S.delete rlt
|
|
|
|
setInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room
|
|
setInLinksPD f = rmLinks %~ setLinkTypePD InLink f
|
|
|
|
setOutLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room
|
|
setOutLinksPD f = rmLinks %~ setLinkTypePD OutLink f
|
|
|
|
swapInOutLinks :: Room -> Room
|
|
swapInOutLinks = rmLinks %~ map (rlType %~ S.map f)
|
|
where
|
|
f InLink = OutLink
|
|
f OutLink = InLink
|
|
f x = x
|
|
|
|
overLnkType :: RoomLinkType -> ([RoomLink] -> [RoomLink]) -> Room -> Room
|
|
overLnkType lt f = rmLinks %~ g
|
|
where
|
|
g lnks = let (xs,ys) = partition (S.member lt . _rlType) lnks
|
|
in f xs ++ ys
|
|
|
|
rlPosDir :: RoomLink -> (Point2,Float)
|
|
rlPosDir rl = (_rlPos rl, _rlDir rl)
|
|
|
|
lnkPosDir :: RoomLink -> (Point2,Float)
|
|
lnkPosDir rl = (_rlPos rl, _rlDir rl)
|
|
|
|
overLnkPosDir :: ((Point2,Float) -> (Point2,Float)) -> RoomLink -> RoomLink
|
|
overLnkPosDir f rl = rl & rlPos .~ p & rlDir .~ a
|
|
where
|
|
(p,a) = f (_rlPos rl,_rlDir rl)
|
|
|
|
outLink :: Point2 -> Float -> RoomLink
|
|
outLink p a = RoomLink
|
|
{_rlType = S.singleton OutLink
|
|
,_rlPos = p
|
|
, _rlDir = a
|
|
}
|
|
inLink :: Point2 -> Float -> RoomLink
|
|
inLink p a = RoomLink
|
|
{_rlType = S.singleton InLink
|
|
,_rlPos = p
|
|
, _rlDir = a
|
|
}
|
|
lnkBothAnd :: RoomLinkType -> (Point2,Float) -> RoomLink
|
|
lnkBothAnd rlt (p,a) = RoomLink
|
|
{_rlType = S.fromList [OutLink,InLink,rlt]
|
|
,_rlPos = p
|
|
, _rlDir = a
|
|
}
|
|
|
|
toBothLnk :: (Point2,Float) -> RoomLink
|
|
toBothLnk (p,a) = RoomLink
|
|
{_rlType = S.fromList [OutLink,InLink]
|
|
,_rlPos = p
|
|
, _rlDir = a
|
|
}
|
|
muout :: [(Point2,Float)] -> [RoomLink]
|
|
muout = map (uncurry outLink)
|
|
muin :: [(Point2,Float)] -> [RoomLink]
|
|
muin = map (uncurry inLink)
|
|
|
|
rmLinksOfType :: RoomLinkType -> Room -> [RoomLink]
|
|
rmLinksOfType lt = filter (S.member lt . _rlType) . _rmLinks
|
|
rmOutLinks,rmInLinks :: Room -> [RoomLink]
|
|
rmOutLinks = rmLinksOfType OutLink
|
|
rmInLinks = rmLinksOfType InLink
|