Tweak block sounds

src/Dodge/Block.hs

@@ -0,0 +1,62 @@
+module Dodge.Block where
+import Dodge.Data
+import Dodge.Data.SoundOrigin
+import Dodge.SoundLogic
+import Dodge.Zone
+import Dodge.WorldEvent.Sound
+import Dodge.Wall.Delete
+import Dodge.Wall.Dust
+import Dodge.RandomHelp
+import Geometry
+import Geometry.ConvexPoly
+
+import Data.Function
+import qualified Data.IntSet as IS
+import qualified Data.IntMap.Strict as IM
+import Control.Lens
+import Control.Monad
+import Control.Monad.State
+
+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
+    wls = IM.restrictKeys (_walls w) (_blWallIDs bl)
+    cen = centroid $ fmap (fst . _wlLine) wls
+
+unshadowBlock :: Int -> World -> World
+unshadowBlock wlid w = case w ^? walls . ix wlid of
+    Just wl -> w
+        & walls . ix wlid . wlDraw .~ True
+        & wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
+      where
+        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
+    Nothing -> w
+
+matSplintSound :: BlockMaterial -> Point2 -> World -> World
+matSplintSound mat = case mat of
+    GlassBlock -> mkSoundSplinterGlass
+    StoneBlock -> mkSoundSplinterBlock
+    DirtBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
+    WoodBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
+    MetalBlock -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]
+matDesSound :: BlockMaterial -> Point2 -> World -> World
+matDesSound mat = case mat of
+    GlassBlock -> mkSoundBreakGlass
+    StoneBlock -> mkSoundSplinterBlock
+    DirtBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
+    WoodBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
+    MetalBlock -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]
+
+destroyBlock :: Block -> World -> World
+destroyBlock bl w = w
+    & deleteWallIDs wlids
+    & blocks %~ IM.delete (_blID bl)
+    & matDesSound (_blMaterial bl) pos
+    & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
+  where
+    wlids = _blWallIDs bl
+    awl = _walls w IM.! IS.findMin wlids
+    pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
+    ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w

src/Dodge/Data.hs

@@ -574,7 +574,9 @@ data Block = Block
     , _blWallIDs :: IS.IntSet
     , _blHPs     :: [Int]
     , _blShadows :: [Int]
+    , _blMaterial :: BlockMaterial
     }
+data BlockMaterial = WoodBlock | DirtBlock | StoneBlock | GlassBlock | MetalBlock
 data Machine = Machine
     { _mcID      :: Int
     , _mcWallIDs :: IS.IntSet

src/Dodge/LevelGen/Data.hs

@@ -20,11 +20,11 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutProp Prop
     | PutFlIt Item
     | PutPressPlate PressPlate
-    | PutBlock [Int] Color [Point2]
+    | PutBlock BlockMaterial [Int] Color [Point2]
     | PutCoordinate Point2
     | PutMod Modification
     | PutTrigger (World -> Bool)
-    | PutLineBlock Wall Float Float Point2 Point2
+    | PutLineBlock Wall BlockMaterial Float Float Point2 Point2
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float
     | PutDoor Color (World -> Bool) [(Point2,Point2)]

src/Dodge/Placement/Instance/Wall.hs

@@ -23,7 +23,7 @@ lowWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 30 ps)
 singleBlock :: Point2 -> [Placement]
 singleBlock a = 
     [sPS a 0 
-        $ PutBlock [5,20,20] (greyN 0.5)
+        $ PutBlock StoneBlock [5,20,20] (greyN 0.5)
         $ reverse 
         $ rectNSWE 10 (-10) (-10) 10
     ]
@@ -32,14 +32,14 @@ Places a line of blocks between two points.
 Width 9, also extends out from each point by 9.
  -}
 blockLine :: Point2 -> Point2 -> Placement
-blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b
+blockLine a b = sps0 $ PutLineBlock baseBlockPane StoneBlock 9 9 a b
 
 {-
 Places an breakable window between two points.
 Width 8, also extends out from each point by 8.
  -}
 windowLine :: Point2 -> Point2 -> Placement
-windowLine a b = sps0 $ PutLineBlock baseWindowPane 8 8 a b
+windowLine a b = sps0 $ PutLineBlock baseWindowPane GlassBlock 8 8 a b
 {-
 Places an unbreakable window between two points.
 Width 7, also extends out from each point by 7.
@@ -70,7 +70,7 @@ wallLine a b = sps0 $ PutWall ps defaultWall
     up   = vNormal left
 
 windowLineType :: Point2 -> Point2 -> PSType
-windowLineType = PutLineBlock baseWindowPane 8 8
+windowLineType = PutLineBlock baseWindowPane GlassBlock 8 8
 
 baseBlockPane :: Wall
 baseBlockPane = defaultWall

src/Dodge/Placement/PlaceSpot.hs

@@ -102,9 +102,9 @@ placeSpotID ps pt w = case pt of
     PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
     PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w
     PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
-    PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
+    PutBlock bm (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps bm w
     PutBlock{} -> error "messed up block placement somehow"
-    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
+    PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
     PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
     PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
     PutNothing -> (0,w)

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -23,15 +23,17 @@ addBlock
     -> Color 
     -> Opacity         -- ^ Is the block see through?
     -> [Int]        -- ^ Extra layers of health
+    -> BlockMaterial
     -> World 
     -> World
-addBlock (p:ps) hp col opacity hps w 
+addBlock (p:ps) hp col opacity hps bm w 
     | hp <= 0 && null hps = w
-    | hp <= 0 = addBlock (p:ps) (head hps + hp) col opacity (tail hps) w
+    | hp <= 0 = addBlock (p:ps) (head hps + hp) col opacity (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=[]})
+        & blocks %~ IM.insert blid Block 
+            {_blID = blid,_blWallIDs = IS.fromList is, _blHPs = hp:hps, _blShadows=[], _blMaterial = bm}
   where 
     blid = IM.newKey $ _blocks w
     lns = zip (p:ps) (ps ++ [p])
@@ -55,24 +57,26 @@ addBlock (p:ps) hp col opacity hps 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 -> Color -> Opacity -> [Int] -> World -> (Int,World)
+placeBlock :: [Point2] -> Int -> Color -> Opacity -> [Int] -> BlockMaterial -> World -> (Int,World)
-placeBlock poly i c opac is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+placeBlock poly i c opac is bm w 
+    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
   where 
     pairs = loopPairs poly
-    wWithBlock = addBlock poly i c opac is w
+    wWithBlock = addBlock poly i c opac is bm w
 
 {- | Splits a line into many four cornered blocks. -}
 placeLineBlock 
     :: Wall     -- ^ Base pane
+    -> BlockMaterial
     -> Float    -- ^ Block width
     -> Float    -- ^ Block depth
     -> Point2   -- ^ Start point (symmetric)
     -> Point2   -- ^ End point (symmetric)
     -> World 
     -> (Int, World)
-placeLineBlock basePane blockWidth depth a b w = (,) 0 
+placeLineBlock basePane bm blockWidth depth a b w = (,) 0 
     $ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
   where 
     psOnLine = divideLineOddNumPoints blockWidth a b
@@ -86,7 +90,8 @@ placeLineBlock basePane blockWidth depth a b w = (,) 0
     wlid = IM.newKey $ _walls w
     blid = IM.newKey $ _blocks w
     insertBlock i = over blocks $ IM.insert (i+blid) Block 
-        {_blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
+        { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
+        , _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm}
     insertBlocks = flip (foldr insertBlock) is
     ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
     visibilityAt i 

src/Dodge/Room/RoadBlock.hs

@@ -1,6 +1,7 @@
 {- Connecting rooms designed with a pass-through technique in mind.  -}
 module Dodge.Room.RoadBlock
     where
+import Dodge.Data
 import Geometry
 import Dodge.Default.Room
 import Dodge.LevelGen.Data
@@ -56,8 +57,7 @@ longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
 longBlockedCorridor = do
     r <- state $ randomR (0,pi)
     n <- state $ randomR (0,3)
-    let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) (75/256) 0 (250/256))
+    let plmnts = [sPS (V2 20 40) r $ dirtPoly $ square 10
-                                          $ reverse $ rectNSWE 10 (-10) (-10) 10
                  ,sPS (V2 20 15) 0 putLamp
                  ]
     sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor) 
@@ -68,24 +68,24 @@ blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
 blockedCorridor = do
     r <- state $ randomR (0,pi)
     let plmnts = 
-            [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256)  0 ( 250/256)) 
+            [sPS (V2 20 40) r $ dirtPoly $ square 10
-                                          $ reverse $ rectNSWE 10 (-10) (-10) 10
             ,spanLightI (V2 0 15) (V2 40 15)
             ]
     sequence $ treeFromPost [] $ return $ Right $ set rmPmnts plmnts corridor
 
+dirtPoly :: [Point2] -> PSType
+dirtPoly = PutBlock DirtBlock [1] (V4 (150/256) ( 75/256)  0 ( 250/256)) . reverse
+
 -- | A single corridor with a destructible block blocking it.
 blockedCorridor' :: RandomGen g => State g Room
 blockedCorridor' = do
     r <- state $ randomR (0,pi)
-    theblocks <- takeOne [ [sPS (V2 20 40) r $ PutBlock [1] thecol $ reverse $ square 10]
+    theblocks <- takeOne [ [sPS (V2 20 40) r $ dirtPoly $ reverse $ square 10]
-        ,   [ sPS (V2 5 40) r $ PutBlock [1] thecol $ reverse $ square 10
+        ,   [ sPS (V2 5 40) r $ dirtPoly $ square 10
-            , sPS (V2 35 40) (r+0.5) $ PutBlock [1] thecol $ reverse $ square 10
+            , sPS (V2 35 40) (r+0.5) $ dirtPoly $ square 10
             ]
         ]
     return $ corridor & rmPmnts .~ theblocks
-  where
-    thecol = V4 (150/256) ( 75/256)  0 ( 250/256)
 
 lasTunnel :: Room
 lasTunnel = defaultRoom

src/Dodge/Room/Room.hs

@@ -1,4 +1,5 @@
 module Dodge.Room.Room where
+import Dodge.Data
 import Dodge.Default.Room
 import Dodge.Item.Weapon.BulletGuns
 import Dodge.Item.Weapon.Launcher
@@ -146,7 +147,7 @@ miniRoom3 = do
         w <- state $ randomR (300,400)
         h <- state $ randomR (300,400)
         let cp = V2 0 (h/2+40)
-        let b = PutBlock [5,20,20] (greyN 0.5) $ map toV2 [(-10,-60) 
+        let b = PutBlock StoneBlock [5,20,20] (greyN 0.5) $ map toV2 [(-10,-60) 
                                                ,( 10,-60) 
                                                ,( 10,-80) 
                                                ,(-10,-80) 

src/Dodge/Room/RunPast.hs

@@ -75,5 +75,4 @@ runPastRoom = do
         critrooms :: [Tree (Either Room Room)]
         critrooms = treeFromPost [Left switchdoor] (Left critroom) : 
             replicate (n-2) (treeFromPost [Left switchdoor] (Left linkcor))
-    return $ treeFromTrunk [Left door] 
+    return $ Node (Left cenroom) (controom : critrooms ++ [return $ Left aswitchroom])
-        $ Node (Left cenroom) (controom : critrooms ++ [return $ Left aswitchroom])

src/Dodge/Room/Start.hs

@@ -29,11 +29,11 @@ import System.Random
 
 startRoom :: RandomGen g => State g (Tree (Either Room Room))
 startRoom = join $ takeOne 
-    [ -- rezBoxesWp
+    [ rezBoxesWp
---    , rezBoxesThenWeaponRoom
+    , rezBoxesThenWeaponRoom
---    , rezBoxThenWeaponRoom
+    , rezBoxThenWeaponRoom
---    , rezBoxesWpCrit
+    , rezBoxesWpCrit
-    runPastStart
+    , runPastStart
     ]
 
 runPastStart :: RandomGen g => State g (Tree (Either Room Room))

src/Dodge/Update.hs

@@ -2,10 +2,9 @@
 Module      : Dodge.Update
 Description : Simulation update
 -}
-module Dodge.Update 
+module Dodge.Update (update) where
-    ( update
-    ) where
 import Dodge.Data
+import Dodge.Block
 import Dodge.Data.SoundOrigin
 import Dodge.SoundLogic
 import Dodge.Menu
@@ -14,15 +13,9 @@ import Dodge.Base
 import Dodge.Zone
 import Dodge.WallCreatureCollisions
 import Dodge.Update.Camera
-import Dodge.SoundLogic
 import Dodge.Inventory
-import Dodge.WorldEvent.Sound
-import Dodge.Wall.Delete
-import Dodge.Wall.Dust
-import Dodge.RandomHelp
 import Sound.Data
 import Geometry
-import Geometry.ConvexPoly
 import Geometry.Vector3D
 
 import SDL (MouseButton (..))
@@ -30,12 +23,9 @@ import Data.List
 import Data.Maybe
 import Data.Function
 import qualified Data.Set as S
-import qualified Data.IntSet as IS
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map.Strict as M
 import Control.Lens
-import Control.Monad
-import Control.Monad.State
 import Data.Monoid
 import System.Random
 
@@ -93,42 +83,18 @@ functionalUpdate w = case _menuLayers w of
         (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
 
 updateCreatureSoundPositions :: World -> World
-updateCreatureSoundPositions w = M.foldrWithKey insertSound w soundsToUpdate
+updateCreatureSoundPositions w = M.foldrWithKey insertSound w 
+    . M.mapMaybeWithKey updateSound 
+    $ _playingSounds w
   where
-    insertSound k s w' = w & toPlaySounds %~ M.insertWith (\_ -> id) k (updateSound k s)
+    insertSound k s = toPlaySounds %~ M.insertWith (const id) k s
     updateSound (CrMouth cid) s = case w ^? creatures . ix cid . crPos of
-        Just p  -> s {_soundPos = p, _soundAngDist = Just (soundAngle p w,0)}
+        Just p  -> Just s {_soundPos = p, _soundAngDist = Just (soundAngle p w,0)}
-        Nothing -> s {_soundTime = Just 0}
+        Nothing -> Just s {_soundTime = Just 0}
-    soundsToUpdate = M.filterWithKey (\k _ -> isCrMouth k) $  _playingSounds w
+    updateSound _ _ = Nothing
-
-isCrMouth :: SoundOrigin -> Bool
-isCrMouth CrMouth{} = True
-isCrMouth _ = False
 
 updateModifications :: World -> World
-updateModifications w = foldr f w (_modifications w)
+updateModifications w = foldr (dbArg _mdUpdate) w (_modifications w)
-  where
-    f md = _mdUpdate md md
-
-splinterBlock :: Block -> World -> World
-splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
-    & blocks . ix (_blID bl) . blHPs %~ tail
-    & theSoundEffect cen
-  where
-    wls = IM.restrictKeys (_walls w) (_blWallIDs bl)
-    cen = centroid $ fmap (fst . _wlLine) wls
-    theSoundEffect 
-        | _wlOpacity (snd $ IM.findMin wls) == SeeThrough = mkSoundSplinterGlass
-        | otherwise                           = mkSoundSplinterBlock
-
-unshadowBlock :: Int -> World -> World
-unshadowBlock wlid w = case w ^? walls . ix wlid of
-    Just wl -> w
-        & walls . ix wlid . wlDraw .~ True
-        & wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
-      where
-        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
-    Nothing -> w
 
 updateBlocks :: World -> World
 updateBlocks w = foldr f w $ _blocks w
@@ -138,17 +104,6 @@ updateBlocks w = foldr f w $ _blocks w
         [x]     | x < 1 -> destroyBlock bl w'
         _ -> w'
 
-destroyBlock :: Block -> World -> World
-destroyBlock bl w = w
-    & deleteWallIDs wlids
-    & blocks %~ IM.delete (_blID bl)
-    & mkSoundBreakGlass pos
-    & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
-  where
-    wlids = _blWallIDs bl
-    awl = _walls w IM.! IS.findMin wlids
-    pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
-    ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
 -- | Note the explict use of record syntax. Using lens created a space leak.
 resetWorldEvents :: World -> World
 resetWorldEvents w = w {_worldEvents = id}

src/Dodge/WorldEvent/Sound.hs

@@ -2,6 +2,7 @@ module Dodge.WorldEvent.Sound
     ( mkSoundBreakGlass
     , mkSoundSplinterGlass
     , mkSoundSplinterBlock
+    , originIDsAt 
     )
   where
 import Dodge.Data