Fix incorrect creation of unused links pos

src/Dodge/Annotation.hs

@@ -37,8 +37,9 @@ randomPadCorridors  (Node x xs) = do
     return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
 {- | Add a corridor to a random out-link of a room.  -}
 roomThenCorridor :: RandomGen g => Room -> State g (SubCompTree Room)
-roomThenCorridor theRoom = fmap (\r -> Node (PassDown theRoom) [(pure . UseAll) r]) 
+roomThenCorridor theRoom = fmap 
-                                (randomiseOutLinks corridor)
+    (\r -> Node (PassDown theRoom) [(pure . UseAll) r]) 
+    (shuffleLinks corridor)
 
 {- | Create a random room tree structure from a list of annotations.  -}
 anoToRoomTree :: RandomGen g => [Annotation g] -> State g (SubCompTree Room)
@@ -62,7 +63,7 @@ anoToRoomTree anos = case anos of
     [OrAno as] -> do
         a <- takeOne as
         anoToRoomTree a
-    [Corridor] -> pure . UseAll <$> randomiseOutLinks corridor
+    [Corridor] -> pure . UseAll <$> shuffleLinks corridor
     [AirlockAno] -> airlock >>=  roomThenCorridor
     [FirstWeapon] -> do
         branchWP <- branchRectWith weaponRoom
@@ -77,4 +78,4 @@ anoToRoomTree anos = case anos of
     _ -> do
         w <- state $ randomR (100,400)
         h <- state $ randomR (200,400)
-        fmap (pure . UseAll) . randomiseOutLinks $ roomRectAutoLinks w h
+        fmap (pure . UseAll) . shuffleLinks $ roomRectAutoLinks w h

src/Dodge/LevelGen/Data.hs

@@ -207,7 +207,8 @@ psj ps pst plmnt = Placement ps pst Nothing (const $ Just plmnt)
 
 -- the NoShiftCont is necessary when shifting then combining rooms
 ps0jPushPS :: PSType -> Placement -> Placement
-ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p)
+ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing 
+    $ \p -> Just $ plmnt & plSpot .~ _plSpot p
 
 addPlmnt :: Placement -> Placement -> Placement
 addPlmnt pl pl2 = case pl2 of

src/Dodge/Placement/Instance/LightSource.hs

@@ -21,7 +21,6 @@ mntLSOn
     -> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
 mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
     = ps0jPushPS (PutShape . setCol $ shapeF wallp lsp)
-    -- = ps0j (PutShape . setCol $ shapeF wallp lsp)
     . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
   where
     lsp' = lsp -.-.- V3 x y 1
@@ -111,6 +110,8 @@ mntLightLnkCond f = RandomPlacement $ do
 unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
 unusedLnkToPS rp _ = case rp of
     UnusedLink p a -> Just (PS p a,UsedSpot p a)
+--    UsedInLink _ p a -> Just (PS p a,UsedSpot p a)
+--    UsedOutLink _ _ p a -> Just (PS p a,UsedSpot p a)
     _ -> Nothing
 
 spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement

src/Dodge/Placement/PlaceSpot.hs

@@ -54,7 +54,6 @@ placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room)
 placePlainPSSpot w rm plmnt shift = 
     let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
         newplmnt = plmnt & plMID ?~ i
-    --in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
     in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
   where
     recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl

src/Dodge/Room/Branch.hs

@@ -20,6 +20,8 @@ branchRectWith t = do
     x <- state $ randomR (100,200)
     y <- state $ randomR (100,200)
     b <- t
-    root <- randomiseOutLinks $ roomRectAutoLinks x y
+    root <- shuffleLinks $ roomRectAutoLinks x y
-    return $ Node (PassDown root) [Node (UseAll door) [], changeToPassDown <$> 
+    return $ Node (PassDown root) 
-        treeFromTrunk [PassDown door] b]
+        [ Node (UseAll door) []
+        , changeToPassDown <$> treeFromTrunk [PassDown door] b
+        ]

src/Dodge/Room/Link.hs

@@ -14,7 +14,6 @@ module Dodge.Room.Link
     , randomiseAllLinks
     , shuffleLinks
     , filterLinks
-    , randomiseOutLinks
     , chooseOneInLink
     , restrictRMInLinksPD
     ) where
@@ -47,13 +46,6 @@ restrictToFstInLink = rmLinks %~ f
         | otherwise = rl : f xs
     f [] = []
 
-{- Shuffle the initial links of a room randomly. -}
-randomiseOutLinks :: RandomGen g => Room -> State g Room
-randomiseOutLinks r = do
-    let (outs,xs) = partition (S.member OutLink . _rlType) $ _rmLinks r
-    newLinks <- shuffle outs
-    return $ r {_rmLinks = newLinks ++ xs }
-
 sortOutLinksOn :: Ord b => ((Point2,Float) -> b) -> Room -> Room
 sortOutLinksOn f = overLnkType OutLink $ sortOn (f . lnkPosDir)
 
@@ -95,8 +87,8 @@ shiftRoomBy shift r = r
     & rmShift %~ shiftPosDirBy shift
     & rmFloor . tiles %~ map 
         ( (tilePoly %~ map (shiftPointBy shift))
-        . (tileZero %~ shiftPointBy shift    )
+        . (tileZero %~ shiftPointBy shift      )
-        . (tileX    %~ shiftPointBy shift         )
+        . (tileX    %~ shiftPointBy shift      )
         )
     & rmViewpoints %~ map (shiftPointBy shift)
 
@@ -109,8 +101,8 @@ moveRoomBy shift r = r
     & rmPmnts %~ map (shiftPlacement shift)
     & rmFloor . tiles %~ map 
         ( (tilePoly %~ map (shiftPointBy shift))
-        . (tileZero %~ shiftPointBy shift    )
+        . (tileZero %~ shiftPointBy shift      )
-        . (tileX    %~ shiftPointBy shift         )
+        . (tileX    %~ shiftPointBy shift      )
         )
     & rmViewpoints %~ map (shiftPointBy shift)
 
@@ -124,8 +116,7 @@ shiftRoomShiftToLink l inlink r
     (p,a) = inlink
 -- NOTE placements, when placed, will be shifted by the value _rmShift
 shiftRoomShiftBy :: (Point2,Float) -> Room -> Room
-shiftRoomShiftBy shift r = r
+shiftRoomShiftBy shift = rmShift %~ shiftPosDirBy shift
-    & rmShift %~ shiftPosDirBy shift
 
 shiftPosDirBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
 shiftPosDirBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)

src/Dodge/Room/Start.hs

@@ -25,7 +25,7 @@ import Dodge.Item.Weapon.Utility
 import Geometry
 --import Padding
 import Color
---import Shape
+import Shape
 import LensHelp
 
 --import Data.Maybe
@@ -96,11 +96,11 @@ startRoom' = do
     h <- state $ randomR (200,400)
     let plmnts = 
             [ sPS (V2 0 0) 0 $ PutShape $ girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2))
-            --, mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70)
+--            , mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70)
             , tankSquareEmboss4 (dim orange) 50 (h-60)
             , tankSquare (dim orange) 50 50
             , tankSquare (dim orange) 50 120
-            --, sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
+            , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
             ]
     thecol <- rezColor
     treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll 

src/Dodge/Tree/Shift.hs

@@ -24,7 +24,8 @@ type RoomInt = (Room,Int)
 
 positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt])
 positionRoomsFromTree (Node (r,i) ts) = printHeader 
-    >> posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty
+    >> (fmap (fmap (map $ first createUnusedLinkPos))) 
+        (posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty)
   where
     r' = r & rmMID ?~ 0
 
@@ -62,19 +63,23 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
             newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
             clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
             updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
-                & rmLinks %~ delete outlnk 
+                & rmLinks    %~ delete outlnk 
-                & rmPos .:~ uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk)
+                & rmPos      .:~ uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk)
                 & rmChildren .:~ snd childi
             shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
             updatechild rm = rm 
                 & rmMParent ?~ snd parenti
                 & rmMID     ?~ snd childi
-                & rmLinks %~ delete il 
+                & rmLinks   %~ delete il 
-                & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
+                & rmPos     %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
-                    . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) )
+--                    . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) 
+                    )
             shiftedt = applyToRoot 
                 (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) t
 
+createUnusedLinkPos :: Room -> Room
+createUnusedLinkPos rm = rm & rmPos .++~ map (uncurry UnusedLink . lnkPosDir) (_rmLinks rm)
+
 zipCount :: [a] -> [(Int,a)]
 zipCount = Prelude.zip [0..]