Add more sounds

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]

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

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
+    11 -> 500
-    12 -> 2000
+    12 -> 1000
-    13 -> 50
+    13 -> 40
-    14 -> 50
+    14 -> 2000
-    15 -> 2000
+    15 -> 50
-    16 -> 200
+    16 -> 50
-    17 -> 40
+    17 -> 2000
-    18 -> 300
+    18 -> 200
-    19 -> 500
+    19 -> 40
-    20 -> 2000
+    20 -> 300
     21 -> 500
-    22 -> 100
+    22 -> 2000
-    23 -> 1000
+    23 -> 500
     24 -> 100
     25 -> 1000
-    26 -> 40
+    26 -> 100
-    27 -> 2000
+    27 -> 1000
-    28 -> 50
+    28 -> 1000
-    29 -> 2000
+    29 -> 40
-    30 -> 50
+    30 -> 2000
-    31 -> 1000
+    31 -> 50
-    32 -> 8000
+    32 -> 2000
-    33 -> 2000
+    33 -> 50
-    34 -> 2000
+    34 -> 1000
-    35 -> 1000
+    35 -> 8000
     36 -> 2000
-    37 -> 100
+    37 -> 2000
-    38 -> 40
+    38 -> 1000
-    39 -> 40
+    39 -> 2000
-    40 -> 2000
+    40 -> 100
-    41 -> 100
+    41 -> 40
-    42 -> 500
+    42 -> 40
-    43 -> 40
+    43 -> 2000
-    44 -> 300
+    44 -> 100
-    45 -> 300
+    45 -> 500
-    46 -> 2000
+    46 -> 40
-    47 -> 1000
+    47 -> 300
-    48 -> 1000
+    48 -> 300
-    49 -> 1000
+    49 -> 2000
-    50 -> 40
+    50 -> 1000
-    51 -> 50
+    51 -> 1000
-    52 -> 500
+    52 -> 1000
-    53 -> 500
+    53 -> 1000
     54 -> 1000
-    55 -> 20
+    55 -> 40
-    56 -> 500
+    56 -> 50
-    57 -> 300
+    57 -> 1000
     58 -> 500
-    59 -> 1000
+    59 -> 500
-    60 -> 500
+    60 -> 1000
-    61 -> 2000
+    61 -> 20
-    62 -> 2000
+    62 -> 500
-    63 -> 500
+    63 -> 300
-    64 -> 2000
+    64 -> 500
-    65 -> 100
+    65 -> 1000
-    66 -> 300
+    66 -> 1000
-    67 -> 1000
+    67 -> 500
-    68 -> 100
+    68 -> 1000
     69 -> 2000
-    70 -> 1000
+    70 -> 2000
-    71 -> 200
+    71 -> 500
-    72 -> 500
+    72 -> 2000
     73 -> 100
-    74 -> 2000
+    74 -> 300
-    75 -> 2000
+    75 -> 1000
-    76 -> 2000
+    76 -> 100
-    77 -> 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"
+    11 -> "DNDNDNDN"
-    12 -> "TATATA"
+    12 -> "CRMBL"
-    13 -> "BLIH"
+    13 -> "TIP"
-    14 -> "HMM"
+    14 -> "TATATA"
-    15 -> "PEW"
+    15 -> "BLIH"
-    16 -> "CRAKLE"
+    16 -> "HMM"
-    17 -> "TAP"
+    17 -> "PEW"
-    18 -> "DWAAH"
+    18 -> "CRAKLE"
-    19 -> "PRUM"
+    19 -> "TAP"
-    20 -> "BANGG"
+    20 -> "DWAAH"
-    21 -> "CRTINK"
+    21 -> "PRUM"
-    22 -> "PHF"
+    22 -> "BANGG"
-    23 -> "ZHM"
+    23 -> "CRTINK"
-    24 -> "THUD"
+    24 -> "PHF"
-    25 -> "CRASH"
+    25 -> "ZHM"
-    26 -> "TAPTIP"
+    26 -> "THUD"
-    27 -> "CHUGUGUG"
+    27 -> "TRWNG"
-    28 -> "HSSS"
+    28 -> "CRASH"
-    29 -> "BOOM"
+    29 -> "TAPTIP"
-    30 -> "HSS"
+    30 -> "CHUGUGUG"
-    31 -> "TAKH"
+    31 -> "HSSS"
-    32 -> "RINGGG"
+    32 -> "BOOM"
-    33 -> "CRH"
+    33 -> "HSS"
-    34 -> "UGGAUGGA"
+    34 -> "TAKH"
-    35 -> "CRUMPLE"
+    35 -> "RINGGG"
-    36 -> "CREUH"
+    36 -> "CRH"
-    37 -> "SMACK"
+    37 -> "UGGAUGGA"
-    38 -> "CLICK"
+    38 -> "CRUMPLE"
-    39 -> "TIPTOP"
+    39 -> "CREUH"
-    40 -> "CRUH"
+    40 -> "SMACK"
-    41 -> "CHNKCHNKCHUNK"
+    41 -> "CLICK"
-    42 -> "CLKCLK"
+    42 -> "TIPTOP"
-    43 -> "TIPTAP"
+    43 -> "CRUH"
-    44 -> "TNKTNKTNK"
+    44 -> "CHNKCHNKCHUNK"
-    45 -> "CHPCHPCHP"
+    45 -> "CLKCLK"
-    46 -> "SCREE"
+    46 -> "TIPTAP"
-    47 -> "BRAP"
+    47 -> "TNKTNKTNK"
-    48 -> "CRSK"
+    48 -> "CHPCHPCHP"
-    49 -> "CRNKL"
+    49 -> "SCREE"
-    50 -> "TAPP"
+    50 -> "DHDHL"
-    51 -> "SHUHP"
+    51 -> "BRAP"
-    52 -> "DEDEDUM"
+    52 -> "CRSK"
-    53 -> "TAK"
+    53 -> "CRNKL"
-    54 -> "CRISH"
+    54 -> "TRNKL"
-    55 -> "SWSH"
+    55 -> "TAPP"
-    56 -> "BIPBIPBIP"
+    56 -> "SHUHP"
-    57 -> "BEP"
+    57 -> "CRUMBL"
-    58 -> "KRTNKL"
+    58 -> "DEDEDUM"
-    59 -> "CRSNK"
+    59 -> "TAK"
-    60 -> "DUDURAH"
+    60 -> "CRISH"
-    61 -> "CHUGUGUG"
+    61 -> "SWSH"
-    62 -> "BANG"
+    62 -> "BIPBIPBIP"
-    63 -> "DEDA"
+    63 -> "BEP"
-    64 -> "WHSSH"
+    64 -> "KRTNKL"
-    65 -> "HNH"
+    65 -> "CRSNK"
-    66 -> "BWAH"
+    66 -> "TTRKL"
-    67 -> "CRUNK"
+    67 -> "DUDURAH"
-    68 -> "DRR"
+    68 -> "CRMPL"
-    69 -> "BRAP"
+    69 -> "CHUGUGUG"
-    70 -> "BLPCHCH"
+    70 -> "BANG"
-    71 -> "ZMM"
+    71 -> "DEDA"
-    72 -> "WRRR"
+    72 -> "WHSSH"
-    73 -> "FWUMP"
+    73 -> "HNH"
-    74 -> "BRAHCHCH"
+    74 -> "BWAH"
-    75 -> "BRPBRPBRP"
+    75 -> "CRUNK"
-    76 -> "WE-OH"
+    76 -> "DRR"
-    77 -> "FHP"
+    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

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)

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.

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 :: [a] -> [(a,a)]
-loopPairs [] = error "tried to make loop with empty list of elements"
+--loopPairs [] = error "tried to make loop with empty list of elements"
-loopPairs [_] = error "tried to make loop with singleton list of elements"
+--loopPairs [_] = error "tried to make loop with singleton list of elements"
-loopPairs (x:xs) = zip (x:xs) (xs ++ [x])
+--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.

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

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