Various improvements, metal debris

src/Dodge/Block/Debris.hs

@@ -16,48 +16,74 @@ import qualified Quaternion as Q
 
 import qualified Data.IntSet as IS
 import Data.Maybe
-makeBlockDebris :: Block -> World -> World
-makeBlockDebris bl w = w & makeDebris mt (_blPos bl)
+
+makeDoorDebris :: Door -> World -> World
+makeDoorDebris dr w = w & makeDebris mt col p
   where
-    mt = fromMaybe Stone $ do
+    p = uncurry midPoint (_drPos dr)
+    (mt,col) = fromMaybe (Stone,greyN 0.5) $ do
+        wlids <- w ^? doors . ix (_drID dr) . drWallIDs
+        (wlid,_) <- IS.minView wlids
+        wl <- w ^? walls . ix wlid
+        return (_wlMaterial wl,_wlColor wl)
+
+makeBlockDebris :: Block -> World -> World
+makeBlockDebris bl w = w & makeDebris mt col (_blPos bl)
+  where
+    (mt,col) = fromMaybe (Stone,greyN 0.5) $ do
         wlids <- w ^? blocks . ix (_blID bl) . blWallIDs
         (wlid,_) <- IS.minView wlids
-        w ^? walls . ix wlid . wlMaterial
+        wl <- w ^? walls . ix wlid
+        return (_wlMaterial wl,_wlColor wl)
 
-makeDebris :: Material -> Point2 -> World -> World
+makeDebris :: Material -> Color -> Point2 -> World -> World
 makeDebris = makeDebrisDirected 1 2 (2*pi) 0
-makeDebrisDirected :: Float -> Float 
-    -> Float -> Float -> Material -> Point2 -> World -> World
-makeDebrisDirected mindist maxdist arcrad dir bm p w = w
+makeDebrisDirected :: Float 
+    -> Float 
+    -> Float 
+    -> Float 
+    -> Material 
+    -> Color
+    -> Point2 
+    -> World -> World
+makeDebrisDirected mindist maxdist arcrad dir bm col p w = w
         & flip (foldr (plNew props pjID)) thedebris
         & randGen .~ newg
         & originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
   where
-    someDebris = case bm of
-        Stone -> stoneDebris
-        Glass -> glassDebris
-        Crystal -> crystalDebris
-        Dirt   -> dirtDebris
-        Wood   -> stoneDebris
-        Metal  -> stoneDebris
-    (thedebris,newg) = runState (mapM f [35,55..95]) $ _randGen w
+    (thedebris,newg) = mapM f [35,55..95] & runState $ _randGen w
     f h = do
         v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad
         q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
-        return $ someDebris
+        spinspeed <- randomR (-0.2,-0.1) & state
+        basedebris <- baseDebris bm
+        return $ basedebris
+            & pjColor .~ col
             & prPos .~ p
             & pjVel .~ v
-            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
             & pjQuat .~ q
             & pjVelZ .~ 0
             & pjPosZ .~ h
 
+baseDebris :: Material -> State StdGen Prop
+baseDebris mt = case mt of
+    Stone   -> return stoneDebris
+    Glass   -> return glassDebris
+    Crystal -> return crystalDebris
+    Dirt    -> return dirtDebris
+    Wood    -> return stoneDebris
+    Metal   -> do
+        sh <- jaggedShape
+        return $ metalDebris
+            & prDraw .~ (`drawMovingShape` sh)
+
 stoneDebris :: Prop
 stoneDebris = PropZ
     {_prPos = 0
     ,_pjStartPos = 0
     ,_pjVel = 0
-    ,_prDraw = \pr -> drawMovingShape pr (debrisShape 4 pr)
+    ,_prDraw = \pr -> drawMovingShape pr (cubeShape 4)
     ,_pjID = 0
     ,_pjUpdate = fallSmallBounceDamage
     ,_pjPosZ = 10
@@ -74,21 +100,31 @@ dirtDebris = stoneDebris
 dirtColor :: Color
 dirtColor = V4 (150/256) ( 75/256)  0 ( 250/256)
 
+metalDebris :: Prop
+metalDebris = stoneDebris
+    & prDraw    .~ (\pr -> drawMovingShape pr (shardShape 4))
+    & pjUpdate  .~ fallSmallBounce
+
 glassDebris :: Prop
 glassDebris = stoneDebris
-    & prDraw    .~ (\pr -> drawMovingShape pr (shardShape 4 pr))
+    & prDraw    .~ (\pr -> drawMovingShape pr (shardShape 4))
     & 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 :: Float -> Shape
+shardShape size = translateSHz (-size) $ upperPrismPoly size
     [V2 size 0
     ,V2 (-size) 1
     ,V2 (-size) (-1)
     ]
 
-debrisShape :: Float -> Prop -> Shape
-debrisShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly (2*size) $ square size
+jaggedShape :: State StdGen Shape
+jaggedShape = do
+    s <- randomR (4,10) & state
+    return $ shardShape s
+
+cubeShape :: Float -> Shape
+cubeShape size = translateSHz (-size) $ upperPrismPoly (2*size) $ square size