import Data.List {- - - This program might maybe be a bit useful for looking at - ways of varying melodies. For instance, let's say we look at the - subscale based on that Rachmaninov (actually Henselt) motif - - (weakchrom,[False,False,False,False,True,False,False,False,False,False,False,True,True]) - - C,B,E - - To look for other transformations of this motive in the minor scale, - we input the command - - show [map f [0..2]| f<-hT (weakchrom,[False,False,False,False,True,False,False,False,False,False,False,True,True]) (chrom,minormask) inj] - - This produces the output: - - "[[0,2,3],[0,2,5],[0,3,6],[0,4,5],[1,3,4],[1,3,6],[1,4,5],[1,6,7],[2,4,5],[2,4,7],[4,6,7]]" - - Which correspond respective to the transformed motives: - - F,Eb,C - Ab,Eb,C - B,F,C - Ab,G,C - G,F,D - B,F,D - Ab,G,D - c,B,D - Ab,G,E - c,G,Eb - c,Bb,G - - These are mostly pretty interesting. - - If we choose a pentatonic mask instead by running the command - show [map f [0..2]| f<-hT (weakchrom,[False,False,False,False,True,False,False,False,False,False,False,True,True]) (chrom,pentatonicmask) inj] - - We get the output - - "[[0,3,4],[1,2,3]]" - - which give motives - - A,G,C - G,F,D - - Things to do: - - possibly link up with counterpoint program to look for quasi-canons. - - possibly add more libraries of scales - - maybe have it take in melodies instead and only require the transformations to be locally harmony-preserving. - - maybe make it preserve relative interval size also; or at least enable people to set some sort of tolerance. (this could easily be done to the output results; but could implement it locally if I got a melody-version of this program finished. Or maybe it's just best to let the person decide for themselves). - - I started writing this program because I noticed the slightly fractalish transformation that maps the diatonic scale onto the chromatic scale from C-G, which seems to preserve a lot of the basic harmonies. Of course, my program doesn't actually detect this as being a valid transformation. There seems to be a certain amount of ad-hoc manipulations of the consonances required to get a decent bunch of transformations once your scales get even slightly big. - - And yes, I know that the notion of putting any sort of order on consonances is not entirely well-founded, but it does have some use! So don't go disrespecting Euler. - - Any questions/comments/whatever, email me at icecube@maths.tcd.ie -} {-Counts the number of times x is in a set s-} count :: Eq a => a -> [a] -> Int count x s = length [p | p<-s, p==x] {-maptomask...given [1,0,1,0,1] it would construct a map from [0,1,2] to [0,1,2,3,4]-} mapToMask :: [Bool]->Int->Int mapToMask m n = (findIndices (\x->x==True) m) !! n type SubScale = ([Int],[Bool]) type Interval = (Int,Int) comp :: SubScale -> Interval -> Bool comp s x = True {- # of notes in the subscale -} subScaleSize :: SubScale -> Int subScaleSize (s,m) = count True m {-set, max value + 1 , input value-} intMap :: [Int] -> Int-> Int -> Int intMap t i x | i<=x = x | otherwise = t !! x maps :: Int -> Int -> [Int -> Int] maps i j = [(\x-> intMap t i x) |t <- lists [0..(j-1)] i] {- lists of elements of list l of length n - cannot be any repeated elements!-} lists :: [a] -> Int -> [[a]] lists s 0 = [[]] lists s n = [x:xs| x <- s, xs<-lists s (n-1) ] {-following functions calculate sets of functions between sets-} iso :: Int -> Int -> [Int -> Int] iso i j | i /= j = [] | otherwise = [(\x-> intMap t i x) |t <- perms [0..(j-1)] [] i] inj :: Int -> Int -> [Int -> Int] inj i j | i > j = [] | otherwise = [(\x-> intMap t i x) |t <- perms [0..(j-1)] [] i] perms :: Eq a => [a] -> [a] -> Int -> [[a]] perms _ _ 0 = [[]] perms s t n = [x:xs| x <- s , notElem x t, xs<-perms s (x:t) (n-1)] oprod :: Ord a => [a] -> [a] -> [[a]] oprod m n = [[x,y]| x<-m, y<-n, x SubScale doubleoct (i,m) = (i ++ tail i, m ++ tail m) scale :: [Int] -> SubScale scale a = (a,map (\x->True) a) diatonicmask, pentatonicmask, fifthmask, minormask :: [Bool] diatonicmask = [True, False, True, False, True, True, False, True, False, True, False, True, True] pentatonicmask = [False,True,False,True,False,False,True,False,True,False,True,False,False] fifthmask = [True, True, True, True, True, True, True, True, False, False, False, False, False] minormask = [True,False,True,True,False,True,False,True,True,False,False,True,True] fifthscale, diatonic, pentatonic::SubScale fifthscale = (chrom, fifthmask) diatonic = (chrom, diatonicmask) pentatonic = (chrom, pentatonicmask) minor = (chrom, minormask) {- majorbiasedchromaticwo - minorbiasedchromaticwo-} cm :: SubScale -> Interval -> Interval -> Bool cm (consonance, mask) (a,b) (c,d) | (a>=s) || (b>=s) || (c>=s) || (d>=s) || (b(consonance !! ((f d)-(f c))) where f = mapToMask mask s = subScaleSize (consonance,mask) {-takes two harmonic maps and either inj or maps-} hT :: SubScale -> SubScale -> (Int -> Int -> [Int -> Int]) -> [Int->Int] hT a b f = consonanceTransformations l1 (cm a) l2 (cm b) f where l1 = subScaleSize a l2 = subScaleSize b {-check what's wrong with a particular transformation: for debugging-} whynot :: SubScale -> SubScale -> [Int] -> [((Int,Int,Int,Int),(Bool,Bool))] whynot a b t = [ (i,ints map i) | i <- int, not (comp map i)] where s1 = subScaleSize a s2 = subScaleSize b int = [(a,b,c,d)| a<-[0..(s1-1)], b<-[0..(s1-1)],c<-[0..(s1-1)],d<-[0..(s1-1)],(a<=b) && (c<=d) ] comp g (a,b,c,d) = (not (o1 (a,b) (c,d))) || (o2 (g a,g b) (g c,g d)) o1 = cm a o2 = cm b map = (\x -> t !! x) ints g (a,b,c,d) = (o1 (a,b) (c,d), o2 (g a,g b) (g c, g d)) consonanceTransformations :: Int -> (Interval -> Interval -> Bool) -> Int -> (Interval -> Interval -> Bool) -> (Int -> Int -> [Int -> Int]) -> [Int->Int] consonanceTransformations s1 o1 s2 o2 hom = [ f | f <- hom s1 s2, comp f `all` int] where int = [(a,b,c,d)| a<-[0..(s1-1)], b<-[0..(s1-1)],c<-[0..(s1-1)],d<-[0..(s1-1)],(a<=b) && (c<=d)] comp g (a,b,c,d) = (not (o1 (a,b) (c,d))) || (o2 (g a,g b) (g c,g d))