diff --git a/data/sound/combine.DNDNDNDN.500.wav b/data/sound/combine.DNDNDNDN.500.wav new file mode 100644 index 000000000..4c491d239 Binary files /dev/null and b/data/sound/combine.DNDNDNDN.500.wav differ diff --git a/data/sound/metal1.TRNKL.1000.wav b/data/sound/metal1.TRNKL.1000.wav new file mode 100644 index 000000000..05fb8c884 Binary files /dev/null and b/data/sound/metal1.TRNKL.1000.wav differ diff --git a/data/sound/metal3.DHDHL.1000.wav b/data/sound/metal3.DHDHL.1000.wav new file mode 100644 index 000000000..272af4a93 Binary files /dev/null and b/data/sound/metal3.DHDHL.1000.wav differ diff --git a/data/sound/metal5.TTRKL.1000.wav b/data/sound/metal5.TTRKL.1000.wav new file mode 100644 index 000000000..926dd38e9 Binary files /dev/null and b/data/sound/metal5.TTRKL.1000.wav differ diff --git a/data/sound/metal6.TRNKL.1000.wav b/data/sound/metal6.TRNKL.1000.wav new file mode 100644 index 000000000..f7772d58d Binary files /dev/null and b/data/sound/metal6.TRNKL.1000.wav differ diff --git a/data/sound/metal7.TRWNG.1000.wav b/data/sound/metal7.TRWNG.1000.wav new file mode 100644 index 000000000..4837bc76d Binary files /dev/null and b/data/sound/metal7.TRWNG.1000.wav differ diff --git a/data/sound/stone2.CRMPL.1000.wav b/data/sound/stone2.CRMPL.1000.wav new file mode 100644 index 000000000..58df44aa6 Binary files /dev/null and b/data/sound/stone2.CRMPL.1000.wav differ diff --git a/data/sound/stone4.CRMBL.1000.wav b/data/sound/stone4.CRMBL.1000.wav new file mode 100644 index 000000000..978121c78 Binary files /dev/null and b/data/sound/stone4.CRMBL.1000.wav differ diff --git a/data/sound/stone5.CRUMBL.1000.wav b/data/sound/stone5.CRUMBL.1000.wav new file mode 100644 index 000000000..8bf59a4ea Binary files /dev/null and b/data/sound/stone5.CRUMBL.1000.wav differ diff --git a/src/Dodge/Material.hs b/src/Dodge/Material.hs index 89171b768..307c5ad36 100644 --- a/src/Dodge/Material.hs +++ b/src/Dodge/Material.hs @@ -7,16 +7,16 @@ destroyMatS :: Material -> [SoundID] destroyMatS mat = case mat of Glass -> [glassShat1S,glassShat2S,glassShat3S,glassShat4S] Crystal -> [glassShat1S,glassShat2S,glassShat3S,glassShat4S] - Stone -> [stone1S,stone3S] + Stone -> [stone1S,stone2S,stone3S,stone4S,stone5S] Dirt -> [stone1S,stone3S] Wood -> [stone1S,stone3S] - Metal -> [metal2S,metal4S] + Metal -> [metal1S,metal2S,metal3S,metal4S,metal5S,metal6S,metal7S] weakenMatS :: Material -> [SoundID] weakenMatS mat = case mat of Glass -> [smallGlass1S,smallGlass2S,smallGlass3S,smallGlass4S] Crystal -> [smallGlass1S,smallGlass2S,smallGlass3S,smallGlass4S] - Stone -> [stone1S,stone3S] + Stone -> [stone1S,stone2S,stone3S,stone4S,stone5S] Dirt -> [stone1S,stone3S] Wood -> [stone1S,stone3S] - Metal -> [metal2S,metal4S] + Metal -> [metal1S,metal2S,metal3S,metal4S,metal5S,metal6S,metal7S] diff --git a/src/Dodge/Prop/Gib.hs b/src/Dodge/Prop/Gib.hs index 6a7433e91..771dd42b6 100644 --- a/src/Dodge/Prop/Gib.hs +++ b/src/Dodge/Prop/Gib.hs @@ -14,6 +14,7 @@ import RandomHelp import qualified Quaternion as Q import Data.List (zip4) +import Data.Foldable aGib :: Prop aGib = PropZ @@ -56,7 +57,7 @@ addCrGibs cr w = case damageDirection $ _csDamage $ _crState cr of cpos = _crPos cr addGibsAt :: Float -> Float -> Color -> Point2 -> World -> World -addGibsAt minh maxh col p w = foldr addg w (zip4 vels zspeeds quats hs) +addGibsAt minh maxh col p w = foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs) & randGen .~ newg where (speeds,newg) = replicateM 4 (state (randomR (1,4))) & runState $ _randGen w @@ -66,18 +67,10 @@ addGibsAt minh maxh col p w = foldr addg w (zip4 vels zspeeds quats hs) zspeeds = replicateM 4 (state (randomR (-8,8))) & evalState $ _randGen w quats :: [Q.Quaternion Float] quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w - addg (v,zs,q,h) = plNew props pjID (aGib & prPos .~ p +.+ (5 *.* normalizeV v) - & pjColor .~ col - & pjVel .~ v - & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) - & pjQuat .~ q - & pjVelZ .~ zs - & pjPosZ .~ h - ) -- this is ugly because it is mostly copy-paste from addGibsAt addGibsAtDir :: Float -> Float -> Float -> Color -> Point2 -> World -> World -addGibsAtDir dir minh maxh col p w = foldr addg w (zip4 vels zspeeds quats hs) +addGibsAtDir dir minh maxh col p w = foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs) & randGen .~ newg where (speeds,newg) = replicateM 4 (state (randomR (1,4))) & runState $ _randGen w @@ -87,15 +80,18 @@ addGibsAtDir dir minh maxh col p w = foldr addg w (zip4 vels zspeeds quats hs) zspeeds = replicateM 4 (state (randomR (-8,8))) & evalState $ _randGen w quats :: [Q.Quaternion Float] quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w - addg (v,zs,q,h) = plNew props pjID (aGib & prPos .~ p +.+ (5 *.* normalizeV v) - & pjColor .~ col - & pjVel .~ v - & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) - & pjQuat .~ q - & pjVelZ .~ zs - & pjPosZ .~ h - ) +addGib4 :: Point2 -> Color -> (Point2, Float, Q.Quaternion Float, Float) + -> World -> World +addGib4 p col (v,zs,q,h) = plNew props pjID (aGib & prPos .~ p +.+ (5 *.* normalizeV v) + & pjColor .~ col + & pjVel .~ v + & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) + & pjQuat .~ q + & pjVelZ .~ zs + & pjPosZ .~ h + ) + addGibAt :: Float -> Color -> Point2 -> World -> World addGibAt h col p w = w & plNew props pjID gib diff --git a/src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs b/src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs index ef2db3196..7190df89b 100644 --- a/src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs +++ b/src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs @@ -1,4 +1,4 @@ --- generated at 2022-06-22 13:32:00.899109782 UTC +-- generated at 2022-06-23 20:14:52.284399733 UTC module Dodge.SoundLogic.ExternallyGeneratedSounds where import Sound.Data soundToVol :: SoundID -> Float @@ -14,73 +14,82 @@ soundToVol v = case _getSoundID v of 8 -> 500 9 -> 500 10 -> 300 - 11 -> 40 - 12 -> 2000 - 13 -> 50 - 14 -> 50 - 15 -> 2000 - 16 -> 200 - 17 -> 40 - 18 -> 300 - 19 -> 500 - 20 -> 2000 + 11 -> 500 + 12 -> 1000 + 13 -> 40 + 14 -> 2000 + 15 -> 50 + 16 -> 50 + 17 -> 2000 + 18 -> 200 + 19 -> 40 + 20 -> 300 21 -> 500 - 22 -> 100 - 23 -> 1000 + 22 -> 2000 + 23 -> 500 24 -> 100 25 -> 1000 - 26 -> 40 - 27 -> 2000 - 28 -> 50 - 29 -> 2000 - 30 -> 50 - 31 -> 1000 - 32 -> 8000 - 33 -> 2000 - 34 -> 2000 - 35 -> 1000 + 26 -> 100 + 27 -> 1000 + 28 -> 1000 + 29 -> 40 + 30 -> 2000 + 31 -> 50 + 32 -> 2000 + 33 -> 50 + 34 -> 1000 + 35 -> 8000 36 -> 2000 - 37 -> 100 - 38 -> 40 - 39 -> 40 - 40 -> 2000 - 41 -> 100 - 42 -> 500 - 43 -> 40 - 44 -> 300 - 45 -> 300 - 46 -> 2000 - 47 -> 1000 - 48 -> 1000 - 49 -> 1000 - 50 -> 40 - 51 -> 50 - 52 -> 500 - 53 -> 500 + 37 -> 2000 + 38 -> 1000 + 39 -> 2000 + 40 -> 100 + 41 -> 40 + 42 -> 40 + 43 -> 2000 + 44 -> 100 + 45 -> 500 + 46 -> 40 + 47 -> 300 + 48 -> 300 + 49 -> 2000 + 50 -> 1000 + 51 -> 1000 + 52 -> 1000 + 53 -> 1000 54 -> 1000 - 55 -> 20 - 56 -> 500 - 57 -> 300 + 55 -> 40 + 56 -> 50 + 57 -> 1000 58 -> 500 - 59 -> 1000 - 60 -> 500 - 61 -> 2000 - 62 -> 2000 - 63 -> 500 - 64 -> 2000 - 65 -> 100 - 66 -> 300 - 67 -> 1000 - 68 -> 100 + 59 -> 500 + 60 -> 1000 + 61 -> 20 + 62 -> 500 + 63 -> 300 + 64 -> 500 + 65 -> 1000 + 66 -> 1000 + 67 -> 500 + 68 -> 1000 69 -> 2000 - 70 -> 1000 - 71 -> 200 - 72 -> 500 + 70 -> 2000 + 71 -> 500 + 72 -> 2000 73 -> 100 - 74 -> 2000 - 75 -> 2000 - 76 -> 2000 - 77 -> 100 + 74 -> 300 + 75 -> 1000 + 76 -> 100 + 77 -> 1000 + 78 -> 2000 + 79 -> 1000 + 80 -> 200 + 81 -> 500 + 82 -> 100 + 83 -> 2000 + 84 -> 2000 + 85 -> 2000 + 86 -> 100 _ -> 50 soundToOnomato :: SoundID -> String soundToOnomato v = case _getSoundID v of @@ -95,73 +104,82 @@ soundToOnomato v = case _getSoundID v of 8 -> "TINKLE" 9 -> "TRINKL" 10 -> "BWAAH" - 11 -> "TIP" - 12 -> "TATATA" - 13 -> "BLIH" - 14 -> "HMM" - 15 -> "PEW" - 16 -> "CRAKLE" - 17 -> "TAP" - 18 -> "DWAAH" - 19 -> "PRUM" - 20 -> "BANGG" - 21 -> "CRTINK" - 22 -> "PHF" - 23 -> "ZHM" - 24 -> "THUD" - 25 -> "CRASH" - 26 -> "TAPTIP" - 27 -> "CHUGUGUG" - 28 -> "HSSS" - 29 -> "BOOM" - 30 -> "HSS" - 31 -> "TAKH" - 32 -> "RINGGG" - 33 -> "CRH" - 34 -> "UGGAUGGA" - 35 -> "CRUMPLE" - 36 -> "CREUH" - 37 -> "SMACK" - 38 -> "CLICK" - 39 -> "TIPTOP" - 40 -> "CRUH" - 41 -> "CHNKCHNKCHUNK" - 42 -> "CLKCLK" - 43 -> "TIPTAP" - 44 -> "TNKTNKTNK" - 45 -> "CHPCHPCHP" - 46 -> "SCREE" - 47 -> "BRAP" - 48 -> "CRSK" - 49 -> "CRNKL" - 50 -> "TAPP" - 51 -> "SHUHP" - 52 -> "DEDEDUM" - 53 -> "TAK" - 54 -> "CRISH" - 55 -> "SWSH" - 56 -> "BIPBIPBIP" - 57 -> "BEP" - 58 -> "KRTNKL" - 59 -> "CRSNK" - 60 -> "DUDURAH" - 61 -> "CHUGUGUG" - 62 -> "BANG" - 63 -> "DEDA" - 64 -> "WHSSH" - 65 -> "HNH" - 66 -> "BWAH" - 67 -> "CRUNK" - 68 -> "DRR" - 69 -> "BRAP" - 70 -> "BLPCHCH" - 71 -> "ZMM" - 72 -> "WRRR" - 73 -> "FWUMP" - 74 -> "BRAHCHCH" - 75 -> "BRPBRPBRP" - 76 -> "WE-OH" - 77 -> "FHP" + 11 -> "DNDNDNDN" + 12 -> "CRMBL" + 13 -> "TIP" + 14 -> "TATATA" + 15 -> "BLIH" + 16 -> "HMM" + 17 -> "PEW" + 18 -> "CRAKLE" + 19 -> "TAP" + 20 -> "DWAAH" + 21 -> "PRUM" + 22 -> "BANGG" + 23 -> "CRTINK" + 24 -> "PHF" + 25 -> "ZHM" + 26 -> "THUD" + 27 -> "TRWNG" + 28 -> "CRASH" + 29 -> "TAPTIP" + 30 -> "CHUGUGUG" + 31 -> "HSSS" + 32 -> "BOOM" + 33 -> "HSS" + 34 -> "TAKH" + 35 -> "RINGGG" + 36 -> "CRH" + 37 -> "UGGAUGGA" + 38 -> "CRUMPLE" + 39 -> "CREUH" + 40 -> "SMACK" + 41 -> "CLICK" + 42 -> "TIPTOP" + 43 -> "CRUH" + 44 -> "CHNKCHNKCHUNK" + 45 -> "CLKCLK" + 46 -> "TIPTAP" + 47 -> "TNKTNKTNK" + 48 -> "CHPCHPCHP" + 49 -> "SCREE" + 50 -> "DHDHL" + 51 -> "BRAP" + 52 -> "CRSK" + 53 -> "CRNKL" + 54 -> "TRNKL" + 55 -> "TAPP" + 56 -> "SHUHP" + 57 -> "CRUMBL" + 58 -> "DEDEDUM" + 59 -> "TAK" + 60 -> "CRISH" + 61 -> "SWSH" + 62 -> "BIPBIPBIP" + 63 -> "BEP" + 64 -> "KRTNKL" + 65 -> "CRSNK" + 66 -> "TTRKL" + 67 -> "DUDURAH" + 68 -> "CRMPL" + 69 -> "CHUGUGUG" + 70 -> "BANG" + 71 -> "DEDA" + 72 -> "WHSSH" + 73 -> "HNH" + 74 -> "BWAH" + 75 -> "CRUNK" + 76 -> "DRR" + 77 -> "TRNKL" + 78 -> "BRAP" + 79 -> "BLPCHCH" + 80 -> "ZMM" + 81 -> "WRRR" + 82 -> "FWUMP" + 83 -> "BRAHCHCH" + 84 -> "BRPBRPBRP" + 85 -> "WE-OH" + 86 -> "FHP" _ -> error "unitialised sound" soundPathList :: [String] soundPathList = @@ -176,6 +194,8 @@ soundPathList = , "smallGlass4.TINKLE.500.wav" , "smallGlass1.TRINKL.500.wav" , "sineRaisePitchTwoSec.BWAAH.300.wav" + , "combine.DNDNDNDN.500.wav" + , "stone4.CRMBL.1000.wav" , "foot1.TIP.40.wav" , "autoB.TATATA.2000.wav" , "heal.BLIH.50.wav" @@ -190,6 +210,7 @@ soundPathList = , "whiteNoiseFadeOut.PHF.100.wav" , "tele.ZHM.1000.wav" , "hit.THUD.100.wav" + , "metal7.TRWNG.1000.wav" , "stone1.CRASH.1000.wav" , "twoStep1.TAPTIP.40.wav" , "seagullChatter.CHUGUGUG.2000.wav" @@ -212,11 +233,14 @@ soundPathList = , "reload.TNKTNKTNK.300.wav" , "reload1.CHPCHPCHP.300.wav" , "tone440sawtooth.SCREE.2000.wav" + , "metal3.DHDHL.1000.wav" , "tap3.BRAP.1000.wav" , "glassShat4.CRSK.1000.wav" , "glassShat2.CRNKL.1000.wav" + , "metal1.TRNKL.1000.wav" , "foot3.TAPP.40.wav" , "pickUp.SHUHP.50.wav" + , "stone5.CRUMBL.1000.wav" , "dededum.DEDEDUM.500.wav" , "tap1.TAK.500.wav" , "metal4.CRISH.1000.wav" @@ -225,7 +249,9 @@ soundPathList = , "tone440.BEP.300.wav" , "smallGlass2.KRTNKL.500.wav" , "glassShat1.CRSNK.1000.wav" + , "metal5.TTRKL.1000.wav" , "eject.DUDURAH.500.wav" + , "stone2.CRMPL.1000.wav" , "seagullChatter1.CHUGUGUG.2000.wav" , "bang.BANG.2000.wav" , "deda.DEDA.500.wav" @@ -234,6 +260,7 @@ soundPathList = , "sineRaisePitchOneSec.BWAH.300.wav" , "metal2.CRUNK.1000.wav" , "slideDoor.DRR.100.wav" + , "metal6.TRNKL.1000.wav" , "autoGun.BRAP.2000.wav" , "oldMachineBoot.BLPCHCH.1000.wav" , "buzz.ZMM.200.wav" @@ -266,137 +293,155 @@ smallGlass1S :: SoundID smallGlass1S = SoundID 9 sineRaisePitchTwoSecS :: SoundID sineRaisePitchTwoSecS = SoundID 10 +combineS :: SoundID +combineS = SoundID 11 +stone4S :: SoundID +stone4S = SoundID 12 foot1S :: SoundID -foot1S = SoundID 11 +foot1S = SoundID 13 autoBS :: SoundID -autoBS = SoundID 12 +autoBS = SoundID 14 healS :: SoundID -healS = SoundID 13 +healS = SoundID 15 fridgeHumS :: SoundID -fridgeHumS = SoundID 14 +fridgeHumS = SoundID 16 seagullWhistle1S :: SoundID -seagullWhistle1S = SoundID 15 +seagullWhistle1S = SoundID 17 elecCrackleS :: SoundID -elecCrackleS = SoundID 16 +elecCrackleS = SoundID 18 foot2S :: SoundID -foot2S = SoundID 17 +foot2S = SoundID 19 skwareFadeTwoSecS :: SoundID -skwareFadeTwoSecS = SoundID 18 +skwareFadeTwoSecS = SoundID 20 insertOneS :: SoundID -insertOneS = SoundID 19 +insertOneS = SoundID 21 bangEchoS :: SoundID -bangEchoS = SoundID 20 +bangEchoS = SoundID 22 smallGlass3S :: SoundID -smallGlass3S = SoundID 21 +smallGlass3S = SoundID 23 whiteNoiseFadeOutS :: SoundID -whiteNoiseFadeOutS = SoundID 22 +whiteNoiseFadeOutS = SoundID 24 teleS :: SoundID -teleS = SoundID 23 +teleS = SoundID 25 hitS :: SoundID -hitS = SoundID 24 +hitS = SoundID 26 +metal7S :: SoundID +metal7S = SoundID 27 stone1S :: SoundID -stone1S = SoundID 25 +stone1S = SoundID 28 twoStep1S :: SoundID -twoStep1S = SoundID 26 +twoStep1S = SoundID 29 seagullChatterS :: SoundID -seagullChatterS = SoundID 27 +seagullChatterS = SoundID 30 foamSprayLoopS :: SoundID -foamSprayLoopS = SoundID 28 +foamSprayLoopS = SoundID 31 explosionS :: SoundID -explosionS = SoundID 29 +explosionS = SoundID 32 foamSprayFadeOutS :: SoundID -foamSprayFadeOutS = SoundID 30 +foamSprayFadeOutS = SoundID 33 tap2S :: SoundID -tap2S = SoundID 31 +tap2S = SoundID 34 tinitusS :: SoundID -tinitusS = SoundID 32 +tinitusS = SoundID 35 seagullCry1S :: SoundID -seagullCry1S = SoundID 33 +seagullCry1S = SoundID 36 seagullBarkS :: SoundID -seagullBarkS = SoundID 34 +seagullBarkS = SoundID 37 stone3S :: SoundID -stone3S = SoundID 35 +stone3S = SoundID 38 seagullCry2S :: SoundID -seagullCry2S = SoundID 36 +seagullCry2S = SoundID 39 hit1S :: SoundID -hit1S = SoundID 37 +hit1S = SoundID 40 click1S :: SoundID -click1S = SoundID 38 +click1S = SoundID 41 twoStepSlowS :: SoundID -twoStepSlowS = SoundID 39 +twoStepSlowS = SoundID 42 seagullCryS :: SoundID -seagullCryS = SoundID 40 +seagullCryS = SoundID 43 crankSlowS :: SoundID -crankSlowS = SoundID 41 +crankSlowS = SoundID 44 primeS :: SoundID -primeS = SoundID 42 +primeS = SoundID 45 twoStepS :: SoundID -twoStepS = SoundID 43 +twoStepS = SoundID 46 reloadS :: SoundID -reloadS = SoundID 44 +reloadS = SoundID 47 reload1S :: SoundID -reload1S = SoundID 45 +reload1S = SoundID 48 tone440sawtoothS :: SoundID -tone440sawtoothS = SoundID 46 +tone440sawtoothS = SoundID 49 +metal3S :: SoundID +metal3S = SoundID 50 tap3S :: SoundID -tap3S = SoundID 47 +tap3S = SoundID 51 glassShat4S :: SoundID -glassShat4S = SoundID 48 +glassShat4S = SoundID 52 glassShat2S :: SoundID -glassShat2S = SoundID 49 +glassShat2S = SoundID 53 +metal1S :: SoundID +metal1S = SoundID 54 foot3S :: SoundID -foot3S = SoundID 50 +foot3S = SoundID 55 pickUpS :: SoundID -pickUpS = SoundID 51 +pickUpS = SoundID 56 +stone5S :: SoundID +stone5S = SoundID 57 dededumS :: SoundID -dededumS = SoundID 52 +dededumS = SoundID 58 tap1S :: SoundID -tap1S = SoundID 53 +tap1S = SoundID 59 metal4S :: SoundID -metal4S = SoundID 54 +metal4S = SoundID 60 knifeS :: SoundID -knifeS = SoundID 55 +knifeS = SoundID 61 computerBeepingS :: SoundID -computerBeepingS = SoundID 56 +computerBeepingS = SoundID 62 tone440S :: SoundID -tone440S = SoundID 57 +tone440S = SoundID 63 smallGlass2S :: SoundID -smallGlass2S = SoundID 58 +smallGlass2S = SoundID 64 glassShat1S :: SoundID -glassShat1S = SoundID 59 +glassShat1S = SoundID 65 +metal5S :: SoundID +metal5S = SoundID 66 ejectS :: SoundID -ejectS = SoundID 60 +ejectS = SoundID 67 +stone2S :: SoundID +stone2S = SoundID 68 seagullChatter1S :: SoundID -seagullChatter1S = SoundID 61 +seagullChatter1S = SoundID 69 bangS :: SoundID -bangS = SoundID 62 +bangS = SoundID 70 dedaS :: SoundID -dedaS = SoundID 63 +dedaS = SoundID 71 missileLaunchS :: SoundID -missileLaunchS = SoundID 64 +missileLaunchS = SoundID 72 gruntS :: SoundID -gruntS = SoundID 65 +gruntS = SoundID 73 sineRaisePitchOneSecS :: SoundID -sineRaisePitchOneSecS = SoundID 66 +sineRaisePitchOneSecS = SoundID 74 metal2S :: SoundID -metal2S = SoundID 67 +metal2S = SoundID 75 slideDoorS :: SoundID -slideDoorS = SoundID 68 +slideDoorS = SoundID 76 +metal6S :: SoundID +metal6S = SoundID 77 autoGunS :: SoundID -autoGunS = SoundID 69 +autoGunS = SoundID 78 oldMachineBootS :: SoundID -oldMachineBootS = SoundID 70 +oldMachineBootS = SoundID 79 buzzS :: SoundID -buzzS = SoundID 71 +buzzS = SoundID 80 fireLoudS :: SoundID -fireLoudS = SoundID 72 +fireLoudS = SoundID 81 tap4S :: SoundID -tap4S = SoundID 73 +tap4S = SoundID 82 shotgunS :: SoundID -shotgunS = SoundID 74 +shotgunS = SoundID 83 miniS :: SoundID -miniS = SoundID 75 +miniS = SoundID 84 seagullWhistleS :: SoundID -seagullWhistleS = SoundID 76 +seagullWhistleS = SoundID 85 whiteNoiseFadeInS :: SoundID -whiteNoiseFadeInS = SoundID 77 +whiteNoiseFadeInS = SoundID 86 diff --git a/src/Dodge/Terminal.hs b/src/Dodge/Terminal.hs index 166a043ba..34e59b8f7 100644 --- a/src/Dodge/Terminal.hs +++ b/src/Dodge/Terminal.hs @@ -8,10 +8,11 @@ import Color import Justify import LensHelp import Sound.Data -import ListHelp (find,safeUncons,safeHead) +import ListHelp (safeUncons,safeHead) import Data.Char import Data.Maybe +import Data.Foldable import qualified Data.Map.Strict as M import qualified Data.IntMap.Strict as IM import qualified Data.Text as T @@ -234,7 +235,7 @@ basicTerminal = defaultTerminal doDeathTriggers :: Terminal -> World -> World doDeathTriggers tm w = w - & triggers %~ flip (foldr doDeathToggle) xs + & triggers %~ flip (foldl' $ flip doDeathToggle) xs where xs = M.elems $ _tmToggles tm doDeathToggle :: TerminalToggle -> IM.IntMap (World -> Bool) -> IM.IntMap (World -> Bool) diff --git a/src/FoldableHelp.hs b/src/FoldableHelp.hs index 440eaf4ef..bd604f1da 100644 --- a/src/FoldableHelp.hs +++ b/src/FoldableHelp.hs @@ -13,6 +13,8 @@ module FoldableHelp import Data.Foldable import qualified Control.Foldl as L + + -- TODO check up whether and how it is necessary to specialise this -- | A version of 'minimum' where the comparison is done on some extracted value. -- Returns Nothing if the list is empty. diff --git a/src/Geometry.hs b/src/Geometry.hs index 2e57cb672..d4d2ca7c1 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -17,6 +17,7 @@ module Geometry , module Geometry.Vector3D , module Geometry.LHS , module Geometry.Polygon + , loopPairs ) where import Geometry.Data import Geometry.Polygon @@ -25,10 +26,11 @@ import Geometry.Bezier import Geometry.Vector import Geometry.Vector3D import Geometry.LHS +import ListHelp --import Geometry.ConvexPoly --import Data.Maybe -import Data.List +--import Data.List -- | Return a point a distance away from a first point towards a second point. -- Does not go past the second point. alongSegBy :: Float -> Point2 -> Point2 -> Point2 @@ -122,6 +124,7 @@ polyToTris'' _ = [] polyToTris :: [s] -> [s] {-# INLINABLE polyToTris #-} +--polyToTris (x:xs) = foldr (f x) [] $ foldPairs xs polyToTris (x:xs) = foldr (f x) [] $ zip xs $ tail xs where f a (b,c) ls = a:b:c:ls @@ -133,9 +136,8 @@ polyToTris' [] = [] polyToTris' (a:as) = prependTwo a as prependTwo :: a -> [a] -> [a] -prependTwo _ [] = [] -prependTwo _ [_] = [] prependTwo sep (x:y:xs) = sep : x : y : prependTwo sep (y:xs) +prependTwo _ _ = [] -- | Return n equidistant points on a circle with a radius of 600. nRays :: Int -> [Point2] @@ -307,10 +309,10 @@ chainPairs xs = zip xs $ tail xs -- | Given a list of points, returns pairs of points linking the points into a -- loop. -loopPairs :: [a] -> [(a,a)] -loopPairs [] = error "tried to make loop with empty list of elements" -loopPairs [_] = error "tried to make loop with singleton list of elements" -loopPairs (x:xs) = zip (x:xs) (xs ++ [x]) +--loopPairs :: [a] -> [(a,a)] +--loopPairs [] = error "tried to make loop with empty list of elements" +--loopPairs [_] = error "tried to make loop with singleton list of elements" +--loopPairs (x:xs) = zip (x:xs) (xs ++ [x]) -- | Test whether a point is in a cone. -- Note the pair is ordered. -- Doesn't work for obtuse angles. diff --git a/src/Geometry/Vector3D.hs b/src/Geometry/Vector3D.hs index 4549a6129..454dd5cfb 100644 --- a/src/Geometry/Vector3D.hs +++ b/src/Geometry/Vector3D.hs @@ -4,6 +4,7 @@ module Geometry.Vector3D import Geometry.Vector import Geometry.Data +import qualified Control.Foldl as L import Data.List infixl 6 +.+.+, -.-.- @@ -27,7 +28,7 @@ V3 x1 y1 z1 -.-.- V3 x2 y2 z2 = !y = y1 - y2 !z = z1 - z2 in V3 x y z -{- | 3D scalar multiplication. -} +{- | 3D scalar multiplication. Strict. -} (*.*.*) :: Float -> Point3 -> Point3 {-# INLINE (*.*.*) #-} a *.*.* (V3 x2 y2 z2) = @@ -112,7 +113,8 @@ orderAround3 v ps = sortOn (argV . prj) ps prj p = V2 (dotV3 xdir p) (dotV3 ydir p) vCen3 :: [Point3] -> Point3 -vCen3 ps = (1 / fromIntegral (length ps)) *.*.* foldr (+.+.+) (V3 0 0 0) ps +vCen3 = L.fold $ (/) <$> L.sum <*> L.genericLength +--vCen3 ps = (1 / fromIntegral (length ps)) *.*.* foldr (+.+.+) (V3 0 0 0) ps dotV3 :: Point3 -> Point3 -> Float dotV3 (V3 x y z) (V3 a b c) = x*a + y*b + z*c diff --git a/src/ListHelp.hs b/src/ListHelp.hs index d1bb0e78d..0ca28b196 100644 --- a/src/ListHelp.hs +++ b/src/ListHelp.hs @@ -7,9 +7,24 @@ module ListHelp , safeHead , safeUncons , errorHead - )where + , foldPairs + , loopPairs + ) where import Data.List +loopPairs :: [a] -> [(a,a)] +loopPairs (a:as) = snd $ foldr f (Just a,[]) (a:as) + where + f x (Nothing,ps) = (Just x,ps) + f x (Just y,ps) = (Just x,(x,y):ps) +loopPairs [] = error "tried to make loop with empty list of elements" + +foldPairs :: [a] -> [(a,a)] +foldPairs = snd . foldr f (Nothing, []) + where + f x (Nothing,ps) = (Just x,ps) + f x (Just y,ps) = (Just x,(x,y):ps) + initOrNull :: [a] -> [a] initOrNull [] = [] initOrNull xs = init xs