Add file

src/Dodge/RoomLink.hs

@@ -0,0 +1,58 @@
+module Dodge.RoomLink where
+import Dodge.LevelGen.Data
+import Geometry
+
+import Data.List (partition)
+import qualified Data.Set as S
+import Control.Lens
+
+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
+
+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