Work towards allowing for children to attach to arbitrary link types

src/Dodge/RoomLink.hs

@@ -6,6 +6,30 @@ 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 & rlType %~ S.delete rlt
+         | otherwise        = rl
+
+restrictInLinks :: ((Point2,Float) -> Bool) -> Room -> Room
+restrictInLinks f = rmLinks %~ restrictLinkType InLink f
+
+restrictOutLinks :: ((Point2,Float) -> Bool) -> Room -> Room
+restrictOutLinks f = rmLinks %~ restrictLinkType OutLink f
+
+setLinkType :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink]
+setLinkType rlt f = map g
+  where
+    g rl | f $ rlPosDir rl  = rl & rlType %~ S.delete rlt
+         | otherwise        = rl & rlType %~ S.insert rlt
+setInLinks :: ((Point2,Float) -> Bool) -> Room -> Room
+setInLinks f = rmLinks %~ setLinkType InLink f
+
+setOutLinks :: ((Point2,Float) -> Bool) -> Room -> Room
+setOutLinks f = rmLinks %~ setLinkType OutLink f
+
+
 swapInOutLinks :: Room -> Room
 swapInOutLinks = rmLinks %~ map (rlType %~ S.map f)
   where
@@ -19,6 +43,9 @@ overLnkType lt f = rmLinks %~ g
     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)