Tweak block sounds

2021-11-18 03:50:54 +00:00
parent 94552ff658
commit 147d6098ab
12 changed files with 114 additions and 89 deletions
@@ -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
@@ -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
@@ -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)]
@@ -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
@@ -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)
@@ -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 poly i c opac is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+placeBlock :: [Point2] -> Int -> Color -> Opacity -> [Int] -> BlockMaterial -> World -> (Int,World)
+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 
@@ -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))
-                                          $ reverse $ rectNSWE 10 (-10) (-10) 10
+    let plmnts = [sPS (V2 20 40) r $ dirtPoly $ square 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)) 
-                                          $ reverse $ rectNSWE 10 (-10) (-10) 10
+            [sPS (V2 20 40) r $ dirtPoly $ square 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]
-        ,   [ sPS (V2 5 40) r $ PutBlock [1] thecol $ reverse $ square 10
-            , sPS (V2 35 40) (r+0.5) $ PutBlock [1] thecol $ reverse $ square 10
+    theblocks <- takeOne [ [sPS (V2 20 40) r $ dirtPoly $ reverse $ square 10]
+        ,   [ sPS (V2 5 40) r $ dirtPoly $ 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
@@ -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) 
@@ -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] 
-        $ Node (Left cenroom) (controom : critrooms ++ [return $ Left aswitchroom])
+    return $ Node (Left cenroom) (controom : critrooms ++ [return $ Left aswitchroom])
@@ -29,11 +29,11 @@ import System.Random

 startRoom :: RandomGen g => State g (Tree (Either Room Room))
 startRoom = join $ takeOne 
-    [ -- rezBoxesWp
--    , rezBoxesThenWeaponRoom
--    , rezBoxThenWeaponRoom
--    , rezBoxesWpCrit
-    runPastStart
+    [ rezBoxesWp
+    , rezBoxesThenWeaponRoom
+    , rezBoxThenWeaponRoom
+    , rezBoxesWpCrit
+    , runPastStart
    ]

 runPastStart :: RandomGen g => State g (Tree (Either Room Room))
@@ -2,10 +2,9 @@
 Module      : Dodge.Update
 Description : Simulation update
 -}
-module Dodge.Update 
-    ( update
-    ) where
+module Dodge.Update (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)}
-        Nothing -> s {_soundTime = Just 0}
-    soundsToUpdate = M.filterWithKey (\k _ -> isCrMouth k) $  _playingSounds w
-
-isCrMouth :: SoundOrigin -> Bool
-isCrMouth CrMouth{} = True
-isCrMouth _ = False
+        Just p  -> Just s {_soundPos = p, _soundAngDist = Just (soundAngle p w,0)}
+        Nothing -> Just s {_soundTime = Just 0}
+    updateSound _ _ = Nothing

 updateModifications :: World -> World
-updateModifications w = foldr f 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
+updateModifications w = foldr (dbArg _mdUpdate) w (_modifications 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}
@@ -2,6 +2,7 @@ module Dodge.WorldEvent.Sound
    ( mkSoundBreakGlass
    , mkSoundSplinterGlass
    , mkSoundSplinterBlock
+    , originIDsAt 
    )
  where
 import Dodge.Data