From 0f01e422f6107b12e3840c158d46c1f5b8830f50 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 23 Jun 2022 14:52:25 +0100 Subject: [PATCH] Move towards allowing partial destruction of doors --- src/Dodge/Data.hs | 12 +++++- src/Dodge/Default/Door.hs | 2 + src/Dodge/Initialisation.hs | 4 +- src/Dodge/LevelGen/Data.hs | 3 ++ src/Dodge/Placement/Instance/Door.hs | 41 +++++++++++++++----- src/Dodge/Placement/PlaceSpot.hs | 4 +- src/Dodge/Placement/PlaceSpot/TriggerDoor.hs | 10 ++--- src/Dodge/Room/LongDoor.hs | 9 +++-- src/Dodge/Room/Procedural.hs | 9 +++-- src/Picture/Data.hs | 4 +- src/Shape/Data.hs | 3 ++ 11 files changed, 73 insertions(+), 28 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index fcaf6587e..77f6267db 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -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 diff --git a/src/Dodge/Default/Door.hs b/src/Dodge/Default/Door.hs index 89a736f66..51ae65477 100644 --- a/src/Dodge/Default/Door.hs +++ b/src/Dodge/Default/Door.hs @@ -14,5 +14,7 @@ defaultDoor = Door , _drHP = 10000 , _drDeath = const id , _drSpeed = 1 + , _drSupport = SupportsItself + , _drPushes = Nothing } diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 20aff343b..ff8ae9b3b 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -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 [] diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index c5b4c29b8..a79039cb6 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -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) diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index 0fad40027..642d24523 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/src/Dodge/Placement/Instance/Door.hs @@ -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 diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 4e8433c44..59c38aba0 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -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 diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 17f91433d..723b81483 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -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 diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index bc02e6ba7..1da87ef90 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -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 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index bb125f352..a4ae3c7e7 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -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 diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 6d92b500b..9b617b695 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -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 #-} diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index d745698f9..4fa49b469 100644 --- a/src/Shape/Data.hs +++ b/src/Shape/Data.hs @@ -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