From aa29e5ddf2138b807235eb786408b82a34fc45fa Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 16 Jun 2022 12:24:09 +0100 Subject: [PATCH] Improve debris --- src/Dodge/Block.hs | 2 +- src/Dodge/Block/Debris.hs | 19 +++++++++++++++++ src/Dodge/Data.hs | 4 ++-- src/Dodge/Item/Weapon/Shatter.hs | 8 ++++---- src/Dodge/Placement/Instance/Wall.hs | 2 +- src/Dodge/Placement/PlaceSpot.hs | 4 ++-- src/Dodge/Placement/PlaceSpot/Block.hs | 28 +++++++++++--------------- src/Dodge/Room/Pillar.hs | 2 +- src/Dodge/Room/RoadBlock.hs | 2 +- src/Dodge/Update.hs | 6 +++--- src/Dodge/Wall/Damage.hs | 23 ++++++++------------- src/Dodge/Wall/DamageEffect.hs | 2 +- src/Dodge/Wall/Dust.hs | 11 ++++++++++ src/RandomHelp.hs | 12 ++++++++--- 14 files changed, 75 insertions(+), 50 deletions(-) diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index b3c541a77..18a3fc671 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -17,7 +17,6 @@ import Control.Lens splinterBlock :: Block -> World -> World splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl) - & blocks . ix (_blID bl) . blHPs %~ tail & matSplintSound (_blMaterial bl) cen where cen = centroid $ fst . _wlLine <$> IM.restrictKeys (_walls w) (_blWallIDs bl) @@ -41,6 +40,7 @@ matSplintSound mat = case mat of destroyBlock :: Block -> World -> World destroyBlock bl w = w + & flip (foldr unshadowBlock) (_blShadows bl) & deleteWallIDs wlids & blocks %~ IM.delete (_blID bl) & matDesSound (_blMaterial bl) pos diff --git a/src/Dodge/Block/Debris.hs b/src/Dodge/Block/Debris.hs index 12e97a6ec..d85509e61 100644 --- a/src/Dodge/Block/Debris.hs +++ b/src/Dodge/Block/Debris.hs @@ -37,6 +37,25 @@ makeDebris bm p w = w & pjVelZ .~ 0 & pjPosZ .~ h +makeDebrisDirected :: BlockMaterial -> Point2 -> Float -> World -> World +makeDebrisDirected bm p dir w = w + & flip (foldr (plNew props pjID)) thedebris + & randGen .~ newg + & matDesSound bm p + where + (thedebris,newg) = runState (mapM f [35,55..95]) $ _randGen w + f h = do + v <- rotateV (dir - pi/4) <$> randInArcStrip 2 3 (pi/2) + q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere + return $ someDebris + & prPos .~ p + & pjColor .~ greyN 0.5 + & pjVel .~ v + & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) + & pjQuat .~ q + & pjVelZ .~ 0 + & pjPosZ .~ h + someDebris :: Prop someDebris = PropZ {_prPos = 0 diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 44f7aa86c..748cee1a3 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -919,7 +919,7 @@ data Either3 a b c = E3x1 a | E3x2 b | E3x3 c data Block = Block { _blID :: Int , _blWallIDs :: IS.IntSet - , _blHPs :: [Int] + , _blHP :: Int , _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists , _blMaterial :: BlockMaterial , _blFootprint :: [Point2] @@ -1399,7 +1399,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutTerminal {_unputTerminal :: Terminal} | PutFlIt Item | PutPPlate PressPlate - | PutBlock BlockMaterial Int [Int] Wall [Point2] + | PutBlock BlockMaterial Int Wall [Point2] | PutCoord Point2 | PutMod Modification | PutTrigger (World -> Bool) diff --git a/src/Dodge/Item/Weapon/Shatter.hs b/src/Dodge/Item/Weapon/Shatter.hs index 05799c7e3..a2d7eacef 100644 --- a/src/Dodge/Item/Weapon/Shatter.hs +++ b/src/Dodge/Item/Weapon/Shatter.hs @@ -59,7 +59,7 @@ shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ collidePointWal ep = sp +.+ 200 *.* unitVectorAtAngle dir shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World -shatterWall w sp ep p wl = w & makeDebris StoneBlock p - & damageWall (Damage SHATTERING 100 sp p ep NoDamageEffect) wl - & damageWall (Damage SHATTERING 100 sp p ep NoDamageEffect) wl - & damageWall (Damage SHATTERING 100 sp p ep NoDamageEffect) wl +shatterWall w sp ep p wl = w + & makeDebris StoneBlock p + & makeDebrisDirected StoneBlock p (argV $ vNormal $ uncurry (-.-) $ _wlLine wl) + & damageWall (Damage SHATTERING 1000 sp p ep NoDamageEffect) wl diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index b847cc534..ec56e7194 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -55,7 +55,7 @@ midWall ps = ps0j (PutShape . colorSH col $ upperPrismPoly 50 ps) singleBlock :: Point2 -> [Placement] singleBlock a = [sPS a 0 - $ PutBlock StoneBlock 5 [20,20] baseBlockPane + $ PutBlock StoneBlock 100 baseBlockPane $ reverse $ square 10 ] diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 933d06d97..659a779af 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -103,8 +103,8 @@ placeSpotID ps pt w = case pt of 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 - PutBlock bm hp hps wl ps' - -> placeBlock (map doShift ps') hp wl hps bm w + PutBlock bm hp wl ps' + -> placeBlock (map doShift ps') hp wl bm w PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w) PutShape sh -> placeShape sh p rot w diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index fbe61f2a3..d7b0fa42b 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -21,20 +21,16 @@ addBlock :: [Point2] -- ^ Block polygon -> Wall -- ^ Base Pane -> Int -- ^ First layer of health - -> [Int] -- ^ Extra layers of health -> BlockMaterial -> World -> World -addBlock (p:ps) wl hp hps bm w - | hp <= 0 && null hps = w - | hp <= 0 = addBlock (p:ps) wl (head hps + hp) (tail hps) bm w - | otherwise = w - & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes - & walls %~ IM.union panes - & blocks %~ IM.insert blid Block - {_blID = blid,_blWallIDs = IS.fromList is, _blHPs = hp:hps, _blShadows=[], _blMaterial = bm - , _blFootprint = p:ps, _blPos = centroid (p:ps), _blDraw = const mempty - , _blDeath = makeBlockDebris} +addBlock (p:ps) wl hp bm w = w + & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes + & walls %~ IM.union panes + & blocks %~ IM.insert blid Block + {_blID = blid,_blWallIDs = IS.fromList is, _blHP = hp, _blShadows=[], _blMaterial = bm + , _blFootprint = p:ps, _blPos = centroid (p:ps), _blDraw = const mempty + , _blDeath = makeBlockDebris} where blid = IM.newKey $ _blocks w lns = zip (p:ps) (ps ++ [p]) @@ -55,14 +51,14 @@ addBlock (p:ps) wl hp hps bm w (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) wlid = _wlID wl ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) -addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon" +addBlock _ _ _ _ _ = error "Trying to add a block with incomplete polygon" -placeBlock :: [Point2] -> Int -> Wall -> [Int] -> BlockMaterial -> World -> (Int,World) -placeBlock poly i wl is bm w +placeBlock :: [Point2] -> Int -> Wall -> BlockMaterial -> World -> (Int,World) +placeBlock poly hp wl bm w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs) where pairs = loopPairs poly - wWithBlock = addBlock poly wl i is bm w + wWithBlock = addBlock poly wl hp bm w {- | Splits a line into many four cornered blocks. -} placeLineBlock @@ -90,7 +86,7 @@ placeLineBlock basePane bm blockWidth depth a b gw = ( 0 blid = IM.newKey $ _blocks gw insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i - , _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm + , _blHP = 1000, _blShadows = shadowsAt i, _blMaterial = bm , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise) , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris} insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs index e4015a0db..d7f8c38e9 100644 --- a/src/Dodge/Room/Pillar.hs +++ b/src/Dodge/Room/Pillar.hs @@ -32,7 +32,7 @@ blockPillar w' h' = ps0jPushPS (aline tl tr) aline = PutLineBlock baseBlockPane StoneBlock 9 9 smallPillar :: PSType -smallPillar = PutBlock StoneBlock 5 [5,5] baseBlockPane $ reverse $ square 5 +smallPillar = PutBlock StoneBlock 500 baseBlockPane $ reverse $ square 5 crossPillar :: Float -> Float -> Placement crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0)) diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index 3b7ab55be..4ea06cf91 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -66,7 +66,7 @@ blockedCorridor :: RandomGen g => State g (Tree Room) blockedCorridor = longBlockedCorridor 0 dirtPoly :: [Point2] -> PSType -dirtPoly = PutBlock DirtBlock 1 [] dirtWall . reverse +dirtPoly = PutBlock DirtBlock 1 dirtWall . reverse -- | A single corridor with a destructible block blocking it. blockedCorridorCloseBlocks :: RandomGen g => State g Room diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 376dc0786..4160bc6b6 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -162,9 +162,9 @@ updateIMl' fim fup w = foldl' (flip fup) w (fim w) updateBlocks :: World -> World updateBlocks w = foldr f w $ _blocks w where - f bl w' = case _blHPs bl of - (x:_:_) | x < 1 -> splinterBlock bl w' - [x] | x < 1 -> destroyBlock bl w' + f bl w' = case _blHP bl of +-- x | x < 1 -> splinterBlock bl w' + x | x < 1 -> destroyBlock bl w' _ -> w' -- | Note the explict use of record syntax. Using lens created a space leak. diff --git a/src/Dodge/Wall/Damage.hs b/src/Dodge/Wall/Damage.hs index 21997bae9..28ae6c73b 100644 --- a/src/Dodge/Wall/Damage.hs +++ b/src/Dodge/Wall/Damage.hs @@ -17,13 +17,13 @@ damageWall dt wl = case _wlStructure wl of damageBlockWith :: Damage -> Block -> Block damageBlockWith dm = case _dmType dm of - PIERCING -> blHPs %~ reduceHead dam - BLUNT -> blHPs %~ reduceHead dam - CUTTING -> blHPs %~ reduceHead dam - EXPLOSIVE -> blHPs %~ reduceHead dam - CONCUSSIVE -> blHPs %~ reduceHead dam - SHATTERING -> blHPs %~ reduceHead dam - CRUSHING -> blHPs %~ reduceHead (dam `div` 4) + PIERCING -> blHP -~ dam + BLUNT -> blHP -~ dam + CUTTING -> blHP -~ dam + EXPLOSIVE -> blHP -~ dam + CONCUSSIVE -> blHP -~ dam + SHATTERING -> blHP -~ dam + CRUSHING -> blHP -~ (dam `div` 4) LASERING -> id SPARKING -> id FLAMING -> id @@ -35,14 +35,7 @@ damageBlockWith dm = case _dmType dm of where dam = _dmAmount dm -reduceHead :: Int -> [Int] -> [Int] -reduceHead y (x:xs) = x-y:xs -reduceHead _ _ = [] - damageBlocksBy :: Int -> Wall -> World -> World damageBlocksBy x wl = case wl ^? wlStructure . wlStBlock of - Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x + Just blid -> blocks . ix blid . blHP -~ x Nothing -> id - where - reduceHeadBy y (z:zs) = z - y : zs - reduceHeadBy _ [] = [] diff --git a/src/Dodge/Wall/DamageEffect.hs b/src/Dodge/Wall/DamageEffect.hs index 770ce1c72..f2ceb1ee2 100644 --- a/src/Dodge/Wall/DamageEffect.hs +++ b/src/Dodge/Wall/DamageEffect.hs @@ -14,7 +14,7 @@ defaultWallDamage dm wl = wallDamageEffect dm wl . case _dmType dm of LASERING -> colSparkRandDir 0.2 8 lSparkCol outTo (reflDirWall sp p wl) PIERCING -> colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo BLUNT -> wlDustAt wl outTo - SHATTERING -> wlDustAt wl outTo + SHATTERING -> muchWlDustAt wl outTo CRUSHING -> id EXPLOSIVE -> id CUTTING -> id diff --git a/src/Dodge/Wall/Dust.hs b/src/Dodge/Wall/Dust.hs index e719eb8c8..2472134b5 100644 --- a/src/Dodge/Wall/Dust.hs +++ b/src/Dodge/Wall/Dust.hs @@ -3,9 +3,20 @@ import Dodge.Data import Dodge.WorldEvent.Cloud import Geometry import Control.Lens +import RandomHelp wlDustAt :: Wall -> Point2 -> World -> World wlDustAt wl = smokeCloudAt dustcol 20 200 1 . addZ 20 where dustcol = _wlColor wl & _4 .~ 1 + +muchWlDustAt :: Wall -> Point2 -> World -> World +muchWlDustAt wl p = flip (foldr f) [10,20..100] + where + f h w = w + & smokeCloudAt dustcol 20 200 1 (addZ h (p +.+ off)) + & randGen .~ g + where + (off,g) = runState (randInCirc 1) (_randGen w) + dustcol = _wlColor wl & _4 .~ 1 diff --git a/src/RandomHelp.hs b/src/RandomHelp.hs index a628e411d..271ca8f9f 100644 --- a/src/RandomHelp.hs +++ b/src/RandomHelp.hs @@ -66,9 +66,15 @@ randProb p = do return (p1 < p) randInCirc :: RandomGen g => Float -> State g Point2 -randInCirc maxRad = do - rad <- state $ randomR (0,maxRad) - ang <- state $ randomR (0,2*pi) +randInCirc = randInArc (2*pi) + +randInArc :: RandomGen g => Float -> Float -> State g Point2 +randInArc = randInArcStrip 0 + +randInArcStrip :: RandomGen g => Float -> Float -> Float -> State g Point2 +randInArcStrip minrad maxangle maxRad = do + rad <- state $ randomR (minrad,maxRad) + ang <- state $ randomR (0,maxangle) return $ rad *.* unitVectorAtAngle ang randOnUnitSphere :: RandomGen g => State g Point3