Work towards allowing for children to attach to arbitrary link types

src/Dodge/Room/Link.hs

@@ -4,22 +4,18 @@ of a position and a rotation.
 The last link in the list is considered the incoming link, the other links are
 the outgoing links.  -}
 module Dodge.Room.Link
-    ( --shiftRoomToLink
-    --, shiftRoomShiftToLink
-     shiftRoomShiftToLink
+    ( shiftRoomShiftToLink
     , shiftRoomBy
     , shiftLinkBy
     , doRoomShift
     , sortOutLinksOn
     , filterSortOutLinksOn
     , randomiseAllLinks
+    , shuffleLinks
     , filterLinks
     , changeLinkTo
     , changeLinkFrom
     , randomiseOutLinks
---    , randomiseLinksBy
-    , invShiftLinkBy
-    --, finalLinksUpdate
     ) where
 import Dodge.Placement.PlaceSpot
 import Dodge.LevelGen.Data
@@ -33,6 +29,7 @@ import Control.Monad.State
 import Control.Lens
 import Data.List
 import qualified Data.Set as S
+
 {- Shuffle the initial links of a room randomly. -}
 randomiseOutLinks :: RandomGen g => Room -> State g Room
 randomiseOutLinks r = do
@@ -56,6 +53,12 @@ randomiseAllLinks :: RandomGen g => Room -> State g Room
 randomiseAllLinks r = do
     newLinks <- shuffle $ _rmLinks r
     return $ r {_rmLinks = newLinks }
+{- Shuffle the order of all links of a room randomly. 
+ - Note this does not change their types. -}
+shuffleLinks :: RandomGen g => Room -> State g Room
+shuffleLinks r = do
+    newLinks <- shuffle $ _rmLinks r
+    return $ r {_rmLinks = newLinks }
 
 --randomiseLinksBy 
 --    :: ( [(Point2,Float)] -> State g [(Point2,Float)] )
@@ -120,14 +123,6 @@ shiftRoomBy shift r = r
         . (tileX    %~ shiftPointBy shift         )
         )
     & rmViewpoints %~ map (shiftPointBy shift)
---shiftRoomShiftToLink :: (Point2,Float) -> Room -> Room
---shiftRoomShiftToLink l r 
---    = shiftRoomShiftBy l 
---    . shiftRoomShiftBy (V2 0 0       , pi-a)  
---    $ shiftRoomShiftBy (V2 0 0 -.- p , 0) 
---    r
---  where 
---    (p,a) = head $ _rmInLinks r
 
 shiftRoomShiftToLink :: (Point2,Float) -> (Point2,Float) -> Room -> Room
 shiftRoomShiftToLink l inlink r 
@@ -150,22 +145,5 @@ shiftLinkBy (pos,rot) = overLnkPosDir f
   where
     f (p,r) = (shiftPointBy (pos,rot) p, r + rot)
 
-invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
-invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
-
-shiftPathBy  
-    :: (Point2,Float) 
-    -> (Point2,Point2) 
-    -> (Point2,Point2) 
+shiftPathBy  :: (Point2,Float) -> (Point2,Point2) -> (Point2,Point2) 
 shiftPathBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
-
---finalLinksUpdate :: Room -> Room
---finalLinksUpdate rm = case _rmInLinks rm of
---    (_:_) -> rm
---        & rmInLinks %~ tail
---        & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir $ head inlnks) :) 
---                    . (map (uncurry UnusedLink . lnkPosDir) (outlnks ++ tail inlnks) ++) )
---    _ -> rm
---  where
---    inlnks = _rmInLinks rm
---    outlnks = _rmOutLinks rm

src/Dodge/Room/LongDoor.hs

@@ -106,7 +106,7 @@ addButtonSlowDoor x h rm = do
        ,( V2 (x/2+50) 5,0::Float)
        ]
     thePlacement <- takeOne [butDoor butPos butRot ]
-    changeLinkFrom aboveH =<< changeLinkTo belowH (rm 
+    shuffleLinks $ setOutLinks aboveH $ setInLinks belowH (rm 
         & rmPmnts %~ (thePlacement :)
         & rmBound %~ (openDoorBound :)
         )

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)
 

src/Dodge/Tree/Shift.hs

@@ -54,13 +54,16 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
             newBounds = map pointsToPoly $ _rmBound r'
             clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
             updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
-                & rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) :)
+                & rmLinks %~ delete outlnk 
+                & rmPos %~ (uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) :)
             shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
             r' = doRoomShift . fst $ rootLabel shiftedt
-            updatechild rm = rm & rmLinks %~ delete il 
+            updatechild rm = rm 
+                & rmLinks %~ delete il 
                 & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
                     . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) )
-            shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) t
+            shiftedt = applyToRoot 
+                (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) t
 
 zipCount :: [a] -> [(Int,a)]
 zipCount = Prelude.zip [0..]