hs-pattrans-0.1.0.1: test/TransformationsSpec.hs
module TransformationsSpec (spec) where
import Control.Monad (forM_)
import Test.Hspec
import Types
import Transformations ((<=>), (~~), tonalTranspOf, exactOf, retrogradeOf, inversionOf, transpositionOf, rotationOf, augmentationOf, trInversionOf, trAugmentationOf, tonalTranspOfCan, tonalInversionOfCan)
forAll :: Example r => [a] -> String -> (a -> r) -> SpecWith (Arg r)
forAll xs title k =
forM_ exs $ \(i, x) -> do
describe title $ do
it ("# " ++ show i) $
k x
where exs = zip [1..] xs
forAll2 :: Example r => [a] -> String -> (a -> a -> r) -> SpecWith (Arg r)
forAll2 xs title k =
forM_ [(x, y) | x <- exs, y <- exs, fst x < fst y] $ \((i, x), (i', x')) -> do
describe title $ do
it (show i ++ " ~ " ++ show i') $
k x x'
where exs = zip [1..] xs
createPitchesfromInterval :: MIDI -> [Interval] -> Length -> [MIDI]
createPitchesfromInterval m i l = map (+m) (take l (scanl1 (+) (cycle i)))
createPitchesfromScaleDegree :: Length -> MIDI -> ScaleType -> [ScaleDegree] -> [MIDI]
createPitchesfromScaleDegree l n st degrees = take l seqMultipleOctaves
where
seqMultipleOctaves :: [MIDI]
seqMultipleOctaves = [(+) (o * 12) | o <- [0 .. 7]] <*> seqOneOctave
seqOneOctave :: [MIDI]
seqOneOctave = oneOctaveLookup degrees oneOctaveScale
oneOctaveLookup :: [ScaleDegree] -> [(MIDI, (ScaleDegree, Octave))] -> [MIDI]
oneOctaveLookup [] _ = []
oneOctaveLookup (sd:sds) scale = map fst (filter (\x -> (fst $ snd x) == sd) scale) ++ oneOctaveLookup sds scale
oneOctaveScale = [ (n + m, (i, 1)) | (i, m) <- zip [1..7] st]
spec :: Spec
spec = do
forAll2 hs "guessScale" $ \x y -> do
guessScale (x++y) `shouldBe` createScaleInC major
forAll2 hs "tonal transposition - hanons" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
forAll2 tris "tonal transposition - triads" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
forAll2 neighBb "tonal transposition - neighbour notes in Bb" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
forAll2 neighDu5u "This one will fail: use tonalTranspCan (the one after next test) instead. tonal transposition - neighbour notes in D up a fifth and neighbouring up" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
forAll2 neighDu5u "guess scale - neighbour notes in D up a fifth and neighbouring up" $ \x y -> do
guessScale (x++y) `shouldBe` createScaleInD major
forAll2 neighDu5u "tonal transposition more candidates - neighbour notes in D up a fifth and neighbouring up" $ \x y -> do
(x <=> y) (tonalTranspOfCan ~~ 1)
forAll2 neighDu5d "This one will fail: use tonalTranspCan (next test) instead. tonal transposition - neighbour notes in D up a fifth and neighbouring down" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
forAll2 neighDu5d "tonal transposition more candidates - neighbour notes in D up a fifth and neighbouring down" $ \x y -> do
(x <=> y) (tonalTranspOfCan ~~ 1)
forAll2 neighAd5d "tonal transposition - neighbour notes in A down a fifth and neighbouring down" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
forAll2 reachF "tonal transposition - reaching notes in F" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
forAll2 escapeG "tonal transposition - escaping notes in G" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
forAll2 launchingEb "tonal transposition - launching notes in Eb" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
forAll2 landingAm "tonal transposition - landing notes in A minor" $ \x y -> do
(x <=> y) (tonalTranspOf ~~ 1)
describe "retrograde" $ do
it "correctly detects self-retrograde with palindromeven" $
(palindromeeven <=> palindromeeven) (retrogradeOf ~~ 1)
describe "retrograde" $ do
it "correctly detects self-retrograde with palindromeodd" $
(palindromeodd <=> palindromeodd) (retrogradeOf ~~ 1)
describe "real transposition" $ do
it "correctly detects real transposition" $
(h1 <=> h1trans) (transpositionOf ~~ 1)
describe "exact approx" $ do
it "correctly detects exact repetition with approximation - deleted first note" $
(h1trans <=> h1transdel1) (exactOf ~~ 0.8)
describe "exact approx" $ do
it "correctly detects exact repetition with approximation - deleted second note" $
(h1trans <=> h1transdel2) (exactOf ~~ 0.8)
describe "exact approx" $ do
it "correctly detects exact repetition with approximation - deleted third note" $
(h1trans <=> h1transdel3) (exactOf ~~ 0.8)
describe "exact approx" $ do
it "correctly detects exact repetition with approximation - deleted last note" $
(h1trans <=> h1transdel4) (exactOf ~~ 0.8)
describe "exact approx" $ do
it "correctly detects exact repetition with approximation - inserted first note" $
(h1trans <=> h1transins1) (exactOf ~~ 0.8)
describe "exact approx" $ do
it "correctly detects exact repetition with approximation - inserted first three note" $
(h1trans <=> h1transins2) (exactOf ~~ 0.7)
describe "exact approx" $ do
it "correctly detects exact repetition with approximation - inserted last note" $
(h1trans <=> h1transins3) (exactOf ~~ 0.8)
describe "transposition approx" $ do
it "correctly detects real transformation with approximation - deleted first note" $
(h1 <=> h1transdel1) (transpositionOf ~~ 0.8)
describe "transposition approx" $ do
it "correctly detects real transformation with approximation - deleted second note, middle notes are different from first and last note (changing two intervals ~~ 0.71)" $
(h1 <=> h1transdel2) (transpositionOf ~~ 0.71)
describe "transposition approx" $ do
it "correctly detects real transformation with approximation - deleted third note (changing two intervals ~~ 0.71)" $
(h1 <=> h1transdel3) (transpositionOf ~~ 0.71)
describe "transposition approx" $ do
it "correctly detects real transformation with approximation - deleted last note" $
(h1 <=> h1transdel4) (transpositionOf ~~ 0.8)
describe "transposition approx" $ do
it "correctly detects real transformation with approximation - inserted first note" $
(h1 <=> h1transins1) (transpositionOf ~~ 0.8)
describe "transposition approx" $ do
it "correctly detects real transformation with approximation - inserted first three note" $
(h1 <=> h1transins2) (transpositionOf ~~ 0.7)
describe "transposition approx" $ do
it "correctly detects real transformation with approximation - inserted last note" $
(h1 <=> h1transins3) (transpositionOf ~~ 0.8)
describe "tonal inversion" $ do
it "correctly detects tonal inversion with hanon C" $
(h1 <=> hback1) (tonalInversionOfCan ~~ 1)
describe "tonal inversion" $ do
it "correctly detects tonal inversion with hanon D" $
(h2 <=> hback2) (tonalInversionOfCan ~~ 1)
describe "inversion" $ do
it "correctly detects real inversion with the triplet" $
(triplet <=> tripletrealinv) (inversionOf ~~ 1)
describe "transposed inversion" $ do
it "correctly detects real transposed inversion with the triplet" $
(triplet <=> tripletrealinvtrans) (trInversionOf ~~ 1)
describe "rotation" $ do
it "correctly detects rotation with the triplet" $
(triplet <=> tripletRI) (rotationOf ~~ 1)
describe "augmentation" $ do
it "correctly detects augmentation with the explicit notes" $
(cna <=> ca) (augmentationOf ~~ 1)
describe "augmentation" $ do
it "correctly detects trans augmentation with the explicit notes" $
(cat <=> ca) (trAugmentationOf ~~ 1)
where
h = createPitchesfromScaleDegree 8 36 major [1,3,4,5,6,5,4,3]
h1 = (.@@) [1..] h
h2 = (.@@) [1..] [38,41,43,45,47,45,43,41]
h3 = (.@@) [1..] [40,43,45,47,48,47,45,43]
h4 = (.@@) [1..] [41,45,47,48,50,48,47,45]
h5 = (.@@) [1..] [43,47,48,50,52,50,48,47]
h6 = (.@@) [1..] [45,48,50,52,53,52,50,48]
h7 = (.@@) [1..] [47,50,52,53,55,53,52,50]
hs = [h1, h2, h3, h4, h5, h6, h7]
triC = (.@@) [1..] [36,40,43]
triD = (.@@) [1..] [38,41,45]
triE = (.@@) [1..] [40,43,47]
triF = (.@@) [1..] [41,45,48]
triG = (.@@) [1..] [43,47,50]
tris = [triC, triD, triE, triF, triG]
neighBb1 = (.@@) [1..] [34,36,34]
neighBb2 = (.@@) [1..] [36,38,36]
neighBb3 = (.@@) [1..] [38,39,38]
neighBb4 = (.@@) [1..] [39,41,39]
neighBb5 = (.@@) [1..] [41,43,41]
neighBb = [neighBb1, neighBb2, neighBb3, neighBb4, neighBb5]
neighD1u5d = (.@@) [1..] [38,45,53,45]
neighD2u5d = (.@@) [1..] [40,47,45,47]
neighD3u5d = (.@@) [1..] [42,49,47,49]
neighD4u5d = (.@@) [1..] [43,50,49,50]
neighDu5d = [neighD1u5d, neighD2u5d, neighD3u5d, neighD4u5d]
neighD1u5u = (.@@) [1..] [38,45,57,45]
neighD2u5u = (.@@) [1..] [40,47,49,47]
neighD3u5u = (.@@) [1..] [42,49,50,49]
neighD4u5u = (.@@) [1..] [43,50,52,50]
neighDu5u = [neighD1u5u, neighD2u5u, neighD3u5u, neighD4u5u]
neighA1d5d = (.@@) [1..] [45,38,37,38]
neighA2d5d = (.@@) [1..] [47,40,38,40]
neighA3d5d = (.@@) [1..] [49,42,40,42]
neighA4d5d = (.@@) [1..] [50,44,42,44]
neighAd5d = [neighA1d5d, neighA2d5d, neighA3d5d, neighA4d5d]
reachF1 = (.@@) [1..] [41,46,45]
reachF2 = (.@@) [1..] [43,48,46]
reachF3 = (.@@) [1..] [45,50,48]
reachF = [reachF1, reachF2, reachF3]
escapeG1 = (.@@) [1..] [43,42,47]
escapeG2 = (.@@) [1..] [45,43,48]
escapeG3 = (.@@) [1..] [47,45,50]
escapeG = [escapeG1, escapeG2, escapeG3]
launchingEb1 = (.@@) [1..] [39,41,46]
launchingEb2 = (.@@) [1..] [41,43,48]
launchingEb3 = (.@@) [1..] [43,44,50]
launchingEb = [launchingEb1, launchingEb2, launchingEb3]
landingAm1 = (.@@) [1..] [33,38,40]
landingAm2 = (.@@) [1..] [35,40,41]
landingAm3 = (.@@) [1..] [36,41,43]
landingAm = [landingAm1, landingAm2, landingAm3]
hback1 = (.@@) [1..] [60,57,55,53,52,53,55,57]
hback2 = (.@@) [1..] [59,55,53,52,50,52,53,55]
palindromeeven = (.@@) [1..] [60,62,64,64,62,60]
palindromeodd = (.@@) [1..] [60,62,64,62,60]
h1trans= (.@@) [1..] [37,41,42,44,46,44,42,41]
h1transdel1 = (.@@) [1..] [41,42,44,46,44,42,41]
h1transdel2 = (.@@) [1..] [37,42,44,46,44,42,41]
h1transdel3 = (.@@) [1..] [37,41,42,46,44,42,41]
h1transdel4 = (.@@) [1..] [37,41,42,44,46,44,42]
h1transins1 = (.@@) [1..] [36,37,41,42,44,46,44,42,41]
h1transins2 = (.@@) [1..] [34,35,36,37,41,42,44,46,44,42,41]
h1transins3 = (.@@) [1..] [37,41,42,44,46,44,42,41,40]
triplet = (.@@) [1..] [60,62,64]
tripletrealinv = (.@@) [1..] [60,58,56]
tripletrealinvtrans = (.@@) [1..] [59,57,55]
tripletRI = (.@@) [1..] [56,58,60]
cna = (.@@) [1,2,3] [36,40,41]
ca = (.@@) [1,3..] [36,40,41]
cat = (.@@) [1,3..] [38,42,43]