------------------------------------------------------------------------------ -- Scale.hs -- created: Sun Mar 14 19:52:43 JST 2010 ------------------------------------------------------------------------------ module Sound.Conductive.Scale where import Data.List import Sound.Conductive.MiscListUtils import Sound.Conductive.MusicalTime import Sound.Conductive.Pitch chromaticRel = [1,1,1,1,1,1,1,1,1,1] -- church modes ionianRel :: [Integer] ionianRel = [ 2, 2, 1, 2, 2, 2, 1 ] dorianRel :: [Integer] dorianRel = [ 2, 1, 2, 2, 2, 1, 2 ] phrygianRel :: [Integer] phrygianRel = [ 1, 2, 2, 2, 1, 2, 2 ] lydianRel :: [Integer] lydianRel = [ 2, 2, 2, 1, 2, 2, 1 ] mixolydianRel :: [Integer] mixolydianRel = [ 2, 2, 1, 2, 2, 1, 2 ] aeolianRel :: [Integer] aeolianRel = [ 2, 1, 2, 2, 1, 2, 2 ] locrianRel :: [Integer] locrianRel = [ 1, 2, 2, 1, 2, 2, 2 ] absoluteScaleMaker :: (Num a) => [a] -> Int -> a -> [a] absoluteScaleMaker scale n startingNote = take n $ deltasToAbsolutes startingNote $ cycle scale -- give the number of pitches and the root pitch to generate the scale chromatic = absoluteScaleMaker chromaticRel ionian :: Int -> Integer -> [Integer] ionian = absoluteScaleMaker ionianRel dorian :: Int -> Integer -> [Integer] dorian = absoluteScaleMaker dorianRel phrygian :: Int -> Integer -> [Integer] phrygian = absoluteScaleMaker phrygianRel lydian :: Int -> Integer -> [Integer] lydian = absoluteScaleMaker lydianRel mixolydian :: Int -> Integer -> [Integer] mixolydian = absoluteScaleMaker mixolydianRel aeolian :: Int -> Integer -> [Integer] aeolian = absoluteScaleMaker aeolianRel locrian :: Int -> Integer -> [Integer] locrian = absoluteScaleMaker locrianRel -- take 100 $ deltasToAbsolutes 0 $ concat $ repeat ionianRel -- Hindustani thaats bilawalRel :: [Integer] bilawalRel = ionianRel khamajRel :: [Integer] khamajRel = mixolydianRel kafiRel :: [Integer] kafiRel = dorianRel asavariRel :: [Integer] asavariRel = aeolianRel bhairaviRel :: [Integer] bhairaviRel = phrygianRel bhairavRel :: [Integer] bhairavRel = [ 1, 3, 1, 2, 1, 3, 1 ] kalyanRel :: [Integer] kalyanRel = lydianRel marwaRel :: [Integer] marwaRel = [ 1, 3, 2, 1, 2, 2, 1 ] poorviRel :: [Integer] poorviRel = [ 1, 3, 2, 1, 1, 3, 1 ] todiRel :: [Integer] todiRel = [ 1, 2, 3, 1, 1, 3, 1 ] --- bilawal :: Int -> Integer -> [Integer] bilawal = ionian khamaj :: Int -> Integer -> [Integer] khamaj = mixolydian kafi :: Int -> Integer -> [Integer] kafi = dorian asavari :: Int -> Integer -> [Integer] asavari = aeolian bhairavi :: Int -> Integer -> [Integer] bhairavi = phrygian bhairav :: Int -> Integer -> [Integer] bhairav = absoluteScaleMaker bhairavRel kalyan :: Int -> Integer -> [Integer] kalyan = absoluteScaleMaker kalyanRel marwa :: Int -> Integer -> [Integer] marwa = absoluteScaleMaker marwaRel poorvi :: Int -> Integer -> [Integer] poorvi = absoluteScaleMaker poorviRel todi :: Int -> Integer -> [Integer] todi = absoluteScaleMaker todiRel -- fit absolute input to a particular scale mold' :: (Num a, Ord a) => [a] -> [a] -> [a] -> [a] mold' xs o y | y == [] = o | elem (y!!0) xs == True = y++o | elem (y!!0) xs == False = let a = span ((>) (y!!0)) xs b = if ((fst a) == []) then head xs else last $ fst a c = if ((snd a) == []) then last xs else head $ snd a d = (y!!0) - b e = c - (y!!0) in if (d > e) then c:o else b:o mold :: (Num a, Ord a) => [a] -> [a] -> a -> [a] mold xs o y = let a = [y] in mold' xs o a -- fitToScale scale root input = -- is there a better way that doesn't require reverse? fitToScale :: (Num b, Ord b) => [b] -> [b] -> [b] fitToScale scale input = reverse $ foldl (\x y -> mold scale x y) [] input -- I'm imagining "raw" to mean values between 0 and 1, but I haven't thought about suitability for other ranges... rawToScaleDegrees scale rs = fitToScale scale $ map convRaw rs where scaleMin = head scale scaleMax = last scale scaleRange = scaleMax - scaleMin convRaw x = (x * scaleRange) + scaleMin transpose :: (Num a) => a -> [a] -> [a] transpose n xs = map (\x -> x + n) xs transposeHeadTo :: (Num a) => a -> [a] -> [a] transposeHeadTo n xs = map (+(n - (head xs))) xs maxInterval' :: (Fractional a, Ord a) => a -> [a] -> [a] -> [a] maxInterval' n xs o | xs == [] = o | o == [] = maxInterval' n (tail xs) $ o ++ [head xs] | (abs $ (last o) - (head xs)) <= n = maxInterval' n (tail xs) $ o ++ [head xs] | (abs $ (last o) - (head xs)) > n = let diff = (last o) - (head xs) sign = diff/(abs diff) newHead = (+) (head xs) $ ((abs diff) - n) * sign in maxInterval' n (tail xs) $ o ++ [newHead] maxInterval :: (Fractional a, Ord a) => a -> [a] -> [a] maxInterval n xs = maxInterval' n xs []