Refactor doors

src/Dodge/Block.hs

@@ -1,4 +1,5 @@
 module Dodge.Block where
+import Dodge.DrWdWd
 import Dodge.Zoning.Wall
 import Dodge.Data
 import Dodge.Base.Collide
@@ -70,7 +71,7 @@ maybeClearPath w (x,y,pe)
 
 destroyDoor :: Door -> World -> World
 destroyDoor dr w = w
-    & _drDeath dr dr
+    & doDrWdWd (_drDeath dr) dr
     & deleteWallIDs wlids
     & doors %~ IM.delete (_drID dr)
     & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
@@ -94,5 +95,5 @@ stopPushing :: Maybe Int -> World -> World
 stopPushing mdrid w = fromMaybe w $ do
     drid <- mdrid
     dr <- w ^? doors . ix drid
-    return $ w & doors . ix drid . drMech .~ const id
+    return $ w & doors . ix drid . drMech .~ DrWdId
         & stopPushing (_drPushes dr)

src/Dodge/CreatureEffect.hs

@@ -1,7 +1,7 @@
 module Dodge.CreatureEffect where
+import Dodge.Creature.Test
 import Dodge.Data
 import Geometry
-import Dodge.Creature.Test
 import Dodge.Base.Collide
 import Dodge.Path
 import qualified IntMapHelp as IM
@@ -47,6 +47,7 @@ doCrBl cb = case cb of
     CrCanShoot -> crCanShoot
     CrIsReloading -> crIsReloading
     CrIsAiming -> crIsAiming
+    CrIsAnimate -> isAnimate
 
 doMCrAc :: MCrAc -> Maybe Creature -> Action
 doMCrAc mca = case mca of

src/Dodge/Data.hs

@@ -83,7 +83,9 @@ module Dodge.Data
     , module Dodge.Data.Prop
     , module Dodge.Data.LinearShockwave
     , module Dodge.Data.TractorBeam
+    , module Dodge.Data.MountedObject
     ) where
+import Dodge.Data.MountedObject
 import Dodge.Data.TractorBeam
 import Dodge.Data.LinearShockwave
 import Dodge.Data.Prop
@@ -292,7 +294,7 @@ data World = World
     , _lSelect          :: Point2
     , _rSelect          :: Point2
     }
---  deriving (Eq,Ord,Show,Read)
+  --deriving (Eq,Ord,Show,Read)
 data WorldHammer
     = SubInvHam
     | DoubleMouseHam
@@ -456,28 +458,6 @@ data MachineType
         , _tuFireTime   :: Int
         , _tuMCrID      :: Maybe Int
         }
-data Door = Door
-    { _drID :: Int
-    , _drWallIDs :: IS.IntSet
-    , _drStatus  :: DoorStatus
-    , _drTrigger :: World -> Bool
-    , _drMech    :: Door -> World -> World
-    , _drPos :: (Point2,Point2)
-    , _drOpenPos :: (Point2,Point2)
-    , _drClosePos :: (Point2,Point2)
-    , _drHP     :: Int
-    , _drDeath  :: Door -> World -> World
-    , _drSpeed  :: Float
-    , _drPushedBy :: PushSource
-    , _drPushes :: Maybe Int
-    , _drMounts :: [MountedObject]
-    , _drObstructs  :: [(Int,Int,PathEdge)]
-    , _drObstacleType   :: EdgeObstacle
-    }
-data MountedObject
-    = MountedLS Int
-    | MountedProp Int
-  deriving (Eq,Ord,Show)
 
 data EffectArguments
     = NoArguments {_cmdEffect :: [TerminalLine]}
@@ -510,7 +490,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
         , _putStartPoint :: Point2, _putEndPoint :: Point2}
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutSlideDr Door Wall EdgeObstacle Float Point2 Point2
-    | PutDoor Color EdgeObstacle (World -> Bool) [(Point2,Point2)]
+    | PutDoor Color EdgeObstacle WdBl [(Point2,Point2)]
     | RandPS (State StdGen PSType)
     | PutForeground ForegroundShape
     | PutDecoration Picture
@@ -594,7 +574,6 @@ data InPlacement = InPlacement
 makeLenses ''World
 makeLenses ''FloorItem
 --makeLenses ''Particle
-makeLenses ''Door
 makeLenses ''Terminal
 makeLenses ''Machine
 makeLenses ''MachineType

src/Dodge/Data/CreatureEffect.hs

@@ -29,6 +29,7 @@ data WdCrBl = WdCrTrue
 data CrBl = CrCanShoot
     | CrIsReloading
     | CrIsAiming
+    | CrIsAnimate
   deriving (Eq,Ord,Show,Read)
 
 data MCrAc = MCrNoAction

src/Dodge/Data/Door.hs

@@ -1,11 +1,37 @@
---{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
 module Dodge.Data.Door where
+import Dodge.Data.PathGraph
+import Dodge.Data.MountedObject
+import Geometry.Data
+import Dodge.Data.WorldEffect
+import qualified Data.IntSet as IS
+import Control.Lens
 
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show,Read)
 
 data PushSource = PushesItself
     | PushedBy Int
     | NotPushed
-  deriving (Eq,Ord,Show)
+  deriving (Eq,Ord,Show,Read)
+data Door = Door
+    { _drID :: Int
+    , _drWallIDs :: IS.IntSet
+    , _drStatus  :: DoorStatus
+    , _drTrigger :: WdBl
+    , _drMech    :: DrWdWd
+    , _drPos :: (Point2,Point2)
+    , _drOpenPos :: (Point2,Point2)
+    , _drClosePos :: (Point2,Point2)
+    , _drHP     :: Int
+    , _drDeath  :: DrWdWd
+    , _drSpeed  :: Float
+    , _drPushedBy :: PushSource
+    , _drPushes :: Maybe Int
+    , _drMounts :: [MountedObject]
+    , _drObstructs  :: [(Int,Int,PathEdge)]
+    , _drObstacleType   :: EdgeObstacle
+    }
+  deriving (Eq,Ord,Show,Read)
+makeLenses ''Door

src/Dodge/Data/EnergyBall.hs

@@ -16,4 +16,5 @@ data EnergyBall = EnergyBall
     , _ebZ :: Float
     , _ebRot :: Float
     }
+  deriving (Eq,Ord,Show,Read)
 makeLenses ''EnergyBall

src/Dodge/Data/Flame.hs

@@ -13,4 +13,5 @@ data Flame = Flame
     , _flZ      :: Float
     , _flOriginalVel :: Point2
     }
+  deriving (Eq,Ord,Show,Read)
 makeLenses ''Flame

src/Dodge/Data/Flare.hs

@@ -4,7 +4,6 @@ module Dodge.Data.Flare where
 import Color
 import Geometry
 import Control.Lens
-
 data Flare
     = MuzFlare 
         { _flarePoly   :: [Point2]
@@ -18,5 +17,5 @@ data Flare
         , _flareTran3  :: Point3
         , _flareTime   :: Int
         }
-
+  deriving (Eq,Ord,Show,Read)
 makeLenses ''Flare

src/Dodge/Data/MountedObject.hs

@@ -0,0 +1,9 @@
+--{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.MountedObject
+    where
+data MountedObject
+    = MountedLS Int
+    | MountedProp Int
+  deriving (Eq,Ord,Show,Read)
+

src/Dodge/Data/PathGraph.hs

@@ -12,19 +12,20 @@ data PathGraph = PathGraph
     , _pgNodeCount  :: Int
     , _pgEdgeMap    :: Map (V2 Point2) (Int,Int,PathEdge)
     }
+  deriving (Eq,Show,Read)
 data PathEdge = PathEdge
     {_peStart :: Point2
     ,_peEnd   :: Point2
     ,_peDist  :: Float
     ,_peObstacles :: Set.Set EdgeObstacle
     }
-  deriving (Eq,Ord,Show)
+  deriving (Eq,Ord,Show,Read)
 data EdgeObstacle
     = BlockObstacle
     | DoorObstacle
     | AutoDoorObstacle
     | WallObstacle
-  deriving (Eq,Ord,Show,Bounded,Enum)
+  deriving (Eq,Ord,Show,Read,Bounded,Enum)
 
 makeLenses ''PathGraph
 makeLenses ''PathEdge

src/Dodge/Data/PosEvent.hs

@@ -5,10 +5,11 @@ import Geometry.Data
 import Control.Lens
 
 data PosEventType = SparkSpawner
-
+  deriving (Eq,Ord,Show,Read)
 data PosEvent = PosEvent
     { _pvType   :: PosEventType
     , _pvTimer  :: Int
     , _pvPos    :: Point2
     }
+  deriving (Eq,Ord,Show,Read)
 makeLenses ''PosEvent

src/Dodge/Data/RadarBlip.hs

@@ -4,7 +4,6 @@ module Dodge.Data.RadarBlip where
 import Color
 import Geometry
 import Control.Lens
-
 data RadarBlip = RadarBlip
     { _rbColor      :: Color
     , _rbTime       :: Int
@@ -12,5 +11,5 @@ data RadarBlip = RadarBlip
     , _rbRad        :: Float
     , _rbPos        :: Point2
     }
-
+  deriving (Eq,Ord,Show,Read)
 makeLenses ''RadarBlip

src/Dodge/Data/RadarSweep.hs

@@ -11,4 +11,5 @@ data RadarSweep = RadarSweep
     , _rsObject :: Object
     , _rsTimer  :: Int
     }
+  deriving (Eq,Ord,Show,Read)
 makeLenses ''RadarSweep

src/Dodge/Data/Spark.hs

@@ -13,4 +13,5 @@ data Spark = Spark
     , _skWidth  :: Float 
     , _skDamageType :: DamageType
     }
+  deriving (Eq,Ord,Show,Read)
 makeLenses ''Spark

src/Dodge/Data/WorldEffect.hs

@@ -1,4 +1,5 @@
 module Dodge.Data.WorldEffect where
+import Dodge.Data.CreatureEffect
 import Sound.Data
 import Geometry.Data
 import Dodge.Data.SoundOrigin
@@ -22,7 +23,17 @@ data MdWdWd = MdWdId
   deriving (Eq,Ord,Show,Read)
 data WdBl = WdTrig Int
     | WdBlDoorMoving Int
+    | WdBlConst Bool
+    | WdBlNegate WdBl
+    | WdBlCrFilterNearPoint Float Point2 CrBl
+    | WdBlBtOn Int
+    | WdBlBtNotOff Int
   deriving (Eq,Ord,Show,Read)
 data WdP2f = WdP2f0
     | WdP2fDoorPosition Int
   deriving (Eq,Ord,Show,Read)
+data DrWdWd = DrWdId
+    | DrWdMakeDoorDebris
+    | DrWdMechanismStepwise Int [Int] [(Point2,Point2)]
+    | DoorMechanism
+  deriving (Eq,Ord,Show,Read)

src/Dodge/Default/Door.hs

@@ -4,7 +4,6 @@ module Dodge.Default.Door
     ) where
 import Dodge.Data
 import Dodge.Default.Wall
-import Dodge.Block.Debris
 import Color
 
 import Control.Lens
@@ -26,13 +25,13 @@ defaultDoor = Door
     { _drID = 0
     , _drWallIDs = mempty
     , _drStatus = DoorClosed
-    , _drTrigger = const False
+    , _drTrigger = WdBlConst False
-    , _drMech   = const id
+    , _drMech   = DrWdId
     , _drPos = (0,0)
     , _drOpenPos = (0,0)
     , _drClosePos = (0,0)
     , _drHP     = 10000
-    , _drDeath  = makeDoorDebris
+    , _drDeath  = DrWdMakeDoorDebris
     , _drSpeed  = 1
     , _drPushedBy = PushesItself
     , _drPushes  = Nothing

src/Dodge/DrWdWd.hs

@@ -0,0 +1,76 @@
+module Dodge.DrWdWd
+    where
+import Dodge.LevelGen.DoorPane
+import Dodge.SoundLogic
+import Dodge.Base
+import Dodge.WorldBool
+import Dodge.Placement.PlaceSpot.TriggerDoor
+import Dodge.Wall.Move
+import Geometry
+import Dodge.Block.Debris
+import Dodge.Data
+
+import qualified Data.IntSet as IS
+import Data.Foldable
+import Control.Lens
+doDrWdWd :: DrWdWd -> Door -> World -> World
+doDrWdWd dww = case dww of
+    DrWdId -> const id
+    DrWdMakeDoorDebris -> makeDoorDebris
+    DrWdMechanismStepwise nsteps wlids pss -> doorMechanismStepwise nsteps wlids pss
+    DoorMechanism -> doorMechanism
+
+-- TODO sort out why DoorClosed status does not update correctly 22/06/23
+doorMechanism :: Door -> World -> World
+doorMechanism dr w = case mvDir of
+    Just d -> w
+        & flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr)
+        & moveUpdate 
+        & doors . ix drid . drPos . each %~ (+.+ d)
+        & maybeClearDoorPaths (_drObstacleType dr) (_drObstructs dr)
+    Nothing -> w
+  where
+    toOpen = doWdBl (_drTrigger dr) w
+    mvDir
+        | toOpen && _drStatus dr == DoorOpen = Nothing -- Not sure why necessary
+        | toOpen && dist dpos dop > 0.5 = Just $ vecBetweenSpeed speed dpos dop
+        | dist dpos dcp > 0.5           = Just $ vecBetweenSpeed speed dpos dcp
+        | otherwise = Nothing
+    speed = _drSpeed dr
+    drid = _drID dr
+    moveUpdate = playSound . setStatus
+    playSound 
+        | _drPushedBy dr == PushesItself = soundContinue (WallSound drid) dpos slideDoorS (Just 1)
+        | otherwise = id
+    dpos = snd $ _drPos dr
+    dop = snd $ _drOpenPos dr
+    dcp = snd $ _drClosePos dr
+    setStatus
+        | dist dpos dop < 1 = doors . ix drid . drStatus .~ DoorOpen
+        | dist dpos dcp < 1 = doors . ix drid . drStatus .~ DoorClosed
+        | otherwise                       = doors . ix drid . drStatus .~ DoorHalfway
+
+-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
+-- TODO update _drPos
+-- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed
+-- perhaps only store intermediate door pos pairs, calculate all wall positions
+-- on the fly
+doorMechanismStepwise :: Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World
+doorMechanismStepwise nsteps 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
+    drid = _drID dr
+    playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1)
+    toOpen = doWdBl (_drTrigger dr) w
+    setWalls n = playSound (foldl' (&) w (zipWith moveWallID wlids newps))
+        & doors . ix drid . drStatus .~ DoorInt n
+      where
+        newps = uncurry (rectanglePairs 9) (pss !! n)
+-- it is not at all clear that the zoning selects the correct walls

src/Dodge/Placement/Instance/Door.hs

@@ -9,17 +9,15 @@ import Dodge.Default.Door
 import Color
 import Geometry
 import Dodge.LevelGen.Data
-import Dodge.Creature.Test
 import Dodge.LevelGen.Switch
 
 import Control.Lens
-import qualified IntMapHelp as IM
 
-putDoubleDoor :: EdgeObstacle -> Wall -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Placement
+putDoubleDoor :: EdgeObstacle -> Wall -> WdBl -> Point2 -> Point2 -> Float -> Placement
 putDoubleDoor eo wl cond a b speed 
     = putDoubleDoorThen eo wl cond 1 a b speed (const $ const Nothing)
 
-putDoubleDoorThen ::EdgeObstacle ->  Wall -> (World -> Bool) 
+putDoubleDoorThen ::EdgeObstacle ->  Wall -> WdBl 
     -> Float -> Point2 -> Point2 -> Float 
     -> (Placement -> Placement -> Maybe Placement)
     -> Placement
@@ -30,7 +28,7 @@ putDoubleDoorThen eo wl cond soff a b speed cont
   where
     half = 0.5 *.* (a +.+ b)
 
-doorBetween :: EdgeObstacle -> Wall -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float ->
+doorBetween :: EdgeObstacle -> Wall -> WdBl -> Float -> Point2 -> Point2 -> Float ->
     (Placement -> Maybe Placement) -> Placement
 doorBetween eo wl cond soff pa pb speed g = case divideLine 40 pa pb of
     [x,y] -> ptCont (PutSlideDr adoor wl eo soff x y) g
@@ -41,7 +39,7 @@ doorBetween eo wl cond soff pa pb speed g = case divideLine 40 pa pb of
         & drTrigger .~ cond
         & drSpeed   .~ speed
 
-divideDoorPane :: Maybe Int -> Wall -> (World -> Bool) -> Float -> Float 
+divideDoorPane :: Maybe Int -> Wall -> WdBl -> Float -> Float 
     -> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement
 divideDoorPane mid wl cond soff speed ppairs g = case ppairs of
     [p] -> ptCont (adoor p) g
@@ -59,8 +57,9 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a)
         (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))) 
+    cond az bz = WdBlCrFilterNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)) CrIsAnimate
-        . IM.filter isAnimate . _creatures
+       --  any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz))) 
+       -- . IM.filter isAnimate . _creatures
 
 switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
 switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) 
@@ -71,7 +70,7 @@ switchDoor btpos btrot dra drb col = pContID (PS btpos btrot)
     doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) DoorObstacle 1 a b
       where
         thedoor = defaultDoor
-            & drTrigger .~ cond btid
+            & drTrigger .~ WdBlBtOn btid
             & drSpeed   .~ 2
     drc = 0.5 *.* (dra +.+ drb)
-    cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
+    --cond btid w' = _btState (_buttons w' IM.! btid) == BtOn

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -2,18 +2,17 @@
 module Dodge.Placement.PlaceSpot.TriggerDoor
     ( plDoor
     , plSlideDoor
+    , maybeClearDoorPaths
     ) where
 import Dodge.Zoning.Wall
 import Dodge.Data
 import Dodge.Base
 import Dodge.Path
 import Dodge.Default.Door
-import Dodge.Wall.Move
 import Dodge.LevelGen.DoorPane
 import Picture
 import Geometry
 import qualified IntMapHelp as IM
-import Dodge.SoundLogic
 import LensHelp
 --import Dodge.LevelGen.LevelStructure
 
@@ -23,7 +22,7 @@ import qualified Data.IntSet as IS
 import qualified Data.Graph.Inductive as FGL
 plDoor :: Color
     -> EdgeObstacle
-    -> (World -> Bool)      -- ^ Opening condition
+    -> WdBl      -- ^ Opening condition
     -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
                     -- Bumped out up and down by 9, not widened
     -> World
@@ -36,7 +35,7 @@ plDoor col eo cond pss gw = (drid, addWalls $ gw & doors %~ addDoor) -- carefull
         , _drWallIDs = IS.fromList wlids
         , _drStatus = DoorInt 0
         , _drTrigger = cond
-        , _drMech   = doorMechanismStepwise nsteps drid wlids pss
+        , _drMech   = DrWdMechanismStepwise nsteps wlids pss
         , _drPos = head pss
         , _drOpenPos = head pss
         , _drClosePos = last pss
@@ -57,59 +56,6 @@ addDoorWall eo drid wl w (wlid,wlps) = w'
     & doors . ix drid . drObstructs .++~ es
   where
     (w',es) = uncurry (obstructPathsCrossing eo) wlps w
--- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
--- TODO update _drPos
--- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed
--- perhaps only store intermediate door pos pairs, calculate all wall positions
--- on the fly
-doorMechanismStepwise :: Int -> Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World
-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' (&) w (zipWith moveWallID wlids newps))
-        & doors . ix drid . drStatus .~ DoorInt n
-      where
-        newps = uncurry (rectanglePairs 9) (pss !! n)
--- it is not at all clear that the zoning selects the correct walls
-
--- TODO sort out why DoorClosed status does not update correctly 22/06/23
-doorMechanism :: Door -> World -> World
-doorMechanism dr w = case mvDir of
-    Just d -> w
-        & flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr)
-        & moveUpdate 
-        & doors . ix drid . drPos . each %~ (+.+ d)
-        & maybeClearDoorPaths (_drObstacleType dr) (_drObstructs dr)
-    Nothing -> w
-  where
-    toOpen = _drTrigger dr w
-    mvDir
-        | toOpen && _drStatus dr == DoorOpen = Nothing -- Not sure why necessary
-        | toOpen && dist dpos dop > 0.5 = Just $ vecBetweenSpeed speed dpos dop
-        | dist dpos dcp > 0.5           = Just $ vecBetweenSpeed speed dpos dcp
-        | otherwise = Nothing
-    speed = _drSpeed dr
-    drid = _drID dr
-    moveUpdate = playSound . setStatus
-    playSound 
-        | _drPushedBy dr == PushesItself = soundContinue (WallSound drid) dpos slideDoorS (Just 1)
-        | otherwise = id
-    dpos = snd $ _drPos dr
-    dop = snd $ _drOpenPos dr
-    dcp = snd $ _drClosePos dr
-    setStatus
-        | dist dpos dop < 1 = doors . ix drid . drStatus .~ DoorOpen
-        | dist dpos dcp < 1 = doors . ix drid . drStatus .~ DoorClosed
-        | otherwise                       = doors . ix drid . drStatus .~ DoorHalfway
 
 maybeClearDoorPaths :: EdgeObstacle -> [(Int,Int,PathEdge)] -> World -> World
 maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es
@@ -138,7 +84,7 @@ plSlideDoor dr wl eo shiftOffset a b gw
         { _drID = drid
         , _drWallIDs = IS.fromList wlids
         , _drStatus = DoorClosed
-        , _drMech   = doorMechanism
+        , _drMech   = DoorMechanism
         , _drPos = (a,b)
         , _drOpenPos = (shiftLeft a,shiftLeft b)
         , _drClosePos = (a,b)

src/Dodge/Room/Airlock.hs

@@ -14,7 +14,6 @@ import Geometry
 import Picture
 
 --import Control.Lens
-import qualified IntMapHelp as IM
 {- | A passage with a switch that opens forward access while closing backwards access. -}
 airlock :: RandomGen g => State g Room
 airlock = takeOne [airlock0,airlock90,airlockCrystal,airlockZ]
@@ -27,8 +26,8 @@ airlock0 = defaultRoom
     , _rmPath  = foldMap doublePairSet [(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 NoWorldEffect NoWorldEffect)
-            $ \btid -> Just $ putDoubleDoorThen DoorObstacle thewall (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2
+            $ \btid -> Just $ putDoubleDoorThen DoorObstacle thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2
-                $ \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (cond' btid) (V2 0 80) (V2 40 80) 2
+                $ \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn 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)
@@ -41,13 +40,12 @@ airlock0 = defaultRoom
     lnks = [(V2 20 95,0)
            ,(V2 20  5,pi)
            ]
-    cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
     col = dim $ dim $ bright red
 
-airlockDoor :: Color -> (World -> Bool) -> [(Point2,Point2)] -> PSType
+airlockDoor :: Color -> WdBl -> [(Point2,Point2)] -> PSType
 airlockDoor col = PutDoor col DoorObstacle
 
-airlockDoubleDoor :: Point2 -> Point2 -> Color -> (World -> Bool) -> [(Point2,Point2)]
+airlockDoubleDoor :: Point2 -> Point2 -> Color -> WdBl -> [(Point2,Point2)]
     -> [(Point2,Point2)] -> Maybe Placement
 airlockDoubleDoor p1 p2 col cond outDoorps inDoorps = jspsJ p1 0 (airlockDoor col cond outDoorps)
     $ sPS p2 0 (airlockDoor col cond inDoorps)
@@ -60,7 +58,7 @@ airlockSimple = defaultRoom
     , _rmPath  = foldMap (doublePairSet . (V2 90 30,) . fst) lnks
     , _rmPmnts = 
         [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
-            $ \btid -> airlockDoubleDoor 0 (V2 180 0) col (cond btid) outDoorps inDoorps
+            $ \btid -> airlockDoubleDoor 0 (V2 180 0) col (WdBlBtOn btid) outDoorps inDoorps
 --            jspsJ (V2 0 0) 0 (airlockDoor col (cond btid) outDoorps)
 --            $ sPS (V2 180 0) 0 (airlockDoor col (cond btid) inDoorps)
         ]
@@ -72,7 +70,6 @@ airlockSimple = defaultRoom
          [(V2 0 30,pi/2)
          ,(V2 180 30,1.5*pi)
          ]
-    cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
     col = dim $ dim $ bright red
     outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55)
     inDoorps  = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 (-55) 0)
@@ -87,7 +84,7 @@ airlockZ = defaultRoom
 --         ]
     , _rmPmnts = 
         [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
-            $ \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (cond btid) outDoorps inDoorps
+            $ \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (WdBlBtOn btid) outDoorps inDoorps
 --            jspsJ (V2 0 60) 0 (airlockDoor col (cond btid) outDoorps)
 --            $ sPS (V2 180 60) 0 (airlockDoor col (cond btid) inDoorps)
         , sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall
@@ -97,7 +94,6 @@ airlockZ = defaultRoom
         [ rectNSWE 120 0 0 180 ]
     }
   where 
-    cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
     col = dim $ dim $ bright red
     outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 0 (-61))
     inDoorps  = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 (-61) 0)
@@ -122,7 +118,7 @@ airlock90 = defaultRoom
     , _rmPath  = doublePairSet (V2 0 40,V2 40 0)
     , _rmPmnts    = 
         [ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
-            $ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (cond btid) pss
+            $ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (WdBlBtOn btid) pss
         , mntLS vShape (V2 35 35) (V3 70 70 50)
         ]
     , _rmBound = 
@@ -136,7 +132,6 @@ airlock90 = defaultRoom
     }
   where 
     --cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
-    cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
     col = dim $ dim $ bright red
     pss = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55)
 
@@ -147,7 +142,7 @@ airlockCrystal = defaultRoom
     , _rmPath  = mempty
     , _rmPmnts    = 
         [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
-            $ \btid -> jsps0 $ airlockDoor col (cond btid) pss
+            $ \btid -> jsps0 $ airlockDoor col (WdBlBtOn btid) pss
         , crystalLine (V2 0 70) (V2 40 70)
         , mntLS vShape (V2 150 70) (V3 110 70 70)
         ]
@@ -155,7 +150,6 @@ airlockCrystal = defaultRoom
     }
   where 
     switchcutout = orderPolygon $ map toV2 [ (39,20) , (150,60) , (150,80) , (39,120) ]
-    cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
     col = dim $ dim $ bright red
     pss :: [(Point2,Point2)]
     pss = reverse $ fmap ( (\x -> (V2 50 (x - 10),V2 50 (x+60)) ) . fromIntegral)

src/Dodge/Room/Door.hs

@@ -10,8 +10,6 @@ import Dodge.Placement.Instance
 import Color
 
 import Data.Maybe
-import qualified IntMapHelp as IM
---import Control.Lens
 
 door :: Room
 door = defaultRoom
@@ -41,4 +39,4 @@ triggerDoorRoom inplid = defaultRoom
   where 
     f (pmnt:_) = putDoubleDoor DoorObstacle (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 = _triggers w IM.! fromJust (_plMID pmnt)
+    cond pmnt = WdTrig $ fromJust (_plMID pmnt)

src/Dodge/Room/LongDoor.hs

@@ -28,8 +28,6 @@ import LensHelp
 
 import qualified Data.Set as S
 import Data.Maybe
---import Data.Tree
-import qualified IntMapHelp as IM
 
 twinSlowDoorRoom 
     :: Float    -- ^ Half width
@@ -67,7 +65,7 @@ twinSlowDoorRoom w h x = defaultRoom
         ]
     thedoor btid = defaultDoor
         & drSpeed .~ wlSpeed
-        & drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) /= BtOff)
+        & drTrigger .~ WdBlBtNotOff btid
     col = dim $ dim $ bright red
 
 twinSlowDoorChasers :: RandomGen g => State g Room
@@ -113,7 +111,7 @@ addButtonSlowDoor x h rm = do
     thewall = switchWallCol red
     butDoor = putLitButOnPos col 
         (rprBool (isUnusedLnkType InLink))
-        $  \btplmnt -> Just $ putDoubleDoorThen DoorObstacle thewall (cond' $ fromJust $ _plMID btplmnt) 
+        $  \btplmnt -> Just $ putDoubleDoorThen DoorObstacle thewall (WdBlBtNotOff $ fromJust $ _plMID btplmnt) 
                             30 (V2 0 h) (V2 x h) 2
         $ \dr1 dr2 -> 
             amountedlight dr1 50
@@ -122,7 +120,6 @@ addButtonSlowDoor x h rm = do
         $ amountedlight dr2 (-50)
          Nothing
     col = dim $ light red
-    cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff
 
 slowDoorRoom :: RandomGen g => State g Room
 slowDoorRoom = do

src/Dodge/Room/Procedural.hs

@@ -34,7 +34,6 @@ import Data.Tile
 import LensHelp
 
 import qualified Data.Set as S
-import qualified IntMapHelp as IM
 --import Control.Lens
 -- This will need a cleanup, but it might change a bit first
 {- A simple rectangular room with a light in the center.
@@ -272,5 +271,5 @@ centerVaultRoom w h d = return $ defaultRoom
         ]
     thewall = switchWallCol col
     thedoor btid = defaultDoor
-        & drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) == BtOn)
+        & drTrigger .~ WdBlBtOn btid
         & drSpeed .~ 2

src/Dodge/Update.hs

@@ -4,6 +4,7 @@ Module      : Dodge.Update
 Description : Simulation update
 -}
 module Dodge.Update ( updateUniverse ) where
+import Dodge.DrWdWd
 import Dodge.TractorBeam.Update
 import Dodge.Prop.Update
 import Dodge.LinearShockwave.Update
@@ -86,7 +87,7 @@ functionalUpdate w = checkEndGame
     . colCrsWalls
     . over uvWorld simpleCrSprings 
     . over uvWorld zoneCreatures
-    . over uvWorld (updateIMl _doors _drMech                )
+    . over uvWorld (updateIMl _doors (doDrWdWd . _drMech)                )
     . over uvWorld doWorldEvents
     . over uvWorld updateDelayedEvents
     . over uvWorld (updateIMl _modifications (doModificationEffect . _mdUpdate)      )

src/Dodge/WorldBool.hs

@@ -1,12 +1,22 @@
 module Dodge.WorldBool
     where
+import Dodge.CreatureEffect
+import Dodge.Creature.Test
 import Dodge.Data
 import Data.Maybe
 import Control.Lens
 
+import qualified IntMapHelp as IM
+
 doWdBl :: WdBl -> World -> Bool
 doWdBl wb w = case wb of
+    WdBlConst bl -> bl
     WdTrig i -> fromMaybe False $ w ^? triggers . ix i
     WdBlDoorMoving i -> fromMaybe False $ do
         dr <- w ^? doors . ix i
         return (DoorHalfway == _drStatus dr)
+    WdBlCrFilterNearPoint r p t -> any (crNearPoint r p) (IM.filter (doCrBl t) (_creatures w))
+    WdBlBtOn btid -> _btState (_buttons w IM.! btid) == BtOn  -- unsafe
+    WdBlBtNotOff btid -> _btState (_buttons w IM.! btid) /= BtOff  -- unsafe
+    WdBlNegate x -> not $ doWdBl x w
+