Commit mid block refactor

src/Dodge/Block.hs

@@ -11,14 +11,19 @@ import Geometry
 --import Geometry.ConvexPoly
 
 import Data.Function
+import Data.Maybe
 import qualified Data.IntSet as IS
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
 splinterBlock :: Block -> World -> World
 splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
-    & matSplintSound (_blMaterial bl) cen
+    & matSplintSound bm cen
   where
+    bm = fromMaybe Stone $ do
+        wlids <- w ^? blocks . ix (_blID bl) . blWallIDs
+        (wlid,_) <- IS.minView wlids
+        w ^? walls . ix wlid . wlMaterial
     cen = centroid $ fst . _wlLine <$> IM.restrictKeys (_walls w) (_blWallIDs bl)
 
 unshadowBlock :: Int -> World -> World
@@ -30,21 +35,21 @@ unshadowBlock wlid w = case w ^? walls . ix wlid of
         (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
     Nothing -> w
 
-matSplintSound :: BlockMaterial -> Point2 -> World -> World
+matSplintSound :: Material -> Point2 -> World -> World
 matSplintSound mat = case mat of
-    GlassBlock -> mkSoundSplinterGlass
-    StoneBlock -> mkSoundSplinterBlock
-    CrystalBlock -> mkSoundSplinterBlock
-    DirtBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
-    WoodBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
-    MetalBlock -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]
+    Glass -> mkSoundSplinterGlass
+    Stone -> mkSoundSplinterBlock
+    Crystal -> mkSoundSplinterBlock
+    Dirt  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
+    Wood  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
+    Metal -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]
 
 destroyBlock :: Block -> World -> World
 destroyBlock bl w = w
     & flip (foldr unshadowBlock) (_blShadows bl)
     & deleteWallIDs wlids
     & blocks %~ IM.delete (_blID bl)
-    & matDesSound (_blMaterial bl) pos
+--    & matDesSound (_blMaterial bl) pos
     & _blDeath bl bl
     & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
   where