From 59f43a36022d9572513cca5f414f84b47d3a511b Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Tue, 2 Nov 2021 19:38:22 +0000
Subject: [PATCH] Add lights to buttons, cleanup

---
 src/Dodge/Data.hs                             |   2 +
 src/Dodge/Default.hs                          |   4 +-
 src/Dodge/Default/World.hs                    |   1 +
 src/Dodge/Floor.hs                            |   2 +-
 src/Dodge/Layout.hs                           |   2 +-
 src/Dodge/LevelGen.hs                         |  85 ++++---------
 src/Dodge/LevelGen/Block.hs                   |  18 ++-
 src/Dodge/LevelGen/Data.hs                    |   2 +
 src/Dodge/LevelGen/TriggerDoor.hs             |   8 +-
 src/Dodge/LightSources/Fitting.hs             |  80 -------------
 src/Dodge/Placements.hs                       |  34 ++----
 src/Dodge/Placements/Button.hs                |  22 ++++
 src/Dodge/Placements/Door.hs                  |  39 ++++++
 src/Dodge/Placements/LightSource.hs           | 113 ++++++++++++++++++
 .../{Room/Placement.hs => Placements/Wall.hs} |  96 +++++----------
 src/Dodge/Room.hs                             |  23 +---
 src/Dodge/Room/Airlock.hs                     |  10 +-
 src/Dodge/Room/Boss.hs                        |  11 +-
 src/Dodge/Room/Corridor.hs                    |   4 +-
 src/Dodge/Room/LongDoor.hs                    | 101 +++++++++-------
 src/Dodge/Room/Procedural.hs                  |  30 ++---
 src/Dodge/Room/RoadBlock.hs                   |   7 +-
 src/Dodge/Room/Start.hs                       |   4 +-
 src/Dodge/Room/Teleport.hs                    |   2 +-
 src/Dodge/Room/Treasure.hs                    |   5 +-
 25 files changed, 356 insertions(+), 349 deletions(-)
 delete mode 100644 src/Dodge/LightSources/Fitting.hs
 create mode 100644 src/Dodge/Placements/Button.hs
 create mode 100644 src/Dodge/Placements/Door.hs
 create mode 100644 src/Dodge/Placements/LightSource.hs
 rename src/Dodge/{Room/Placement.hs => Placements/Wall.hs} (65%)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index ab8d4e26b..402b104bb 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -59,6 +59,7 @@ data World = World
     , _doors                :: IM.IntMap Door
     , _machines             :: IM.IntMap Machine
     , _blocks               :: IM.IntMap Block
+    , _coordinates          :: IM.IntMap Point2
     , _wallsZone            :: Zone (IM.IntMap Wall)
     , _floorItems           :: IM.IntMap FloorItem
     , _floorTiles           :: [(Point3,Point3)]
@@ -569,6 +570,7 @@ data Door = Door
     , _drStatus  :: DoorStatus
     , _drTrigger :: World -> Bool
     , _drMech    :: Door -> World -> World
+    , _drCoord   :: Int
     }
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
   deriving (Eq, Ord, Show)
diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs
index 0c0ee9b60..d7b6c316a 100644
--- a/src/Dodge/Default.hs
+++ b/src/Dodge/Default.hs
@@ -276,8 +276,8 @@ defaultLS = LS
     { _lsID = 0
     , _lsPos = 0
     , _lsDir = 0
-    , _lsRad = 4
-    , _lsIntensity = 0.5
+    , _lsRad = 700
+    , _lsIntensity = 0.6
     , _lsPict = defLSPic 
     }
 defLSPic :: LightSource -> Picture
diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs
index 3126ad22b..5f1adb628 100644
--- a/src/Dodge/Default/World.hs
+++ b/src/Dodge/Default/World.hs
@@ -38,6 +38,7 @@ defaultWorld = World
     , _blocks = IM.empty
     , _machines = IM.empty
     , _doors = IM.empty
+    , _coordinates = IM.empty
     , _wallsZone = Zone IM.empty
     , _floorItems = IM.empty
     , _floorTiles = []
diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs
index 9d0490b75..45fdb471a 100644
--- a/src/Dodge/Floor.hs
+++ b/src/Dodge/Floor.hs
@@ -36,7 +36,7 @@ initialRoomTree = do
             [[StartRoom]
             ,[Corridor]
             ,[Corridor]
-            ,[SpecificRoom slowDoorRoom ]
+            ,[SpecificRoom $ fmap connectRoom slowDoorRoom ]
             ,[Corridor]
             ,[Corridor]
             ,[Corridor]
diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs
index 74ace23fe..fcfb239ee 100644
--- a/src/Dodge/Layout.hs
+++ b/src/Dodge/Layout.hs
@@ -4,7 +4,7 @@ module Dodge.Layout
 import Dodge.Data
 import Dodge.LevelGen
 import Dodge.LevelGen.StaticWalls
---import Dodge.LevelGen.Data
+import Dodge.LevelGen.Pathing
 import Dodge.Base
 import Dodge.Zone
 import Dodge.GameRoom
diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs
index 5be5883b6..d55783d72 100644
--- a/src/Dodge/LevelGen.hs
+++ b/src/Dodge/LevelGen.hs
@@ -2,18 +2,14 @@
 -- | deals with placement of objects within the world
 -- after they have had their coordinates set by the layout
 module Dodge.LevelGen 
-    ( module Dodge.LevelGen
-    , cutWalls
-    , pairsToGraph
-    , makeButton
-    , makeSwitch
+    ( shiftPlacement
+    , shiftPointBy
+    , placeSpot
     ) where
 import Dodge.Data
 import Dodge.LevelGen.Block
 import Dodge.LevelGen.Pathing
-import Dodge.LevelGen.StaticWalls
 import Dodge.LevelGen.TriggerDoor
-import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Data
 import Dodge.Default.Wall
 import Geometry
@@ -27,13 +23,16 @@ import Control.Lens
 import qualified Data.IntSet as IS
 
 placeSpot :: World -> ((Point2,Float) , Placement) -> World
-placeSpot w (shift, plmnt) =
+placeSpot w (shift, plmnt@Placement{}) =
     let (i,w') =  placeSpotID (shiftPSBy shift (_placementSpot plmnt)) w
     in  maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)
+placeSpot w (shift, PlacementPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))
 
 shiftPlacement :: (Point2,Float) -> Placement -> Placement
 shiftPlacement shift (Placement ps f) = Placement (shiftPSBy shift ps)
      (fmap (fmap $ shiftPlacement shift) f)
+shiftPlacement shift (PlacementPos p f) = PlacementPos (shiftPoint3By shift p)
+     (fmap (shiftPlacement shift) f)
 
 shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
 shiftPSBy (pos,rot) ps = ps
@@ -54,13 +53,12 @@ placeSpotID ps w = case _psType ps of
     RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
       where 
         (evaluatedType, g) = runState rgen (_randGen w)
-    PutDoor col f pss -> putDoor col f (map (bimap doShift doShift) pss) w
-    PutSlideDoor pathing col f a b speed 
-        -> placeSlideDoor pathing col f (doShift a) (doShift b) speed w
+    PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
+    PutCoordinate coordp -> placeCoordinate (doShift coordp) w
+    PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
     PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
     PutBlock{} -> error "messed up block placement somehow"
-    PutLineBlock wl width depth a b
-        -> placeLineBlock wl width depth (doShift a) (doShift b) w
+    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
     PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
       where 
         qs = map doShift ps'
@@ -68,37 +66,18 @@ placeSpotID ps w = case _psType ps of
     PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
     PutNothing -> (0,w)
     PutID i -> (i, w)
-    --_   -> w
   where 
     p@(V2 px py) = _psPos ps
     p' = V3 px py 0
     rot = _psRot ps
     doShift = shiftPointBy (p,rot)
 
--- TODO: remove this typeclass
-class Shiftable a where
-    translateS :: Point2 -> a -> a
-    rotateS    :: Float -> a -> a
-
-instance {-# OVERLAPPING #-} Shiftable Point2 where
-    translateS = (+.+)
-    rotateS    = rotateV
-
-instance (Shiftable a,Shiftable b) => Shiftable (a, b) where
-    translateS p (x,y) = (translateS p x,translateS p y)
-    rotateS    r (x,y) = (   rotateS r x,   rotateS r y)
-
-instance (Shiftable a) => Shiftable [a] where
-    translateS p x = map (translateS p) x
-    rotateS    r x = map (rotateS r)    x
-
-instance Shiftable PlacementSpot where
-    translateS p' (PS p r x) = PS (p +.+ p') r x
-    rotateS    r' (PS p r x) = PS (rotateV r' p) (r + r') x
-
 shiftPointBy :: (Point2,Float) -> Point2 -> Point2
 shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
 
+shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
+shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)
+
 addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
 addWalls qs wl wls = foldr (addPane wl) wls pairs
   where 
@@ -106,11 +85,14 @@ addWalls qs wl wls = foldr (addPane wl) wls pairs
     pairs = zip (ps ++ [p]) (p:ps)
 
 addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
-addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl
-    { _wlLine = (p0,p1)
-    , _wlID = IM.newKey wls
-    })
-    wls
+addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
+  where
+    wlid = IM.newKey wls
+
+placeCoordinate :: Point2 -> World -> (Int,World)
+placeCoordinate p w = (i, w & coordinates %~ IM.insert i p)
+  where
+    i = IM.newKey $ _coordinates w
 
 placeProp 
     :: Prop
@@ -144,15 +126,9 @@ placeFlIt
     -> Float    -- ^ Rotation
     -> World
     -> (Int, World)
-placeFlIt itm p rot w = (i, w & floorItems %~ 
-    \ fis -> IM.insert i 
-        (FlIt
-            { _flItPos = p
-            , _flItRot = rot
-            , _flItID = i
-            , _flIt = itm
-            }
-        ) fis
+placeFlIt itm p rot w = (i, w & floorItems %~ \ fis -> IM.insert i 
+    ( FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
+    ) fis
     )
   where
     i = IM.newKey $ _floorItems w
@@ -168,12 +144,6 @@ placePressPlate pp p rot w = (i , over pressPlates addPP w)
     i = IM.newKey $ _pressPlates w
     addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
 
-placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
-placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
-  where 
-    cid = IM.newKey (_creatures w)
-    cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 
-
 placeCr :: Creature -> Point2 -> Float -> World -> (Int,World)
 placeCr crF p rot w = (cid, over creatures addCr w)
   where 
@@ -204,7 +174,4 @@ placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
   where 
     i = IM.newKey $ _lightSources w
     startPos = onXY (rotateV rot) $ _lsPos ls
-    addLS lss = IM.insert 
-        (IM.newKey lss) 
-        (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss}) 
-        lss
+    addLS = IM.insert i (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = i})
diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs
index 78df50df1..fc519cd4f 100644
--- a/src/Dodge/LevelGen/Block.hs
+++ b/src/Dodge/LevelGen/Block.hs
@@ -75,33 +75,31 @@ placeLineBlock
 placeLineBlock basePane blockWidth depth a b w = (,) 0 
     $ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
   where 
-    d = dist a b
-    rot = argV (b -.- a)
     psOnLine = divideLineOddNumPoints blockWidth a b
-    halfBlockWidth = d / fromIntegral (length psOnLine - 1)
+    halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
     blockCenPs = snd $ evenOddSplit psOnLine
     numBlocks = length blockCenPs
     is = [0.. numBlocks - 1]
     cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
-    cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
+    cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
     linesAt p = loopPairs $ cornersAt p
-    k = IM.newKey $ _walls w
+    wlid = IM.newKey $ _walls w
     blid = IM.newKey $ _blocks w
     insertBlock i = over blocks $ IM.insert (i+blid) Block 
         {_blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
     insertBlocks = flip (foldr insertBlock) is
-    ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
+    ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
     visibilityAt i 
-        | i == 0             = [ True,True,False,True]
-        | i == numBlocks - 1 = [False,True, True,True]
+        | i == 0             = [False,True,True ,True]
+        | i == numBlocks - 1 = [True ,True,False,True]
         | otherwise          = [False,True,False,True]
     shadowsAt i
         | i == 0             = ksAtI 1
         | i == numBlocks - 1 = ksAtI $ numBlocks - 2
         | otherwise          = ksAtI (i-1) ++ ksAtI (i+1)
     makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
-    makePane i visStatus k' ps = basePane
-        {_wlID = k'
+    makePane i visStatus k ps = basePane
+        {_wlID = k
         ,_wlStructure = BlockPart $ i + blid
         ,_wlLine = ps
         ,_wlDraw = visStatus
diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs
index ea8d027d0..7b35c3826 100644
--- a/src/Dodge/LevelGen/Data.hs
+++ b/src/Dodge/LevelGen/Data.hs
@@ -18,6 +18,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutFlIt Item
     | PutPressPlate PressPlate
     | PutBlock [Int] Color [Point2]
+    | PutCoordinate Point2
     | PutLineBlock Wall Float Float Point2 Point2
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float
@@ -36,6 +37,7 @@ data Placement = Placement
     { _placementSpot :: PlacementSpot
     , _idPlacement :: Int -> Maybe Placement 
     }
+  | PlacementPos Point3 (Point3 -> Placement)
 
 sPS :: Point2 -> Float -> PSType -> Placement
 sPS p a pt = Placement (PS p a pt) (const Nothing)
diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs
index b20e15c6d..f66d19c7b 100644
--- a/src/Dodge/LevelGen/TriggerDoor.hs
+++ b/src/Dodge/LevelGen/TriggerDoor.hs
@@ -1,6 +1,6 @@
 --{-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.TriggerDoor
-    ( putDoor
+    ( placeDoor
     , placeSlideDoor
     --, addButtonDoor
     ) where
@@ -24,14 +24,14 @@ import Data.List
 import Control.Lens
 --import Data.Graph.Inductive hiding ((&))
 import qualified Data.IntSet as IS
-putDoor 
+placeDoor 
     :: Color 
     -> (World -> Bool)      -- ^ Opening condition
     -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
                     -- Bumped out up and down by 9, not widened
     -> World 
     -> (Int,World)
-putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
+placeDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
   where
     drid = IM.newKey $ _doors w
     addDoor = IM.insert drid $ Door
@@ -40,6 +40,7 @@ putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
         , _drStatus = DoorInt 0
         , _drTrigger = cond
         , _drMech   = doorMechanismStepwise nsteps drid wlids pss
+        , _drCoord = 0
         }
     nsteps = length pss - 1
     wlids = take 4 [IM.newKey $ _walls w ..]
@@ -112,6 +113,7 @@ placeSlideDoor isPathable col cond a b speed w = (drid, addWalls w & doors %~ ad
         , _drStatus = DoorClosed
         , _drTrigger = cond
         , _drMech   = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
+        , _drCoord = 0
         }
     addWalls w' = foldl' addWall w' $ zip wlids pairs
     addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
diff --git a/src/Dodge/LightSources/Fitting.hs b/src/Dodge/LightSources/Fitting.hs
deleted file mode 100644
index e6e20946a..000000000
--- a/src/Dodge/LightSources/Fitting.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-module Dodge.LightSources.Fitting
-    where
-import Dodge.LightSources.Lamp
-import Dodge.LevelGen.Data
-import Dodge.Room.Foreground
-import Geometry
-
-mountedLight :: Point2 -> Point3 -> Placement
-mountedLight wallPos lampPos@(V3 x y z) 
-    = ps0j (PutForeground $ thinHighBar (z+5) wallPos pout)
-    $ sps0 $ PutLS (colorLightAt 0.75 lampPos 0)
-  where
-    pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wallPos)
-
-mountLightL :: Point2 -> Point3 -> Placement
-mountLightL wallpos lamppos@(V3 x y z)
-    = ps0j (PutLS $ colorLightAt 0.75 lamppos 0)
-    $ sps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
-        <> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
-  where
-    n = vNormal (wallpos -.- V2 x y)
-    wallposUp = wallpos +.+ n
-    turnpos = V2 x y +.+ n
-
-mountedLightJ :: Point2 -> Point3 -> Placement
-mountedLightJ wallpos lamppos@(V3 x y z)
-    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
-    $ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp turn1
-        <> thinHighBar (z + 5) turn1 turn2
-        <> thinHighBar (z + 5) turn2 (endpos `extendAway` turn2)
-  where
-    n = vNormal (wallpos -.- endpos)
-    wallposUp = wallpos +.+ n
-    endpos = V2 x y
-    turnpos = endpos +.+ n
-    turn1 = 0.5 *.* (wallposUp +.+ turnpos)
-    turn2 = 0.5 *.* (turnpos +.+ endpos)
-
-wallMountl :: Point2 -> Point3 -> Placement
-wallMountl wallpos lamppos@(V3 x y z)
-    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
-    $ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
-        <> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
-  where
-    n = vNormal (V2 x y -.- wallpos)
-    wallposUp = wallpos +.+ n
-    turnpos = V2 x y +.+ n
-
-mountLightA :: Point2 -> Point3 -> Placement
-mountLightA wallpos lamppos@(V3 x y z)
-    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
-    $ \_ -> jsps0 $ PutForeground $ girder (z+10) 20 10 pout wallpos
-  where
-    pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
-
-mountColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
-mountColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0)
-    $ sps0 $ PutForeground $ highPipe (h + 5) a b
-  where
-    V2 x y = 0.5 *.* (a +.+ b)
-
-mountedLightI :: Float -> Point2 -> Point2 -> Placement
-mountedLightI h a b = ps0j (PutLS $ lightAt (V3 x y h) 0)
-    $ sps0 $ PutForeground $ highPipe (h + 5) a b
-  where
-    V2 x y = 0.5 *.* (a +.+ b)
-
-mountedLightV :: Point2 -> Point3 -> Placement
-mountedLightV wallpos lamppos@(V3 x y z)
-    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
-    $ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (lxy `extendAway` wallposUp)
-        <> thinHighBar (z + 5) wallposDown (lxy `extendAway` wallposDown)
-  where
-    lxy = V2 x y
-    n = vNormal (wallpos -.- lxy)
-    wallposUp = wallpos +.+ n
-    wallposDown = wallpos -.- n
-
-extendAway :: Point2 -> Point2 -> Point2
-extendAway p x = p +.+ safeNormalizeV (p -.- x)
diff --git a/src/Dodge/Placements.hs b/src/Dodge/Placements.hs
index c5d47ab2a..8df064f1e 100644
--- a/src/Dodge/Placements.hs
+++ b/src/Dodge/Placements.hs
@@ -1,29 +1,11 @@
 module Dodge.Placements
-    ( putDoubleDoor
-    , putDoubleDoorThen
-    , putAutoDoor
+    ( module Dodge.Placements.Door
+    , module Dodge.Placements.LightSource
+    , module Dodge.Placements.Wall
+    , module Dodge.Placements.Button
     )
     where
-import Dodge.Data
-import Dodge.Base
-import Color
-import Geometry
-import Dodge.LevelGen.Data
-import Dodge.Creature.Property
-
-import qualified Data.IntMap.Strict as IM
-
-putDoubleDoor :: Bool -> Color -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Placement
-putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a b speed Nothing
-
-putDoubleDoorThen :: Bool -> Color -> (World -> Bool) 
-    -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
-putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed)
-    $ Placement (PS (V2 0 0) 0 (PutSlideDoor pathing col cond b half speed)) $ const mayp
-  where
-    half = 0.5 *.* (a +.+ b)
-
-putAutoDoor :: Point2 -> Point2 -> Placement
-putAutoDoor a b = putDoubleDoorThen True (dim yellow) cond a b 3 Nothing
-  where
-    cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures
+import Dodge.Placements.Door
+import Dodge.Placements.LightSource
+import Dodge.Placements.Wall
+import Dodge.Placements.Button
diff --git a/src/Dodge/Placements/Button.hs b/src/Dodge/Placements/Button.hs
new file mode 100644
index 000000000..303bc1337
--- /dev/null
+++ b/src/Dodge/Placements/Button.hs
@@ -0,0 +1,22 @@
+module Dodge.Placements.Button
+    where
+import Dodge.Data
+import Color
+import Geometry
+import Geometry.Vector3D
+import Dodge.LevelGen.Data
+import Dodge.Default
+import Dodge.LevelGen.Switch
+import Dodge.Placements.LightSource
+
+import Control.Lens
+
+putLitButtonID :: Color -> Point2 -> Float -> (Int -> Maybe Placement) -> Placement
+putLitButtonID col p a subpl = mountLightlID ls p'' (addZ 40 p')
+    $ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = p, _btRot = a})
+    subpl
+  where
+    p'  = p -.- 20 *.* vNormal (unitVectorAtAngle a)
+    p'' = p +.+ 10 *.* vNormal (unitVectorAtAngle a)
+    changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
+    ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
diff --git a/src/Dodge/Placements/Door.hs b/src/Dodge/Placements/Door.hs
new file mode 100644
index 000000000..8eb809c1d
--- /dev/null
+++ b/src/Dodge/Placements/Door.hs
@@ -0,0 +1,39 @@
+module Dodge.Placements.Door
+    where
+import Dodge.Data
+import Dodge.Base
+import Color
+import Geometry
+import Geometry.Vector3D
+import Dodge.LevelGen.Data
+import Dodge.Creature.Property
+import Dodge.LevelGen.Switch
+
+import qualified Data.IntMap.Strict as IM
+
+putDoubleDoor :: Bool -> Color -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Placement
+putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a b speed Nothing
+
+putDoubleDoorThen :: Bool -> Color -> (World -> Bool) 
+    -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
+putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed)
+    $ Placement (PS (V2 0 0) 0 (PutSlideDoor pathing col cond b half speed)) $ const mayp
+  where
+    half = 0.5 *.* (a +.+ b)
+
+    
+
+putAutoDoor :: Point2 -> Point2 -> Placement
+putAutoDoor a b = PlacementPos (addZ 0 a)
+    $ \az -> PlacementPos (addZ 0 b)
+    $ \bz -> putDoubleDoor True (dim yellow) (cond az bz) a b 3
+  where
+    cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures
+
+switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
+switchDoor btpos btrot dra drb col = Placement (PS btpos btrot $ PutButton $ makeSwitch col red id id)
+    $ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
+    $          sps0   (PutSlideDoor False col (cond btid) drb drc 2)
+  where
+    drc = 0.5 *.* (dra +.+ drb)
+    cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
diff --git a/src/Dodge/Placements/LightSource.hs b/src/Dodge/Placements/LightSource.hs
new file mode 100644
index 000000000..3e4c622af
--- /dev/null
+++ b/src/Dodge/Placements/LightSource.hs
@@ -0,0 +1,113 @@
+module Dodge.Placements.LightSource
+    where
+import Dodge.Data
+import Dodge.LightSources.Lamp
+import Dodge.LevelGen.Data
+import Dodge.Room.Foreground
+import Geometry
+import Dodge.Creature.Inanimate
+import Shape.Data
+import Dodge.Default
+
+mountLightOnShape
+    :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
+    -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightOnShape shapeF ls wallp lsp = ps0j (PutForeground $ shapeF wallp lsp)
+    . ps0 (PutLS $ ls {_lsPos = lsp})
+
+mountLightID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightID = mountLightOnShape f 
+  where
+    f wp (V3 x y z) = thinHighBar (z+5) wp pout
+      where
+        pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wp)
+
+redMID :: (LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement)
+    -> Point2 -> Point3 -> Placement
+redMID f wallp lampp = f defaultLS wallp lampp (const Nothing)
+
+mountLight :: Point2 -> Point3 -> Placement
+mountLight = redMID mountLightID
+
+mountLightLID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightLID = mountLightOnShape f
+  where
+    f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
+            <> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)    
+      where
+        n = vNormal (wallpos -.- V2 x y)
+        wallposUp = wallpos +.+ n
+        turnpos = V2 x y +.+ n
+
+mountLightL :: Point2 -> Point3 -> Placement
+mountLightL = redMID mountLightLID
+
+mountLightJID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightJID = mountLightOnShape f
+  where
+    f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp turn1
+        <> thinHighBar (z + 5) turn1 turn2
+        <> thinHighBar (z + 5) turn2 (endpos `extendAway` turn2)
+      where
+        n = vNormal (wallpos -.- V2 x y)
+        wallposUp = wallpos +.+ n
+        turnpos = V2 x y +.+ n
+        endpos = V2 x y
+        turn1 = 0.5 *.* (wallposUp +.+ turnpos)
+        turn2 = 0.5 *.* (turnpos +.+ endpos)
+
+mountLightJ :: Point2 -> Point3 -> Placement
+mountLightJ = redMID mountLightJID
+
+mountLightlID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightlID = mountLightOnShape f
+  where
+    f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
+        <> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
+      where
+        n = vNormal (V2 x y -.- wallpos)
+        wallposUp = wallpos +.+ n
+        turnpos = V2 x y +.+ n
+
+mountLightll :: Point2 -> Point3 -> Placement
+mountLightll = redMID mountLightlID
+
+mountLightA :: Point2 -> Point3 -> Placement
+mountLightA wallpos lamppos@(V3 x y z)
+    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
+    $ \_ -> jsps0 $ PutForeground $ girder (z+10) 20 10 pout wallpos
+  where
+    pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
+
+mountColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
+mountColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0)
+    $ sps0 $ PutForeground $ highPipe (h + 5) a b
+  where
+    V2 x y = 0.5 *.* (a +.+ b)
+
+mountLightI :: Float -> Point2 -> Point2 -> Placement
+mountLightI h a b = ps0j (PutLS $ lightAt (V3 x y h) 0)
+    $ sps0 $ PutForeground $ highPipe (h + 5) a b
+  where
+    V2 x y = 0.5 *.* (a +.+ b)
+
+mountLightV :: Point2 -> Point3 -> Placement
+mountLightV wallpos lamppos@(V3 x y z)
+    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
+    $ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (lxy `extendAway` wallposUp)
+        <> thinHighBar (z + 5) wallposDown (lxy `extendAway` wallposDown)
+  where
+    lxy = V2 x y
+    n = vNormal (wallpos -.- lxy)
+    wallposUp = wallpos +.+ n
+    wallposDown = wallpos -.- n
+
+extendAway :: Point2 -> Point2 -> Point2
+extendAway p x = p +.+ safeNormalizeV (p -.- x)
+
+putColorLamp :: Point3 -> PSType
+putColorLamp col = PutCrit (colorLamp col 90)
+
+putLamp :: PSType
+putLamp = PutCrit (lamp 90)
+
diff --git a/src/Dodge/Room/Placement.hs b/src/Dodge/Placements/Wall.hs
similarity index 65%
rename from src/Dodge/Room/Placement.hs
rename to src/Dodge/Placements/Wall.hs
index 65453f97d..5cc40c26f 100644
--- a/src/Dodge/Room/Placement.hs
+++ b/src/Dodge/Placements/Wall.hs
@@ -1,25 +1,14 @@
--- | Module defining helper placements for rooms.
-module Dodge.Room.Placement
-  where
+module Dodge.Placements.Wall
+    where
 import Dodge.Data
-import Dodge.Default.Wall
-import Dodge.LevelGen.Data
-import Dodge.LevelGen.Switch
-import Dodge.Room.Data
-import Dodge.Creature.Inanimate
-import Picture
+import Color
 import Geometry
+import Dodge.LevelGen.Data
+import Dodge.Default.Wall
+import Dodge.Room.Data
 
 import Data.List
 import Control.Lens
-import qualified Data.IntMap.Strict as IM
-
-putColorLamp :: Point3 -> PSType
-putColorLamp col = PutCrit (colorLamp col 90)
-
-putLamp :: PSType
-putLamp = PutCrit (lamp 90)
-
 singleBlock :: Point2 -> [Placement]
 singleBlock a = 
     [sPS a 0 
@@ -110,6 +99,7 @@ baseWindowPane = defaultWall
     , _wlDraw = True
     , _wlFireThrough = True
     }
+-- TODO find home for this
 {- Replaces instances of a given 'PutID' with 'PSType's drawn from a list.  -}
 replacePutID 
     :: Int      -- ^ The id of 'PutID' to be replaced
@@ -134,51 +124,27 @@ subZipWith f g xs ys =
 isPutID :: Int -> Placement -> Bool
 isPutID i ps = Just i == ps ^? placementSpot . psType . putID
 
-putBlockRect
-    :: Float
-    -> Float
-    -> Float
-    -> Float
-    -> [Placement]
-putBlockRect a x b y =  [ blockLine (V2 a b) (V2 a y)
-                        , blockLine (V2 a y) (V2 x y)
-                        , blockLine (V2 x y) (V2 x b)
-                        , blockLine (V2 x b) (V2 a b)
-                        ]
-putBlockV
-    :: Float
-    -> Float
-    -> Float
-    -> Float
-    -> [Placement]
-putBlockV a x b y = [ blockLine (V2 a b) (V2 a y)
-                    , blockLine (V2 x b) (V2 a b)
-                    ]
-putBlockC
-    :: Float
-    -> Float
-    -> Float
-    -> Float
-    -> [Placement]
-putBlockC a x b y = [ blockLine (V2 a b) (V2 a y)
-                    , blockLine (V2 x b) (V2 a b)
-                    , blockLine (V2 a y) (V2 x y)
-                    ]
-putBlockN
-    :: Float
-    -> Float
-    -> Float
-    -> Float
-    -> [Placement]
-putBlockN a x b y = [ blockLine (V2 a b) (V2 a y)
-                    , blockLine (V2 x b) (V2 a b)
-                    , blockLine (V2 x y) (V2 x b)
-                    ]
-
-switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
-switchDoor btpos btrot dra drb col = Placement (PS btpos btrot $ PutButton $ makeSwitch col red id id)
-    $ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
-    $          sps0   (PutSlideDoor False col (cond btid) drb drc 2)
-  where
-    drc = 0.5 *.* (dra +.+ drb)
-    cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
+putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
+putBlockRect a x b y =
+    [ blockLine (V2 a b) (V2 a y)
+    , blockLine (V2 a y) (V2 x y)
+    , blockLine (V2 x y) (V2 x b)
+    , blockLine (V2 x b) (V2 a b)
+    ]
+putBlockV :: Float -> Float -> Float -> Float -> [Placement]
+putBlockV a x b y = 
+    [ blockLine (V2 a b) (V2 a y)
+    , blockLine (V2 x b) (V2 a b)
+    ]
+putBlockC :: Float -> Float -> Float -> Float -> [Placement]
+putBlockC a x b y = 
+    [ blockLine (V2 a b) (V2 a y)
+    , blockLine (V2 x b) (V2 a b)
+    , blockLine (V2 a y) (V2 x y)
+    ]
+putBlockN :: Float -> Float -> Float -> Float -> [Placement]
+putBlockN a x b y = 
+    [ blockLine (V2 a b) (V2 a y)
+    , blockLine (V2 x b) (V2 a b)
+    , blockLine (V2 x y) (V2 x b)
+    ]
diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs
index c39f1d818..80e91fb89 100644
--- a/src/Dodge/Room.hs
+++ b/src/Dodge/Room.hs
@@ -10,31 +10,20 @@ import Dodge.Item.Weapon.BulletGuns
 import Dodge.Item.Weapon.Launcher
 import Dodge.Creature
 import Dodge.Room.Foreground
---import Dodge.Creature.Inanimate
---import Dodge.LevelGen
 import Dodge.LevelGen.Data
---import Dodge.Base
 import Dodge.RandomHelp
-import Dodge.LevelGen
 import Dodge.Default.Wall
---import Dodge.Path
---import Dodge.Layout
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.Layout.Tree.Either
-import Dodge.LightSources.Fitting
---import Dodge.LightSources
---import Dodge.SoundLogic
+import Dodge.Placements
 import Dodge.Room.Data
-import Dodge.Room.Placement
 import Dodge.Room.Procedural
 import Dodge.Room.Corridor
 import Dodge.Room.Link
---import Dodge.Room.Branch
 import Dodge.Room.Door
 import Dodge.Room.Airlock
 import Dodge.Room.LongDoor
 import Geometry
---import Geometry.Data
 import Picture
 import Tile
 
@@ -44,8 +33,6 @@ import Control.Monad.Loops
 import System.Random
 import Data.Tree
 import Data.Bifunctor
---import qualified Data.Map as M
---import qualified Data.IntMap.Strict as IM
 
 roomC :: Float -> Float -> Room
 roomC x y = defaultRoom
@@ -66,7 +53,7 @@ roomC x y = defaultRoom
     yn = 4
     yd = (y - 40) / fromIntegral yn
     xd = (x - 40) / fromIntegral xn
-    pth  = linksAndPath lnks $ translateS (V2 20 20) (makeGrid xd xn yd yn)
+    pth  = linksAndPath lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
 
 roomPadCut :: [Point2] -> Point2 -> Room
 roomPadCut ps p = defaultRoom
@@ -79,9 +66,9 @@ roomPadCut ps p = defaultRoom
 roomPillars :: Room
 roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
   where 
-    plmnts = mountedLightI 70 (V2 120 24) (V2 120 216) 
-        : mountedLightV (V2 12 12) (V3 25 25 70)
-        : mountedLightV (V2 228 228) (V3 215 215 70)
+    plmnts = mountLightI 70 (V2 120 24) (V2 120 216) 
+        : mountLightV (V2 12 12) (V3 25 25 70)
+        : mountLightV (V2 228 228) (V3 215 215 70)
         : sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25))
         : sps0 (PutForeground $ thinHighBar 75 (V2 214 215) (V2 120 215))
         : g 180 150 90 60
diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs
index 78335a346..275438578 100644
--- a/src/Dodge/Room/Airlock.hs
+++ b/src/Dodge/Room/Airlock.hs
@@ -2,12 +2,10 @@
 {- Rooms that contain two doors and a switch alternating both.  -}
 module Dodge.Room.Airlock where
 import Dodge.Room.Data
-import Dodge.LightSources.Fitting
-import Dodge.Room.Placement
+import Dodge.Placements
 import Dodge.Room.Foreground
 import Dodge.Default.Room
 import Dodge.Data
-import Dodge.Placements
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.Switch
 import Dodge.RandomHelp
@@ -30,7 +28,7 @@ airlock0 = defaultRoom
         [Placement (PS (V2 (-35) 50) (negate $ pi/2) $ PutButton $ makeSwitch col red id id)
             $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
                 $ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
-        ,mountedLightI 70 (V2 (-2) 30) (V2 (-2) 70)
+        ,mountLightI 70 (V2 (-2) 30) (V2 (-2) 70)
         ,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
         ]
     , _rmBound = [rectNSWE 75 15 0 40]
@@ -65,7 +63,7 @@ airlock90 = defaultRoom
     , _rmPS    = 
         [ Placement (PS (V2 120 120) (3 * pi/4) (PutButton $ makeSwitch col red id id))
             $ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
-        ,mountedLightV (V2 20 20) (V3 70 70 50)
+        ,mountLightV (V2 20 20) (V3 70 70 50)
         ]
     , _rmBound = 
         [map toV2 [ (10,10)
@@ -94,7 +92,7 @@ airlockCrystal = defaultRoom
         [ Placement (PS (V2 145 70) (pi/2) (PutButton $ makeSwitch col red id id))
             $ \btid -> jsps0 $ PutDoor col (cond btid) pss
         , crystalLine (V2 0 70) (V2 40 70)
-        , mountedLightV (V2 150 70) (V3 110 70 70)
+        , mountLightV (V2 150 70) (V3 110 70 70)
         ]
     , _rmBound = 
         [         ]
diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs
index f0406b622..76d172899 100644
--- a/src/Dodge/Room/Boss.hs
+++ b/src/Dodge/Room/Boss.hs
@@ -5,10 +5,9 @@ module Dodge.Room.Boss
   where
 import Dodge.Data
 import Dodge.Default.Room
-import Dodge.LightSources.Fitting
+import Dodge.Placements
 import Dodge.Room.Data
 import Dodge.Room.Procedural
-import Dodge.Room.Placement
 import Dodge.Room.Link
 import Dodge.Room.Corridor
 import Dodge.Room.Path
@@ -98,8 +97,8 @@ roomCross x y = defaultRoom
         ]
     , _rmPath  = []
     , _rmPS = 
-        [ mountedLightI 70 (V2 (x+5) x) (V2 (x+5) (-x))
-        , mountedLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x))
+        [ mountLightI 70 (V2 (x+5) x) (V2 (x+5) (-x))
+        , mountLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x))
         ]
     , _rmBound = 
         [rectNSWE y (-y) (-x) x
@@ -122,7 +121,7 @@ roomShuriken x y =
             { _rmPolys  = ps
             , _rmLinks  = [(V2 (x-1) (y-20),negate $ pi/2)]
             , _rmPath   = []
-            , _rmPS     = [mountedLight (V2 x x) (V3 (x-20) x 70)]
+            , _rmPS     = [mountLight (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]
@@ -146,7 +145,7 @@ roomTwistCross x y z =
             { _rmPolys  = ps
             , _rmLinks  = [(V2 z (y-20), pi/2)]
             , _rmPath   = []
-            , _rmPS     = [mountedLight (V2 x x) (V3 (x-20) (x-20) 70)]
+            , _rmPS     = [mountLight (V2 x x) (V3 (x-20) (x-20) 70)]
             , _rmBound  = ps
             }
     in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs
index 110e0ee99..f4f011d9b 100644
--- a/src/Dodge/Room/Corridor.hs
+++ b/src/Dodge/Room/Corridor.hs
@@ -5,7 +5,7 @@ import Dodge.Room.Data
 import Dodge.Default.Room
 --import Dodge.LevelGen.Data
 --import Dodge.LightSources.Lamp
-import Dodge.LightSources.Fitting
+import Dodge.Placements
 import Geometry
 import Tile
 
@@ -17,7 +17,7 @@ corridor = defaultRoom
     { _rmPolys = [poly]
     , _rmLinks = lnks
     , _rmPath  = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
-    , _rmPS    = [ mountedLightI 50 (V2 0 40) (V2 40 40) ]
+    , _rmPS    = [ mountLightI 50 (V2 0 40) (V2 40 40) ]
     , _rmBound = [ rectNSWE 50 30 0 40 ]
     , _rmFloor = [makeTileFromPoly poly 2]  
     }
diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs
index e7cfb1035..6eaf7561c 100644
--- a/src/Dodge/Room/LongDoor.hs
+++ b/src/Dodge/Room/LongDoor.hs
@@ -6,24 +6,23 @@ module Dodge.Room.LongDoor
 import Dodge.Data
 import Dodge.Default.Room
 import Dodge.Room.Data
-import Dodge.Room.Placement
+import Dodge.Placements
 import Dodge.Room.Link
 import Dodge.Room.Procedural
-import Dodge.Layout.Tree.Either
+--import Dodge.Layout.Tree.Either
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.Switch
 import Dodge.RandomHelp
 import Dodge.Creature.Inanimate
 import Dodge.Creature
 import Dodge.LightSources.Lamp
-import Dodge.Placements
 import Picture
 import Geometry
 
 import System.Random
 import Control.Lens
 import Control.Monad.State
-import Data.Tree
+--import Data.Tree
 import qualified Data.IntMap as IM
 
 twinSlowDoorRoom 
@@ -76,51 +75,63 @@ twinSlowDoorChasers = do
     let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
     return $ twinSlowDoorRoom 80 200 40 & rmPS %~ (plmnts ++)
 
-slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room))
-slowDoorRoom = do
-     x <- state $ randomR (400,800)
-     y <- state $ randomR (400,800)
-     h <- state $ randomR (200,min (y-100) 500)
-     (butPos,butRot) <- takeOne 
-        [( V2 (x/2-50) 5,0)
-        ,( V2 (x/2+50) 5,0)
-        ]
-     let n = 25
-     xs <- replicateM n $ state $ randomR (10,x-10)
-     ys <- replicateM n $ state $ randomR (h+20,y)
-     rs <- replicateM n $ state $ randomR (0,2*pi)
-     let ps = zipWith V2 xs ys
-     xs' <- replicateM 5 $ state $ randomR (10,x-10)
-     ys' <- replicateM 5 $ state $ randomR (h+20,y)
-     let crits = zipWith (\p r -> sPS p r randC1) ps rs
-         lsources = [sPS (V2 (x/2) 30) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
-         barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
-         pillarsa = []
-         pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
-            ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
-            ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
-            ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
-         pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
-            ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
-     pillars <- takeOne [pillarsa, pillarsb, pillarsc]
-     let cond x'  = (sndV2 . fst) x' > h + 40
-         cond2 x' = (sndV2 . fst) x' < h - 40
-     but <- takeOne [butDoor x h butPos butRot
-                    ]
-     fmap connectRoom 
-        (filterLinks cond =<< 
-            changeLinkTo cond2 
-                (set rmPS ([but] ++ crits ++ pillars ++ barrels ++ lsources) 
-                $ roomRectAutoLinks x y
-                )
-        )
+southPillarsRoom :: RandomGen g => Float -> Float -> Float -> State g Room
+southPillarsRoom x y h = do
+    let pillarsa = []
+        pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
+           ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
+           ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
+           ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
+        pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
+           ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
+    pillars <- takeOne [pillarsa, pillarsb, pillarsc]
+    return $ roomRectAutoLinks x y & rmPS .~ pillars
+
+addSouthPillars :: RandomGen g => Float -> Float -> Room -> State g Room
+addSouthPillars x h r = do
+    let pillarsa = []
+        pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
+           ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
+           ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
+           ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
+        pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
+           ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
+    pillars <- takeOne [pillarsa, pillarsb, pillarsc]
+    return $ r & rmPS %~ (++ pillars)
+
+addButtonSlowDoor :: RandomGen g => Float -> Float -> Room -> State g Room
+addButtonSlowDoor x h rm = do
+    (butPos,butRot) <- takeOne 
+       [( V2 (x/2-50) 5,0)
+       ,( V2 (x/2+50) 5,0)
+       ]
+    thePlacement <- takeOne [butDoor butPos butRot ]
+    filterLinks aboveH =<< changeLinkTo belowH (rm & rmPS %~ (thePlacement :))
   where
-    butDoor x h bpos brot 
-        = ps0 (PutButton $ (makeButton col id) {_btPos = bpos, _btRot = brot})
+    belowH y = (sndV2 . fst) y < h - 40
+    aboveH y = (sndV2 . fst) y > h + 40
+    butDoor bpos brot = putLitButtonID col bpos brot
         $  \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
     col = dim $ light red
     cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff
-     --but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h) 2
+
+slowDoorRoom :: RandomGen g => State g Room
+slowDoorRoom = do
+    x <- state $ randomR (400,800)
+    y <- state $ randomR (400,800)
+    h <- state $ randomR (200,min (y-100) 500)
+    let n = 25
+    xs <- replicateM n $ state $ randomR (10,x-10)
+    ys <- replicateM n $ state $ randomR (h+20,y)
+    rs <- replicateM n $ state $ randomR (0,2*pi)
+    let ps = zipWith V2 xs ys
+    xs' <- replicateM 5 $ state $ randomR (10,x-10)
+    ys' <- replicateM 5 $ state $ randomR (h+20,y)
+    let crits = zipWith (\p r -> sPS p r randC1) ps rs
+        lsources = [sPS (V2 (x/2) 30) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
+        barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
+    proom <- southPillarsRoom x y h
+    addButtonSlowDoor x h (proom & rmPS %~ (++ (crits ++ barrels ++ lsources)))
 
 randC1 :: PSType
 randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit
diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs
index aa2c5dcd4..f91f5d72d 100644
--- a/src/Dodge/Room/Procedural.hs
+++ b/src/Dodge/Room/Procedural.hs
@@ -12,7 +12,7 @@ module Dodge.Room.Procedural
 import Dodge.Data
 import Dodge.Default.Wall
 import Dodge.Room.Data
-import Dodge.Room.Placement
+import Dodge.Placements
 import Dodge.Room.Link
 import Dodge.Room.Path
 import Dodge.Default.Room
@@ -24,7 +24,7 @@ import Dodge.Item.Weapon.Launcher
 import Dodge.RandomHelp
 import Dodge.LevelGen
 import Dodge.LevelGen.Data
-import Dodge.LightSources.Fitting
+import Dodge.LevelGen.Switch
 import Dodge.Creature
 import Geometry
 import Geometry.Vector3D
@@ -60,12 +60,12 @@ roomRect x y xn yn = defaultRoom
   where 
     yd = (y - 40) / fromIntegral yn
     xd = (x - 40) / fromIntegral xn
-    elnks = zip (translateS (V2 0 20) $ gridPoints  0  1      yd (yn+1))  (repeat ( pi/2)) 
-    wlnks = zip (translateS (V2 x 20) $ gridPoints  0  1      yd (yn+1))  (repeat (-pi/2)) 
-    nlnks = zip (translateS (V2 20 y) $ gridPoints xd (xn+1)  0  1     )  (repeat      0 ) 
-    slnks = zip (translateS (V2 20 0) $ gridPoints xd (xn+1)  0  1     )  (repeat     pi ) 
+    elnks = zip (map (+.+ V2 0 20) $ gridPoints  0  1      yd (yn+1))  (repeat ( pi/2)) 
+    wlnks = zip (map (+.+ V2 x 20) $ gridPoints  0  1      yd (yn+1))  (repeat (-pi/2)) 
+    nlnks = zip (map (+.+ V2 20 y) $ gridPoints xd (xn+1)  0  1     )  (repeat      0 ) 
+    slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1)  0  1     )  (repeat     pi ) 
     lnks = nlnks ++ elnks ++ wlnks ++ slnks
-    pth  = linksAndPath lnks $ translateS (V2 20 20) (makeGrid xd xn yd yn)
+    pth  = linksAndPath lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
 {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size.  -}
 roomRectAutoLinks :: Float -> Float -> Room
 roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
@@ -94,16 +94,16 @@ Add a light and a 'PutNothing' placement.  -}
 quarterRoomFlat :: RandomGen g => Float -> State g Room
 quarterRoomFlat w = do
     b <- takeOne 
-        [   [ mountedLightV (V2 0 w) (V3 0 (w-20) 70)
-            , mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
+        [   [ mountLightV (V2 0 w) (V3 0 (w-20) 70)
+            , mountLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
             , sPS (V2 (w-20) (w-20)) pi PutNothing
             , blockLine (V2 (w/2) (w/2)) (V2 (w/2) w)
             ]
-        ,   [ mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
+        ,   [ mountLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
             , sPS (V2 (w-20) (w-20)) pi PutNothing
             , blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))
             ]
-        ,   [ mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
+        ,   [ mountLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
             , sPS (V2 (w-20) (w-20)) pi PutNothing
             , blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
             , blockLine (V2 (-29) w) (V2 0 (w/2))
@@ -127,17 +127,17 @@ quarterRoomFlat w = do
 fourthCornerWall :: RandomGen g => Float -> State g Room
 fourthCornerWall w = do
     b <- takeOne 
-        [   [ mountedLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
+        [   [ mountLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
             , blockLine (V2 (w/2) (w/2)) (V2 0 w)
             , blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
             , sPS (V2 20     (2*w-40)) pi PutNothing
             ]
-        ,   [ mountedLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
+        ,   [ mountLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
             , blockLine (V2 (w/2)      (w/2)) (V2 0 w)
             , blockLine (V2 (negate w)  w   ) (V2 0 w)
             , sPS (V2 20     (2*w-40)) pi PutNothing
             ]
-        ,   [ mountedLight (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20)  (1.3*w-20) 70)
+        ,   [ mountLight (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20)  (1.3*w-20) 70)
             , blockLine (V2 (w/2) (w/2)) (V2 0 w)
             , blockLine (V2 0 w) (V2 0 (w*2))
             , sPS (V2 20     (2*w-40)) pi PutNothing
@@ -222,7 +222,7 @@ centerVaultRoom w h d = do
             ,sps0 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall
             ,sps0 $ PutForeground $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h))
             ]
-            ++ map (\a -> mountedLightV (rotateV a $ V2 0  d) (rotate3z a $ V3 0 (d+30) 70))
+            ++ map (\a -> mountLightV (rotateV a $ V2 0  d) (rotate3z a $ V3 0 (d+30) 70))
                 [0,0.5*pi,pi,1.5*pi]
             ++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor) 
                         [0,pi/2,pi,3*pi/2]
diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs
index b723d5ecf..69fabfda9 100644
--- a/src/Dodge/Room/RoadBlock.hs
+++ b/src/Dodge/Room/RoadBlock.hs
@@ -7,13 +7,12 @@ import Geometry
 import Dodge.Default.Room
 import Dodge.Room.Data
 import Dodge.Room.Link
-import Dodge.Room.Placement
+import Dodge.Placements
 import Dodge.Room.Corridor
 import Dodge.LevelGen.Data
 --import Dodge.RandomHelp
 import Dodge.Creature
 import Dodge.Layout.Tree.Polymorphic
-import Dodge.LightSources.Fitting
 
 import Data.Tree
 import Control.Monad.State
@@ -43,7 +42,7 @@ litCorridor90 = do
             ]
         , _rmPS    = 
             [ sPS (V2 20 (h-5)) 0     putLamp
-            , mountedLightI 70 (V2 0 (0.4*h)) (V2 40 (0.4*h))
+            , mountLightI 70 (V2 0 (0.4*h)) (V2 40 (0.4*h))
             , windowLine (V2 0 (h-20)) (V2 40 (h-20))
             , sPS (V2 (-50) (h-85)) 0   putLamp
             , windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))
@@ -76,6 +75,6 @@ blockedCorridor = do
     let plmnts = 
             [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256)  0 ( 250/256)) 
                                           $ reverse $ rectNSWE 10 (-10) (-10) 10
-            ,mountedLightI 55 (V2 0 15) (V2 40 15)
+            ,mountLightI 55 (V2 0 15) (V2 40 15)
             ]
     sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor
diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs
index 148d33192..bc4ea4e77 100644
--- a/src/Dodge/Room/Start.hs
+++ b/src/Dodge/Room/Start.hs
@@ -6,9 +6,9 @@ import Dodge.Room.Link
 import Dodge.Room.Procedural
 import Dodge.Room.Foreground
 import Dodge.Room.Furniture
+import Dodge.Placements
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.LevelGen.Data
-import Dodge.LightSources.Fitting
 import Dodge.Machine.Sensor
 import Geometry.Data
 import Color
@@ -33,7 +33,7 @@ startRoom = do
         <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) 
             $ roomRectAutoLinks w h & rmPS .~ 
             [ fground
-            , mountedLightJ (V2 0 (h/3)) (V3 40 (h/3) 70)
+            , mountLightJ (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
diff --git a/src/Dodge/Room/Teleport.hs b/src/Dodge/Room/Teleport.hs
index 42c5685c7..21adabfb1 100644
--- a/src/Dodge/Room/Teleport.hs
+++ b/src/Dodge/Room/Teleport.hs
@@ -5,7 +5,7 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.Room.Data
 import Dodge.Room.Procedural
-import Dodge.Room.Placement
+import Dodge.Placements
 import Dodge.LevelGen.Data
 import Geometry
 import Picture
diff --git a/src/Dodge/Room/Treasure.hs b/src/Dodge/Room/Treasure.hs
index 564e68854..12027edf4 100644
--- a/src/Dodge/Room/Treasure.hs
+++ b/src/Dodge/Room/Treasure.hs
@@ -6,10 +6,9 @@ module Dodge.Room.Treasure
     where
 import Dodge.Data
 import Dodge.Room.Data
-import Dodge.Room.Placement
+import Dodge.Placements
 import Dodge.Default.Room
 import Dodge.LevelGen.Data
-import Dodge.LightSources.Fitting
 import Geometry
 
 --import Data.List
@@ -33,7 +32,7 @@ triLootRoom w h = pure $ defaultRoom
         [sPS (V2 (15-w)    15 )  0 $ PutID 0
         ,sPS (V2 (w-15)    15 ) pi $ PutID 0
         ,sPS (V2     0  (h-35))  0 $ PutID 2
-        ,mountedLightV (V2 0 (h-20)) (V3 0 (h-80) 70)
+        ,mountLightV (V2 0 (h-20)) (V3 0 (h-80) 70)
         ,sPS (V2     0  ( -60))  0 putLamp
         ]
     , _rmBound  = [tri , base]