Various improvements, metal debris

2022-06-23 18:53:26 +01:00
parent e3d5c4eb4b
commit 8d266a6770
18 changed files with 147 additions and 82 deletions
@@ -32,7 +32,7 @@ unshadowBlock wlid w = case w ^? walls . ix wlid of
        & walls . ix wlid . wlDraw .~ True
        & wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
      where
-        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
+        (x,y) = zoneOfPoint $ uncurry midPoint (_wlLine wl)
    Nothing -> w

 checkBlockHP :: Block -> World -> World
@@ -16,48 +16,74 @@ import qualified Quaternion as Q

 import qualified Data.IntSet as IS
 import Data.Maybe
-makeBlockDebris :: Block -> World -> World
-makeBlockDebris bl w = w & makeDebris mt (_blPos bl)
+
+makeDoorDebris :: Door -> World -> World
+makeDoorDebris dr w = w & makeDebris mt col p
  where
-    mt = fromMaybe Stone $ do
+    p = uncurry midPoint (_drPos dr)
+    (mt,col) = fromMaybe (Stone,greyN 0.5) $ do
+        wlids <- w ^? doors . ix (_drID dr) . drWallIDs
+        (wlid,_) <- IS.minView wlids
+        wl <- w ^? walls . ix wlid
+        return (_wlMaterial wl,_wlColor wl)
+
+makeBlockDebris :: Block -> World -> World
+makeBlockDebris bl w = w & makeDebris mt col (_blPos bl)
+  where
+    (mt,col) = fromMaybe (Stone,greyN 0.5) $ do
        wlids <- w ^? blocks . ix (_blID bl) . blWallIDs
        (wlid,_) <- IS.minView wlids
-        w ^? walls . ix wlid . wlMaterial
+        wl <- w ^? walls . ix wlid
+        return (_wlMaterial wl,_wlColor wl)

-makeDebris :: Material -> Point2 -> World -> World
+makeDebris :: Material -> Color -> Point2 -> World -> World
 makeDebris = makeDebrisDirected 1 2 (2*pi) 0
-makeDebrisDirected :: Float -> Float 
-    -> Float -> Float -> Material -> Point2 -> World -> World
-makeDebrisDirected mindist maxdist arcrad dir bm p w = w
+makeDebrisDirected :: Float 
+    -> Float 
+    -> Float 
+    -> Float 
+    -> Material 
+    -> Color
+    -> Point2 
+    -> World -> World
+makeDebrisDirected mindist maxdist arcrad dir bm col p w = w
        & flip (foldr (plNew props pjID)) thedebris
        & randGen .~ newg
        & originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
  where
-    someDebris = case bm of
-        Stone -> stoneDebris
-        Glass -> glassDebris
-        Crystal -> crystalDebris
-        Dirt   -> dirtDebris
-        Wood   -> stoneDebris
-        Metal  -> stoneDebris
-    (thedebris,newg) = runState (mapM f [35,55..95]) $ _randGen w
+    (thedebris,newg) = mapM f [35,55..95] & runState $ _randGen w
    f h = do
        v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad
        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
-        return $ someDebris
+        spinspeed <- randomR (-0.2,-0.1) & state
+        basedebris <- baseDebris bm
+        return $ basedebris
+            & pjColor .~ col
            & prPos .~ p
            & pjVel .~ v
-            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
            & pjQuat .~ q
            & pjVelZ .~ 0
            & pjPosZ .~ h

+baseDebris :: Material -> State StdGen Prop
+baseDebris mt = case mt of
+    Stone   -> return stoneDebris
+    Glass   -> return glassDebris
+    Crystal -> return crystalDebris
+    Dirt    -> return dirtDebris
+    Wood    -> return stoneDebris
+    Metal   -> do
+        sh <- jaggedShape
+        return $ metalDebris
+            & prDraw .~ (`drawMovingShape` sh)
+
 stoneDebris :: Prop
 stoneDebris = PropZ
    {_prPos = 0
    ,_pjStartPos = 0
    ,_pjVel = 0
-    ,_prDraw = \pr -> drawMovingShape pr (debrisShape 4 pr)
+    ,_prDraw = \pr -> drawMovingShape pr (cubeShape 4)
    ,_pjID = 0
    ,_pjUpdate = fallSmallBounceDamage
    ,_pjPosZ = 10
@@ -74,21 +100,31 @@ dirtDebris = stoneDebris
 dirtColor :: Color
 dirtColor = V4 (150/256) ( 75/256)  0 ( 250/256)

+metalDebris :: Prop
+metalDebris = stoneDebris
+    & prDraw    .~ (\pr -> drawMovingShape pr (shardShape 4))
+    & pjUpdate  .~ fallSmallBounce
+
 glassDebris :: Prop
 glassDebris = stoneDebris
-    & prDraw    .~ (\pr -> drawMovingShape pr (shardShape 4 pr))
+    & prDraw    .~ (\pr -> drawMovingShape pr (shardShape 4))
    & pjUpdate  .~ fallSmallBounce
    & pjColor   .~ withAlpha 0.5 cyan
 crystalDebris :: Prop
 crystalDebris = glassDebris
    & pjColor .~ withAlpha 0.5 aquamarine

-shardShape :: Float -> Prop -> Shape
-shardShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly size
+shardShape :: Float -> Shape
+shardShape size = translateSHz (-size) $ upperPrismPoly size
    [V2 size 0
    ,V2 (-size) 1
    ,V2 (-size) (-1)
    ]

-debrisShape :: Float -> Prop -> Shape
-debrisShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly (2*size) $ square size
+jaggedShape :: State StdGen Shape
+jaggedShape = do
+    s <- randomR (4,10) & state
+    return $ shardShape s
+
+cubeShape :: Float -> Shape
+cubeShape size = translateSHz (-size) $ upperPrismPoly (2*size) $ square size
@@ -1397,7 +1397,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
    | PutLineBlock {_putWall :: Wall , _putWidth :: Float
        , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
    | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
-    | PutSlideDr Bool Color Door Float Point2 Point2
+    | PutSlideDr Door Wall Float Point2 Point2
 --    | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
    | PutDoor Color (World -> Bool) [(Point2,Point2)]
    | RandPS (State StdGen PSType)
@@ -1,5 +1,25 @@
-module Dodge.Default.Door where
+module Dodge.Default.Door 
+    ( module Dodge.Default.Door
+    , module Dodge.Default.Wall
+    ) where
 import Dodge.Data
+import Dodge.Default.Wall
+import Dodge.Block.Debris
+import Color
+
+import Control.Lens
+
+switchWallCol :: Color -> Wall
+switchWallCol col = defaultSwitchWall & wlColor .~ col
+
+defaultAutoWall :: Wall
+defaultAutoWall = defaultDoorWall'
+    & wlColor .~ dim yellow
+    & wlPathable .~ True
+defaultSwitchWall :: Wall
+defaultSwitchWall = defaultDoorWall'
+    & wlColor .~ red
+    & wlPathable .~ False

 defaultDoor :: Door
 defaultDoor = Door
@@ -12,7 +32,7 @@ defaultDoor = Door
    , _drOpenPos = (0,0)
    , _drClosePos = (0,0)
    , _drHP     = 10000
-    , _drDeath  = const id
+    , _drDeath  = makeDoorDebris
    , _drSpeed  = 1
    , _drPushedBy = PushesItself
    , _drPushes  = Nothing
@@ -23,6 +23,11 @@ defaultWall = Wall
    , _wlHeight = 100
    , _wlMaterial = Stone
    }
+defaultDoorWall' :: Wall
+defaultDoorWall' = defaultWall
+    { _wlPathable = True
+    , _wlMaterial = Metal
+    }
 {- Indestructible see-through wall.  -}
 defaultCrystalWall :: Wall
 defaultCrystalWall = defaultWall 
@@ -60,6 +60,7 @@ shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ collidePointWal

 shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World
 shatterWall w sp ep p wl = w 
-    & makeDebris (_wlMaterial wl) p
-    & makeDebrisDirected 1 2 (pi/2) (argV $ vNormal $ uncurry (-.-) $ _wlLine wl) (_wlMaterial wl) p
+    & makeDebris (_wlMaterial wl) (_wlColor wl) p
+    & makeDebrisDirected 1 2 (pi/2) (argV $ vNormal $ uncurry (-.-) $ _wlLine wl) (_wlMaterial wl) 
+        (_wlColor wl) p
    & damageWall (Damage SHATTERING 1000 sp p ep NoDamageEffect) wl
@@ -185,8 +185,7 @@ withWarmUp
    :: SoundID -- ^ warm up sound id
    -> ChainEffect
 withWarmUp soundID f item cr w
-    | crWeaponReady cr = w
-    | curWarmUp < maxWarmUp = w
+    | curWarmUp < maxWarmUp && crWeaponReady cr = w
        & pointerToItem . itUse . useDelay . warmTime +~ 2
        & soundContinue (CrWeaponSound cid 0) (_crPos cr) soundID (Just 2)
    | otherwise = w
@@ -6,7 +6,6 @@ module Dodge.Placement.Instance.Door
    ) where
 import Dodge.Data
 import Dodge.Default.Door
--import Dodge.Base
 import Color
 import Geometry
 import Dodge.LevelGen.Data
@@ -16,47 +15,48 @@ import Dodge.LevelGen.Switch
 import Control.Lens
 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 1 a b speed (const $ const Nothing)
+putDoubleDoor :: Wall -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Placement
+putDoubleDoor wl cond a b speed 
+    = putDoubleDoorThen wl cond 1 a b speed (const $ const Nothing)

-putDoubleDoorThen :: Bool -> Color -> (World -> Bool) 
+putDoubleDoorThen :: Wall -> (World -> Bool) 
    -> Float -> Point2 -> Point2 -> Float 
    -> (Placement -> Placement -> Maybe Placement)
    -> Placement
-putDoubleDoorThen pathing col cond soff a b speed cont 
-     = doorBetween pathing col cond soff a half speed
-    $ \pl1 -> Just $ doorBetween pathing col cond soff b half speed
+putDoubleDoorThen wl cond soff a b speed cont 
+     = doorBetween wl cond soff a half speed
+    $ \pl1 -> Just $ doorBetween wl cond soff b half speed
    $ \pl2 -> cont pl1 pl2
  where
    half = 0.5 *.* (a +.+ b)

-doorBetween :: Bool -> Color -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float ->
+doorBetween :: Wall -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float ->
    (Placement -> Maybe Placement) -> Placement
-doorBetween pathing col cond soff pa pb speed g = case divideLine 40 pa pb of
-    [x,y] -> ptCont (PutSlideDr pathing col adoor soff x y) g
-    (x:y:zs) -> divideDoorPane Nothing pathing col cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
+doorBetween wl cond soff pa pb speed g = case divideLine 40 pa pb of
+    [x,y] -> ptCont (PutSlideDr adoor wl soff x y) g
+    (x:y:zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
    _ -> undefined
  where
    adoor = defaultDoor
        & drTrigger .~ cond
        & drSpeed   .~ speed

-divideDoorPane :: Maybe Int -> Bool -> Color -> (World -> Bool) -> Float -> Float 
+divideDoorPane :: Maybe Int -> Wall -> (World -> Bool) -> Float -> Float 
    -> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement
-divideDoorPane mid pathing col cond soff speed ppairs g = case ppairs of
+divideDoorPane mid wl cond soff speed ppairs g = case ppairs of
    [p] -> ptCont (adoor p) g
-    (p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) pathing col cond soff speed ps g
+    (p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g
    _ -> undefined
  where
-    adoor (x,y) = PutSlideDr pathing col thedoor soff x y
+    adoor (x,y) = PutSlideDr thedoor wl soff x y
    thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond
        & drPushedBy .~ maybe PushesItself PushedBy mid

 putAutoDoor :: Point2 -> Point2 -> Placement
 putAutoDoor a b = PlacementUsingPos (addZ 0 a)
    $ \az -> PlacementUsingPos (addZ 0 b)
-    $ \bz -> putDoubleDoor True (dim yellow) (cond az bz) a b 3
+    $ \bz -> putDoubleDoor defaultAutoWall
+        (cond az bz) a b 3
  where
    --cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures
    cond az bz = any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz))) 
@@ -67,7 +67,7 @@ switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeS
    $ \btid -> jsps0J (doorbetween btid dra drc)
    $          sps0   (doorbetween btid drb drc)
  where
-    doorbetween btid a b = PutSlideDr False col thedoor 1 a b
+    doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) 1 a b
      where
        thedoor = defaultDoor
            & drTrigger .~ cond btid
@@ -23,6 +23,7 @@ import Shape
 import qualified IntMapHelp as IM
 import Color

+import Data.Foldable
 import Data.Maybe
 import System.Random
 import Control.Monad.State
@@ -101,8 +102,8 @@ placeSpotID ps pt w = case pt of
    RandPS      rgn         -> evaluateRandPS rgn ps w
    PutDoor     col f   pss -> plDoor col f (map (bimap doShift doShift) pss) w
    PutCoord    cp          -> plNewID   coordinates (doShift cp) w
-    PutSlideDr  pth col dr off  a   b 
-                            -> plSlideDoor pth col dr off (doShift a) (doShift b) w
+    PutSlideDr  wl dr off  a   b 
+                            -> plSlideDoor wl dr off (doShift a) (doShift b) w
    PutBlock    bl wl  ps'  -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
                                    wl w
    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
@@ -129,18 +130,18 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
    (evaluatedType, g) = runState rgen (_randGen w)

 placeWallPoly :: [Point2] -> Wall -> World -> World
-placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
+placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
  where
    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps

-addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
-addWalls qs wl wls = foldr (addPane wl) wls pairs
+placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
+placeWalls qs wl wls = foldl' (addPane wl) wls pairs
  where 
    (p:ps) = orderPolygon qs
    pairs = zip (ps ++ [p]) (p:ps)

-addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
-addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
+addPane :: Wall -> IM.IntMap Wall -> (Point2,Point2) -> IM.IntMap Wall
+addPane wl wls l = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
  where
    wlid = IM.newKey wls

@@ -47,7 +47,7 @@ addBlock (p:ps) wl bl w = w
            = insertIMInZone x y wlid wl'
        | otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips
      where 
-        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
+        (x,y) = zoneOfPoint $ uncurry midPoint (_wlLine wl)
        wlid  = _wlID wl
        ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
 addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
@@ -5,7 +5,6 @@ module Dodge.Placement.PlaceSpot.TriggerDoor
    ) where
 import Dodge.Data
 import Dodge.Base
-import Dodge.Default.Wall
 import Dodge.Default.Door
 import Dodge.Wall.Move
 import Dodge.LevelGen.DoorPane
@@ -42,14 +41,12 @@ plDoor col cond pss gw = (drid, addWalls gw & doors %~ addDoor)
    nsteps = length pss - 1
    wlids = take 4 [IM.newKey $ _walls gw ..]
    wlps' = uncurry (rectanglePairs 9) $ head pss
-    addWalls w' = foldl' (addDoorWall drid col False) w' $ zip wlids wlps'
+    addWalls w' = foldl' (addDoorWall drid $ switchWallCol col) w' $ zip wlids wlps'

-addDoorWall :: Int -> Color -> Bool -> World -> (Int,(Point2,Point2)) -> World
-addDoorWall drid col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defaultWall
+addDoorWall :: Int -> Wall -> World -> (Int,(Point2,Point2)) -> World
+addDoorWall drid wl w (wlid,wlps) = w & walls %~ IM.insert wlid wl
    { _wlLine = wlps
    , _wlID = wlid
-    , _wlColor = col
-    , _wlPathable = pathableStatus
    , _wlStructure = DoorPart drid
    }
 -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
@@ -80,7 +77,7 @@ doorMechanismStepwise nsteps drid wlids pss dr w
 doorMechanism :: Door -> World -> World
 doorMechanism dr w = case mvDir of
    Just d -> w
-        & flip (IS.foldr (`translateWallID` d)) (_drWallIDs dr)
+        & flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr)
        & moveUpdate 
        & doors . ix drid . drPos . each %~ (+.+ d)
    Nothing -> w
@@ -105,15 +102,14 @@ doorMechanism dr w = case mvDir of

 -- TODO cut pathing if not pathable, reset when opened
 plSlideDoor 
-    :: Bool 
-    -> Color 
-    -> Door 
+    :: Door 
+    -> Wall
    -> Float
    -> Point2 
    -> Point2 
    -> World
    -> (Int, World)
-plSlideDoor isPathable col dr shiftOffset a b gw 
+plSlideDoor dr wl shiftOffset a b gw 
    = (drid, addDoorWalls gw & doors %~ addDoor)
  where
    drid = IM.newKey $ _doors gw
@@ -126,7 +122,7 @@ plSlideDoor isPathable col dr shiftOffset a b gw
        , _drOpenPos = (shiftLeft a,shiftLeft b)
        , _drClosePos = (a,b)
        }
-    addDoorWalls w' = foldl' (addDoorWall drid col isPathable) w' $ zip wlids pairs
+    addDoorWalls w' = foldl' (addDoorWall drid wl) w' $ zip wlids pairs
    pairs = rectanglePairs 9 a b
    shiftLeft  = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
    wlids = take 4 [IM.newKey $ _walls gw ..]
@@ -67,3 +67,4 @@ drawMovingShape pr = noPic
    . translateSHz (_pjPosZ pr)
    . uncurryV translateSHf (_prPos pr) 
    . overPosSH (Q.rotate (_pjQuat pr))
+    . colorSH (_pjColor pr)
@@ -5,7 +5,7 @@ import Dodge.Placement.Instance
 import Dodge.Room.Foreground
 import Dodge.RoomLink
 import Dodge.Default.Room
-import Dodge.Default.Wall
+import Dodge.Default.Door
 import Dodge.Data
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.Switch
@@ -13,6 +13,7 @@ import RandomHelp
 import Geometry
 import Picture

+--import Control.Lens
 import qualified Data.IntMap.Strict as IM
 {- | A passage with a switch that opens forward access while closing backwards access. -}
 airlock :: RandomGen g => State g Room
@@ -26,8 +27,8 @@ airlock0 = defaultRoom
    , _rmPath  = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20  5) ]
    , _rmPmnts    = 
        [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
-            $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2
-                $ \_ _ -> Just $ putDoubleDoor False col (cond' btid) (V2 0 80) (V2 40 80) 2
+            $ \btid -> Just $ putDoubleDoorThen thewall (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2
+                $ \_ _ -> Just $ putDoubleDoor thewall (cond' btid) (V2 0 80) (V2 40 80) 2
        , invisibleWall $ rectNSWE 60 40 (-40) (-30)
        ,spanLightI (V2 (-2) 30) (V2 (-2) 70)
        ,sps0 $ PutShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
@@ -35,6 +36,7 @@ airlock0 = defaultRoom
    , _rmBound = [rectNSWE 75 15 0 40,switchcut]
    }
  where 
+    thewall = switchWallCol col
    switchcut = rectNSWE 65 35 (-40) 20 
    lnks = [(V2 20 95,0)
           ,(V2 20  5,pi)
@@ -5,6 +5,7 @@ import Geometry
 import Dodge.RoomLink
 import Dodge.Data
 import Dodge.Default.Room
+import Dodge.Default.Door
 import Dodge.Placement.Instance
 import Color

@@ -39,6 +40,6 @@ triggerDoorRoom inplid = defaultRoom
 -- note no bounds
    }
  where 
-    f (pmnt:_) = putDoubleDoor False red (cond pmnt) (V2 0 20) (V2 40 20) 2
+    f (pmnt:_) = putDoubleDoor (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2
    f _ = error "tried to put a door using an empty placement list"
    cond pmnt w = w & _triggers w IM.! fromJust (_plMID pmnt)
@@ -46,8 +46,8 @@ twinSlowDoorRoom w h x = defaultRoom
    , _rmPath   = []
    , _rmPmnts     = 
        [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
-            $ \btid -> jsps0J (PutSlideDr False col (thedoor btid) 1 (V2 x 1) (V2 x h))
-            $ ps0 (PutSlideDr False col (thedoor btid) 1 (V2 (-x) 1) (V2 (-x) h))
+            $ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h))
+            $ ps0 (PutSlideDr (thedoor btid) thewall 1 (V2 (-x) 1) (V2 (-x) h))
            $ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampHeight)))
            $ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
        ]
@@ -56,6 +56,7 @@ twinSlowDoorRoom w h x = defaultRoom
    , _rmViewpoints = [V2 0 h]
    }
  where
+    thewall = switchWallCol red
    wlSpeed = 0.5
    addColorChange lsid drid = over pjUpdate $ dbArgChain $ const f
      where
@@ -114,9 +115,10 @@ addButtonSlowDoor x h rm = do
        [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)]
    -- TODO make the height of this light source and of other mounted lights
    -- be taken from a single consistent source
+    thewall = switchWallCol red
    butDoor = putLitButOnPos col 
        (rprBool (isUnusedLnkType InLink))
-        $  \btplmnt -> Just $ putDoubleDoorThen False col (cond' $ fromJust $ _plMID btplmnt) 
+        $  \btplmnt -> Just $ putDoubleDoorThen thewall (cond' $ fromJust $ _plMID btplmnt) 
                            30 (V2 0 h) (V2 x h) 2
        $ \dr1 dr2 -> 
            amountedlight dr1 50
@@ -267,9 +267,10 @@ centerVaultRoom w h d = return $ defaultRoom
    col = dim $ dim $ bright red
    theDoor = 
        [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
-            $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (thedoor btid) 1 (V2 (-21) 0) (V2 0 0))
-            $          sPS   (V2 0 (d-10)) 0 (PutSlideDr False col (thedoor btid) 1 (V2   21  0) (V2 0 0))
+            $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall 1 (V2 (-21) 0) (V2 0 0))
+            $          sPS   (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall 1 (V2   21  0) (V2 0 0))
        ]
+    thewall = switchWallCol col
    thedoor btid = defaultDoor
        & drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) == BtOn)
        & drSpeed .~ 2
@@ -10,7 +10,7 @@ import Data.Foldable

 zoneOfWall :: Wall -> [(Int,Int)]
 zoneOfWall wl 
-    | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry pHalf wlline ]
+    | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ]
    | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline
  where
    wlline = _wlLine wl
@@ -68,8 +68,8 @@ errorClosestPointOnLineParam  _ !x! y! z
    | otherwise = closestPointOnLineParam x y z

 -- | Return midpoint between two points.
-pHalf :: Point2 -> Point2 -> Point2
-pHalf !a !b = 0.5 *.* (a +.+ b)
+midPoint :: Point2 -> Point2 -> Point2
+midPoint !a !b = 0.5 *.* (a +.+ b)
 -- | Test whether a circle is on a segment by intersecting a new normal segment through the 
 -- center of the circle with the segment itself.
 -- Returns False if the circle center is beyond the endpoints of the