Fix bug in the placement of mounted lightsources when shifted

src/Dodge/LevelGen/Data.hs

@@ -150,7 +150,7 @@ spNoID :: PlacementSpot -> PSType -> Placement
 spNoID ps pst = Placement ps pst Nothing (const Nothing)
 
 pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
-pContID ps pt = Placement ps pt Nothing . intPlPlPl
+pContID ps pt = Placement ps pt Nothing . contToIDCont
 
 psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
 psPtCont ps pt = Placement ps pt Nothing
@@ -183,19 +183,16 @@ jsps0J :: PSType -> Placement -> Maybe Placement
 jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ -> Just plm
 
 ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
-ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
+ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . contToIDCont
 
 pt0 :: PSType -> (Placement -> Maybe Placement) -> Placement
 pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing
 
 contToIDCont :: (Int -> Maybe Placement) -> Placement -> Maybe Placement
-contToIDCont f plmnt = f $ fromJust (_plMID plmnt)
+contToIDCont f = f . fromJust . _plMID
-
-intPlPlPl :: (Int -> Maybe Placement) -> Placement -> Maybe Placement
-intPlPlPl f = f . fromJust . _plMID
 
 jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
-jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
+jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . contToIDCont
 
 jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
 jps0PushPS pst f = Just . Placement (PS (V2 0 0) 0) pst Nothing
@@ -209,6 +206,7 @@ psj ps pst plmnt = Placement ps pst Nothing (const $ Just plmnt)
 
 ps0jPushPS :: PSType -> Placement -> Placement
 ps0jPushPS pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p)
+--ps0jPushPS pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt)
 
 addPlmnt :: Placement -> Placement -> Placement
 addPlmnt pl pl2 = case pl2 of

src/Dodge/Placement/Shift.hs

@@ -13,7 +13,9 @@ shiftPSBy (pos,rot) ps = ps
 shiftPlacement :: (Point2,Float) -> Placement -> Placement
 shiftPlacement shift plmnt = case plmnt of
     Placement {} -> plmnt & plSpot %~ shiftPSBy shift 
-        & plIDCont %~ fmap (fmap $ shiftPlacement shift)
+-- TODO check whether the following continuation is ever necessary
+-- it can interfere with ps0jPushPS
+--        & plIDCont %~ fmap (fmap $ shiftPlacement shift)
     PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
         (fmap (shiftPlacement shift) f)
     RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl

src/Dodge/Room/Boss.hs

@@ -25,7 +25,6 @@ roomGlassOctogon
     :: Float    -- ^ Size
     -> Room
 roomGlassOctogon x = createPathGrid $ defaultRoom
---roomGlassOctogon x = defaultRoom
     { _rmPolys = 
         [rectNSWE x (-x) (-x) x
         ,rectNSWE 0 (-(x + 40)) (-20) 20
@@ -126,7 +125,7 @@ roomShuriken x y =
             , _rmPmnts  = [mntLS iShape (V2 x x) (V3 (x-20) x 70)]
             , _rmBound  = ps
             }
-    in (foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2])
+    in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2])
             {_rmName = "shuriken"}
 {- | TODO: pathing 
 Precondition: first float is less than the second by at least 40. -}
@@ -151,5 +150,5 @@ roomTwistCross x y z =
             , _rmPmnts  = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)]
             , _rmBound  = map (expandPolyCorners 10) ps
             }
-    in (foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2])
+    in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2])
         {_rmName = "twistCross" }

src/Dodge/Room/Procedural.hs

@@ -12,7 +12,7 @@ module Dodge.Room.Procedural
 import Dodge.Data
 import Dodge.Placement.Shift
 import Dodge.Default.Wall
-import Shape.Data
+--import Shape.Data
 import Dodge.PlacementSpot
 import Dodge.Placement.Instance
 import Dodge.RoomLink
@@ -109,8 +109,8 @@ combineFloors :: Floor -> Floor -> Floor
 combineFloors f _ = f
 {- Randomly generate a top fourth of a room possibly with a wall.
 Add a light and a 'PutNothing' placement.  -}
-quarterRoomFlat :: RandomGen g => Float -> State g Room
+quarterRoomTri :: RandomGen g => Float -> State g Room
-quarterRoomFlat w = do
+quarterRoomTri w = do
     let commonPlacements = 
             [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70)
             , sPS (V2 (w-20) (w-20)) pi PutNothing 
@@ -140,26 +140,8 @@ 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
+quarterRoomSquare :: RandomGen g => Float -> State g Room
-quarterRoomFlat' mntshape col w = do
+quarterRoomSquare 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 
         [   [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
             , blockLine (V2 (w/2) (w/2)) (V2 0 w)
@@ -220,17 +202,14 @@ shufflePlacements r = do
 Tight corridors, random placements. -}
 randomFourCornerRoom :: RandomGen g => [Item] -> State g Room
 randomFourCornerRoom its = do
-    corners <- replicateM 4 . join $ takeOne [quarterRoomFlat 100, fourthCornerWall 100]
+    corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 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 :)
+        . over rmPmnts ( sps0 putLamp :)
         . foldr1 combineRooms
         $ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
         )