module Music.Theory.Pitch.Spelling.Cluster where
import Data.List
import qualified Music.Theory.List as T
import qualified Music.Theory.Pitch as T
import qualified Music.Theory.Pitch.Note as T
import Music.Theory.Pitch.Note.Name
cluster_normal_order :: [T.PitchClass] -> [T.PitchClass]
cluster_normal_order =
let with_bounds x = ((last x head x) `mod` 12,x)
in snd . head . sort . map with_bounds . T.rotations
cluster_normal_order_octpc :: T.Octave -> [T.PitchClass] -> [T.OctPC]
cluster_normal_order_octpc o pc =
let pc_n = cluster_normal_order pc
pc_0 = head pc_n
in map (\x -> (if x >= pc_0 then o else o + 1,x)) pc_n
cluster_is_multiple_octave :: [T.PitchClass] -> Bool
cluster_is_multiple_octave x = sort x /= cluster_normal_order x
spell_cluster_table :: [([T.PitchClass],[(T.Note_T,T.Alteration_T)])]
spell_cluster_table =
[([0,1,2,3],[bis,cis,d,ees])
,([0,1,2],[bis,cis,d])
,([0,1,3],[c,des,ees])
,([0,1],[c,des])
,([0,2,3],[c,d,ees])
,([0,2],[c,d])
,([0],[c])
,([1,2,3],[cis,d,ees])
,([1,2],[cis,d])
,([10,0,1,2],[ais,bis,cis,d])
,([10,0,1,3],[bes,c,des,ees])
,([10,0,1],[bes,c,des])
,([10,0,2,3],[bes,c,d,ees])
,([10,0,2],[bes,c,d])
,([10,1,2,3],[bes,cis,d,ees])
,([10,1,2],[ais,cis,d])
,([10,11,0,1,2,3],[ais,b,c,cis,d,ees])
,([10,11,0,1],[ais,b,c,des])
,([10,11,0,2],[ais,b,c,d])
,([10,11,0,3],[ais,b,c,dis])
,([10,11,0],[ais,b,c])
,([10,11,1,2],[ais,b,cis,d])
,([10,11,1,3],[ais,b,cis,dis])
,([10,11,1],[ais,b,cis])
,([10,11,2,3],[bes,ces,d,ees])
,([10,11,2],[ais,b,d])
,([10,11],[ais,b])
,([10],[bes])
,([11,0,1,2],[aisis,bis,cis,d])
,([11,0,1,3],[b,c,des,ees])
,([11,0,1],[b,c,des])
,([11,0,2,3],[b,c,d,ees])
,([11,0,2],[b,c,d])
,([11,0,3],[b,c,dis])
,([11,0],[b,c])
,([11,1,2,3],[b,cis,d,ees])
,([11,1,2],[b,cis,d])
,([11,1,3],[b,cis,dis])
,([11,1],[b,cis])
,([11,2,3],[b,d,ees])
,([11,2],[b,d])
,([11],[b])
,([1],[cis])
,([2,3,4,5],[d,ees,fes,geses])
,([2,3,4],[d,ees,fes])
,([2,3,5],[d,ees,f])
,([2,3],[d,ees])
,([2,4,5],[d,e,f])
,([2,4],[d,e])
,([2,5],[d,f])
,([2],[d])
,([3,4,5],[dis,e,f])
,([3,4],[dis,e])
,([3,5],[ees,f])
,([3],[ees])
,([4,5],[e,f])
,([4],[e])
,([5,6,7,8,9],[eis,fis,g,aes,beses])
,([5,6,7,8],[eis,fis,g,aes])
,([5,6,7,9],[eis,fis,g,a])
,([5,6,7],[eis,fis,g])
,([5,6,8,9],[eis,fis,gis,a])
,([5,6,8],[f,ges,aes])
,([5,6,9],[f,ges,a])
,([5,6],[f,ges])
,([5,7,8,9],[f,g,aes,beses])
,([5,7,8],[f,g,aes])
,([5,7,9],[f,g,a])
,([5,7],[f,g])
,([5,8,9],[f,gis,a])
,([5,8],[f,aes])
,([5,9],[f,a])
,([5],[f])
,([6,7,8,9],[fis,g,aes,beses])
,([6,7,8],[fis,g,aes])
,([6,7,9],[fis,g,a])
,([6,7],[fis,g])
,([6,8,9],[fis,gis,a])
,([6,8],[fis,gis])
,([6,9],[fis,a])
,([6],[fis])
,([7,8,9],[fisis,gis,a])
,([7,8],[g,aes])
,([7,9],[g,a])
,([7],[g])
,([8,10],[aes,bes])
,([8,9,10],[gis,a,bes])
,([8,9],[gis,a])
,([8],[aes])
,([9,10],[a,bes])
,([9],[a])]
spell_cluster :: [T.PitchClass] -> Maybe [(T.Note_T,T.Alteration_T)]
spell_cluster = flip lookup spell_cluster_table
spell_cluster_octpc :: [T.OctPC] -> Maybe [T.Pitch]
spell_cluster_octpc o =
let p = cluster_normal_order (sort (nub (map snd o)))
na_f na =
let na_tbl = map (\x -> (T.note_alteration_to_pc_err x,x)) na
o_f (oct,pc) = let (n,alt) = T.lookup_err pc na_tbl in T.Pitch n alt oct
in map o_f o
in fmap na_f (spell_cluster p)
spell_cluster_c4 :: [T.PitchClass] -> Maybe [T.Pitch]
spell_cluster_c4 p =
let o_0 = if cluster_is_multiple_octave p then 3 else 4
oct = map fst (cluster_normal_order_octpc o_0 p)
in case spell_cluster p of
Nothing -> Nothing
Just na -> Just (map (\((n,alt),o) -> T.Pitch n alt o) (zip na oct))
spell_cluster_c :: T.Octave -> [T.PitchClass] -> Maybe [T.Pitch]
spell_cluster_c o =
fmap (map (T.pitch_edit_octave (+ (o 4)))) .
spell_cluster_c4
spell_cluster_f :: (T.PitchClass -> T.Octave) -> [T.PitchClass] -> Maybe [T.Pitch]
spell_cluster_f o_f p =
let fn r = case r of
[] -> []
l:_ -> let (o,n) = T.pitch_to_octpc l
oct_f = (+ (o_f n o))
in (map (T.pitch_edit_octave oct_f) r)
in fmap fn (spell_cluster_c4 p)
spell_cluster_left :: T.Octave -> [T.PitchClass] -> Maybe [T.Pitch]
spell_cluster_left o p =
let fn r = case r of
[] -> []
l:_ -> let oct_f = (+ (o T.octave l))
in map (T.pitch_edit_octave oct_f) r
in fmap fn (spell_cluster_c4 p)