Improve debris

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

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

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)

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
+shatterWall w sp ep p wl = w 
-    & damageWall (Damage SHATTERING 100 sp p ep NoDamageEffect) wl
+    & makeDebris StoneBlock p
-    & damageWall (Damage SHATTERING 100 sp p ep NoDamageEffect) wl
+    & makeDebrisDirected StoneBlock p (argV $ vNormal $ uncurry (-.-) $ _wlLine wl)
-    & damageWall (Damage SHATTERING 100 sp p ep NoDamageEffect) wl
+    & damageWall (Damage SHATTERING 1000 sp p ep NoDamageEffect) wl

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
     ]

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' 
+    PutBlock    bm  hp wl  ps' 
-                            -> placeBlock (map doShift ps') hp wl hps bm w
+                            -> 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

@@ -21,18 +21,14 @@ 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 
+addBlock (p:ps) wl hp bm w = 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
+        {_blID = blid,_blWallIDs = IS.fromList is, _blHP = hp, _blShadows=[], _blMaterial = bm
             , _blFootprint = p:ps, _blPos = centroid (p:ps), _blDraw = const mempty
             , _blDeath = makeBlockDebris}
   where 
@@ -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 :: [Point2] -> Int -> Wall -> BlockMaterial -> World -> (Int,World)
-placeBlock poly i wl is bm w 
+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

@@ -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

@@ -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

@@ -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
+    f bl w' = case _blHP bl of
-        (x:_:_) | x < 1 -> splinterBlock bl w'
+--        x | x < 1 -> splinterBlock bl w'
-        [x]     | x < 1 -> destroyBlock 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

@@ -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
+    PIERCING    -> blHP -~ dam
-    BLUNT       -> blHPs %~ reduceHead dam
+    BLUNT       -> blHP -~ dam
-    CUTTING     -> blHPs %~ reduceHead dam
+    CUTTING     -> blHP -~ dam
-    EXPLOSIVE   -> blHPs %~ reduceHead dam
+    EXPLOSIVE   -> blHP -~ dam
-    CONCUSSIVE  -> blHPs %~ reduceHead dam
+    CONCUSSIVE  -> blHP -~ dam
-    SHATTERING  -> blHPs %~ reduceHead dam
+    SHATTERING  -> blHP -~ dam
-    CRUSHING    -> blHPs %~ reduceHead (dam `div` 4)
+    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

@@ -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

@@ -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
+    

src/RandomHelp.hs

@@ -66,9 +66,15 @@ randProb p = do
     return (p1 < p)
 
 randInCirc :: RandomGen g => Float -> State g Point2
-randInCirc maxRad = do 
+randInCirc = randInArc (2*pi)
-    rad <- state $ randomR (0,maxRad)
+
-    ang <- state $ randomR (0,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