156 lines
4.3 KiB
Haskell
156 lines
4.3 KiB
Haskell
module Dodge.RoomLink (
|
|
muout,
|
|
muin,
|
|
outLink,
|
|
inLink,
|
|
restrictLinkType,
|
|
overLnkType,
|
|
overLnkPosDir,
|
|
toBothLnk,
|
|
rmInLinks,
|
|
rmOutLinks,
|
|
setOutLinksPD,
|
|
setOutLinksByType,
|
|
setInLinksPD,
|
|
restrictOutLinks,
|
|
restrictInLinks,
|
|
setOutLinks,
|
|
setInLinks,
|
|
setInLinksByType,
|
|
setLinkType,
|
|
getLinksOfType,
|
|
swapInOutLinks,
|
|
isCornerLink,
|
|
isMidEdgeLink,
|
|
) where
|
|
|
|
import Dodge.Base.CardinalPoint
|
|
import Control.Lens
|
|
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
|
|
|
|
isMidEdgeLink :: Room -> CardinalPoint -> RoomLink -> Bool
|
|
isMidEdgeLink r x rl
|
|
| x == North || x == South = g West (f $ r ^?! rmType . numLinkEW)
|
|
&& OnEdge x `S.member` (rl ^. rlType)
|
|
| otherwise = g South (f $ r ^?! rmType . numLinkNS)
|
|
&& OnEdge x `S.member` (rl ^. rlType)
|
|
where
|
|
f y | even y = [y `div` 2]
|
|
| otherwise = [y `div` 2, 1 + (y `div` 2)]
|
|
g a = any (\y -> FromEdge a y `S.member` (rl ^. rlType))
|
|
|
|
isCornerLink :: CardinalPointBetween -> RoomLink -> Bool
|
|
isCornerLink x rl = (OnEdge a `S.member` xs && FromEdge b 0 `S.member` xs)
|
|
|| (OnEdge b `S.member` xs && FromEdge a 0 `S.member` xs)
|
|
where
|
|
xs = rl ^. rlType
|
|
(a,b) = cardinalBetweenAdj x
|
|
|
|
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) -> [RoomLink] -> [RoomLink]
|
|
overLnkType lt f = each %~ g
|
|
where
|
|
g lnk | lt `S.member` _rlType lnk = f lnk
|
|
| otherwise = lnk
|
|
|
|
rlPosDir :: RoomLink -> (Point2, Float)
|
|
rlPosDir 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
|