Commit before placement refactor

src/Dodge/Base/Collide.hs

@@ -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 

src/Dodge/Data.hs

@@ -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

src/Dodge/Default/Wall.hs

@@ -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)
-    }

src/Dodge/Layout.hs

@@ -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

src/Dodge/LevelGen.hs

@@ -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
+    (simplePlacements, idPlacements ) = partition isSimple pss
-    isSPS SinglePlacement{} = True
+    isSimple SimplePlacement{} = True
-    isSPS _ = False
+    isSimple _ = 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
 
-{- | 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

src/Dodge/LevelGen/Data.hs

@@ -14,8 +14,9 @@ module Dodge.LevelGen.Data
     , pwPoly
     , pwWall
     , unPutCrit
-    , groupPlacementID
+--    , groupPlacementID
-    , groupUpdate
+--    , groupUpdate
+    , idPlacement
     ) where
 import Dodge.Data
 import Picture
@@ -49,14 +50,15 @@ data PlacementSpot = PS
     , _psType :: PSType
     }
 data Placement
-    = SinglePlacement {_placementSpot :: PlacementSpot }
+    = SimplePlacement {_placementSpot :: PlacementSpot }
-    | GroupedPlacement
+    | IDPlacement {_placementSpot :: PlacementSpot, _idPlacement :: Int -> Placement }
-        {_groupPlacementID :: Int
+--    | GroupedPlacement
-        ,_groupUpdate :: World -> [Placement] -> World
+--        {_groupPlacementID :: Int
-        ,_placementSpot :: PlacementSpot
+--        ,_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

src/Dodge/LevelGen/DoorPane.hs

@@ -1,43 +1,11 @@
 module Dodge.LevelGen.DoorPane
-    ( linearPane
+    ( rectanglePairs
-    , mkDoubleDoor
-    , mkSingleDoor
-    , rectanglePairs
     ) where
-import Dodge.Data
+--import Dodge.Data
-import Dodge.LevelGen.MoveDoor
-import Picture
-import qualified DoubleStack as DS
 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

src/Dodge/LevelGen/MoveDoor.hs

@@ -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)

src/Dodge/LevelGen/SwarmPlacement.hs

@@ -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 :: Int -> Point2 -> Float -> Creature -> Placement
-swarmPS i p a cr = GroupedPlacement
+--swarmPS i p a cr = GroupedPlacement
-    { _groupPlacementID = i
+--    { _groupPlacementID = i
-    , _groupUpdate = setSwarm
+--    , _groupUpdate = setSwarm
---    , _groupPlacementFunc = setSwarm i
+----    , _groupPlacementFunc = setSwarm i
-    , _placementSpot = PS p a $ PutCrit cr
+--    , _placementSpot = PS p a $ PutCrit cr
-    }
+--    }
-setSwarm :: World -> [Placement] -> World
+--setSwarm :: World -> [Placement] -> World
-setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
+--setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
-  where
+--  where
-    (w', crs) = mapAccumR updateCrit w ps
+--    (w', crs) = mapAccumR updateCrit w ps
-    is = IS.fromList $ map _crID crs
+--    is = IS.fromList $ map _crID crs
-    cpos = centroid $ map _crPos crs
+--    cpos = centroid $ map _crPos crs
-    gid = IM.newKey (_creatureGroups w')
+--    gid = IM.newKey (_creatureGroups w')
-    theGroupParams = CrGroupParams
+--    theGroupParams = CrGroupParams
-        { _crGroupParamID = gid
+--        { _crGroupParamID = gid
-        , _crGroupIDs = is
+--        , _crGroupIDs = is
-        , _crGroupCenter = cpos
+--        , _crGroupCenter = cpos
-        , _crGroupUpdate = crGroupUpdateCenter
+--        , _crGroupUpdate = crGroupUpdateCenter
-        }
+--        }
-    updateCrs w'' = IS.foldl' (\w''' cid -> w''' & creatures . ix cid %~ setSwarmStatus) w'' is
+--    updateCrs w'' = IS.foldl' (\w''' cid -> w''' & creatures . ix cid %~ setSwarmStatus) w'' is
-    setSwarmStatus = crGroup .~ Swarm {_swarm = is, _crGroupID = gid}
+--    setSwarmStatus = crGroup .~ Swarm {_swarm = is, _crGroupID = gid}
-
+--
-crGroupUpdateCenter :: World -> CrGroupParams -> Maybe CrGroupParams
+--crGroupUpdateCenter :: World -> CrGroupParams -> Maybe CrGroupParams
-crGroupUpdateCenter w cgp 
+--crGroupUpdateCenter w cgp 
-    | IM.null crs = Nothing
+--    | IM.null crs = Nothing
-    | otherwise = Just $ cgp & crGroupCenter .~
+--    | otherwise = Just $ cgp & crGroupCenter .~
-        centroid (IM.map _crPos crs)
+--        centroid (IM.map _crPos crs)
-  where
+--  where
-    crs = IM.restrictKeys (_creatures w) (_crGroupIDs cgp)
+--    crs = IM.restrictKeys (_creatures w) (_crGroupIDs cgp)
-
+--
-updateCrit :: World -> Placement -> (World, Creature)
+--updateCrit :: World -> Placement -> (World, Creature)
-updateCrit w pl = (w & creatures %~ IM.insert cid cr
+--updateCrit w pl = (w & creatures %~ IM.insert cid cr
-    , cr
+--    , cr
-    )
+--    )
-  where 
+--  where 
-    p = _psPos $ _placementSpot pl
+--    p = _psPos $ _placementSpot pl
-    rot = _psRot $ _placementSpot pl
+--    rot = _psRot $ _placementSpot pl
-    scr = _unPutCrit $ _psType $ _placementSpot pl
+--    scr = _unPutCrit $ _psType $ _placementSpot pl
-    cid = IM.newKey (_creatures w)
+--    cid = IM.newKey (_creatures w)
-    cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 
+--    cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 

src/Dodge/LevelGen/Switch.hs

@@ -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)
 

src/Dodge/LevelGen/TriggerDoor.hs

@@ -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
+    wlps' = uncurry (rectanglePairs 9) $ head pss
-    addWalls w' = foldl' addWall w' $ zip wlids wlps
+    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
+    setWall w' (wlid,ps,cps) = w' & walls . ix wlid . wlLine .~ ps
-        & (\w'' -> foldr (changeZonedWall (wlLine .~ ps) wlid) w'' (zoneps 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
+    | toOpen     && dstatus /= DoorOpen   = moveUpdate $ foldl' doOpen  w wlidOpCps
-    | not toOpen && not (dstatus == DoorClosed) = playSound . setStatus $ foldl' doClose 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
+        | dist (fst wlpos) (fst opos) < 1 = doors . ix drid . drStatus .~ DoorOpen
-        | isClosed  = doors . ix drid . drStatus .~ DoorClosed
+        | 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
     dstatus = _drStatus dr
-    doOpen w'  (wlid,openpos,cp) = w' 
+    doOpen  w' (wlid,openpos,cp) = mvDoorWithZone w' wlid openpos cp
-        & walls . ix wlid %~ moveDoorToward speed openpos
+    doClose w' (wlid,_,cp)       = mvDoorWithZone w' wlid cp      cp
-        & (\w'' -> foldr (changeZonedWall (moveDoorToward speed openpos) wlid) w'' (zoneps cp))
+    mvDoorWithZone w' wlid p zp = w'
-    doClose w' (wlid,_,cp) = w' & walls . ix wlid %~ moveDoorToward speed cp
+        & walls . ix wlid %~ moveDoorToward speed p
-        & (\w'' -> foldr (changeZonedWall (moveDoorToward speed cp) wlid) w'' (zoneps cp))
+        & (\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

src/Dodge/LightSources.hs

@@ -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
     )

src/Dodge/Room/LongDoor.hs

@@ -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

src/Dodge/Room/Placement.hs

@@ -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

src/Dodge/Room/Procedural.hs

@@ -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.

src/Dodge/Update.hs

@@ -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)