diff --git a/package.yaml b/package.yaml
index 990eb51e1..a6e1f8b9c 100644
--- a/package.yaml
+++ b/package.yaml
@@ -28,7 +28,6 @@ dependencies:
 - sdl2-mixer
 - text
 - OpenGL
-  #- OpenGLRaw
 - raw-strings-qq
 - bytestring
 - lens
@@ -47,6 +46,7 @@ dependencies:
 - aeson
 - directory
 - QuickCheck
+- utility-ht
 
 library:
   source-dirs: src
diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs
index 8ecf536ae..1ab085015 100644
--- a/src/Dodge/Base.hs
+++ b/src/Dodge/Base.hs
@@ -195,10 +195,12 @@ wallsNearPoint p w =  IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-
 wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
 {-# INLINE wallsAlongLine #-}
 wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
-    where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
-          kps = zoneOfLine' a b
-          f i m = case IM.lookup i m of Just val -> val
-                                        _        -> IM.empty
+  where 
+    g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
+    kps = zoneOfLineIntMap a b
+    f i m = case IM.lookup i m of 
+        Just val -> val
+        _        -> IM.empty
 
 wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
 {-# INLINE wallsNearZone' #-}
@@ -235,7 +237,7 @@ creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
 --                                        _        -> IM.empty
 creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty kps
     where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _creaturesZone w) s))
-          kps = zoneOfLine' a b
+          kps = zoneOfLineIntMap a b
           f i m = case IM.lookup i m of Just val -> val
                                         _        -> IM.empty
 
@@ -281,9 +283,9 @@ zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
                                  $ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
     where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
 
-zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
-{-# INLINE zoneOfLine' #-}
-zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
+zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
+{-# INLINE zoneOfLineIntMap #-}
+zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
     where (x,y) = zoneOfPoint a
           (x',y') = zoneOfPoint b
 --zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f 
@@ -391,11 +393,12 @@ furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elem
                                         ) ++ [p2]
 
 collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
-collidePointIndirect p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems 
+collidePointIndirect p1 p2 ws = listToMaybe $ sortOn (dist p1) $ IM.elems 
                                     $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
                                                     . _wlLine
                                                   ) notWindows
-    where notWindows = IM.filter (not . _wlIsSeeThrough) ws
+  where 
+    notWindows = IM.filter (not . _wlIsSeeThrough) ws
 
 collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
 collidePointFire p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems 
diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs
index fb9daee72..973c18de0 100644
--- a/src/Dodge/Creature/Action.hs
+++ b/src/Dodge/Creature/Action.hs
@@ -1,4 +1,4 @@
-{- Actions performed by creatures within the world
+{- | Actions performed by creatures within the world
  -}
 {-# LANGUAGE BangPatterns #-}
 module Dodge.Creature.Action 
@@ -27,94 +27,139 @@ import System.Random
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
 
-moveForwardSpeed :: Float -> Int -> World -> World
+moveForwardSpeed 
+    :: Float    -- ^ Speed
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 moveForwardSpeed x n w = over (creatures . ix n . crPos) (+.+ p) w
-    where p = (*.*) x $ unitVectorAtAngle $ _crDir $ _creatures w IM.! n
+  where 
+    p = (*.*) x $ unitVectorAtAngle $ _crDir $ _creatures w IM.! n
 
-mvForward :: Float -> Int -> World -> World
-mvForward speed cid w = stepForward cid speed $ over (creatures . ix cid . crPos) (+.+ p) w
-    where p =  (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir $ _creatures w IM.! cid
-          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid
+crStrafeLeft
+    :: Float    -- ^ Speed
+    -> Creature 
+    -> Creature
+crStrafeLeft speed cr = stepForward s2 $ over crPos (+.+ p) cr
+  where 
+    p =  (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2)
+    equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
+    s2 = (speed * equipFactor)
 
-crStrafeLeft :: Float -> Creature -> Creature
-crStrafeLeft speed cr = stepForward' s2 $ over crPos (+.+ p) cr
-    where p =  (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2)
-          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
-          s2 = (speed * equipFactor)
-crStrafeRight :: Float -> Creature -> Creature
-crStrafeRight speed cr = stepForward' s2 $ over crPos (+.+ p) cr
-    where p =  (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2)
-          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
-          s2 = (speed * equipFactor)
+crStrafeRight 
+    :: Float    -- ^ Speed
+    -> Creature 
+    -> Creature
+crStrafeRight speed cr = stepForward s2 $ over crPos (+.+ p) cr
+  where 
+    p =  (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2)
+    equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
+    s2 = (speed * equipFactor)
 
-crMvForward :: Float -> Creature -> Creature
+crMvForward 
+    :: Float    -- ^ Speed
+    -> Creature 
+    -> Creature
 crMvForward speed cr = over crPos (+.+ p) cr
-    where p =  (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr
-          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
+  where 
+    p =  (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr
+    equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
 
-crMvBy :: Point2 -> Creature -> Creature
-crMvBy p' cr = stepForward' (magV p) $ over crPos (+.+ p) cr
-    where p =  (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p'
-          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
-          aimingFactor | (_posture $ _stance $ _crState cr) == Aiming
-                            = fromMaybe 1 $ it ^? itAimingSpeed
-                       | otherwise = 1
-          it = _crInv cr IM.! _crInvSel cr
+crMvBy 
+    :: Point2   -- ^ Movement translation vector
+    -> Creature 
+    -> Creature
+crMvBy p' cr = stepForward (magV p) $ over crPos (+.+ p) cr
+  where 
+    p =  (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p'
+    equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
+    aimingFactor | (_posture $ _stance $ _crState cr) == Aiming
+                      = fromMaybe 1 $ it ^? itAimingSpeed
+                 | otherwise = 1
+    it = _crInv cr IM.! _crInvSel cr
 
-stepForward :: Int -> Float -> World -> World
-stepForward cid speed = over (creatures . ix cid . crState . stance . carriage) f
-    where f (w@Walking {}) = w {_stepToAdd = ceiling speed}
-          f s = s
-
-stepForward' :: Float -> Creature -> Creature
-stepForward' speed cr = over (crState . stance . carriage) f cr
-    where f (w@Walking {}) = w {_stepToAdd = ceiling speed}
-          f s = s
+stepForward 
+    :: Float    -- ^ Speed
+    -> Creature 
+    -> Creature
+stepForward speed cr = over (crState . stance . carriage) f cr
+  where 
+    f (w@Walking {}) = w {_stepToAdd = ceiling speed}
+    f s = s
 
+{- Determine the speed modifier of an item. -}
+equipSpeed :: Item -> Float
 equipSpeed NoItem = 1
 equipSpeed it | _itIdentity it == FrontArmour = 0.75
               | _itIdentity it == FlameShield = 0.75
               | otherwise                     = 1
 
-turnTo :: Point2 -> Int -> World -> World
+turnTo 
+    :: Point2   -- ^ Target point
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 turnTo p n w = set (creatures . ix n . crDir) dirToTarget w
-    where cr = _creatures w IM.! n
-          dirToTarget = argV (p -.- _crPos cr)
+  where 
+    cr = _creatures w IM.! n
+    dirToTarget = argV (p -.- _crPos cr)
 
-turnToward :: Point2 -> Int -> World -> World
-turnToward p n w | isLeftOfA dirToTarget (_crDir cr)
-                             = f $ over (creatures . ix n . crDir) 
-                                        (normalizeAngle . (+ (0.03 + r*m))) w
-                 | otherwise = f $ over (creatures . ix n . crDir) 
-                                        (\x->normalizeAngle (x - (0.03 + r*m))) w
-                    where cr          = _creatures w IM.! n
-                          dirToTarget = argV (p -.- _crPos cr)
-                          (r,g)       = randomR (-0.1,0.1) (_randGen w)
-                          m           = diffAngles dirToTarget (_crDir cr)
-                          f           = set randGen g
+turnTowardRandomise
+    :: Point2   -- ^ Target point
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
+turnTowardRandomise p n w 
+    | isLeftOfA dirToTarget (_crDir cr)
+                = f $ over (creatures . ix n . crDir) 
+                           (normalizeAngle . (+ (0.03 + r*m))) w
+    | otherwise = f $ over (creatures . ix n . crDir) 
+                           (\x->normalizeAngle (x - (0.03 + r*m))) w
+  where 
+    cr          = _creatures w IM.! n
+    dirToTarget = argV (p -.- _crPos cr)
+    (r,g)       = randomR (-0.1,0.1) (_randGen w)
+    m           = diffAngles dirToTarget (_crDir cr)
+    f           = set randGen g
 
-turnTowardAngle :: Float -> Int -> World -> World
+turnTowardAngle 
+    :: Float    -- ^ Angle
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 turnTowardAngle a n w 
     | isLeftOfA a (_crDir cr) = f $ over (creatures . ix n . crDir) 
                                         (normalizeAngle . (+ (0.03 + r*m))) w
     | otherwise = f $ over (creatures . ix n . crDir) 
                                         (\x->normalizeAngle (x - (0.03 + r*m))) w
-                    where cr          = _creatures w IM.! n
-                          (r,g)       = randomR (-0.1,0.1) (_randGen w)
-                          m           = diffAngles a (_crDir cr)
-                          f           = set randGen g
+  where 
+    cr      = _creatures w IM.! n
+    (r,g)   = randomR (-0.1,0.1) (_randGen w)
+    m       = diffAngles a (_crDir cr)
+    f       = set randGen g
 
-turnToward'' :: Float -> Point2 -> Int -> World -> World
-turnToward'' turnSpeed p n w 
+turnTowardWithSpeed 
+    :: Float    -- ^ Turn speed
+    -> Point2   -- ^ Target point
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
+turnTowardWithSpeed turnSpeed p n w 
     | isLeftOfA dirToTarget (_crDir cr)
                 = f $ over (creatures . ix n . crDir) (normalizeAngle. (+ (turnSpeed + r))) w
     | otherwise = f $ over (creatures . ix n . crDir) (\x->normalizeAngle (x - (turnSpeed + r))) w
-                    where cr          = _creatures w IM.! n
-                          dirToTarget = argV (p -.- _crPos cr)
-                          (r,g)       = randomR (-0.1,0.1) (_randGen w)
-                          f           = set randGen g
+  where 
+    cr          = _creatures w IM.! n
+    dirToTarget = argV (p -.- _crPos cr)
+    (r,g)       = randomR (-0.1,0.1) (_randGen w)
+    f           = set randGen g
 
-crTurnAndStrafeIn :: Float -> Float -> Point2 -> Creature -> Creature
+crTurnAndStrafeIn 
+    :: Float    -- ^ Strafe speed
+    -> Float    -- ^ Turn speed
+    -> Point2   -- ^ Target position
+    -> Creature 
+    -> Creature
 crTurnAndStrafeIn strafeSpeed turnSpeed p cr
     | vToTarg == (0,0) = cr -- this should deal with the angleVV error
     | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
@@ -124,15 +169,23 @@ crTurnAndStrafeIn strafeSpeed turnSpeed p cr
                       $ crStrafeLeft strafeSpeed cr
     | otherwise = over crDir (\x->normalizeAngle (x - turnAmount))
                       $ crStrafeRight strafeSpeed cr
-                    where vToTarg = p -.- _crPos cr
-                          dirToTarget = argV vToTarg
-                          turnAmount  = turnSpeed
+  where 
+    vToTarg = p -.- _crPos cr
+    dirToTarget = argV vToTarg
+    turnAmount  = turnSpeed
 
-crTurnTo :: Point2 -> Creature -> Creature
+crTurnTo 
+    :: Point2   -- ^ Target position
+    -> Creature 
+    -> Creature
 crTurnTo p cr = set crDir dirToTarget cr
     where dirToTarget = argV (p -.- _crPos cr)
 
-crTurnTowardSpeed :: Float -> Point2 -> Creature -> Creature
+crTurnTowardSpeed 
+    :: Float    -- ^ Turn speed
+    -> Point2   -- ^ Target position
+    -> Creature 
+    -> Creature
 crTurnTowardSpeed turnSpeed p cr
     | vToTarg == (0,0) = cr -- this should deal with the angleVV error
     | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
@@ -144,7 +197,12 @@ crTurnTowardSpeed turnSpeed p cr
                           dirToTarget = argV vToTarg
                           turnAmount  = turnSpeed
 
-turnTowardSpeed :: Float -> Point2 -> Int -> World -> World
+turnTowardSpeed 
+    :: Float    -- ^ Turn speed
+    -> Point2   -- ^ Target position
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 turnTowardSpeed turnSpeed p n w 
     | vToTarg == (0,0) = w -- this should deal with the angleVV error
     | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
@@ -157,43 +215,54 @@ turnTowardSpeed turnSpeed p n w
                           dirToTarget = argV vToTarg
                           turnAmount  = turnSpeed
 
-turnLRS :: Int -> World -> World
-turnLRS n w = f $ over (creatures . ix n . crDir) (+ (fromIntegral r * pi / 2)) w
-    where (r,g) = randomR (negate 1::Int,1) (_randGen w)
-          f     = set randGen g
+turnToward 
+    :: Point2   -- ^ Target position
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
+turnToward p n w 
+    | isLeftOfA dirToTarget (_crDir cr) = over (creatures . ix n . crDir) (+ 0.03) w
+    | otherwise = over (creatures . ix n . crDir) (\x-> x - 0.03) w
+  where 
+    cr          = _creatures w IM.! n
+    dirToTarget = argV (p -.- _crPos cr)
 
-turnToward' :: Point2 -> Int -> World -> World
-turnToward' p n w | isLeftOfA dirToTarget (_crDir cr)
-                              = over (creatures . ix n . crDir) (+ 0.03) w
-                  | otherwise = over (creatures . ix n . crDir) (\x-> x - 0.03) w
-                    where cr          = _creatures w IM.! n
-                          dirToTarget = argV (p -.- _crPos cr)
-
-overturnToward :: Point2 -> Int -> World -> World
-overturnToward  p n w 
-                | isLeftOfA dirToTarget (_crDir cr)
-                            = over (creatures . ix n . crDir) (normalizeAngle. (+ 0.03 )) w
-                | otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - 0.03 )) w
-                    where cr          = _creatures w IM.! n
-                          dirToTarget = argV (p -.- _crPos cr)
-
-moveForward :: Int -> World -> World
+{- Move a creature forward in the direction it is facing. -}
+moveForward 
+    :: Int      -- ^ Creature id
+    -> World 
+    -> World
 moveForward n w = over (creatures . ix n . crPos) (+.+ p) w
-    where p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n
+  where 
+    p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n
 
-moveToward :: Point2 -> Int -> World -> World
+{- Move a creature forward, faster if it is facing a target point -}
+moveToward 
+    :: Point2   -- ^ Target point
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 moveToward p n w
     | angle < 10 = moveForwardSpeed 0.1 n w
     | angle < 20 = moveForwardSpeed 0.02 n w
     | angle < 40 = moveForwardSpeed 0.01 n w
     | otherwise  = w
-        where angle  = errorAngleVV 5 (p -.- curPos) (unitVectorAtAngle (_crDir (_creatures w IM.! n)))
-              curPos = _crPos (_creatures w IM.! n)
+  where 
+    angle  = errorAngleVV 5 (p -.- curPos) (unitVectorAtAngle (_crDir (_creatures w IM.! n)))
+    curPos = _crPos (_creatures w IM.! n)
 
-moveBy :: Int -> Point2 -> World -> World
+{- Translate a creature. -}
+moveBy 
+    :: Int      -- ^ Creature id
+    -> Point2   -- ^ Translation
+    -> World 
+    -> World
 moveBy n v = over (creatures . ix n . crPos) (+.+ v)
 
-reloadWeapon :: Int -> World -> Maybe World
+reloadWeapon 
+    :: Int      -- ^ Creature id
+    -> World 
+    -> Maybe World
 reloadWeapon cid w = 
     let cr = _creatures w IM.! cid
         it = _crInv cr IM.! _crInvSel cr
@@ -204,24 +273,32 @@ reloadWeapon cid w =
                                             $ set ( itRef . wpReloadState) rT w
         _                          -> Nothing
 
+{- Start reloading if clip is empty. -}
 crAutoReload :: Creature -> Creature
 crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of
-        Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT)
-                     & crInv . ix (_crInvSel cr) . wpLoadedAmmo  %~ (`fromMaybe` maxA)
-        _      -> cr
-    where reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime
-          maxA    = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo
+    Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT)
+                 & crInv . ix (_crInvSel cr) . wpLoadedAmmo  %~ (`fromMaybe` maxA)
+    _      -> cr
+  where 
+    reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime
+    maxA    = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo
 
-blinkAction :: Int -> World -> World
-blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
-                    $ blinkShockwave n p3
-                    $ inverseShockwaveAt cp 40 2 2 2 
-                        w
-    where   p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
-            cp = _crPos $ _creatures w IM.! n
-            p2 = collidePointWalls cp p1 $ wallsAlongLine cp p1 w
-            r  = 1.5 * _crRad (_creatures w IM.! n)
-            p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)
+{- Teleport a creature to the mouse position -}
+blinkAction 
+    :: Int      -- ^ Creature id
+    -> World 
+    -> World
+blinkAction n w = soundOnce teleSound 
+    $ set (creatures . ix n . crPos) p3
+    $ blinkShockwave n p3
+    $ inverseShockwaveAt cp 40 2 2 2 
+        w
+  where
+    p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
+    cp = _crPos $ _creatures w IM.! n
+    p2 = collidePointWalls cp p1 $ wallsAlongLine cp p1 w
+    r  = 1.5 * _crRad (_creatures w IM.! n)
+    p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)
 
 blinkShockwave 
     :: Int      -- ^ Blinking creature ID.
@@ -230,19 +307,25 @@ blinkShockwave
     -> World
 blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan 
 
-moveAmountToward :: Point2 -> Float -> Point2 -> Point2
+moveAmountToward 
+    :: Point2   -- ^ Start point
+    -> Float    -- ^ Fraction to move along
+    -> Point2   -- ^ End point
+    -> Point2
 moveAmountToward p1 am p2
     = p1 +.+ am *.* errorNormalizeV 44 (p2 -.- p1)
 
-facePointAI :: Point2 -> Int -> World -> World
-facePointAI p n w = set (creatures . ix n . crDir) 
-                        (argV (p -.- _crPos (_creatures w IM.! n)) )
-                        w
-
-reverseDir :: Int -> World -> World
+reverseDir 
+    :: Int      -- ^ Creature id
+    -> World 
+    -> World
 reverseDir n = over (creatures . ix n . crDir) (+ pi)
 
-turnBy :: Float -> Int -> World -> World
+turnBy 
+    :: Float    -- ^ Angle change
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 turnBy a n = over (creatures . ix n . crDir) (+ a)
 
 {- 
@@ -251,60 +334,49 @@ Get your creature to drop the item under the cursor.
 youDropItem :: World -> World
 youDropItem w = case yourItem w of
     NoItem -> w
-    it -> rmSelectedInvItem (_yourID w) $ over floorItems (IM.insert flid theflit)
-                            $ updateLocation
-                            $ soundOnce putDownSound 
-                            $ set randGen g w
-      where (rot, g) = randomR (-pi,pi) $ _randGen w
-            offset = _crRad (you w) *.* unitVectorAtAngle rot
-            updateLocation w = case it ^? itID of
-                                  Just (Just i)  -> w & itemPositions . ix i .~ OnFloor flid
-                                  _ -> w
-            flid = newKey $ _floorItems w
-            theflit = FlIt {_flIt = set itAmount 1 it
-                            ,_flItPos = offset +.+ _crPos (you w)
-                            ,_flItRot = rot
-                            ,_flItID = flid}
+    it -> rmSelectedInvItem (_yourID w) 
+        . copyItemToFloor (you w) (_crInvSel $ you w)
+        $ soundOnce putDownSound 
+        w
 
-{- Drop an item silently. -}
-dropItem 
-    :: Int      -- ^ Creature id
+{- Copy an inventory item to the floor. -}
+copyItemToFloor 
+    :: Creature
     -> Int      -- ^ Inventory position
     -> World 
     -> World
-dropItem cid i w = case _crInv cr IM.! i of
-    NoItem -> w
-    it -> rmInvItem cid i 
-        . over floorItems (IM.insert flid theflit)
+copyItemToFloor cr i w = case _crInv cr IM.! i of
+    NoItem  -> w
+    it      -> over floorItems (IM.insert flid theflit)
         . updateLocation
         $ set randGen g w
       where 
         (rot, g) = randomR (-pi,pi) $ _randGen w
-        offset = _crRad cr *.* unitVectorAtAngle rot
+        offset = (_crRad cr + 2) *.* unitVectorAtAngle rot
         updateLocation w = case it ^? itID of
             Just (Just i)  -> w & itemPositions . ix i .~ OnFloor flid
             _ -> w
         flid = newKey $ _floorItems w
         theflit = FlIt 
-            {_flIt = set itAmount 1 it
+            {_flIt = it
             ,_flItPos = offset +.+ _crPos cr
             ,_flItRot = rot
             ,_flItID = flid
             }
-  where 
-    cr = _creatures w IM.! cid
 
-pickUpItem' :: FloorItem -> World -> World
-pickUpItem' flit w = case maybeInvSlot of
+{- Pick up a specific item. -}
+pickUpItem :: FloorItem -> World -> World
+pickUpItem flit w = case maybeInvSlot of
     Nothing -> w
-    Just i  -> soundOnce pickUpSound
-               $ updateItLocation i
-               $ w & floorItems %~ IM.delete (_flItID flit)
-                   & creatures . ix 0 . crInv . ix i %~ addItem it
-    where 
-        it = _flIt flit
-        maybeInvSlot = checkInvSlotsYou it w
-        updateItLocation invid w' 
-            = case _itID it of Nothing -> w'
-                               Just j  -> w' & itemPositions . ix j .~ InInv 0 invid
+    Just i  -> w
+        & soundOnce pickUpSound
+        & updateItLocation i
+        & floorItems                      %~ IM.delete (_flItID flit)
+        & creatures . ix 0 . crInv . ix i %~ addItem it
+  where 
+    it = _flIt flit
+    maybeInvSlot = checkInvSlotsYou it w
+    updateItLocation invid w' = case _itID it of 
+        Nothing -> w'
+        Just j  -> w' & itemPositions . ix j .~ InInv 0 invid
 
diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs
index 8427df9f2..f3aded0bc 100644
--- a/src/Dodge/Creature/Inanimate.hs
+++ b/src/Dodge/Creature/Inanimate.hs
@@ -22,8 +22,8 @@ lamp :: Creature
 lamp = defaultInanimate
     { _crUpdate = initialiseLamp
     , _crHP = 500
-    , _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 5
-    , _crRad = 5
+    , _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 3
+    , _crRad = 3
     }
 
 initialiseLamp :: CRUpdate
diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs
index 99596ccac..d8030eedc 100644
--- a/src/Dodge/Creature/State.hs
+++ b/src/Dodge/Creature/State.hs
@@ -67,31 +67,6 @@ dropByState cr w = foldr (copyItemToFloor cr) w is
         DropSpecific xs -> xs
         DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w)
 
-{- Copy an inventory item to the floor. -}
-copyItemToFloor 
-    :: Creature
-    -> Int      -- ^ Inventory position
-    -> World 
-    -> World
-copyItemToFloor cr i w = case _crInv cr IM.! i of
-    NoItem -> w
-    it -> over floorItems (IM.insert flid theflit)
-        . updateLocation
-        $ set randGen g w
-      where 
-        (rot, g) = randomR (-pi,pi) $ _randGen w
-        offset = _crRad cr *.* unitVectorAtAngle rot
-        updateLocation w = case it ^? itID of
-            Just (Just i)  -> w & itemPositions . ix i .~ OnFloor flid
-            _ -> w
-        flid = newKey $ _floorItems w
-        theflit = FlIt 
-            {_flIt = it
-            ,_flItPos = offset +.+ _crPos cr
-            ,_flItRot = rot
-            ,_flItID = flid
-            }
-
 
 setOldPos :: Creature -> Creature
 setOldPos cr = set crOldPos (_crPos cr) cr
diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs
index 04c4a55fb..5d19fa9d0 100644
--- a/src/Dodge/Creature/YourControl.hs
+++ b/src/Dodge/Creature/YourControl.hs
@@ -57,13 +57,13 @@ wasdWithAiming w speed aimSpeed i cr
         = set (crState . stance . carriage) Floating
           cr
     | isAiming
-        = stepForward' aimSpeed
+        = stepForward aimSpeed
           $ over crPos (+.+ (aimSpeed *.* mov)) 
           $ set crDir mouseDir 
           $ set (crState . stance . carriage) (Walking 0 0)
           cr
     | isMoving
-        = stepForward' speed
+        = stepForward speed
           $ over ( crPos) (+.+ (speed *.* mov)) 
           $ over ( crDir) (flip fromMaybe dir) 
           $ set (crState . stance . carriage) (Walking 0 0)
diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs
index 08e4764a5..4d52741f1 100644
--- a/src/Dodge/Event/Keyboard.hs
+++ b/src/Dodge/Event/Keyboard.hs
@@ -76,7 +76,7 @@ spaceAction w = if _carteDisplay w
         w & carteCenter .~ theLoc
     else 
         case listToMaybe $ _closeActiveObjects w of
-            Just (Left flit) -> pickUpItem' flit w
+            Just (Left flit) -> pickUpItem flit w
             Just (Right but) -> updateTopCloseObject (_btID but) $ _btEvent but but w
             Nothing -> w
   where
@@ -90,22 +90,14 @@ toggleMap w = w & carteDisplay %~ not
 escapeMap w = w & carteDisplay .~ False
 
 dropLight :: World -> World
-dropLight w = placeLS ls dec pos 0
-        --  $ over creatures IM.insert i (lamp)
-        $ w
-        --case yourItem w of
-        --NoItem -> w
-        --it -> rmInvItem (_yourID w) $ over floorItems (IM.insert flid theflit)
-        --             gg           $ updateLocation
-        --                        $ soundOnce putDownSound 
-        --                        $ set randGen g w
-        where --(rot, g) = randomR (-pi,pi) $ _randGen w
-            i = newCrKey w -- to give different lights different keys
-            pos = _crPos(you w)
-            ls = lightAt pos 0
-            dec = onLayer PtLayer $ color white $ circleSolid 8
+dropLight w = placeLS ls dec pos 0 w
+  where --(rot, g) = randomR (-pi,pi) $ _randGen w
+    i = newCrKey w -- to give different lights different keys
+    pos = _crPos(you w)
+    ls = lightAt pos 0
+    dec = onLayer PtLayer $ color white $ circleSolid 8
 
 dropLight' :: World -> World
 dropLight' w = placeCr lamp pos 0 w
-        where
-            pos = _crPos(you w)
+  where
+    pos = _crPos(you w)
diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs
index 713cbb5a9..66b7fae1e 100644
--- a/src/Dodge/Floor.hs
+++ b/src/Dodge/Floor.hs
@@ -42,6 +42,8 @@ roomTreex = do
         t = treeFromTrunk 
                 [[StartRoom]
                 ,[Corridor]
+                ,[SpecificRoom $ fmap (pure . Right) $ randomiseAllLinks =<< centerVaultRoom 1 200 200 50]
+                ,[SpecificRoom blockedCorridor]
                 ,[OrAno [[DoorAno]
                         ,[Corridor]
                         ,[DoorNumAno 0,AirlockAno]] 
@@ -68,7 +70,7 @@ levx = untilJust roomTreex
 
 lev1' :: RandomGen g => State g (Tree Room)
 lev1' = do
-    firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
+    firstWeapon <- takeOne $ [[branchRectWith weaponRoom,longBlockedCorridor]] ++ replicate 5 [weaponRoom]
     iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) 
         $ sequence $ treeFromPost 
         (
diff --git a/src/Dodge/Layout/Tree/Annotate.hs b/src/Dodge/Layout/Tree/Annotate.hs
index bddb2d718..01b065933 100644
--- a/src/Dodge/Layout/Tree/Annotate.hs
+++ b/src/Dodge/Layout/Tree/Annotate.hs
@@ -9,6 +9,7 @@ import Dodge.Layout.Tree.Polymorphic
 import Dodge.Layout.Tree.Either
 import Dodge.Room.Procedural
 import Dodge.Room.Branch
+import Dodge.Room.RoadBlock
 import Dodge.Room.Door
 import Dodge.Room.Boss
 import Dodge.Room.Treasure
@@ -66,7 +67,7 @@ annoToRoomTree [DoorAno] = roomThenCorridor door
 annoToRoomTree [DoorNumAno i,AirlockAno] = roomThenCorridor (airlock i)
 annoToRoomTree [FirstWeapon] = do
     branchWP <- branchRectWith weaponRoom
-    blockedC <- blockedCorridor
+    blockedC <- longBlockedCorridor
     firstWeapon <- takeOne $ [return $ appendEitherTree branchWP [blockedC]] ++ replicate 5 weaponRoom
     firstWeapon
 annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
diff --git a/src/Dodge/LevelGen/Pathing.hs b/src/Dodge/LevelGen/Pathing.hs
index 46b44f7d0..d38fbe9c5 100644
--- a/src/Dodge/LevelGen/Pathing.hs
+++ b/src/Dodge/LevelGen/Pathing.hs
@@ -23,7 +23,7 @@ removePathsCrossing :: Point2 -> Point2 -> World -> World
 removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
                             $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
                             w
-    where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
-          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
-          newGraph = pairsToGraph dist pg'
-
+  where 
+    pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
+    insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+    newGraph = pairsToGraph dist pg'
diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs
index 899ce4ea1..6fa010355 100644
--- a/src/Dodge/LevelGen/StaticWalls.hs
+++ b/src/Dodge/LevelGen/StaticWalls.hs
@@ -35,26 +35,26 @@ nearCollinear (a,b) (x,y)
 -- | Remove inverse walls.
 removeInverseWalls :: [WallP] -> [WallP]
 removeInverseWalls ((a,b):ps)
-    | elem (b,a) ps = removeInverseWalls $ delete (b,a) ps
-    | otherwise     = (a,b) : (removeInverseWalls ps)
+    | (b,a) `elem` ps = removeInverseWalls $ delete (b,a) ps
+    | otherwise       = (a,b) : removeInverseWalls ps
 removeInverseWalls ps = ps
 
 -- | Cut out a polygon from a set of walls, and check for errors in the
 -- created walls.
 -- If created walls are not consistent, expand poly and retry.
 cutWalls :: [Point2] -> [WallP] -> [WallP]
-cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
+cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
     [] -> newWalls
     _  -> cutWalls (expandPolyBy 0.01 ps) wls
   where
     newWalls = cutWalls' ps wls
-    errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
+    errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
 
 -- | Cut out a polygon from a set of walls, and check for errors in the
 -- created walls.
 -- Give error if created walls are not consistent.
 cutWalls'' :: [Point2] -> [WallP] -> [WallP]
-cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
+cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
     [] -> newWalls
     errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps 
         ++ "\nRight corner errors:\n"
@@ -67,7 +67,7 @@ cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
         ++ unlines (map show newWalls)
   where
     newWalls = cutWalls' ps wls
-    errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
+    errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
 
 -- | Given a specific wall and list of walls, checks that the number of walls leaving the
 -- second point is the same as the number of walls entering the second point of
@@ -126,7 +126,7 @@ cutWalls' qs walls =
 expandPolyBy :: Float -> [Point2] -> [Point2]
 expandPolyBy x ps = map f ps
   where
-    cp = (1/(fromIntegral (length ps))) *.* (foldr (+.+) (0,0) ps)
+    cp = 1/(fromIntegral (length ps)) *.* foldr (+.+) (0,0) ps
     f p = p +.+ x *.* (p -.- cp)
 
 -- | Given a polygon expressed as a list of points and a collection of walls,
@@ -144,7 +144,7 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
 -- | List the points of intersection between a segment and collection of walls.
 cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
 --cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
-cutWallsPoints p1 p2 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws
+cutWallsPoints p1 p2 = mapMaybe (uncurry $ myIntersectSegSeg p1 p2)
 
 -- | Given a segment and a wall, split the wall into two if it crosses the segment.
 cutWall :: Point2 -> Point2 -> WallP -> [WallP]
@@ -171,9 +171,7 @@ addPolyWall (p1,p2) walls =
   where 
     p3 = 0.5 *.* (p1 +.+ p2)
     p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-    maybeWs = -- listToMaybe .
-              fmap (fst . unzip)
---              . fmap unzip
+    maybeWs = fmap (map fst)
               . listToMaybe
               $ groupBy ((==) `on` (dist p3 . snd))
                 wlsP
@@ -224,10 +222,6 @@ wallIsZeroLength (x,y) = x == y
 
 -- | Given a polygon and list of walls, removes walls inside the polygon.
 removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
-removeWallsInPolygon ps walls = filter (not . cond) walls
+removeWallsInPolygon ps = filter (not . cond)
   where 
-    cond wall = 
-        pointInOrOnPolygon (0.5 *.* (fst wall +.+ snd wall)) ps
---        pointInOrOnPolygon (fst wall) ps
---                        && pointInOrOnPolygon (snd wall) ps
-
+    cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs
index e977ab849..45d5c3c24 100644
--- a/src/Dodge/LevelGen/Switch.hs
+++ b/src/Dodge/LevelGen/Switch.hs
@@ -29,10 +29,14 @@ makeButton c eff = Button
     , _btState = BtOff
     }
   where
-    turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
+    turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = const id}
     onPict = onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
 
-makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
+makeSwitch 
+    :: Color 
+    -> (World -> World) -- ^ Switch on effect
+    -> (World -> World) -- ^ Switch off effect
+    -> Button
 makeSwitch c effOn effOff = Button
     { _btPict = offPict
     , _btPos = (0,0)
@@ -42,28 +46,28 @@ makeSwitch c effOn effOff = Button
     , _btText = "SWITCH/"
     , _btState = BtOff
     }
-    where 
-        flipSwitch b w = switchEffect b . soundOnce 1 $ w
-        switchEffect b = case _btState b of
-            BtOff -> effOn  . over buttons (IM.adjust turnOn  (_btID b))
-            BtOn  -> effOff . over buttons (IM.adjust turnOff (_btID b))
-        offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
-                                  polygon $ rectNSEW (-2) (-5) (-10) (10)
-                                  ,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
-                                 ]
-        onPict  = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
-                                  polygon $ rectNSEW (-2) (-5) (-10) (10)
-                                  ,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
-                                 ]
-        turnOn :: Button -> Button
-        turnOn bt = bt 
-            { _btState = BtOn
-            , _btPict = onPict
-            , _btText = "SWITCH\\"
-            }
-        turnOff :: Button -> Button
-        turnOff bt = bt 
-            { _btState = BtOff
-            , _btPict = offPict
-            , _btText = "SWITCH/"
-            }
+  where 
+    flipSwitch b w = switchEffect b . soundOnce 1 $ w
+    switchEffect b = case _btState b of
+        BtOff -> effOn  . over buttons (IM.adjust turnOn  (_btID b))
+        BtOn  -> effOff . over buttons (IM.adjust turnOff (_btID b))
+    offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
+                              polygon $ rectNSEW (-2) (-5) (-10) 10
+                              ,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
+                             ]
+    onPict  = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
+                              polygon $ rectNSEW (-2) (-5) (-10) 10
+                              ,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
+                             ]
+    turnOn :: Button -> Button
+    turnOn bt = bt 
+        { _btState = BtOn
+        , _btPict = onPict
+        , _btText = "SWITCH\\"
+        }
+    turnOff :: Button -> Button
+    turnOff bt = bt 
+        { _btState = BtOff
+        , _btPict = offPict
+        , _btText = "SWITCH/"
+        }
diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs
index ed16b4a27..9d488ff7a 100644
--- a/src/Dodge/LevelGen/TriggerDoor.hs
+++ b/src/Dodge/LevelGen/TriggerDoor.hs
@@ -88,7 +88,7 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
         ]
     shiftRight = map (+.+ (0.5 *.* (pr -.- pl)))
     shiftLeft = map (+.+ (0.5 *.* (pl -.- pr)))
-    norm = 14 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
+    norm = 9 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
     hw = 0.5 *.* (pl +.+ pr)
     perp = 5 *.* normalizeV (pl -.- pr)
     plu = pl +.+ norm
@@ -99,12 +99,12 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
     hwd = hw -.- norm
     addSound (x:xs) = f x : xs
     f wl = over doorMech g wl
-    g dm w | dist wp pld > 2 && dist wp hwd > 2 
-                    = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
-                                                                    $ dm w
-            | otherwise = dm w
-          where 
-            wp = _wlLine (_walls w IM.! (head xs)) !! 1
+    g dm w 
+        | dist wp pld > 2 && dist wp hwd > 2 
+                    = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
+        | otherwise = dm w
+      where 
+        wp = _wlLine (_walls w IM.! head xs) !! 1
 
 triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
 triggerDoorPane c cond n closedPos openPos = Door
diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs
index b0cecd246..0550a3516 100644
--- a/src/Dodge/Render/Picture.hs
+++ b/src/Dodge/Render/Picture.hs
@@ -210,7 +210,7 @@ wallsForShadows w = map (linePairs . _wlLine)
                         . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
     where linePairs (x:y:_) = (x,y)
 
-lightsForGloom' :: World -> [(Point4)]
+lightsForGloom' :: World -> [Point4]
 lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
     where getLS ls  = ( fst $ _lsPos ls, snd $ _lsPos ls,  _lsRad ls , _lsIntensity ls)
           getTLS ls = ( fst $ _tlsPos ls,snd $ _tlsPos ls, _tlsRad ls, _tlsIntensity ls)
diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs
index 54a78a9e3..28442cf64 100644
--- a/src/Dodge/Room.hs
+++ b/src/Dodge/Room.hs
@@ -65,7 +65,10 @@ airlockOneWay n = Room
                  ]
           cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
           col = dim $ dim $ bright red
-airlock :: Int -> Room
+
+airlock 
+    :: Int  -- ^ Door id
+    -> Room
 airlock n = Room
     { _rmPolys =
         [ rectNSWE 100 0 0 40
@@ -85,11 +88,13 @@ airlock n = Room
         ]
     , _rmBound = rectNSWE 75 15 0 40
     }
-    where lnks = [((20,85),0)
-                 ,((20, 5),pi)
-                 ]
-          cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
-          col = dim $ dim $ bright red
+  where 
+    lnks = [((20,85),0)
+           ,((20, 5),pi)
+           ]
+    cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
+    col = dim $ dim $ bright red
+
 roomC :: Float -> Float -> Room
 roomC x y = Room
     { _rmPolys = [rectNSWE y 0 0 x]
@@ -312,8 +317,8 @@ randFirstWeapon = do
         ++ replicate 5 multGun
         ++ replicate 2 autoGun
         ++ [launcher]
-        ++ [lasGun]
-        ++ [flamer]
+--        ++ [lasGun]
+--        ++ [flamer]
 
 --randC1 :: State StdGen PSType
 randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
@@ -381,17 +386,6 @@ weaponBetweenPillars = do
       (fmap connectRoom . randomiseOutLinks) =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars)
     where f (_,a) = a == 0
 
-blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
-blockedCorridor = do
-    r <- state $ randomR (0,pi)
-    n <- state $ randomR (0,3)
-    let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256) 
-                                          $ reverse $ rectNSWE 10 (-10) (-10) 10
-                 ,PS (20,15) 0 $ putLamp
-                 ]
-    sequence $ treeFromPost (replicate n $ fmap Left $ randomiseOutLinks corridor) 
-                        $ fmap Right $ return $ set rmPS plmnts corridor
-
 weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
 weaponLongCorridor = do
     root <- takeOne $ [tEast, tWest]
diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs
index 6b54caa35..5b2ee71b1 100644
--- a/src/Dodge/Room/Procedural.hs
+++ b/src/Dodge/Room/Procedural.hs
@@ -1,10 +1,11 @@
 {-
-Procedural creation of rooms.
+Procedural creation of rooms and subroom parts.
 -}
 module Dodge.Room.Procedural
     ( roomRect
     , roomRectAutoLinks
     , testRoom
+    , centerVaultRoom
     ) where
 import Dodge.Data
 import Dodge.Room.Data
@@ -18,9 +19,11 @@ import Dodge.LevelGen.Data
 import Dodge.Creature
 import Dodge.Default
 import Geometry
+import Picture
 
 import Data.List (nub,nubBy,sortBy,minimumBy)
 import Data.Function (on)
+import qualified Data.Map as M
 import Control.Lens
 import Control.Monad
 import Control.Monad.State
@@ -220,9 +223,55 @@ testRoom = do
     nCrits <- state $ randomR (1,3)
     crits <- takeN nCrits $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
         ++ replicate 20 chaseCrit
-    randomiseAllLinks . (fillNothingPlacements $ crits ++ itms) =<< 
+    randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<< 
         ( shufflePlacements
         . foldr1 combineRooms 
         $ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2]
         )
 
+{- | Creates room with a central vault with doors around it.
+-}
+centerVaultRoom
+    :: RandomGen g 
+    => Int      -- ^ Door id
+    -> Float    -- ^ Width
+    -> Float    -- ^ Height
+    -> Float    -- ^ Vault dimensions
+    -> State g Room
+centerVaultRoom n w h d = do
+    let northPoly = rectNSWE h d (-w) w
+        nsDoors = rectNSWE (d + 20) (negate (d +20)) (-20) 20
+        weDoors = rectNSWE 20 (-20) (d + 20) (negate (d +20)) 
+        centerPoly = rectWdthHght (d - 20) (d - 20)
+        polys = centerPoly : nsDoors : weDoors : (take 4 $ iterate (map vNormal) northPoly)
+    cr <- takeOne [miniGunCrit, autoCrit]
+    return $ Room
+        { _rmPolys  = polys
+        , _rmLinks  = 
+            [((0,h),0)
+            ,((w,0),-pi/2)
+            ,((-w,0),pi/2)
+            ,((0,-h),pi)
+            ]
+        , _rmPath   = []
+        , _rmPS     = 
+            [PS (d-25,d-25) 0 putLamp
+            ,PS (w-5,h-5) 0 putLamp
+            ,PS (w-5,5-h) 0 putLamp
+            ,PS (5-w,h-5) 0 putLamp
+            ,PS (5-w,5-h) 0 putLamp
+            ,PS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
+            ]
+            ++ concat (zipWith (\i r -> map (shiftPSBy ((0,0),r)) $ theDoor i) 
+                        [n, n+1, n+2, n+3] [0,pi/2,pi,3*pi/2])
+        , _rmBound  = rectNSWE h (-h) (-w) w
+        }
+  where
+    col = dim $ dim $ bright red
+    theDoor i = 
+        [ PS (0,d-10) 0 $ PutTriggerDoor col (cond i) (-19,0) (19,0)
+        , PS (35,d+4) 0 $ PutButton $ makeSwitch col 
+                           (over worldState (M.insert (DoorNumOpen i) True))
+                           (over worldState (M.insert (DoorNumOpen i) False))
+        ]
+    cond i w = or $ M.lookup (DoorNumOpen i) (_worldState w)
diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs
index 4d52a409a..43b70a841 100644
--- a/src/Dodge/Room/RoadBlock.hs
+++ b/src/Dodge/Room/RoadBlock.hs
@@ -7,12 +7,15 @@ import Geometry
 import Dodge.Room.Data
 import Dodge.Room.Link
 import Dodge.Room.Placement
+import Dodge.Room.Corridor
 import Dodge.LevelGen.Data
 import Dodge.RandomHelp
 import Dodge.Creature
+import Dodge.Layout.Tree.Polymorphic
 
 import Data.Tree
 import Control.Monad.State
+import Control.Lens
 import System.Random
 
 armouredCorridor :: RandomGen g => State g Room
@@ -46,3 +49,30 @@ litCorridor90 = do
             ]
         , _rmBound = poly
         }
+
+noWeaponTest :: RandomGen g => State g (Tree (Either Room Room))
+noWeaponTest = do
+    undefined
+
+-- | A random length corridor with a descrutible block blocking it.
+longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
+longBlockedCorridor = do
+    r <- state $ randomR (0,pi)
+    n <- state $ randomR (0,3)
+    let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256) 
+                                          $ reverse $ rectNSWE 10 (-10) (-10) 10
+                 ,PS (20,15) 0 $ putLamp
+                 ]
+    sequence $ treeFromPost (replicate n $ fmap Left $ randomiseOutLinks corridor) 
+                        $ fmap Right $ return $ set rmPS plmnts corridor
+
+-- | A single corridor with a descrutible block blocking it.
+blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
+blockedCorridor = do
+    r <- state $ randomR (0,pi)
+    let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256) 
+                                          $ reverse $ rectNSWE 10 (-10) (-10) 10
+                 ,PS (20,15) 0 $ putLamp
+                 ]
+    sequence $ treeFromPost [] 
+                        $ fmap Right $ return $ set rmPS plmnts corridor
diff --git a/src/Dodge/Room/Teleport.hs b/src/Dodge/Room/Teleport.hs
index 636818de4..224cfdafe 100644
--- a/src/Dodge/Room/Teleport.hs
+++ b/src/Dodge/Room/Teleport.hs
@@ -28,7 +28,7 @@ telRoomLev i = do
     h <- state $ randomR (200,300)
     return $ roomRectAutoLinks w h & rmPS .~ 
         [ PS (w/2,h/2) 0 $ PutPressPlate telPP 
-        , PS (w/2,h/2+ 30) 0 $ putLamp
+        , PS (w/2,h/2+ 30) 0 putLamp
         ]
   where
     telPP = PressPlate
diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs
index 050d27f83..17abfc2ee 100644
--- a/src/Dodge/Update.hs
+++ b/src/Dodge/Update.hs
@@ -118,11 +118,11 @@ ppEvents w = IM.foldr (\pp w -> _ppEvent pp pp w) w $ _pressPlates w
 
 updateSeenWalls :: World -> World
 updateSeenWalls w = foldr markSeen w wallsToUpdate
-    where yPos = _crPos $ _creatures w IM.! 0
---          wallsToUpdate = map _wlID $ IM.elems $ wallsNearPoint yPos w
-          wallsToUpdate = concatMap (\p -> collidePointFindWalls yPos (yPos +.+p) $ wallsAlongLine yPos (yPos +.+ p) w)
-                                   $ nRays 60
-          markSeen i = set (walls . ix i . wlSeen) True
+  where 
+    vPos = _cameraViewFrom w
+    wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
+                             $ nRays 20
+    markSeen i = set (walls . ix i . wlSeen) True
 
 setTestStringIO :: IO World -> IO World
 setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
@@ -186,20 +186,22 @@ crCrSpring c1 c2 w
                overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
                massT    = _crMass c1 + _crMass c2
 
-collidePointFindWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Int
-collidePointFindWall p1 p2 ws = fmap fst $ listToMaybe $ sortBy f 
-                                            $ IM.toList 
-                                            $ IM.mapMaybe ((\(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
-    where f (_,a) (_,b) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
-
-collidePointFindWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
-collidePointFindWalls p1 p2 ws 
-    -- = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fst . fromJust)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
-    = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fromJust . fst)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
-    where f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
-          g (_,wl) = _wlIsSeeThrough wl
-          takeWhileAnd h xs = let (ys,zs) = span h xs
-                              in  ys ++ tf zs
-                where tf (x:_) = [x]
-                      tf _ = []
+{-
+Finds the IDs of visible walls from a point to another point.
+-}
+visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
+visibleWalls p1 p2 ws 
+    = map fst 
+    . takeUntil (_wlIsSeeThrough . snd) 
+    . map snd 
+    . sortOn (dist p1 . fromJust . fst) 
+    . filter ((/=) Nothing . fst) 
+    . map f 
+    $ IM.toList ws
+  where 
+    f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
+    takeUntil h xs = let (ys,zs) = span h xs
+                     in  ys ++ tf zs
+      where tf (x:_) = [x]
+            tf _ = []
 
diff --git a/src/Geometry.hs b/src/Geometry.hs
index 2b4c5b64a..cd6d758db 100644
--- a/src/Geometry.hs
+++ b/src/Geometry.hs
@@ -68,6 +68,11 @@ rectNSEW !n !s !e !w = rectNESW n e s w
 rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
 rectNSWE !n !s !w !e = [ (w,n), (w,s), (e,s), (e,n)]
 
+rectWdthHght :: Float -> Float -> [Point2]
+rectWdthHght w h = rectNSWE h (-h) (-w) w
+
+-- | Draw a rectangle around the origin with given height and width
+
 -- | Test whether a point is in a polygon or on the polygon border.
 -- Supposes the points in the
 -- polygon are listed in anticlockwise order.
@@ -423,6 +428,7 @@ divideLineOddNumPoints x a b = take 5000
 -- | Given two pairs of Ints, returns a list of pairs of Ints that form 
 -- a digital line between them.
 digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
+{-# INLINE digitalLine #-}
 digitalLine (x1,y1) (x2,y2) 
     | abs (x1-x2) > abs (y1-y2) = [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) ) 
                                     | x <- intervalList x1 x2 ]
@@ -431,6 +437,17 @@ digitalLine (x1,y1) (x2,y2)
   where 
     rdiv a b = round $ fromIntegral a / fromIntegral b
 
+-- | Given two pairs of 'Int's, create a list of pairs of 'Int's that form a
+-- rectangle between them.
+digitalRect :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
+{-# INLINE digitalRect #-}
+digitalRect (a,b) (c,d) = [(s,t) | s <- [minx .. maxx] , t <- [miny .. maxy]]
+  where
+    maxx = max a c
+    minx = min a c
+    maxy = max b d
+    miny = min b d
+
 -- | Given two Ints, creates the list of Ints between these.
 intervalList :: Int -> Int -> [Int]
 intervalList x y