Allow for random choice between placements in different rooms

src/Dodge/Layout.hs

@@ -15,6 +15,7 @@ import Dodge.GameRoom
 import Dodge.Bounds
 import Dodge.Default.Wall
 import Dodge.Room.Link
+import Dodge.Randify
 import Geometry
 import Geometry.Vector3D
 import Geometry.ConvexPoly
@@ -35,35 +36,41 @@ import Data.Maybe
 import Data.Function
 import Control.Monad.State
 
-generateLevelFromRoomList :: [Room] -> World -> World
+generateLevelFromRoomList :: IM.IntMap Room -> World -> World
 generateLevelFromRoomList gr' w 
     = initWallZoning 
     . setupWorldBounds
     . placeWires
+    . doAfterPlacements
     . doPartialPlacements
     . doExtendedPlacements
-    . flip (mapAccumR doRoomPlacements) rs'
-    . worldToGenWorld
+    . doIndividualPlacements
+--    . flip (mapAccumR doRoomPlacements) (IM.elems rs')
+    . worldToGenWorld rs'
     $ w { _walls        = wallsFromRooms rs
         , _floorTiles   = floorsFromRooms rs
-        , _gameRooms    = gameRoomsFromRooms rs'
+        , _gameRooms    = gameRoomsFromRooms (IM.elems rs')
         , _pathGraph    = path
         , _pathGraphP   = pairPath
         }
   where
     path = pairsToGraph dist pairPath
     pairPath = concatMap _rmPath rs
-    zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
-    rs = map doRoomShift rs'
-    rs' = mapM shuffleRoomPos (zipWith addTile zs gr') & evalState $ _randGen w
+    rs = map doRoomShift $ IM.elems rs'
+    rs'= mapM (shuffleRoomPos >=> addRandomTile) gr' & evalState $ _randGen w
+
+addRandomTile :: RandomGen g => Room -> State g Room
+addRandomTile r = do
+    z <- state $ randomR (0,63)
+    return $ addTile z r
 
 shuffleRoomPos :: RandomGen g => Room -> State g Room
 shuffleRoomPos rm = do
     newPos <- shuffle $ _rmPos rm
     return $ rm & rmPos .~ newPos
 
-placeWires :: (GenWorld,[Room])-> World
-placeWires (w,rms) = foldr placeRoomWires (_gWorld w) rms
+placeWires :: GenWorld -> World
+placeWires w = foldr placeRoomWires (_gWorld w) $ _gRooms w
 
 placeRoomWires :: Room -> World -> World
 placeRoomWires rm w = IM.foldr ($) w 
@@ -91,8 +98,18 @@ placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape
     rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
     rs = _rmShift rm
 
-doPartialPlacements :: ( (IM.IntMap [Placement],GenWorld) , [Room] ) -> (GenWorld,[Room])
-doPartialPlacements ((im,w),rms) = mapAccumR (doPartialPlacement im) w rms
+doAfterPlacements :: GenWorld -> GenWorld
+doAfterPlacements gw = foldr doAfterPlacement gw (_gPlacements gw)
+
+doAfterPlacement :: [(Placement,Int)] -> GenWorld -> GenWorld
+doAfterPlacement pmntis gw = gRandify gw $ do
+    (pmnt,i) <- takeOne pmntis
+    let (newgw,rm) = fst $ placeSpot (gw,_gRooms gw IM.! i) pmnt
+    return $ newgw & gRooms . ix i .~ rm
+
+doPartialPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld
+doPartialPlacements (im,w) = let (gw,rms) = mapAccumR (doPartialPlacement im) w (_gRooms w)
+    in gw {_gRooms = rms}
 
 doPartialPlacement :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room)
 doPartialPlacement im w rm = case _rmPartPmnt rm of
@@ -101,8 +118,9 @@ doPartialPlacement im w rm = case _rmPartPmnt rm of
         Nothing -> (w, rm)
         Just i  -> fst $ placeSpot (w,rm) (fi (im IM.! i))
 
-doExtendedPlacements :: (GenWorld,[Room]) -> ( (IM.IntMap [Placement], GenWorld) , [Room] )
-doExtendedPlacements (w,rms) = mapAccumR doExtendedPlacement (IM.empty,w) rms
+doExtendedPlacements :: GenWorld -> ( IM.IntMap [Placement], GenWorld)
+doExtendedPlacements w = let ((pmnts,gw),rms) = mapAccumR doExtendedPlacement (IM.empty,w) (_gRooms w)
+    in (pmnts,gw{_gRooms = rms})
 
 doExtendedPlacement :: (IM.IntMap [Placement], GenWorld) -> Room 
     -> ( (IM.IntMap [Placement], GenWorld) , Room )
@@ -113,6 +131,10 @@ doExtendedPlacement (im,w) rm = case _rmExtPmnt rm of
         Just i  -> let ((neww,newrm),plmnts) = placeSpot (w,rm) plmnt
             in ( (IM.insert i plmnts im, neww) , newrm )
 
+doIndividualPlacements :: GenWorld -> GenWorld
+doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_gRooms gw)
+    in gw' {_gRooms = rms}
+
 doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room)
 doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
 
@@ -142,16 +164,18 @@ initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~
 --makePath = concatMap _rmPath . flatten
 
 wallsFromRooms :: [Room] -> IM.IntMap Wall
-wallsFromRooms =
---    divideWalls .
-    IM.fromList . zipWith f [0..] . removeInverseWalls 
-        . foldl' (flip cutWalls) [] . concatMap _rmPolys
+wallsFromRooms = --    divideWalls .
+    IM.fromAscList 
+    . zipWith f [0..] 
+    . removeInverseWalls 
+    . foldl' (flip cutWalls) [] 
+    . concatMap _rmPolys
   where
     f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
 
 -- TODO sort out shifting before or after etc
 gameRoomsFromRooms :: [Room] -> [GameRoom]
-gameRoomsFromRooms = map gameRoomFromRoom
+gameRoomsFromRooms = fmap gameRoomFromRoom
 
 gameRoomFromRoom :: Room -> GameRoom
 gameRoomFromRoom rm = GameRoom