From 08e5df07e20569aba787b12a85559c176a264269 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 19 Jun 2022 20:50:03 +0100 Subject: [PATCH] Allow for door destruction --- src/Dodge/Base/Collide.hs | 3 +++ src/Dodge/Block.hs | 12 ++++++++++++ src/Dodge/Block/Debris.hs | 20 +++++--------------- src/Dodge/Creature/Action.hs | 1 + src/Dodge/CullBox.hs | 2 +- src/Dodge/Data.hs | 2 ++ src/Dodge/Debug/Terminal.hs | 2 +- src/Dodge/Default/Door.hs | 17 +++++++++++++++++ src/Dodge/Event.hs | 13 +++++++++---- src/Dodge/Inventory/Add.hs | 14 ++++++++------ src/Dodge/Placement/PlaceSpot/TriggerDoor.hs | 18 +++++++++--------- src/Dodge/Update/Camera.hs | 11 ++++++----- src/Dodge/Wall/Damage.hs | 7 +++++++ src/Picture.hs | 2 +- 14 files changed, 82 insertions(+), 42 deletions(-) create mode 100644 src/Dodge/Default/Door.hs diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index cf3b8dc1a..69cc819a5 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -366,15 +366,18 @@ collidePointAnyWallsReflect p1 p2 -- If found, gives collision point -- If not found, returns point collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 +{-# INLINE collidePointWalls #-} collidePointWalls p1 p2 = foldr findPoint p2 . fmap _wlLine where findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 +{-# INLINE collidePointWalls' #-} collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine where findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) collidePointWallsFilt' :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2 +{-# INLINE collidePointWallsFilt' #-} collidePointWallsFilt' t p1 p2 = collidePointWalls p1 p2 . IM.filter t -- | Looks for first collision of a circle with walls. diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index b82b6d8ac..395ba344f 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -62,3 +62,15 @@ destroyBlock bl w = w awl = _walls w IM.! IS.findMin wlids pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w + +destroyDoor :: Door -> World -> World +destroyDoor dr w = w + & _drDeath dr dr + & deleteWallIDs wlids + & doors %~ IM.delete (_drID dr) + & flip (foldr (wlDustAt awl)) (map (pos +.+) ps) + where + wlids = _drWallIDs dr + awl = _walls w IM.! IS.findMin wlids + pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids + ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w diff --git a/src/Dodge/Block/Debris.hs b/src/Dodge/Block/Debris.hs index 892a2cefb..9f1579568 100644 --- a/src/Dodge/Block/Debris.hs +++ b/src/Dodge/Block/Debris.hs @@ -75,26 +75,16 @@ dirtColor :: Color dirtColor = V4 (150/256) ( 75/256) 0 ( 250/256) glassDebris :: Prop -glassDebris = PropZ - {_prPos = 0 - ,_pjStartPos = 0 - ,_pjVel = 0 - ,_prDraw = \pr -> drawMovingShape pr (shardShape 4 pr) - ,_pjID = 0 - ,_pjUpdate = fallSmallBounce - ,_pjPosZ = 10 - ,_pjVelZ = 5 - ,_pjTimer = 20 - ,_pjQuat = Q.axisAngle (V3 1 0 0) 0 - ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1 - ,_pjColor = withAlpha 0.5 cyan - } +glassDebris = stoneDebris + & prDraw .~ (\pr -> drawMovingShape pr (shardShape 4 pr)) + & pjUpdate .~ fallSmallBounce + & pjColor .~ withAlpha 0.5 cyan crystalDebris :: Prop crystalDebris = glassDebris & pjColor .~ withAlpha 0.5 aquamarine shardShape :: Float -> Prop -> Shape -shardShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly size $ +shardShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly size [V2 size 0 ,V2 (-size) 1 ,V2 (-size) (-1) diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index c419384fe..a4e68be96 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -318,4 +318,5 @@ pickUpItemID cid flid w = pickUpItem cid (_floorItems w IM.! flid) w {- | Pick up a specific item. -} pickUpItem :: Int -> FloorItem -> World -> World pickUpItem cid flit w = maybe w (soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing) + . fmap snd $ tryPutItemInInv cid flit w diff --git a/src/Dodge/CullBox.hs b/src/Dodge/CullBox.hs index ca3520b24..1373b1b40 100644 --- a/src/Dodge/CullBox.hs +++ b/src/Dodge/CullBox.hs @@ -15,7 +15,7 @@ cullBox :: Configuration -> World -> [Point2] --cullBox cfig w = farWallPoints cp w cullBox cfig w' | debugOn Bound_box_screen cfig = screenPolygon cfig w' - | otherwise = let (n,s,e,w) = farWallDistDirection (_cameraCenter w') cfig w' + | otherwise = let (n,s,e,w) = farWallDistDirection (_cameraCenter w') w' in map ((+.+ _cameraCenter w') . rotateV (_cameraRot w') ) $ rectNSWE n (negate s) (negate w) e -- --mapMaybe (fmap (fst . _wlLine . snd) . f) $ screenPolygon cfig w -- where diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index b5702b186..0b67ba4de 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -1012,6 +1012,8 @@ data Door = Door , _drPos :: (Point2,Point2) , _drOpenPos :: (Point2,Point2) , _drClosePos :: (Point2,Point2) + , _drHP :: Int + , _drDeath :: Door -> World -> World } data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int deriving (Eq, Ord, Show) diff --git a/src/Dodge/Debug/Terminal.hs b/src/Dodge/Debug/Terminal.hs index 0bd3ed346..799539e29 100644 --- a/src/Dodge/Debug/Terminal.hs +++ b/src/Dodge/Debug/Terminal.hs @@ -62,7 +62,7 @@ applyTerminalCommandArguments :: String -> [String] -> Universe -> Universe applyTerminalCommandArguments command args u = case command of "ITEM" -> fromMaybe u $ do ibt <- safeHead args >>= readMaybe - return $ u & uvWorld %~ createPutItem (itemFromBase ibt) + return $ u & uvWorld %~ (snd . createPutItem (itemFromBase ibt)) _ -> u showTerminalError :: String -> String -> Universe -> Universe diff --git a/src/Dodge/Default/Door.hs b/src/Dodge/Default/Door.hs new file mode 100644 index 000000000..2a17eeb03 --- /dev/null +++ b/src/Dodge/Default/Door.hs @@ -0,0 +1,17 @@ +module Dodge.Default.Door where +import Dodge.Data + +defaultDoor :: Door +defaultDoor = Door + { _drID = 0 + , _drWallIDs = mempty + , _drStatus = DoorClosed + , _drTrigger = const False + , _drMech = const id + , _drPos = (0,0) + , _drOpenPos = (0,0) + , _drClosePos = (0,0) + , _drHP = 10000 + , _drDeath = const id + } + diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 238bd82eb..ae2379bdd 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -101,21 +101,26 @@ handlePressedMouseButton but w = case (_hudElement (_hud w), but) of | inTermFocus w -> doTerminalEffectLB (w ^?! terminals . ix tmid) w | otherwise -> w & terminals . ix tmid . tmInput . tiFocus %~ const True ( DisplayInventory (CombineInventory mi) , ButtonLeft) - -> maybe (hud . hudElement .~ DisplayInventory NoSubInventory) doCombine mi w + -> maybeexitcombine $ maybe id doCombine mi w _ -> w + where + maybeexitcombine + | ButtonRight `S.member` _mouseButtons w = id + | otherwise = hud . hudElement .~ DisplayInventory NoSubInventory -- note "sort" on the inventory indices; otherwise -- lower items may be shifted up and items below these removed instead doCombine :: Int -> World -> World doCombine i w = case combineItemListYou w !? i of Nothing -> w - Just (is,it) -> enterCombineInv + Just (is,it) -> -- set (hud . hudElement) (DisplayInventory NoSubInventory) + selectinv --enterCombineInv . createPutItem it --- . uncurry (putItemInInvID yid) --- . copyItemToFloorID (_crPos $ you w) (applyModules it) $ foldr (rmInvItem yid) w (sort is) where yid = _yourID w + selectinv (Just i', w') = w' & creatures . ix yid . crInvSel .~ i' + selectinv (Nothing, w') = w' handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe diff --git a/src/Dodge/Inventory/Add.hs b/src/Dodge/Inventory/Add.hs index a5630a010..0d162a814 100644 --- a/src/Dodge/Inventory/Add.hs +++ b/src/Dodge/Inventory/Add.hs @@ -9,21 +9,23 @@ import Data.Maybe import Control.Lens import qualified Data.IntMap.Strict as IM -putItemInInvID :: Int -> Int -> World -> World -putItemInInvID cid flid w = fromMaybe w - $ tryPutItemInInv cid (_floorItems w IM.! flid) w +putItemInInvID :: Int -> Int -> World -> (Maybe Int,World) +putItemInInvID cid flid w = fromMaybe (Nothing,w) $ do + (i,w') <- tryPutItemInInv cid (_floorItems w IM.! flid) w + return (Just i,w') putItemInInvSlot :: Int -> Item -> IM.IntMap Item -> IM.IntMap Item putItemInInvSlot = IM.insertWith (const $ itConsumption . icAmount +~ 1) {- | Pick up a specific item. -} -tryPutItemInInv :: Int -> FloorItem -> World -> Maybe World +tryPutItemInInv :: Int -> FloorItem -> World -> Maybe (Int,World) tryPutItemInInv cid flit w = case maybeInvSlot of Nothing -> Nothing - Just i -> Just $ w + Just i -> Just (i, w & updateItLocation i & floorItems %~ IM.delete (_flItID flit) & creatures . ix cid . crInv %~ putItemInInvSlot i it + ) where it = _flIt flit maybeInvSlot = checkInvSlotsYou it w @@ -45,6 +47,6 @@ tryPutItemInInv cid flit w = case maybeInvSlot of -- updateItLocation invid w' = case _itID it of -- Nothing -> w' -- Just j -> w' & itemPositions . ix j .~ InInv cid invid -createPutItem :: Item -> World -> World +createPutItem :: Item -> World -> (Maybe Int, World) createPutItem it w = uncurry (putItemInInvID (_yourID w)) $ copyItemToFloorID (_crPos $ you w) (applyModules it) w diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 580a30f91..bcd763750 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -5,6 +5,7 @@ module Dodge.Placement.PlaceSpot.TriggerDoor ) where import Dodge.Data import Dodge.Default.Wall +import Dodge.Default.Door import Dodge.Wall.Move import Dodge.LevelGen.DoorPane import Picture @@ -26,7 +27,7 @@ plDoor :: Color plDoor col cond pss gw = (drid, addWalls gw & doors %~ addDoor) where drid = IM.newKey $ _doors gw - addDoor = IM.insert drid $ Door + addDoor = IM.insert drid $ defaultDoor { _drID = drid , _drWallIDs = IS.fromList wlids , _drStatus = DoorInt 0 @@ -39,16 +40,15 @@ plDoor col cond pss gw = (drid, addWalls gw & doors %~ addDoor) nsteps = length pss - 1 wlids = take 4 [IM.newKey $ _walls gw ..] wlps' = uncurry (rectanglePairs 9) $ head pss - addWalls w' = foldl' (addDoorWall col False) w' $ zip wlids wlps' + addWalls w' = foldl' (addDoorWall drid col False) w' $ zip wlids wlps' -addDoorWall :: Color -> Bool -> World -> (Int,(Point2,Point2)) -> World -addDoorWall col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defaultWall +addDoorWall :: Int -> Color -> Bool -> World -> (Int,(Point2,Point2)) -> World +addDoorWall drid col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defaultWall { _wlLine = wlps , _wlID = wlid , _wlColor = col - , _wlSeen = False - , _wlOpacity = Opaque , _wlPathable = pathableStatus + , _wlStructure = DoorPart drid } -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs -- TODO update _drPos @@ -108,10 +108,10 @@ plSlideDoor -> World -> (Int, World) plSlideDoor isPathable col cond shiftOffset a b speed gw - = (drid, addWalls gw & doors %~ addDoor) + = (drid, addDoorWalls gw & doors %~ addDoor) where drid = IM.newKey $ _doors gw - addDoor = IM.insert drid $ Door + addDoor = IM.insert drid $ defaultDoor { _drID = drid , _drWallIDs = IS.fromList wlids , _drStatus = DoorClosed @@ -121,7 +121,7 @@ plSlideDoor isPathable col cond shiftOffset a b speed gw , _drOpenPos = (shiftLeft a,shiftLeft b) , _drClosePos = (a,b) } - addWalls w' = foldl' (addDoorWall col isPathable) w' $ zip wlids pairs + addDoorWalls w' = foldl' (addDoorWall drid col isPathable) w' $ zip wlids pairs pairs = rectanglePairs 9 a b shiftedPairs = map (bimap shiftLeft shiftLeft) pairs shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a))) diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 40758a954..7a1c0ce46 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -18,6 +18,7 @@ import LensHelp --import qualified Data.List.NonEmpty as NEL --import Control.Applicative +import Data.Foldable import Data.Maybe import Control.Monad import qualified Data.Set as S @@ -206,16 +207,16 @@ farWallDist p cfig w = (winFac /) wos = wallsOnScreen cfig w distFromEqmnt = foldr max 1 $ IM.mapMaybe (_eqViewDist . _eqEq. _itUse) $ getCrEquipment $ you w -farWallDistDirection :: Point2 -> Configuration -> World -> (Float,Float,Float,Float) ---farWallDist p cfig w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps -farWallDistDirection p cfig w = foldr (m . f) (0,0,0,0) vps +farWallDistDirection :: Point2 -> World -> (Float,Float,Float,Float) +farWallDistDirection p w = foldl' (flip (m . f)) (0,0,0,0) vps where - f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWallsFilt' wlIsOpaque p q wos -.- p + --f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWallsFilt' wlIsOpaque p q wos -.- p + f q = g $ rotateV (negate $ _cameraRot w) + $ collidePointWallsFilt' wlIsOpaque p q (wallsAlongLine p q w) -.- p g (V2 x y) = (y, negate y, x, negate x) m (a,b,c,d) (x,y,z,w') = (max a x, max b y, max c z, max d w') vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w) - wos = wallsOnScreen cfig w extendedViewPoints :: Point2 -> [GameRoom] -> [Point2] extendedViewPoints p grs = map extend diff --git a/src/Dodge/Wall/Damage.hs b/src/Dodge/Wall/Damage.hs index 1b1373eba..604d2a2c5 100644 --- a/src/Dodge/Wall/Damage.hs +++ b/src/Dodge/Wall/Damage.hs @@ -16,6 +16,8 @@ damageWall dt wl w = case _wlStructure wl of & machines . ix mcid . mcDamage .:~ dt BlockPart blid -> let (w',x) = defaultWallDamage dt wl w in w' & blocks . ix blid . blHP -~ x & maybeDestroyBlock blid + DoorPart drid -> let (w',x) = defaultWallDamage dt wl w + in w' & doors . ix drid . drHP -~ x & maybeDestroyDoor drid _ -> fst $ defaultWallDamage dt wl w -- block destruction is convoluted... @@ -24,6 +26,11 @@ maybeDestroyBlock blid w = case w ^? blocks . ix blid of Just bl | _blHP bl < 1 -> destroyBlock bl w _ -> w +maybeDestroyDoor :: Int -> World -> World +maybeDestroyDoor drid w = case w ^? doors . ix drid of + Just dr | _drHP dr < 1 -> destroyDoor dr w + _ -> w + damageBlocksBy :: Int -> Wall -> World -> World damageBlocksBy x wl = case wl ^? wlStructure . wsBlock of Just blid -> blocks . ix blid . blHP -~ x diff --git a/src/Picture.hs b/src/Picture.hs index f06d0fbc5..d216ec0b4 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -55,7 +55,7 @@ polygonWire :: [Point2] -> Picture {-# INLINE polygonWire #-} polygonWire ps = line (ps ++ [head ps]) --- need to check the winding! +-- | Expects clockwise input. polygon :: [Point2] -> Picture {-# INLINE polygon #-} polygon = map f . polyToTris