justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor doors

Browse Source
This commit is contained in:
justin
2022-07-24 20:36:27 +01:00
parent 2c1bc67a51
commit d6a94ec4bc
25 changed files with 186 additions and 135 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block.hs
+3 -2
View File
@@ -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
+2 -1
View File
@@ -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
+4 -25
View File
@@ -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
+1
View File
@@ -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
+29 -3
View File
@@ -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
+1
View File
@@ -16,4 +16,5 @@ data EnergyBall = EnergyBall
, _ebZ :: Float
, _ebRot :: Float
}
deriving (Eq,Ord,Show,Read)
makeLenses ''EnergyBall
src/Dodge/Data/Flame.hs
+1
View File
@@ -13,4 +13,5 @@ data Flame = Flame
, _flZ :: Float
, _flOriginalVel :: Point2
}
deriving (Eq,Ord,Show,Read)
makeLenses ''Flame
src/Dodge/Data/Flare.hs
+1 -2
View File
@@ -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
+9
View File
@@ -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
+3 -2
View File
@@ -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
+2 -1
View File
@@ -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
+1 -2
View File
@@ -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
+1
View File
@@ -11,4 +11,5 @@ data RadarSweep = RadarSweep
, _rsObject :: Object
, _rsTimer :: Int
}
deriving (Eq,Ord,Show,Read)
makeLenses ''RadarSweep
src/Dodge/Data/Spark.hs
+1
View File
@@ -13,4 +13,5 @@ data Spark = Spark
, _skWidth :: Float
, _skDamageType :: DamageType
}
deriving (Eq,Ord,Show,Read)
makeLenses ''Spark
src/Dodge/Data/WorldEffect.hs
+11
View File
@@ -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
+3 -4
View File
@@ -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
, _drMech = const id
, _drTrigger = WdBlConst False
, _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
+76
View File
@@ -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 -10
View File
@@ -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)))
. IM.filter isAnimate . _creatures
cond az bz = WdBlCrFilterNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)) CrIsAnimate
-- 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
+4 -58
View File
@@ -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
+8 -14
View File
@@ -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
$ \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (cond' btid) (V2 0 80) (V2 40 80) 2
$ \btid -> Just $ putDoubleDoorThen DoorObstacle thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 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
+1 -3
View File
@@ -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
+2 -5
View File
@@ -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
+1 -2
View File
@@ -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
+2 -1
View File
@@ -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
+10
View File
@@ -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