Commit before placement refactor

2021-09-28 14:55:22 +01:00
parent 751000636e
commit b8af2ce9d8
16 changed files with 134 additions and 331 deletions
@@ -64,7 +64,7 @@ pointHitsWalls p1 p2
 collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
 collidePointWalkable p1 p2 ws 
    = any (isJust . uncurry (intersectSegSeg p1 p2) . _wlLine) 
-    $ IM.filter (fromMaybe True . (^? doorPathable)) ws
+    $ IM.filter (fromMaybe True . (^? wlPathable)) ws

 furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
 furthestPointWalkable p1 p2 ws 
@@ -27,7 +27,6 @@ import Picture.Data
 import ShapePicture
 import Geometry.Data
 import Sound.Data
-import qualified DoubleStack as DS
 import Dodge.GameRoom
 import Color
 import Shape
@@ -374,8 +373,6 @@ data Item
        , _itEffect     :: ItEffect
        , _itHammer     :: HammerPosition
        , _itScroll     :: Float -> Creature -> Item -> Item
--        , _itScrollUp   :: Int -> World -> World
--        , _itScrollDown :: Int -> World -> World
        , _itAimStance  :: AimStance
        }
     | NoItem
@@ -482,6 +479,13 @@ data Prop
        , _pjID :: Int
        , _pjUpdate :: Prop -> World -> World
        }
+    | RecursiveProp
+        { _pjPos    :: Point2
+        , _pjID     :: Int
+        , _pjDraw   :: Prop -> SPic
+        , _pjUpdate :: Prop -> World -> World
+        , _pjProp   :: Prop
+        }
    | ProjectileTimed
        { _pjPos :: Point2
        , _pjStartPos :: Point2
@@ -497,6 +501,7 @@ data Prop
        , _pjRot :: Float
        , _pjUpdate :: Prop -> World -> World
        , _prDraw :: Prop -> SPic
+        , _prToggle :: Bool
        }
    | Shell 
        { _pjPos :: Point2
@@ -559,16 +564,6 @@ data Wall
        , _blHP :: Int
        , _wlIsSeeThrough :: Bool
        }
-    | Door 
-        { _wlLine :: (Point2,Point2) 
-        , _wlID :: Int 
-        , _doorMech :: World -> World
-        , _wlColor :: Color
-        , _wlSeen :: Bool
-        , _wlIsSeeThrough :: Bool
-        , _doorPathable :: Bool
-        , _drPositions :: DS.DS (Point2,Point2)
-        }
    | Block 
        { _wlLine :: (Point2,Point2)
        , _wlID :: Int
@@ -2,7 +2,6 @@ module Dodge.Default.Wall
    where
 import Dodge.Data
 import Picture
-import qualified DoubleStack as DS
 import Geometry.Data
 {- Indestructible wall.  -}
 defaultWall :: Wall
@@ -24,30 +23,3 @@ defaultCrystalWall = Wall
    , _wlIsSeeThrough = True
    , _wlPathable = False
    }
-{- Door that opens on approach.
-Pathable.  -}
-defaultAutoDoor :: Wall
-defaultAutoDoor = Door 
-    { _wlLine = (V2 0 0,V2 50 0)
-    , _wlID = 0
-    , _doorMech = id
-    , _wlColor = light $ dim $ dim $ dim yellow
-    , _wlSeen = False
-    , _wlIsSeeThrough = False
-    , _doorPathable = True
-    , _drPositions = DS.singleton (V2 0 0,V2 50 0)
-    }
-{-
-Non-pathable door.
- -}
-defaultDoor :: Wall
-defaultDoor = Door 
-    { _wlLine = (V2 0 0,V2 50 0)
-    , _wlID = 0
-    , _doorMech = id
-    , _wlColor = light $ dim $ dim $ dim yellow
-    , _wlSeen = False
-    , _wlIsSeeThrough = False
-    , _doorPathable = False
-    , _drPositions = DS.singleton (V2 0 0,V2 50 0)
-    }
@@ -137,7 +137,7 @@ gameRoomsFromRooms :: [Room] -> [GameRoom]
 gameRoomsFromRooms = map f
  where
    f rm = GameRoom
-        { _grViewpoints = (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
+        { _grViewpoints = map fst . foldl' (flip cutWalls) [] $ _rmPolys rm
        , _grViewpointsEx = map fst (_rmLinks rm)
        , _grBound = expandPolyByFixed 100 $ orderPolygon $ convexHullSafe $ concat $ _rmBound rm ++ _rmPolys rm
        , _grDir   = snd . last $ _rmLinks rm
@@ -36,38 +36,12 @@ import Data.List.Extra
 --import qualified Data.Map as M

 placeSpots :: [Placement] -> World -> World
-placeSpots pss w = foldr (placeSpot . _placementSpot) w' singlePlacements
+placeSpots pss w = foldr (placeSpot . _placementSpot) w simplePlacements
  where
-    (singlePlacements, groupedPlacements) = partition isSPS pss
-    isSPS SinglePlacement{} = True
-    isSPS _ = False
-    gplmnts :: [[Placement]]
-    gplmnts = groupOn _groupPlacementID $ sortOn _groupPlacementID groupedPlacements
-    w' = foldr putGroup w gplmnts
-    putGroup :: [Placement] -> World -> World
-    putGroup gps w'' = (_groupUpdate $ head gps) w'' gps
+    (simplePlacements, idPlacements ) = partition isSimple pss
+    isSimple SimplePlacement{} = True
+    isSimple _ = False

-{- | OK, this is perhaps slightly impenetrable.
- - The idea is that for a list of collected group placements, we first update
- - the world for each placement and update the placements into PSTypes.
- - This is the mapAccumR step.
- - After this, for each placement we apply the group placement function to
- - the psType using a zipWith, and taking all the pstypes as a paramenter,
- - then successively update the world using a foldr. -}
--updateGroup :: [Placement] -> World -> World
--updateGroup ps w =
--    let (w', psTypes) = mapAccumR updateSpot w $ map _placementSpot ps
--        fs = zipWith (\gp pst -> _groupPlacementFunc gp psTypes pst) ps psTypes
--    in foldr ($) w' fs
--{- | -}
--updateSpot :: World -> PlacementSpot -> (World, PSType)
--updateSpot w ps = case _psType ps of
--    PutButton bt -> undefined
--    PutCrit cr -> placeUpdateCr cr p rot w
--  where
--    p = _psPos ps
--    rot = _psRot ps
-{- | -}    
 placeSpot :: PlacementSpot -> World -> World
 placeSpot ps w = case _psType ps of
    PutProp prop -> placeProp prop p rot w
@@ -155,6 +129,17 @@ placeProp pr p a = over props addProp
  where 
    addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs

+placePropID 
+    :: Prop
+    -> Point2
+    -> Float -- ^ Rotation
+    -> World
+    -> (World,Int)
+placePropID pr p a w = (w & props %~ addProp , k)
+  where 
+    k = IM.newKey (_props w)
+    addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs
+
 placeBt 
    :: Button
    -> Point2
@@ -14,8 +14,9 @@ module Dodge.LevelGen.Data
    , pwPoly
    , pwWall
    , unPutCrit
-    , groupPlacementID
-    , groupUpdate
+--    , groupPlacementID
+--    , groupUpdate
+    , idPlacement
    ) where
 import Dodge.Data
 import Picture
@@ -49,14 +50,15 @@ data PlacementSpot = PS
    , _psType :: PSType
    }
 data Placement
-    = SinglePlacement {_placementSpot :: PlacementSpot }
-    | GroupedPlacement
-        {_groupPlacementID :: Int
-        ,_groupUpdate :: World -> [Placement] -> World
-        ,_placementSpot :: PlacementSpot
-        }
+    = SimplePlacement {_placementSpot :: PlacementSpot }
+    | IDPlacement {_placementSpot :: PlacementSpot, _idPlacement :: Int -> Placement }
+--    | GroupedPlacement
+--        {_groupPlacementID :: Int
+--        ,_groupUpdate :: World -> [Placement] -> World
+--        ,_placementSpot :: PlacementSpot
+--        }
 sPS :: Point2 -> Float -> PSType -> Placement
-sPS p a = SinglePlacement . PS p a
+sPS p a = SimplePlacement . PS p a
 makeLenses ''PSType
 makeLenses ''PlacementSpot
 makeLenses ''Placement
@@ -1,43 +1,11 @@
 module Dodge.LevelGen.DoorPane
-    ( linearPane
-    , mkDoubleDoor
-    , mkSingleDoor
-    , rectanglePairs
+    ( rectanglePairs
    ) where
-import Dodge.Data
-import Dodge.LevelGen.MoveDoor
-import Picture
-import qualified DoubleStack as DS
+--import Dodge.Data
 import Geometry.Vector
 import Geometry.Data

-import Data.Bifunctor

-- | A door pane that moves linearly between open and closed positions using a
-- boolean trigger.
-linearPane 
-    :: Color 
-    -> Bool             -- ^ Pathable flag
-    -> (World -> Bool)  -- ^ Opening condition
-    -> Float            -- ^ speed
-    -> Int              -- ^ Wall id
-    -> (Point2,Point2)  -- ^ Closed position
-    -> (Point2,Point2)  -- ^ Open position
-    -> Wall
-linearPane c isPathable cond speed n closedPos openPos = Door
-    { _wlLine = closedPos
-    , _wlID = n
-    , _doorMech = dm
-    , _wlColor = c
-    , _wlSeen = False
-    , _wlIsSeeThrough = False
-    , _doorPathable = isPathable
-    , _drPositions = DS.singleton closedPos
-    }
-  where 
-    dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond 
-    openDoor  = moveDoorToward speed openPos
-    closeDoor = moveDoorToward speed closedPos

 rectanglePairs :: Float -> Point2 -> Point2 -> [(Point2,Point2)]
 rectanglePairs wdth a b =
@@ -52,49 +20,3 @@ rectanglePairs wdth a b =
    bu = b +.+ norm
    bd = b -.- norm
    norm = wdth *.* normalizeV ( vNormal (b -.- a))
-
-mkSingleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall]
-mkSingleDoor c isPathable cond hingep edgep speed is 
-    = addSoundToDoor (head is) (fst $ head theDoor) (fst $ head shiftedDoor)
-    $ zipWith3 (linearPane c isPathable cond speed)
-        is
-        theDoor
-        shiftedDoor
-  where 
-    theDoor = rectanglePairs 9 hingep edgep
-    shiftedDoor = map (bimap shiftLeft shiftLeft) theDoor
-    shiftLeft  = (+.+ (hingep -.- edgep))
-
-mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall]
-mkDoubleDoor c isPathable cond pl pr speed is 
-    = addSoundToDoor (head is) (fst $ head leftDoor) (fst $ head shiftedDoor)
-    $ zipWith3 (linearPane c isPathable cond speed)
-        is
-        (leftDoor ++ rightDoor)
-        shiftedDoor
-  where 
-    shiftedDoor = map shiftLeft leftDoor ++ map shiftRight rightDoor
-    leftDoor = 
-        [ (pld +.+ perp,hwd)
-        , (hwd,         hwu)
-        , (hwu,         plu +.+ perp)
-        , (plu +.+ perp,pld +.+ perp)
-        ]
-    rightDoor =
-        [ (pru -.- perp,hwu)
-        , (hwu,         hwd)
-        , (hwd,         prd -.- perp)
-        , (prd -.- perp,pru -.- perp)
-        ]
-    shiftRight = h (+.+ (0.5 *.* (pr -.- pl)))
-    shiftLeft  = h (+.+ (0.5 *.* (pl -.- pr)))
-    h func (x,y) = (func x,func y)
-    norm = 9 *.* normalizeV ( vNormal (pr -.- pl))
-    hw = 0.5 *.* (pl +.+ pr)
-    perp = 5 *.* normalizeV (pl -.- pr)
-    plu = pl +.+ norm
-    pld = pl -.- norm
-    pru = pr +.+ norm
-    prd = pr -.- norm
-    hwu = hw +.+ norm
-    hwd = hw -.- norm
@@ -1,21 +1,15 @@
 {-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.MoveDoor
-    ( doorMechan
-    , zoneps
+    ( zoneps
    , moveDoorToward
-    , addSoundToDoor
    , changeZonedWall
    ) where
 import Dodge.Data
-import Dodge.Data.SoundOrigin
 import Dodge.Base
 import Dodge.Zone
 import Dodge.Zone.Data
-import Dodge.SoundLogic
-import Dodge.SoundLogic.LoadSound
 import Geometry

-import qualified Data.IntMap.Strict as IM
 import Control.Lens

 -- This deserves a clean up
@@ -38,20 +32,6 @@ zoneps (a,b)
                = [zoneOfPoint $ pHalf a b]
    | otherwise = map zoneOfPoint $ divideLine zoneSize a b

-doorMechan 
-    :: Int
-    -> [(Int,Int)]
-    -> (Wall -> Wall) 
-    -> (Wall -> Wall) 
-    -> (World -> Bool) 
-    -> World 
-    -> World
-doorMechan n zonePs openEff closeEff cond w
-    | cond w = flip (foldr $ changeZonedWall openEff n) zonePs
-                $ over walls (IM.adjust openEff n) w
-    | otherwise = flip (foldr $ changeZonedWall closeEff n) zonePs
-                $ over walls (IM.adjust closeEff n) w
-
 changeZonedWall
    :: (Wall -> Wall)
    -> Int
@@ -60,15 +40,3 @@ changeZonedWall
    -> World
 changeZonedWall eff n (x,y) = over (wallsZone . znObjects) $ adjustIMZone eff x y n

-addSoundToDoor :: Int -> Point2 -> Point2 -> [Wall] -> [Wall]
-addSoundToDoor _   _   _ [] = error "When creating door tried to add sound to nothing"
-addSoundToDoor i pld hwd (x:ys) = f x : ys
-  where
-    f wl = over doorMech g wl
-      where
-        g dm w 
-            | dist wp pld > 2 && dist wp hwd > 2 
-                        = soundContinue (WallSound i) wp slideDoorS (Just 1) $ dm w
-            | otherwise = dm w
-          where 
-            wp = fst $ _wlLine (_walls w IM.! i)
@@ -1,5 +1,5 @@
 module Dodge.LevelGen.SwarmPlacement
-    ( swarmPS
+    ( --swarmPS
    )
    where
 import Dodge.Data
@@ -14,44 +14,44 @@ import Data.List
 import qualified Data.IntSet as IS
 import Control.Lens

-swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
-swarmPS i p a cr = GroupedPlacement
-    { _groupPlacementID = i
-    , _groupUpdate = setSwarm
--    , _groupPlacementFunc = setSwarm i
-    , _placementSpot = PS p a $ PutCrit cr
-    }
-setSwarm :: World -> [Placement] -> World
-setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
-  where
-    (w', crs) = mapAccumR updateCrit w ps
-    is = IS.fromList $ map _crID crs
-    cpos = centroid $ map _crPos crs
-    gid = IM.newKey (_creatureGroups w')
-    theGroupParams = CrGroupParams
-        { _crGroupParamID = gid
-        , _crGroupIDs = is
-        , _crGroupCenter = cpos
-        , _crGroupUpdate = crGroupUpdateCenter
-        }
-    updateCrs w'' = IS.foldl' (\w''' cid -> w''' & creatures . ix cid %~ setSwarmStatus) w'' is
-    setSwarmStatus = crGroup .~ Swarm {_swarm = is, _crGroupID = gid}
-
-crGroupUpdateCenter :: World -> CrGroupParams -> Maybe CrGroupParams
-crGroupUpdateCenter w cgp 
-    | IM.null crs = Nothing
-    | otherwise = Just $ cgp & crGroupCenter .~
-        centroid (IM.map _crPos crs)
-  where
-    crs = IM.restrictKeys (_creatures w) (_crGroupIDs cgp)
-
-updateCrit :: World -> Placement -> (World, Creature)
-updateCrit w pl = (w & creatures %~ IM.insert cid cr
-    , cr
-    )
-  where 
-    p = _psPos $ _placementSpot pl
-    rot = _psRot $ _placementSpot pl
-    scr = _unPutCrit $ _psType $ _placementSpot pl
-    cid = IM.newKey (_creatures w)
-    cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 
+--swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
+--swarmPS i p a cr = GroupedPlacement
+--    { _groupPlacementID = i
+--    , _groupUpdate = setSwarm
+----    , _groupPlacementFunc = setSwarm i
+--    , _placementSpot = PS p a $ PutCrit cr
+--    }
+--setSwarm :: World -> [Placement] -> World
+--setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
+--  where
+--    (w', crs) = mapAccumR updateCrit w ps
+--    is = IS.fromList $ map _crID crs
+--    cpos = centroid $ map _crPos crs
+--    gid = IM.newKey (_creatureGroups w')
+--    theGroupParams = CrGroupParams
+--        { _crGroupParamID = gid
+--        , _crGroupIDs = is
+--        , _crGroupCenter = cpos
+--        , _crGroupUpdate = crGroupUpdateCenter
+--        }
+--    updateCrs w'' = IS.foldl' (\w''' cid -> w''' & creatures . ix cid %~ setSwarmStatus) w'' is
+--    setSwarmStatus = crGroup .~ Swarm {_swarm = is, _crGroupID = gid}
+--
+--crGroupUpdateCenter :: World -> CrGroupParams -> Maybe CrGroupParams
+--crGroupUpdateCenter w cgp 
+--    | IM.null crs = Nothing
+--    | otherwise = Just $ cgp & crGroupCenter .~
+--        centroid (IM.map _crPos crs)
+--  where
+--    crs = IM.restrictKeys (_creatures w) (_crGroupIDs cgp)
+--
+--updateCrit :: World -> Placement -> (World, Creature)
+--updateCrit w pl = (w & creatures %~ IM.insert cid cr
+--    , cr
+--    )
+--  where 
+--    p = _psPos $ _placementSpot pl
+--    rot = _psRot $ _placementSpot pl
+--    scr = _unPutCrit $ _psType $ _placementSpot pl
+--    cid = IM.newKey (_creatures w)
+--    cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 
@@ -25,7 +25,6 @@ makeButton col eff = Button
                                . soundFromGeneral (LeverSound 0) (btpos b) click1S Nothing $ w
    , _btID = 0
    , _btText = "Button"
-    --, _btText = "Button"
    , _btState = BtOff
    }
  where
@@ -39,7 +38,7 @@ drawSwitch col1 col2 bt
  where
    flick a = ( mconcat
        [ colorSH col1 . translateSHz 10 . upperPrismPoly 10 $ rectNSEW (-2) (-5) 10 (-10)
-        , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperPrismPoly 2 $ rectNSEW 10 (0) 2 (-2)
+        , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperPrismPoly 2 $ rectNSEW 10 0 2 (-2)
        ]   
        , mempty)

@@ -14,7 +14,6 @@ import Dodge.LevelGen.MoveDoor
 import Dodge.LevelGen.DoorPane
 import Picture
 import Geometry
-import qualified DoubleStack as DS
 import qualified IntMapHelp as IM
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
@@ -45,19 +44,6 @@ addButtonDoor c btp btr a b speed w
             . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
    f (x,y) = (x,y,dist x y)

-putDoor' 
-    :: Color 
-    -> (World -> Bool)      -- ^ Opening condition
-    -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
-                    -- Bumped out up and down by 9, not widened
-    -> World 
-    -> World
-putDoor' c cond pss = over walls triggerDoor
-  where
-    triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is
-      where
-        is = [IM.newKey wls..]
-
 putDoor 
    :: Color 
    -> (World -> Bool)      -- ^ Opening condition
@@ -78,8 +64,8 @@ putDoor col cond pss w = addWalls w
        }
    nsteps = length pss - 1
    wlids = take 4 [IM.newKey $ _walls w ..]
-    wlps = uncurry (rectanglePairs 9) $ head pss
-    addWalls w' = foldl' addWall w' $ zip wlids wlps
+    wlps' = uncurry (rectanglePairs 9) $ head pss
+    addWalls w' = foldl' addWall w' $ zip wlids wlps'
    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid Wall
        { _wlLine = wlps
        , _wlID = wlid
@@ -95,18 +81,21 @@ doorMechanismStepwise nsteps drid wlids pss dr w
    | toOpen = case _drStatus dr of
        DoorInt x | x == nsteps -> w
        DoorInt x      -> setWalls (x+1)
+        _ -> w
    | otherwise = case _drStatus dr of
        DoorInt 0 -> w
        DoorInt x -> setWalls (x-1)
+        _ -> w
  where
    playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1)
    toOpen = _drTrigger dr w
-    setWalls n = (playSound $ foldl' setWall w (zip wlids newps))
+    cpss = uncurry (rectanglePairs 9) (head pss)
+    setWalls n = (playSound $ foldl' setWall w (zip3 wlids newps cpss))
        & doors . ix drid . drStatus .~ DoorInt n
      where
        newps = uncurry (rectanglePairs 9) (pss !! n)
-    setWall w' (wlid,ps) = w & walls . ix wlid . wlLine .~ ps
-        & (\w'' -> foldr (changeZonedWall (wlLine .~ ps) wlid) w'' (zoneps ps)) 
+    setWall w' (wlid,ps,cps) = w' & walls . ix wlid . wlLine .~ ps
+        & (\w'' -> foldr (changeZonedWall (wlLine .~ ps) wlid) w'' (zoneps cps)) 
 -- it is not at all clear that the zoning selects the correct walls


@@ -120,26 +109,25 @@ putDoubleDoor isPathable col cond a b speed
 -- TODO think about wall zoning, simplify!
 doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door' -> World -> World
 doorMechanism drid speed wlidOpCps dr w 
-    | toOpen && not (dstatus == DoorOpen) = playSound . setStatus $ foldl' doOpen  w wlidOpCps
-    | not toOpen && not (dstatus == DoorClosed) = playSound . setStatus $ foldl' doClose w wlidOpCps
+    | toOpen     && dstatus /= DoorOpen   = moveUpdate $ foldl' doOpen  w wlidOpCps
+    | not toOpen && dstatus /= DoorClosed = moveUpdate $ foldl' doClose w wlidOpCps
    | otherwise = w
  where
+    moveUpdate = playSound . setStatus
    playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
    setStatus
-        | isOpen    = doors . ix drid . drStatus .~ DoorOpen
-        | isClosed  = doors . ix drid . drStatus .~ DoorClosed
-        | otherwise = doors . ix drid . drStatus .~ DoorHalfway
+        | dist (fst wlpos) (fst opos) < 1 = doors . ix drid . drStatus .~ DoorOpen
+        | dist (fst wlpos) (fst cpos) < 1 = doors . ix drid . drStatus .~ DoorClosed
+        | otherwise                       = doors . ix drid . drStatus .~ DoorHalfway
    (wlid',opos,cpos) = head wlidOpCps
    wlpos    = _wlLine $ _walls w IM.! wlid'
-    isOpen   = dist (fst wlpos) (fst opos) < 1
-    isClosed = dist (fst wlpos) (fst cpos) < 1
-    toOpen = _drTrigger dr w
+    toOpen  = _drTrigger dr w
    dstatus = _drStatus dr
-    doOpen w'  (wlid,openpos,cp) = w' 
-        & walls . ix wlid %~ moveDoorToward speed openpos
-        & (\w'' -> foldr (changeZonedWall (moveDoorToward speed openpos) wlid) w'' (zoneps cp))
-    doClose w' (wlid,_,cp) = w' & walls . ix wlid %~ moveDoorToward speed cp
-        & (\w'' -> foldr (changeZonedWall (moveDoorToward speed cp) wlid) w'' (zoneps cp))
+    doOpen  w' (wlid,openpos,cp) = mvDoorWithZone w' wlid openpos cp
+    doClose w' (wlid,_,cp)       = mvDoorWithZone w' wlid cp      cp
+    mvDoorWithZone w' wlid p zp = w'
+        & walls . ix wlid %~ moveDoorToward speed p
+        & (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp))

 putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
 putSingleDoor isPathable col cond a b speed w = addWalls w 
@@ -167,49 +155,3 @@ putSingleDoor isPathable col cond a b speed w = addWalls w
    shiftLeft  = (+.+ (a -.- b))
    wlids = take 4 [IM.newKey $ _walls w ..]

-mkTriggerDoor 
-    :: Color 
-    -> (World -> Bool)      -- ^ Opening condition
-    -> [(Point2,Point2)]    -- ^ List of wall position pairs, closed to open
-    -> [Int]                -- ^ Wall ids
-    -> [Wall]
-{-# INLINE mkTriggerDoor #-}
-mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
-    transpose $ map toPanePoints ppairs
-
-toPanePoints :: (Point2,Point2) -> [(Point2,Point2)]
-{-# INLINE toPanePoints #-}
-toPanePoints (x,y) = 
-    [ (y +.+ perp, y -.- perp)
-    , (y -.- perp, x -.- perp)
-    , (x -.- perp, x +.+ perp)
-    , (x +.+ perp, y +.+ perp)
-    ]
-  where
-    perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y))
-{- |
-Zoning might be an issue here.
-It is necessary in the current version, but I am not sure of its behaviour. -}
-triggerDoorPane
-    :: Color 
-    -> (World -> Bool)      -- ^ Opening condition
-    -> Int                  -- ^ Wall id
-    -> [(Point2,Point2)]    -- ^ List of positions: closed to open
-    -> Wall
-triggerDoorPane c cond n poss = Door
-    { _wlLine = head poss
-    , _wlID = n
-    , _doorMech = dm
-    , _wlColor = c
-    , _wlSeen = False
-    , _wlIsSeeThrough = False
-    , _doorPathable = False
-    , _drPositions = DS.fromListL poss
-    }
-  where 
-    dm = doorMechan n allZoneps openDoor closeDoor cond 
-    openDoor  = updatePos . (drPositions %~ DS.pushL)
-    closeDoor = updatePos . (drPositions %~ DS.pushR)
-    updatePos :: Wall -> Wall
-    updatePos d = d & wlLine %~ maybe id const (DS.head <$> (d ^? drPositions))
-    allZoneps = nub $ concatMap zoneps poss
@@ -5,6 +5,7 @@ module Dodge.LightSources
    , colorLightAt
    , lampPic
    , lampCover
+    , lampCoverWhen
    , doubleLampCover
    , verticalLampCover
    )
@@ -76,6 +77,16 @@ lampCover h = ShapeProp
    , _pjRot = 0
    , _pjUpdate = rotateProp 0.15
    , _prDraw = drawLampCover h
+    , _prToggle = True
+    }
+lampCoverWhen :: (World -> Bool) -> Float -> Prop
+lampCoverWhen cond h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = setToggle cond `chain` rotateProp 0.15
+    , _prDraw = drawLampCover h
+    , _prToggle = True
    }

 doubleLampCover :: Float -> Prop
@@ -85,6 +96,7 @@ doubleLampCover h = ShapeProp
    , _pjRot = 0
    , _pjUpdate = rotateProp 0.15
    , _prDraw = drawDoubleLampCover h
+    , _prToggle = True
    }

 -- on the current (27/9/21) version of shadow stencilling, this glitches
@@ -96,14 +108,23 @@ verticalLampCover h = ShapeProp
    , _pjRot = 0
    , _pjUpdate = rotateProp 0.15
    , _prDraw = drawVerticalLampCover h
+    , _prToggle = True
    }

 rotateProp :: Float -> Prop -> World -> World
 rotateProp rotAmount pr w = w
    & props . ix (_pjID pr) . pjRot +~ rotAmount

+setToggle :: (World -> Bool) -> Prop -> World -> World
+setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w
+
+-- TODO check whether this is simply the reader monad, flipped
+chain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b
+chain f g x = f x . g x
+
 drawLampCover :: Float -> Prop -> SPic
-drawLampCover h pr =
+drawLampCover h pr | not (_prToggle pr) = mempty
+                   | otherwise =
    ( translateSHz (h-2.5) . uncurryV translateSHf pos 
        $ rotateSH a $ mconcat
        [ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
@@ -111,7 +132,7 @@ drawLampCover h pr =
        , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
        , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
        --, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
-        , upperPrismPoly 1 $ [V2 2 2,V2 (-1) 2,V2 2 (-1)]
+        , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
        ]
    , mempty
    )
@@ -126,7 +147,7 @@ drawDoubleLampCover h pr =
        [ upperPrismPoly 5 $ rectNSEW 6 5       6 (-6)
        , upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6)
        , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
-        , upperPrismPoly 1 [V2 0 (1),V2 (-6) (-5),V2 6 (-5)]
+        , upperPrismPoly 1 [V2 0   1 ,V2 (-6) (-5),V2 6 (-5)]
        ]
    , mempty
    )
@@ -24,6 +24,7 @@ import Control.Lens
 import Control.Monad.State
 import Data.Tree
 import qualified Data.Map as M
+import qualified Data.IntMap as IM

 twinSlowDoorRoom 
    :: Int      -- ^ Door id
@@ -49,12 +50,13 @@ twinSlowDoorRoom drid w h x = defaultRoom
            (worldState %~ M.insert (DoorNumOpen drid) True )
            (worldState %~ M.insert (DoorNumOpen drid) False)
        , sPS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
-        , sPS (V2 0 (h-1)) 0 $ PutProp $ lampCover lampHeight
+        , sPS (V2 0 (h-1)) 0 $ PutProp $ lampCoverWhen drmoving lampHeight
        ]
    , _rmBound  = ps
    , _rmName   = "twinSlowDoorRoom"
    }
  where
+    drmoving w' = True -- DoorHalfway == _drStatus (_doors w' IM.! drid)
    lampHeight = 41
    ps = 
        [rectNSWE h    0 (-w) w
@@ -30,7 +30,7 @@ Places a line of blocks between two points.
 Width 9, also extends out from each point by 9.
 -}
 blockLine :: Point2 -> Point2 -> Placement
-blockLine a b = SinglePlacement $ PS
+blockLine a b = SimplePlacement $ PS
    { _psPos    = V2 0 0
    , _psRot    = 0
    , _psType   = PutLineBlock baseBlockPane 9 9 a b
@@ -41,7 +41,7 @@ Places an breakable window between two points.
 Width 8, also extends out from each point by 8.
 -}
 windowLine :: Point2 -> Point2 -> Placement
-windowLine a b = SinglePlacement $ PS 
+windowLine a b = SimplePlacement $ PS 
    { _psPos    = V2 0 0
    , _psRot    = 0
    , _psType   = PutLineBlock baseWindowPane 8 8 a b
@@ -52,7 +52,7 @@ Places an unbreakable window between two points.
 Width 7, also extends out from each point by 7.
 -}
 crystalLine :: Point2 -> Point2 -> Placement
-crystalLine a b = SinglePlacement $ PS 
+crystalLine a b = SimplePlacement $ PS 
    { _psPos    = V2 0 0
    , _psRot    = 0
    , _psType   = PutWall ps defaultCrystalWall
@@ -70,7 +70,7 @@ crystalLine a b = SinglePlacement $ PS
 Depth 15, does not extend wider than points.
 -}
 wallLine :: Point2 -> Point2 -> Placement
-wallLine a b = SinglePlacement $ PS 
+wallLine a b = SimplePlacement $ PS 
    { _psPos    = V2 0 0
    , _psRot    = 0
    , _psType   = PutWall ps defaultWall
@@ -180,7 +180,7 @@ fillNothingPlacement :: PSType -> Room -> Room
 fillNothingPlacement pst r =
    r & rmPS %~ replaceNothingWith pst
  where
-    replaceNothingWith x (SinglePlacement (PS p rot PutNothing): pss) = sPS p rot x : pss
+    replaceNothingWith x (SimplePlacement (PS p rot PutNothing): pss) = sPS p rot x : pss
    replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
    replaceNothingWith _ [] = []
 {- | Successively fill 'PutNothing' placements with a list of given 'PSType's.
@@ -62,7 +62,6 @@ functionalUpdate w = case _menuLayers w of
        . simpleCrSprings 
        . zoneCreatures 
        . updateDoors
-        . updateWalls
        . resetWorldEvents
        . dbArg _worldEvents
        . updateParticles 
@@ -143,10 +142,6 @@ updateCreatures w = appEndo f $ w
      where
        (f'',cr') = _crUpdate cr cr (w & randGen .~ g)
        (_,g') = genWord8 g
-{- |
-Apply door mechanisms.  -}
-updateWalls :: World -> World
-updateWalls w = IM.foldl' (flip $ fromMaybe id . (^? doorMech)) w (_walls w)

 updateDoors :: World -> World
 updateDoors w = IM.foldl' (\w' dr -> _drMech dr dr w') w (_doors w)