justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Add more sounds

Browse Source
This commit is contained in:
justin
2022-06-23 21:23:45 +01:00
parent 8d266a6770
commit fb3f677957
17 changed files with 291 additions and 228 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Material.hs
+4 -4
View File
@@ -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 -18
View File
@@ -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
+239 -194
View File
@@ -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
src/Dodge/Terminal.hs
+3 -2
View File
@@ -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
+2
View File
@@ -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
+9 -7
View File
@@ -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.
src/Geometry/Vector3D.hs
+4 -2
View File
@@ -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
+16 -1
View File
@@ -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