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 quasicanons.
  possibly add more libraries of scales
  maybe have it take in melodies instead and only require the transformations to be locally harmonypreserving.
  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 melodyversion 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 CG, 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 adhoc 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 wellfounded, 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..(j1)] 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 (n1) ]
{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..(j1)] [] i]
inj :: Int > Int > [Int > Int]
inj i j  i > j = []
 otherwise = [(\x> intMap t i x) t < perms [0..(j1)] [] 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) (n1)]
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..(s11)], b<[0..(s11)],c<[0..(s11)],d<[0..(s11)],(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..(s11)], b<[0..(s11)],c<[0..(s11)],d<[0..(s11)],(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))