Commit before attempting to fix placement shifting bug

src/Dodge/Placement/Instance/LightSource.hs

@@ -80,6 +80,15 @@ vShape wallpos (V3 x y z) =
 mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
 mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing)
 
+mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
+mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
+
+mntLSLampCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
+mntLSLampCol shp (V4 x y z _) wallp lampp = mntLSOn shp Nothing (defaultLS & lsParam . lsCol .~ col)
+    wallp lampp (const Nothing)
+  where
+    col = V3 x y z
+
 mntLSCond :: (Point2 -> Point3 -> Shape) 
     -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) 
     -> Placement

src/Dodge/Placement/Shift.hs

@@ -9,7 +9,7 @@ import Control.Lens
 shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
 shiftPSBy (pos,rot) ps = ps
     & psPos %~ shiftPointBy (pos,rot)
-    & psRot %~ (+ rot)
+    & psRot +~ rot
 shiftPlacement :: (Point2,Float) -> Placement -> Placement
 shiftPlacement shift plmnt = case plmnt of
     Placement {} -> plmnt & plSpot %~ shiftPSBy shift 

src/Dodge/Room/Link.hs

@@ -6,6 +6,7 @@ the outgoing links.  -}
 module Dodge.Room.Link
     ( shiftRoomShiftToLink
     , shiftRoomBy
+    , moveRoomBy
     , shiftLinkBy
     , doRoomShift
     , sortOutLinksOn
@@ -21,6 +22,7 @@ module Dodge.Room.Link
     ) where
 import Dodge.ShiftPoint
 --import Dodge.Placement.PlaceSpot
+import Dodge.Placement.Shift
 import Dodge.LevelGen.Data
 import Dodge.RandomHelp
 import Geometry
@@ -141,6 +143,20 @@ shiftRoomBy shift r = r
         )
     & rmViewpoints %~ map (shiftPointBy shift)
 
+moveRoomBy :: (Point2,Float) -> Room -> Room
+moveRoomBy shift r = r
+    & rmPolys %~ fmap (map (shiftPointBy shift))
+    & rmLinks %~ fmap (shiftLinkBy shift)
+    & rmPath  %~ map (shiftPathBy shift)
+    & rmBound %~ fmap (map (shiftPointBy shift))
+    & rmPmnts %~ map (shiftPlacement shift)
+    & rmFloor . tiles %~ map 
+        ( (tilePoly %~ map (shiftPointBy shift))
+        . (tileZero %~ shiftPointBy shift    )
+        . (tileX    %~ shiftPointBy shift         )
+        )
+    & rmViewpoints %~ map (shiftPointBy shift)
+
 shiftRoomShiftToLink :: (Point2,Float) -> (Point2,Float) -> Room -> Room
 shiftRoomShiftToLink l inlink r 
     = shiftRoomShiftBy l 

src/Dodge/Room/Procedural.hs

@@ -12,6 +12,7 @@ module Dodge.Room.Procedural
 import Dodge.Data
 import Dodge.Placement.Shift
 import Dodge.Default.Wall
+import Shape.Data
 import Dodge.PlacementSpot
 import Dodge.Placement.Instance
 import Dodge.RoomLink
@@ -89,8 +90,10 @@ combineRooms r r' = defaultRoom
     , _rmLinks = _rmLinks r ++ _rmLinks r'
     , _rmPath  = map clampPath $ _rmPath  r 
               ++ _rmPath  r'
-    , _rmPmnts    = map (shiftPlacement $ _rmShift r)  (_rmPmnts r) 
-              ++ map (shiftPlacement $ _rmShift r') (_rmPmnts r')
+    , _rmPmnts    = (_rmPmnts r) 
+              ++ (_rmPmnts r')
+    --, _rmPmnts    = map (shiftPlacement $ _rmShift r)  (_rmPmnts r) 
+    --          ++ map (shiftPlacement $ _rmShift r') (_rmPmnts r')
     , _rmBound = _rmBound r ++ _rmBound r'
     , _rmFloor = combineFloors (_rmFloor r) (_rmFloor r')
     , _rmShift  = (V2 0 0 , 0)
@@ -137,6 +140,24 @@ quarterRoomFlat w = do
         , _rmPmnts     = b
         , _rmBound  = [[V2 0 0,V2 w w,V2 (-w) w]]
         }
+quarterRoomFlat' :: RandomGen g => (Point2 -> Point3 -> Shape) -> Color -> Float -> State g Room
+quarterRoomFlat' mntshape col w = do
+    let b = [ mntLSLampCol mntshape col (V2 (w-20) w) (V3 (w-20) (w-20) 70)
+            ]
+    pure $ defaultRoom
+        { _rmPolys  = [ [V2 0 0,V2 w w,V2 (-w) w] ]
+        , _rmLinks  = [toBothLnk (V2 0 w, 0)]
+        , _rmPath   = concatMap doublePair
+            [(V2 0 w,V2 0 (w-20))
+            ,(V2 0 (w-20),V2 (w-20) (w-20))
+            ,(V2 0 (w-20),V2 (55-w) (w-20))
+            ,(V2 (55-w) (w-20),V2 (20-w) (w-20))
+            ,(V2 0 (w-20),V2 0 0)
+            ,(V2 (55-w) (w-20),V2 0 0)
+            ]
+        , _rmPmnts     = b
+        , _rmBound  = [[V2 0 0,V2 w w,V2 (-w) w]]
+        }
 fourthCornerWall :: RandomGen g => Float -> State g Room
 fourthCornerWall w = do
     b <- takeOne 
@@ -200,15 +221,18 @@ Tight corridors, random placements. -}
 randomFourCornerRoom :: RandomGen g => [Item] -> State g Room
 randomFourCornerRoom its = do
     corners <- replicateM 4 . join $ takeOne [quarterRoomFlat 100, fourthCornerWall 100]
+--    corners <- sequence $ map (\s -> uncurry quarterRoomFlat' s 100) $ zip 
+--        [iShape,vShape,lShape,jShape]
+--        [red,yellow,green,blue]
     itms <- shuffle its
     nCrits <- state $ randomR (1,3)
     crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
         ++ replicate 20 chaseCrit
     randomiseAllLinks . fillNothingPlacements (crits ++ map PutFlIt itms) =<< 
         ( shufflePlacements
-        . over rmPmnts ( sps0 putLamp :)
-        . foldr1 combineRooms 
-        $ zipWith (\r a -> shiftRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
+--        . over rmPmnts ( sps0 putLamp :)
+        . foldr1 combineRooms
+        $ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
         )
 {- | Creates room with a central vault with doors around it.  -}
 centerVaultRoom