Working room generation with less shifting, should be more sensible

src/Dodge/Layout.hs

@@ -33,7 +33,7 @@ generateLevelFromRoomList gr' w
     . placeWires
     . doPartialPlacements
     . doExtendedPlacements
-    . flip (mapAccumR doRoomPlacements) rs
+    . flip (mapAccumR doRoomPlacements) rs'
     $ w { _walls        = wallsFromRooms rs
         , _floorTiles   = floorsFromRooms rs
         , _gameRooms    = gameRoomsFromRooms rs
@@ -43,9 +43,9 @@ generateLevelFromRoomList gr' w
   where
     path = pairsToGraph dist pairPath
     pairPath = concatMap _rmPath rs
-    rs = zipWith addTile zs gr
     zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
-    gr = map doRoomShift gr'
+    rs = map doRoomShift rs'
+    rs' = zipWith addTile zs gr'
 
 placeWires :: (World,[Room])-> World
 placeWires (w,rms) = foldr placeRoomWires w rms

src/Dodge/Layout/Tree/Shift.hs

@@ -16,11 +16,10 @@ import Data.List (delete)
 import Data.Bifunctor
 import Control.Lens hiding (Empty, (<|) , (|>))
 
-positionRooms :: Tree RoomInt -> IO (Maybe [Room])
-positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
-
 type RoomInt = (Room,Int)
 
+positionRooms :: Tree RoomInt -> IO (Maybe [Room])
+positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
 
 posRms :: [ConvexPoly]
     -> RoomInt
@@ -50,8 +49,8 @@ posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
         clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
         newr = (lnkEff l $ r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :)
             , i)
-        shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t
+        (Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t
-        shiftedt'@(Node (r'',_) _) = applyToRoot (first $ shiftRoomShiftToLink l) t
+        shiftedt' = applyToRoot (first $ shiftRoomShiftToLink l) t
 
 lnkEff :: (Point2,Float) -> Room -> Room
 lnkEff x rm = case _rmLinkEff rm of

src/Dodge/LevelGen.hs

@@ -49,11 +49,6 @@ placeSpot (w,rm) plmnt = case plmnt of
   where
     shift = _rmShift rm
 
-invShiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
-invShiftPSBy (pos,rot) (PS p r) = PS (invShiftPointBy (pos,rot) p) (r - rot)
-invShiftPSBy _ ps = ps
-
-
 -- this should be tidied up
 placeSpotUsingLink :: World -> Room -> Placement 
     -> (RoomPos -> Maybe PlacementSpot)
@@ -67,7 +62,7 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
         Just plmnt' -> placeSpot (w,rm) plmnt'
   where
     searchedPoss [] = error "no correct pos type for lnk placement"
-    searchedPoss (pos:poss) = case extract (invShiftPosBy (_rmShift rm) pos) of
+    searchedPoss (pos:poss) = case extract pos of
         Nothing -> second (pos:) <$> searchedPoss poss
         Just ps -> Just ( ps,pos, poss)
 
@@ -135,17 +130,6 @@ shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
 invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
 invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1
 
-invShiftPosBy :: (Point2,Float) -> RoomPos -> RoomPos
-invShiftPosBy s rp = case rp of
-    OutLink i p a   -> uncurry (OutLink i)  $ invShiftLinkBy s (p,a)
-    InLink  p a     -> uncurry (InLink)     $ invShiftLinkBy s (p,a)
-    UnusedLink p a  -> uncurry (UnusedLink) $ invShiftLinkBy s (p,a)
-    PosPl   p a     -> uncurry (PosPl)      $ invShiftLinkBy s (p,a)
-    LabPos  i rp'   -> LabPos i $ invShiftPosBy s rp'
-
-invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
-invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
-
 shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
 shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)
 

src/Dodge/Placements/Button.hs

@@ -8,15 +8,11 @@ import Dodge.LevelGen.Data
 import Dodge.Default
 import Dodge.LevelGen.Switch
 import Dodge.Placements.LightSource
-import Dodge.Placements.Spot
 
 import Data.Maybe
 import Control.Lens
 
 externalButton :: Color -> PlacementSpot -> Placement
---externalButton col ps = pContID ps (PutTrigger (const False))
---    $ \trigid -> Just $ pContID ps (PutButton (makeSwitch col col (oneff trigid) (offeff trigid))) 
---                    (const Nothing)
 externalButton col ps = plCont ps (PutTrigger (const False))
     $ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (oneff $ trigid tp) (offeff $ trigid tp))) 
                     (const Nothing)
@@ -38,7 +34,7 @@ putLitButtonID col p a subpl = mntLSOn aShape (Just col) ls p'' (addZ 40 p')
 
 putLitButOnPos :: Color -> (RoomPos -> Maybe PlacementSpot) -> (Int -> Maybe Placement) -> Placement
 putLitButOnPos col f subpl 
-    = updatePSToLevel 1 (const thePS) $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
+    = plSpot .~ thePS $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
     $ \plmnt -> let lsid = fromJust $ _plMID plmnt
         in jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = V2 0 (-1), _btRot = pi})
                 subpl <&> plSpot .~ _plSpot plmnt

src/Dodge/Placements/LightSource.hs

@@ -3,7 +3,6 @@ import Dodge.Data
 import Dodge.LightSources.Lamp
 import Dodge.LevelGen.Data
 import Dodge.Room.Foreground
-import Dodge.Placements.Spot
 import Geometry
 import Geometry.Vector3D
 import Dodge.Creature.Inanimate
@@ -13,6 +12,8 @@ import Dodge.RandomHelp
 import Color
 import Shape
 
+import Control.Lens
+
 -- | mount a light source on a shape
 mntLSOn
     :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
@@ -80,8 +81,9 @@ mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
 mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing)
 
 mntLSCond :: (Point2 -> Point3 -> Shape) -> (RoomPos -> Maybe PlacementSpot) -> Placement
-mntLSCond shp shift = updatePSToLevel 2 (const $ PSLnk shift (const id) Nothing) 
+mntLSCond shp shift = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $ 
-    $ mntLS shp 0 (V3 0 (-40) 90)
+    mntLS shp 0 (V3 0 (-40) 90)
+    & plSpot .~ PSLnk shift (const id) Nothing
     -- note that this perhaps pushes the vshape light out too far
 
 mntLight :: Point2 -> Point2 -> Placement

src/Dodge/Placements/Spot.hs

@@ -1,30 +0,0 @@
-module Dodge.Placements.Spot
-    ( setPS
-    , setLocalPS
-    , updatePS
-    , updatePSToLevel
-    ) where
-import Dodge.LevelGen.Data
-
-setPS :: PlacementSpot -> Placement -> Placement
-setPS = updatePS . const
-
--- TODO remove this, use previous placement spots in continued placements
--- instead
-updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Placement
-updatePSToLevel 0 _ plmnt = plmnt
-updatePSToLevel i f plmnt = case plmnt of
-    PlacementUsingPos p pl  -> PlacementUsingPos p (fmap (updatePSToLevel i f) pl)
-    Placement ps pt mi pl   -> Placement (f ps) pt mi (fmap (fmap (updatePSToLevel (i-1) f)) pl)
-    RandomPlacement rplmnt  -> RandomPlacement $ fmap (updatePSToLevel i f) rplmnt
-
-setLocalPS :: PlacementSpot -> Placement -> Placement
-setLocalPS ps (Placement _ pt mi f) = Placement ps pt mi f
-setLocalPS ps (RandomPlacement rplmnt) = RandomPlacement (fmap (setLocalPS ps) rplmnt)
-setLocalPS _ plmnt = plmnt
-
-updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement
-updatePS f pl' = case pl' of
-    Placement ps pt mi ipl  -> Placement (f ps) pt mi $ (fmap . fmap $ updatePS f) ipl
-    PlacementUsingPos p pl  -> PlacementUsingPos p (fmap (updatePS f) pl)
-    RandomPlacement rpl     -> RandomPlacement (fmap (updatePS f) rpl)

src/Dodge/Room/Start.hs

@@ -28,7 +28,7 @@ startRoom = do
     h <- state $ randomR (200,400)
     let plmnts = 
             [ sPS (V2 0 0) 0 $ PutForeground $ 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