Refactor doors
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
Reference in New Issue
Block a user