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

Improve debris

Browse Source
This commit is contained in:
justin
2022-06-16 12:24:09 +01:00
parent fa762c7687
commit aa29e5ddf2
14 changed files with 75 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block.hs
+1 -1
View File
@@ -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
src/Dodge/Block/Debris.hs
+19
View File
@@ -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
src/Dodge/Data.hs
+2 -2
View File
@@ -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)
src/Dodge/Item/Weapon/Shatter.hs
+4 -4
View File
@@ -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
src/Dodge/Placement/Instance/Wall.hs
+1 -1
View File
@@ -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
]
src/Dodge/Placement/PlaceSpot.hs
+2 -2
View File
@@ -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
src/Dodge/Placement/PlaceSpot/Block.hs
+12 -16
View File
@@ -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
src/Dodge/Room/Pillar.hs
+1 -1
View File
@@ -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))
src/Dodge/Room/RoadBlock.hs
+1 -1
View File
@@ -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
src/Dodge/Update.hs
+3 -3
View File
@@ -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.
src/Dodge/Wall/Damage.hs
+8 -15
View File
@@ -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 _ [] = []
src/Dodge/Wall/DamageEffect.hs
+1 -1
View File
@@ -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
src/Dodge/Wall/Dust.hs
+11
View File
@@ -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