Improve debris
This commit is contained in:
+1
-1
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+2
-2
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
]
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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))
|
||||
|
||||
@@ -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
|
||||
|
||||
+3
-3
@@ -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.
|
||||
|
||||
@@ -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 _ [] = []
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
+9
-3
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user