141 lines
3.7 KiB
Haskell
141 lines
3.7 KiB
Haskell
module Dodge.RoomLink (
|
|
muout,
|
|
muin,
|
|
outLink,
|
|
inLink,
|
|
restrictLinkType,
|
|
overLnkType,
|
|
lnkPosDir,
|
|
overLnkPosDir,
|
|
toBothLnk,
|
|
rmInLinks,
|
|
rmOutLinks,
|
|
setOutLinksPD,
|
|
setOutLinksByType,
|
|
setInLinksPD,
|
|
restrictOutLinks,
|
|
restrictInLinks,
|
|
setOutLinks,
|
|
setInLinks,
|
|
setInLinksByType,
|
|
setLinkType,
|
|
getLinksOfType,
|
|
swapInOutLinks,
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Data.List (partition)
|
|
import qualified Data.Set as S
|
|
import Dodge.Data.GenWorld
|
|
import Geometry
|
|
|
|
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 = over rmLinks . restrictLinkType InLink
|
|
|
|
restrictOutLinks :: ((Point2, Float) -> Bool) -> Room -> Room
|
|
restrictOutLinks f = rmLinks %~ restrictLinkType OutLink f
|
|
|
|
setOutLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
|
|
setOutLinks = setLinkType OutLink
|
|
|
|
setInLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
|
|
setInLinks = setLinkType InLink
|
|
|
|
setInLinksByType :: RoomLinkType -> [RoomLink] -> [RoomLink]
|
|
setInLinksByType lt = setInLinks (\rl -> lt `S.member` _rlType rl)
|
|
|
|
setOutLinksByType :: RoomLinkType -> [RoomLink] -> [RoomLink]
|
|
setOutLinksByType lt = setOutLinks (\rl -> lt `S.member` _rlType rl)
|
|
|
|
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
|
|
}
|
|
|
|
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
|