------------------------------------------------------------------------------

-- 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.Pitch

-- 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

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

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 []