Allow for door destruction
This commit is contained in:
@@ -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.
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
}
|
||||
|
||||
+9
-4
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)))
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+1
-1
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user