diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 991d686f2..2356dca43 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -76,7 +76,9 @@ module Dodge.Data , module Dodge.Data.Gust , module Dodge.Data.Projectile , module Dodge.Data.Modification + , module Dodge.Data.PressPlate ) where +import Dodge.Data.PressPlate import Dodge.Data.Modification import Dodge.Data.Projectile import Dodge.Data.Gust @@ -351,15 +353,8 @@ data TerminalLine {_tlPause :: Int ,_tlEffect :: Terminal -> World -> World } -data PressPlate = PressPlate - { _ppPict :: Picture - , _ppPos :: Point2 - , _ppRot :: Float - , _ppEvent :: PressPlate -> World -> World - , _ppID :: Int - , _ppText :: String - } data FloorItem = FlIt { _flIt :: Item , _flItPos :: Point2 , _flItRot :: Float, _flItID :: Int} + deriving (Eq,Ord,Show,Read) data IntID a = IntID Int a @@ -370,6 +365,7 @@ data WorldBeams = WorldBeams ,_positronBeams :: [Beam] ,_electronBeams :: [Beam] } + deriving (Eq,Ord,Show,Read) {- Objects without ids. Update themselves, perhaps with side effects. -} @@ -688,7 +684,6 @@ makeLenses ''World makeLenses ''FloorItem makeLenses ''Prop makeLenses ''Particle -makeLenses ''PressPlate makeLenses ''Door makeLenses ''Terminal makeLenses ''Machine diff --git a/src/Dodge/Data/PressPlate.hs b/src/Dodge/Data/PressPlate.hs new file mode 100644 index 000000000..ae5e757c7 --- /dev/null +++ b/src/Dodge/Data/PressPlate.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Data.PressPlate + where +import Geometry.Data +import Picture +import Control.Lens +data PressPlateEvent = PressPlateId + | PPLevelReset + deriving (Eq,Ord,Show,Read) +data PressPlate = PressPlate + { _ppPict :: Picture + , _ppPos :: Point2 + , _ppRot :: Float + , _ppEvent :: PressPlateEvent + , _ppID :: Int + , _ppText :: String + } +makeLenses ''PressPlate diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 773ce392b..b3e3d0d39 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -103,7 +103,7 @@ defaultPP = PressPlate { _ppPict = setDepth 1 . color (dim . dim $ bright blue) $ circleSolid 5 , _ppPos = V2 0 0 , _ppRot = 0 - , _ppEvent = const id + , _ppEvent = PressPlateId , _ppID = -1 , _ppText = "Pressure plate" } diff --git a/src/Dodge/PressPlate.hs b/src/Dodge/PressPlate.hs new file mode 100644 index 000000000..2fe6264bf --- /dev/null +++ b/src/Dodge/PressPlate.hs @@ -0,0 +1,16 @@ +module Dodge.PressPlate + where +import Dodge.Data +import Geometry +import Dodge.Base.You +import Dodge.WorldEvent.Explosion + +doPressPlateEvent :: PressPlateEvent -> PressPlate -> World -> World +doPressPlateEvent ppe = case ppe of + PressPlateId -> const id + PPLevelReset -> ppLevelReset + +ppLevelReset pp w + | dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) w + | otherwise = w + diff --git a/src/Dodge/Room/Teleport.hs b/src/Dodge/Room/Teleport.hs index 7d2862ce1..3e39c9cb8 100644 --- a/src/Dodge/Room/Teleport.hs +++ b/src/Dodge/Room/Teleport.hs @@ -31,11 +31,8 @@ telRoomLev _ = do { _ppPict = setDepth 0.5 . color red $ polygon ppFootprint , _ppPos = V2 0 0 , _ppRot = 0 - , _ppEvent = levelReset + , _ppEvent = PPLevelReset , _ppID = 0 , _ppText = "NEW LEVEL" } ppFootprint = reverse $ rectNSWE 20 (-20) (-20) 20 - levelReset pp w - | dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) w - | otherwise = w diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index a0108549a..a6d1bc522 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -4,6 +4,7 @@ Module : Dodge.Update Description : Simulation update -} module Dodge.Update ( updateUniverse ) where +import Dodge.PressPlate import Dodge.ModificationEffect import Dodge.CrGroupUpdate import Dodge.Zoning.Cloud @@ -352,7 +353,7 @@ updateMIM f up = f %~ IM.mapMaybe (dbArg up) -- (_,g') = genWord8 g ppEvents :: World -> World -ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w +ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ _pressPlates w updateSeenWalls :: World -> World updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w)