Commit before unifying positions

src/Dodge/Layout.hs

@@ -3,8 +3,10 @@ module Dodge.Layout
     where
 import Dodge.Data
 import Dodge.LevelGen
+import Dodge.LevelGen.Data
 import Dodge.LevelGen.StaticWalls
 import Dodge.LevelGen.Pathing
+import Dodge.Placements.Spot
 import Dodge.Base
 import Dodge.Zone
 import Dodge.GameRoom
@@ -25,7 +27,7 @@ import Tile
 import Polyhedra
 import Polyhedra.Data
 
-import Data.List (nubBy)
+import Data.List (nubBy, partition,mapAccumR)
 import Control.Monad.State
 import Control.Lens
 import System.Random
@@ -50,10 +52,25 @@ generateLevelFromRoomList gr w
   where
     path = pairsToGraph dist pairPath
     pairPath = concatMap _rmPath rs
-    plmnts = concatMap (\r -> map (_rmShift r ,) (_rmPS r)) rs
-    rs = zipWith addTile zs rs'
+    plmnts = concatMap (\r -> map (_rmShift r ,) (assignPlacementSpots r)) rs
+    rs = zipWith addTile zs . evalState gr $ _randGen w
     zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
-    rs' = evalState gr $ _randGen w
+
+assignPlacementSpots :: Room -> [Placement]
+assignPlacementSpots rm = plmnts ++ plmnts'
+  where
+    (lnkplmnts, plmnts) = partition islnk (_rmPS rm)
+    islnk Placement{_placementSpot=PSLnk{}} = True
+    islnk _ = False
+    (_,plmnts') = mapAccumR f (_rmLinks rm) lnkplmnts
+    f lnks plmnt = 
+        let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks
+            thepair = _psLinkShift (_placementSpot plmnt) x
+        in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt)
+
+updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot
+updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
+updatePSLnkUsing _ ps = ps
 
 setupWorldBounds :: World -> World
 setupWorldBounds w = w
@@ -106,10 +123,10 @@ wallsFromTree t =
 wallsFromRooms :: [Room] -> IM.IntMap Wall
 wallsFromRooms =
 --    divideWalls .
-    IM.fromList . zip [0..] . zipWith f [0..] . removeInverseWalls 
+    IM.fromList . zipWith f [0..] . removeInverseWalls 
         . foldl' (flip cutWalls) [] . concatMap _rmPolys
   where
-    f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}
+    f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
 
 gameRoomsFromRooms :: [Room] -> [GameRoom]
 gameRoomsFromRooms = map f