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

Move towards allowing partial destruction of doors

Browse Source
This commit is contained in:
justin
2022-06-23 14:52:25 +01:00
parent 4c8c82b55c
commit 0f01e422f6
11 changed files with 73 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+11 -1
View File
@@ -11,6 +11,7 @@ module Dodge.Data
( module Dodge.Data
, module Dodge.Data.Material
, module Dodge.Data.LoadAction
, module Dodge.Data.ForegroundShape
, module Dodge.Data.Wall
, module Dodge.Combine.Data
, module Dodge.Distortion.Data
@@ -30,6 +31,7 @@ module Dodge.Data
, module Dodge.Data.Room
) where
import Dodge.Data.Room
import Dodge.Data.ForegroundShape
import Dodge.Data.LoadAction
import Dodge.Data.Material
import Dodge.Data.Wall
@@ -135,6 +137,7 @@ data World = World
, _toPlaySounds :: M.Map SoundOrigin Sound
, _playingSounds :: M.Map SoundOrigin Sound
, _decorations :: IM.IntMap Picture
, _shapes :: IM.IntMap ForegroundShape
, _foregroundShape :: Shape
, _corpses :: IM.IntMap Corpse
, _clickMousePos :: Point2
@@ -1018,10 +1021,16 @@ data Door = Door
, _drHP :: Int
, _drDeath :: Door -> World -> World
, _drSpeed :: Float
, _drSupport :: Support
, _drPushes :: Maybe Int
}
data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
deriving (Eq, Ord, Show)
data Support = SupportsItself
| SupportedBy Int
| Unsupported
data ActionPlan
= Inanimate
| ActionPlan
@@ -1381,7 +1390,8 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutLineBlock {_putWall :: Wall , _putWidth :: Float
, _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
| PutSlideDr Bool Color Door Float Point2 Point2
-- | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
| PutDoor Color (World -> Bool) [(Point2,Point2)]
| RandPS (State StdGen PSType)
| PutShape Shape
src/Dodge/Default/Door.hs
+2
View File
@@ -14,5 +14,7 @@ defaultDoor = Door
, _drHP = 10000
, _drDeath = const id
, _drSpeed = 1
, _drSupport = SupportsItself
, _drPushes = Nothing
}
src/Dodge/Initialisation.hs
+2 -2
View File
@@ -41,5 +41,5 @@ initialWorld = defaultWorld
}
testStringInit :: World -> [String]
testStringInit = map (show . _drStatus) . IM.elems . _doors
--testStringInit = const []
--testStringInit = map (show . _drStatus) . IM.elems . _doors
testStringInit = const []
src/Dodge/LevelGen/Data.hs
+3
View File
@@ -28,6 +28,9 @@ pContID ps pt = Placement 10 ps pt Nothing . contToIDCont
psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
psPtCont ps pt = Placement 10 ps pt Nothing . const
ptCont :: PSType -> (Placement -> Maybe Placement) -> Placement
ptCont = psPtCont (PS 0 0)
psPt :: PlacementSpot -> PSType -> Placement
psPt ps pt = Placement 10 ps pt Nothing (const . const Nothing)
src/Dodge/Placement/Instance/Door.hs
+31 -10
View File
@@ -5,6 +5,7 @@ module Dodge.Placement.Instance.Door
, switchDoor -- not used 9/3/22
) where
import Dodge.Data
import Dodge.Default.Door
--import Dodge.Base
import Color
import Geometry
@@ -12,6 +13,8 @@ import Dodge.LevelGen.Data
import Dodge.Creature.Test
import Dodge.LevelGen.Switch
import Data.Maybe
import Control.Lens
import qualified Data.IntMap.Strict as IM
putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement
@@ -23,19 +26,33 @@ putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
-> (Placement -> Placement -> Maybe Placement)
-> Placement
putDoubleDoorThen pathing col cond soff a b speed cont
= doorbetween a half
$ \pl1 -> Just $ doorbetween b half
= doorBetween pathing col cond soff a half speed
$ \pl1 -> Just $ doorBetween pathing col cond soff b half speed
$ \pl2 -> cont pl1 pl2
where
doorbetween pa pb = pt0 $ PutSlideDr pathing col cond soff pa pb speed
half = 0.5 *.* (a +.+ b)
--doorBetween pathing col cond soff pa pb speed g = case divideLine 80 pa pb of
-- [x,y] -> \_ -> Just (pt0 (PutSlideDr pathing col cond soff x y speed) g)
-- (x:y:zs) -> foldr f g (zip (x:y:zs) (y:zs))
-- where
-- f :: (Point2,Point2) -> (Placement -> Maybe Placement) -> (Placement -> Maybe Placement)
-- f (a,b) h = \pl -> Just (pt0 (PutSlideDr pathing col cond (soff - dist y pb) a b speed) h)
doorBetween :: Bool -> Color -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float ->
(Placement -> Maybe Placement) -> Placement
doorBetween pathing col cond soff pa pb speed g = case divideLine 40 pa pb of
[x,y] -> ptCont (PutSlideDr pathing col adoor soff x y) g
(x:y:zs) -> divideDoorPane Nothing pathing col cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
_ -> undefined
where
adoor = defaultDoor
& drTrigger .~ cond
& drSpeed .~ speed
divideDoorPane :: Maybe Int -> Bool -> Color -> (World -> Bool) -> Float -> Float
-> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement
divideDoorPane mid pathing col cond soff speed ppairs g = case ppairs of
[p] -> ptCont (adoor p) $ g
(p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) pathing col cond soff speed ps g
_ -> undefined
where
adoor (x,y) = PutSlideDr pathing col thedoor soff x y
thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond
& drSupport .~ SupportedBy (fromJust mid)
putAutoDoor :: Point2 -> Point2 -> Placement
putAutoDoor a b = PlacementUsingPos (addZ 0 a)
@@ -51,6 +68,10 @@ switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeS
$ \btid -> jsps0J (doorbetween btid dra drc)
$ sps0 (doorbetween btid drb drc)
where
doorbetween btid a b = PutSlideDr False col (cond btid) 1 a b 2
doorbetween btid a b = PutSlideDr False col thedoor 1 a b
where
thedoor = defaultDoor
& drTrigger .~ cond btid
& drSpeed .~ 2
drc = 0.5 *.* (dra +.+ drb)
cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
src/Dodge/Placement/PlaceSpot.hs
+2 -2
View File
@@ -101,8 +101,8 @@ placeSpotID ps pt w = case pt of
RandPS rgn -> evaluateRandPS rgn ps w
PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w
PutCoord cp -> plNewID coordinates (doShift cp) w
PutSlideDr pth col f off a b spd
-> plSlideDoor pth col f off (doShift a) (doShift b) spd w
PutSlideDr pth col dr off a b
-> plSlideDoor pth col dr off (doShift a) (doShift b) w
PutBlock bl wl ps' -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
wl w
PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+4 -6
View File
@@ -15,6 +15,7 @@ import qualified IntMapHelp as IM
import Dodge.SoundLogic
--import Dodge.LevelGen.LevelStructure
--import Data.Maybe
import Data.List
import Control.Lens
--import Data.Graph.Inductive hiding ((&))
@@ -106,27 +107,24 @@ doorMechanism dr w = case mvDir of
plSlideDoor
:: Bool
-> Color
-> (World -> Bool)
-> Door
-> Float
-> Point2
-> Point2
-> Float
-> World
-> (Int, World)
plSlideDoor isPathable col cond shiftOffset a b speed gw
plSlideDoor isPathable col dr shiftOffset a b gw
= (drid, addDoorWalls gw & doors %~ addDoor)
where
drid = IM.newKey $ _doors gw
addDoor = IM.insert drid $ defaultDoor
addDoor = IM.insert drid $ dr
{ _drID = drid
, _drWallIDs = IS.fromList wlids
, _drStatus = DoorClosed
, _drTrigger = cond
, _drMech = doorMechanism
, _drPos = (a,b)
, _drOpenPos = (shiftLeft a,shiftLeft b)
, _drClosePos = (a,b)
, _drSpeed = speed
}
addDoorWalls w' = foldl' (addDoorWall drid col isPathable) w' $ zip wlids pairs
pairs = rectanglePairs 9 a b
src/Dodge/Room/LongDoor.hs
+6 -3
View File
@@ -3,6 +3,7 @@
-}
module Dodge.Room.LongDoor where
import Dodge.Data
import Dodge.Default.Door
import Dodge.Cleat
import Dodge.RoomLink
import Dodge.Base
@@ -45,8 +46,8 @@ twinSlowDoorRoom w h x = defaultRoom
, _rmPath = []
, _rmPmnts =
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
$ \btid -> jsps0J (PutSlideDr False col (cond' btid) 1 (V2 x 1) (V2 x h) wlSpeed)
$ ps0 (PutSlideDr False col (cond' btid) 1 (V2 (-x) 1) (V2 (-x) h) wlSpeed)
$ \btid -> jsps0J (PutSlideDr False col (thedoor btid) 1 (V2 x 1) (V2 x h))
$ ps0 (PutSlideDr False col (thedoor btid) 1 (V2 (-x) 1) (V2 (-x) h))
$ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampHeight)))
$ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
]
@@ -68,7 +69,9 @@ twinSlowDoorRoom w h x = defaultRoom
[rectNSWE h 0 (-w) w
,rectNSWE 20 (-h) (negate x) x
]
cond' btid w' = _btState (_buttons w' IM.! btid) /= BtOff
thedoor btid = defaultDoor
& drSpeed .~ wlSpeed
& drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) /= BtOff)
col = dim $ dim $ bright red
twinSlowDoorChasers :: RandomGen g => State g Room
src/Dodge/Room/Procedural.hs
+6 -3
View File
@@ -12,6 +12,7 @@ module Dodge.Room.Procedural
import Dodge.Data
import Dodge.Placement.Shift
import Dodge.Default.Wall
import Dodge.Default.Door
--import Shape.Data
import Dodge.PlacementSpot
import Dodge.Placement.Instance
@@ -266,7 +267,9 @@ centerVaultRoom w h d = return $ defaultRoom
col = dim $ dim $ bright red
theDoor =
[ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2 (-21) 0) (V2 0 0) 2)
$ sPS (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2 21 0) (V2 0 0) 2)
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (thedoor btid) 1 (V2 (-21) 0) (V2 0 0))
$ sPS (V2 0 (d-10)) 0 (PutSlideDr False col (thedoor btid) 1 (V2 21 0) (V2 0 0))
]
cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
thedoor btid = defaultDoor
& drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) == BtOn)
& drSpeed .~ 2
src/Picture/Data.hs
+3 -1
View File
@@ -13,6 +13,7 @@ data Verx = Verx
, _vxLayer :: !Layer
, _vxShadNum :: !ShadNum
}
deriving (Eq,Ord,Show)
--newtype LayNum = LayNum { _unLayNum :: Int }
data Layer
@@ -22,7 +23,7 @@ data Layer
| BloomNoZWrite
| DebugLayer
| FixedCoordLayer
deriving (Eq,Ord,Enum,Bounded)
deriving (Eq,Ord,Enum,Bounded,Show)
layerNum :: Layer -> Int
layerNum = fromEnum
@@ -30,6 +31,7 @@ numLayers :: Int
numLayers = length [minBound::Layer .. maxBound]
--TODO use synonyms for layer numbers
newtype ShadNum = ShadNum { _unShadNum :: Int }
deriving (Eq,Ord,Show)
polyNum, polyzNum, bezNum, textNum, arcNum, ellNum :: ShadNum
{-# INLINE polyNum #-}
{-# INLINE polyzNum #-}
src/Shape/Data.hs
+3
View File
@@ -29,14 +29,17 @@ data ShapeObj = ShapeObj
{ _shType :: ShapeType
, _shVs :: [ShapeV]
}
deriving (Eq,Ord,Show)
newtype ShapeType = TopPrism Int
deriving (Eq,Ord,Show)
-- edges are given by four consecutive points
data ShapeV = ShapeV
{_svPos :: Point3
,_svCol :: Point4
}
deriving (Eq,Ord,Show)
pairToSV :: (Point3,Point4) -> ShapeV
{-# INLINE pairToSV #-}
pairToSV = uncurry ShapeV