hmt 0.2 → 0.3

raw patch · 23 files changed

+2179/−209 lines, 23 filesdep +multiset-combdep +splitsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: multiset-comb, split

API changes (from Hackage documentation)

Files

• Help/hmt.help.lhs +14/−1
• Music/Theory.hs +0/−13
• Music/Theory/Bjorklund.hs +108/−0
• Music/Theory/Contour/Polansky_1992.hs +237/−0
• Music/Theory/Duration.hs +205/−0
• Music/Theory/Duration/Name.hs +52/−0
• Music/Theory/Duration/Sequence/Notate.hs +378/−0
• Music/Theory/Interval.hs +149/−0
• Music/Theory/Key.hs +18/−0
• Music/Theory/Parse.hs +2/−2
• Music/Theory/Pct.hs +1/−1
• Music/Theory/Permutations.hs +9/−3
• Music/Theory/Pitch.hs +98/−175
• Music/Theory/Pitch/Name.hs +390/−0
• Music/Theory/PitchClass.hs +205/−0
• Music/Theory/Prime.hs +1/−1
• Music/Theory/Set.hs +2/−2
• Music/Theory/Spelling.hs +88/−0
• Music/Theory/Tuning.hs +198/−0
• README +3/−2
• Setup.hs +3/−0
• Setup.lhs +0/−3
• hmt.cabal +18/−6

@@ -1,10 +1,16 @@-> import Music.Theory+This file illustrates equivalent expressions in pct and hmt terms. +The file imports modules as required and so must be traversed in order.+ $ sro T4 156 59A +> import Music.Theory.PitchClass+ > tn 4 [1,5,6] +> import Music.Theory.Parse+ > sro (rnrtnmi "T4") (pco "156")  $ sro T4I 156@@ -25,12 +31,15 @@ $ pcom pcseg iseg 01549 | pcom iseg icseg | pcom icseg icset 145 +> import Music.Theory.Set+ > (set . map ic . int) [0,1,5,4,9]  $ pcom pcseg pcset 01549 | pcom pcset sc | pcom sc icv | pcom icv icset 1345  > import Data.Maybe+> import Music.Theory.Prime  > let icv_icset x = let f x y = if x > 0 then Just y else Nothing >                   in catMaybes (zipWith f x [1..6])@@ -43,6 +52,8 @@ 11223344556 $ +> import Music.Theory.Pct+ > bip [0,10,9,5,7,2,8,11,3,4,1,6]  > bip (pco "0t95728e3416")@@ -57,6 +68,8 @@  > let f g = sort (g [1..4]) > in f Music.Theory.Permutations.permutations == f permutations++> import Music.Theory.Table  > let f = nub . map bip . permutations . sc > in f "5-Z17" `intersect` f "5-Z37"

@@ -1,13 +0,0 @@-module Music.Theory (module Music.Theory.Parse,-                     module Music.Theory.Pitch,-                     module Music.Theory.Pct,-                     module Music.Theory.Prime,-                     module Music.Theory.Set,-                     module Music.Theory.Table) where--import Music.Theory.Parse-import Music.Theory.Pitch-import Music.Theory.Pct-import Music.Theory.Prime-import Music.Theory.Set-import Music.Theory.Table

@@ -0,0 +1,108 @@+module Music.Theory.Bjorklund (bjorklund,xdot,iseq,iseq_str) where++{-+Godfried T. Toussaint et. al.+"The distance geometry of music"+Journal of Computational Geometry: Theory and Applications+Volume 42, Issue 5, July, 2009+doi>10.1016/j.comgeo.2008.04.005+-}++import Data.List.Split++type STEP a = ((Int, Int), ([[a]], [[a]]))++left :: STEP a -> STEP a+left ((i,j),(xs,ys)) =+    let (xs',xs'') = splitAt j xs+    in ((j,i-j),(zipWith (++) xs' ys, xs''))++right :: STEP a -> STEP a+right ((i,j),(xs,ys)) =+    let (ys',ys'') = splitAt i ys+    in ((i,j-i),(zipWith (++) xs ys', ys''))++bjorklund' :: STEP a -> STEP a+bjorklund' (n,x) =+    let (i,j) = n+    in if min i j <= 1+       then (n,x)+       else bjorklund' (if i > j then left (n,x) else right (n,x))++bjorklund :: (Int, Int) -> [Bool]+bjorklund (i,j') =+    let j = j' - i+        x = replicate i [True]+        y = replicate j [False]+        (_,(x',y')) = bjorklund' ((i,j),(x,y))+    in concat x' ++ concat y'++xdot :: [Bool] -> String+xdot = map (\x -> if x then 'x' else '.')++iseq :: [Bool] -> [Int]+iseq = let f = split . keepDelimsL . whenElt+       in tail . map length . f (== True)++iseq_str :: [Bool] -> String+iseq_str = let f xs = "(" ++ concatMap show xs ++ ")"+           in f . iseq++{-+xdot (bjorklund (5,9))+iseq_str (bjorklund (5,9))++let es = [(2,3),(2,5)+         ,(3,4),(3,5),(3,8)+         ,(4,7),(4,9),(4,12),(4,15)+         ,(5,6),(5,7),(5,8),(5,9),(5,11),(5,12),(5,13),(5,16)+         ,(6,7),(6,13)+         ,(7,8),(7,9),(7,10),(7,12),(7,15),(7,16),(7,17),(7,18)+         ,(8,17),(8,19)+         ,(9,14),(9,16),(9,22),(9,23)+         ,(11,12),(11,24)+         ,(13,24)+         ,(15,34)]+in map (\e -> let e' = bjorklund e in (e,xdot e',iseq_str e')) es++ =>++[((2,3),"xx.","(12)")+,((2,5),"x.x..","(23)")+,((3,4),"xxx.","(112)")+,((3,5),"x.x.x","(221)")+,((3,8),"x..x..x.","(332)")+,((4,7),"x.x.x.x","(2221)")+,((4,9),"x.x.x.x..","(2223)")+,((4,12),"x..x..x..x..","(3333)")+,((4,15),"x...x...x...x..","(4443)")+,((5,6),"xxxxx.","(11112)")+,((5,7),"x.xx.xx","(21211)")+,((5,8),"x.xx.xx.","(21212)")+,((5,9),"x.x.x.x.x","(22221)")+,((5,11),"x.x.x.x.x..","(22223)")+,((5,12),"x..x.x..x.x.","(32322)")+,((5,13),"x..x.x..x.x..","(32323)")+,((5,16),"x..x..x..x..x...","(33334)")+,((6,7),"xxxxxx.","(111112)")+,((6,13),"x.x.x.x.x.x..","(222223)")+,((7,8),"xxxxxxx.","(1111112)")+,((7,9),"x.xxx.xxx","(2112111)")+,((7,10),"x.xx.xx.xx","(2121211)")+,((7,12),"x.xx.x.xx.x.","(2122122)")+,((7,15),"x.x.x.x.x.x.x..","(2222223)")+,((7,16),"x..x.x.x..x.x.x.","(3223222)")+,((7,17),"x..x.x..x.x..x.x.","(3232322)")+,((7,18),"x..x.x..x.x..x.x..","(3232323)")+,((8,17),"x.x.x.x.x.x.x.x..","(22222223)")+,((8,19),"x..x.x.x..x.x.x..x.","(32232232)")+,((9,14),"x.xx.xx.xx.xx.","(212121212)")+,((9,16),"x.xx.x.x.xx.x.x.","(212221222)")+,((9,22),"x..x.x..x.x..x.x..x.x.","(323232322)")+,((9,23),"x..x.x..x.x..x.x..x.x..","(323232323)")+,((11,12),"xxxxxxxxxxx.","(11111111112)")+,((11,24),"x..x.x.x.x.x..x.x.x.x.x.","(32222322222)")+,((13,24),"x.xx.x.x.x.x.xx.x.x.x.x.","(2122222122222)")+,((15,34),"x..x.x.x.x..x.x.x.x..x.x.x.x..x.x.","(322232223222322)")]++-}

@@ -0,0 +1,237 @@+module Music.Theory.Contour.Polansky_1992 where++{-+Polansky, Larry and Bassein, Richard+"Possible and Impossible Melody: Some Formal Aspects of Contour"+JMT 36/2, 1992 (pp.259-284)+-}++import Data.List+import Data.List.Split+import qualified Data.Map as M+import Data.Maybe+import Data.Ratio+import qualified Music.Theory.Set as T+import qualified Music.Theory.Permutations as T++-- p.262+compare_adjacent :: Ord a => [a] -> [Ordering]+compare_adjacent xs = zipWith compare xs (tail xs)++matrix_f :: (a -> a -> b) -> [a] -> [[b]]+matrix_f f =+    let g (x,xs) = map (\x' -> f x x') xs+        h xs = map (\x -> (x,xs)) xs+    in map g . h++-- p.263+contour_matrix :: Ord a => [a] -> [[Ordering]]+contour_matrix = matrix_f compare++data Contour_Half_Matrix = Contour_Half_Matrix {+      contour_half_matrix_n :: Int+    , contour_half_matrix_m :: [[Ordering]] } deriving (Eq)++half_matrix_f :: (a -> a -> b) -> [a] -> [[b]]+half_matrix_f f xs =+    let drop_last = reverse . drop 1 . reverse+        m = drop_last (matrix_f f  xs)+    in map (\(i,ns) -> drop i ns) (zip [1..] m)++{-+half_matrix_f (flip (-)) [2,10,6,7]+==> [[8,4,5],[-4,-3],[1]]+half_matrix_f (flip (-)) [5,0,3,2]+==> [[-5,-2,-3],[3,2],[-1]]+-}++-- p.264+contour_half_matrix :: Ord a => [a] -> Contour_Half_Matrix+contour_half_matrix xs =+    let hm = half_matrix_f compare xs+    in Contour_Half_Matrix (length xs) hm++contour_half_matrix_str :: Contour_Half_Matrix -> String+contour_half_matrix_str (Contour_Half_Matrix _ hm) =+    let hm' = map (concatMap (show . fromEnum)) hm+    in intercalate " " hm'++instance Show Contour_Half_Matrix where+    show = contour_half_matrix_str++-- p.263+ord_to_int :: Integral a => Ordering -> a+ord_to_int = fromIntegral . fromEnum++-- p.263+int_to_ord :: Integral a => a -> Ordering+int_to_ord = toEnum . fromIntegral++data Contour_Description = Contour_Description {+      contour_description_n :: Int+    , contour_description_m :: M.Map (Int,Int) Ordering } deriving (Eq)++adjacent_indices :: Integral i => i -> [(i,i)]+adjacent_indices n = zip [0..n-2] [1..n-1]++-- in (i,j) indices in half matrix order+all_indices :: Integral i => i -> [(i,i)]+all_indices n =+    let n' = n - 1+    in [(i,j) | i <- [0 .. n'], j <- [i + 1 .. n']]++-- p.264+contour_description :: Ord a => [a] -> Contour_Description+contour_description x =+    let n = length x+        ix = all_indices n+        o = zip ix (map (\(i,j) -> compare (x !! i) (x !! j)) ix)+    in Contour_Description n (M.fromList o)++-- p.264+contour_description_str :: Contour_Description -> String+contour_description_str (Contour_Description n m) =+    let xs = concatMap (show . fromEnum . snd) (M.toList m)+    in intercalate " " (splitPlaces [n-1,n-2 .. 0] xs)++instance Show Contour_Description where+    show = contour_description_str++half_matrix_to_description :: Contour_Half_Matrix -> Contour_Description+half_matrix_to_description (Contour_Half_Matrix n hm) =+    let ix = all_indices n+        o = zip ix (concat hm)+    in Contour_Description n (M.fromList o)++-- ordering from i-th to j-th element of sequence described at d+contour_description_ix :: Contour_Description -> (Int,Int) -> Ordering+contour_description_ix d i = contour_description_m d M.! i++all_equal :: Eq a => [a] -> Bool+all_equal xs = all id (zipWith (==) xs (tail xs))++-- | true if contour is all descending, equal or ascending+uniform :: Contour_Description -> Bool+uniform (Contour_Description _ m) = all_equal (M.elems m)++-- | true if contour does not containt any EQ elements+no_equalities :: Contour_Description -> Bool+no_equalities (Contour_Description _ m) = not (EQ `elem` M.elems m)++-- | all contour descriptions+all_contours :: Int -> [Contour_Description]+all_contours n =+    let n' = contour_description_lm n+        ix = all_indices n+        cs = filter (not.null) (T.powerset [LT,EQ,GT])+        ps = concatMap (concatMap T.multiset_permutations . T.se n') cs+        mk p = Contour_Description n (M.fromList (zip ix p))+    in map mk ps++-- p.266+violations :: Contour_Description -> [(Int, Int, Int, Ordering)]+violations d =+    let n = contour_description_n d - 1+        ms = [(i,j,k) | i <- [0..n], j <- [i + 1 .. n], k <- [j + 1 .. n]]+        ix = contour_description_ix d+        complies (i,j,k) =+            let l = ix (i,j)+                r = ix (j,k)+                b = ix (i,k)+            in case implication (l,r) of+                 Nothing -> Nothing+                 Just x -> if x == b+                           then Nothing+                           else Just (i,j,k,x)+    in mapMaybe complies ms++is_possible :: Contour_Description -> Bool+is_possible = (== 0) . length . violations++-- | all possible contour descriptions+possible_contours :: Int -> [Contour_Description]+possible_contours = filter is_possible . all_contours++-- | all impossible contour descriptions+impossible_contours :: Int -> [Contour_Description]+impossible_contours = filter (not.is_possible) . all_contours++-- p.263+contour_description_lm :: Integral a => a -> a+contour_description_lm l = (l * l - l) `div` 2++-- a sequence of orderings (i,j) & (j,k) may imply ordering for (i,k)+implication :: (Ordering,Ordering) -> Maybe Ordering+implication (i,j) =+    case (min i j,max i j) of+      (LT,LT) -> Just LT+      (LT,EQ) -> Just LT+      (LT,GT) -> Nothing+      (EQ,EQ) -> Just EQ+      (EQ,GT) -> Just GT+      (GT,GT) -> Just GT+      _ -> error "implication"++-- replace the i-th value at ns with x+replace :: Integral i => [a] -> i -> a -> [a]+replace ns i x =+    let fn (j,y) = if i == j then x else y+    in map fn (zip [0..] ns)++-- diverges for impossible contours+draw_contour :: Integral i => Contour_Description -> [i]+draw_contour d =+    let n = contour_description_n d+        ix = all_indices n+        normalise :: Integral i => [Rational] -> [i]+        normalise xs =+            let xs' = nub (sort xs)+            in map (\i -> fromIntegral (fromJust (findIndex (== i) xs'))) xs+        adjustment x = if x == 0 then 1 else 1 % (denominator x * 2)+        step (i,j) ns = let c = contour_description_ix d (i,j)+                            i' = ns !! i+                            j' = ns !! j+                            c' = compare i' j' -- traceShow (i,j,ns) $+                        in if c == c'+                           then Nothing+                           else let j'' = case c of+                                            LT -> i' + (adjustment j')+                                            EQ -> i'+                                            GT -> i' - (adjustment j')+                                in Just (replace ns j j'')+        refine [] ns = ns+        refine (i:is) ns = case step i ns of+                             Nothing -> refine is ns+                             Just ns' -> refine ix ns'+    in normalise (refine ix (replicate n 0))++ord_invert :: Ordering -> Ordering+ord_invert x =+    case x of+      LT -> GT+      EQ -> EQ+      GT -> LT++contour_description_invert :: Contour_Description -> Contour_Description+contour_description_invert (Contour_Description n m) =+    Contour_Description n (M.map ord_invert m)++-- p.262 (quarter-note durations)+ex_1 :: [Rational]+ex_1 = [2,3%2,1%2,1,2]++-- p.265 (pitch)+ex_2 :: [Integer]+ex_2 = [0,5,3]++-- p.265 (pitch)+ex_3 :: [Integer]+ex_3 = [12,7,6,7,8,7]++-- p.266 (impossible)+ex_4 :: Contour_Description+ex_4 =+    let ns :: [[Int]]+        ns = [[2,2,2,1],[2,2,0],[0,0],[1]]+        ns' = map (map int_to_ord) ns+    in half_matrix_to_description (Contour_Half_Matrix 5 ns')

@@ -0,0 +1,205 @@+module Music.Theory.Duration where++import Data.Function+import Data.List+import Data.Ratio++data Duration = Duration { division :: Integer+                         , dots :: Integer+                         , multiplier :: Rational }+                  deriving (Eq, Show)++instance Ord Duration where+    compare = duration_compare++-- | Duration annotations+data D_Annotation = Tie_Right | Tie_Left+                  | Begin_Tuplet (Integer,Integer,Duration) | End_Tuplet+                    deriving (Eq,Show)++-- * Constants++breve,whole_note,half_note,quarter_note,eighth_note,sixteenth_note,thirtysecond_note :: Duration+breve = Duration 0 0 1+whole_note = Duration 1 0 1+half_note = Duration 2 0 1+quarter_note = Duration 4 0 1+eighth_note = Duration 8 0 1+sixteenth_note = Duration 16 0 1+thirtysecond_note = Duration 32 0 1++dotted_breve,dotted_whole_note,dotted_half_note,dotted_quarter_note,dotted_eighth_note,dotted_sixteenth_note,dotted_thirtysecond_note :: Duration+dotted_breve = Duration 0 1 1+dotted_whole_note = Duration 1 1 1+dotted_half_note = Duration 2 1 1+dotted_quarter_note = Duration 4 1 1+dotted_eighth_note = Duration 8 1 1+dotted_sixteenth_note = Duration 16 1 1+dotted_thirtysecond_note = Duration 32 1 1++double_dotted_breve,double_dotted_whole_note,double_dotted_half_note,double_dotted_quarter_note,double_dotted_eighth_note,double_dotted_sixteenth_note,double_dotted_thirtysecond_note :: Duration+double_dotted_breve = Duration 0 2 1+double_dotted_whole_note = Duration 2 2 1+double_dotted_half_note = Duration 2 2 1+double_dotted_quarter_note = Duration 4 2 1+double_dotted_eighth_note = Duration 8 2 1+double_dotted_sixteenth_note = Duration 16 2 1+double_dotted_thirtysecond_note = Duration 32 2 1++-- * Operations++duration_compare :: Duration -> Duration -> Ordering+duration_compare = compare `on` duration_to_rq+++-- | Compare durations with equal multipliers.+duration_compare_meq :: Duration -> Duration -> Ordering+duration_compare_meq y0 y1 =+    if y0 == y1+    then EQ+    else let (Duration x0 n0 m0) = y0+             (Duration x1 n1 m1) = y1+         in if m0 /= m1+            then error "duration_compare_meq: non-equal multipliers"+            else if x0 == x1+                 then compare n0 n1+                 else compare x1 x0++{-+zipWith duration_compare_meq [e,e,e,e'] [e,s,q,e]+-}++sort_pair :: (t -> t -> Ordering) -> (t, t) -> (t, t)+sort_pair fn (x,y) =+    case fn x y of+      LT -> (x,y)+      EQ -> (x,y)+      GT -> (y,x)++-- | True if neither duration is dotted.+no_dots :: (Duration, Duration) -> Bool+no_dots (x0,x1) = dots x0 == 0 && dots x1 == 0++-- | Sum undotted divisions, input is required to be sorted.+sum_dur_undotted :: (Integer, Integer) -> Maybe Duration+sum_dur_undotted (x0, x1)+    | x0 == x1 = Just (Duration (x0 `div` 2) 0 1)+    | x0 == x1 * 2 = Just (Duration x1 1 1)+    | otherwise = Nothing++-- | Sum dotted divisions, input is required to be sorted.+sum_dur_dotted :: (Integer,Integer,Integer,Integer) -> Maybe Duration+sum_dur_dotted (x0, n0, x1, n1)+    | x0 == x1 &&+      n0 == 1 &&+      n1 == 1 = Just (Duration (x1 `div` 2) 1 1)+    | x0 == x1 * 2 &&+      n0 == 0 &&+      n1 == 1 = Just (Duration (x1 `div` 2) 0 1)+    | otherwise = Nothing++-- | Sum durations.  Not all durations can be summed, and the present+--   algorithm is not exhaustive.+sum_dur :: Duration -> Duration -> Maybe Duration+sum_dur y0 y1 =+    let (x0,x1) = sort_pair duration_compare_meq (y0,y1)+    in if no_dots (x0,x1)+       then sum_dur_undotted (division x0, division x1)+       else sum_dur_dotted (division x0, dots x0+                           ,division x1, dots x1)++sum_dur' :: Duration -> Duration -> Duration+sum_dur' y0 y1 =+    let y2 = sum_dur y0 y1+        err = error ("sum_dur': " ++ show (y0,y1))+    in maybe err id y2++{-+zipWith sum_dur [e,q,q'] [e,e,e]+-}++-- * RQ (Rational Quarter Note Count)++-- | Rational number of quarter notes to duration value.+--   It is a mistake to hope this could handle tuplets+--   directly, ie. a 3:2 dotted note will be of the same+--   duration as a plain undotted note.+rq_to_duration :: Rational -> Maybe Duration+rq_to_duration x =+    case (numerator x,denominator x) of+      (1,8) -> Just thirtysecond_note+      (3,16) -> Just dotted_thirtysecond_note+      (1,4) -> Just sixteenth_note+      (3,8) -> Just dotted_sixteenth_note+      (1,2) -> Just eighth_note+      (3,4) -> Just dotted_eighth_note+      (1,1) -> Just quarter_note+      (3,2) -> Just dotted_quarter_note+      (2,1) -> Just half_note+      (3,1) -> Just dotted_half_note+      (7,2) -> Just double_dotted_half_note+      (4,1) -> Just whole_note+      (6,1) -> Just dotted_whole_note+      (8,1) -> Just breve+      (12,1) -> Just dotted_breve+      _ -> Nothing++-- | Convert a whole note division integer to a RQ.+whole_note_division_to_rq :: Integer -> Rational+whole_note_division_to_rq x =+    let f = (* 4) . recip . (%1)+    in case x of+         0 -> 8+         -1 -> 16+         _ -> f x++-- | Apply `d' dots to the duration `n'.+rq_apply_dots :: Rational -> Integer -> Rational+rq_apply_dots n d =+    let m = iterate (\x -> x / 2) n+    in sum (genericTake (d + 1) m)++-- | Convert duration to RQ value, see rq_to_duration for partial+--   inverse.+duration_to_rq :: Duration -> Rational+duration_to_rq (Duration n d m) =+    let x = whole_note_division_to_rq n+    in rq_apply_dots x d * m++-- | +whole_note_division_to_musicxml_type :: Integer -> String+whole_note_division_to_musicxml_type x =+    case x of+      256 -> "256th"+      128 -> "128th"+      64 -> "64th"+      32 -> "32nd"+      16 -> "16th"+      8 -> "eighth"+      4 -> "quarter"+      2 -> "half"+      1 -> "whole"+      0 -> "breve"+      -1 -> "long"+      _ -> error ("whole_note_division_to_musicxml_type: " ++ show x)++duration_to_musicxml_type :: Duration -> String+duration_to_musicxml_type = whole_note_division_to_musicxml_type . division++-- Note the duration multiplier is *not* written.+duration_to_lilypond_type :: Duration -> String+duration_to_lilypond_type (Duration dv d _) =+    let dv' = if dv == 0 then "\\breve" else show dv+    in dv' ++ replicate (fromIntegral d) '.'++whole_note_division_to_beam_count :: Integer -> Maybe Integer+whole_note_division_to_beam_count x =+    let t = [(256,6),(128,5),(64,4),(32,3),(16,2),(8,1)+            ,(4,0),(2,0),(1,0),(0,0),(-1,0)]+    in lookup x t++duration_beam_count :: Duration -> Integer+duration_beam_count (Duration x _ _) =+    case whole_note_division_to_beam_count x of+      Nothing -> error "duration_beam_count"+      Just x' -> x'

@@ -0,0 +1,52 @@+module Music.Theory.Duration.Name where++import Music.Theory.Duration++-- * w,h,q,e,s++w,h,q,e,s :: Duration+w = whole_note+h = half_note+q = quarter_note+e = eighth_note+s = sixteenth_note++w',h',q',e',s' :: Duration+w' = dotted_whole_note+h' = dotted_half_note+q' = dotted_quarter_note+e' = dotted_eighth_note+s' = dotted_sixteenth_note++w'',h'',q'',e'',s'' :: Duration+w'' = Duration 1 2 1+h'' = Duration 2 2 1+q'' = Duration 4 2 1+e'' = Duration 8 2 1+s'' = Duration 16 2 1++-- * _1,_2,_4,_8,_16,_32++_1,_2,_4,_8,_16,_32 :: Duration+_1 = whole_note+_2 = half_note+_4 = quarter_note+_8 = eighth_note+_16 = sixteenth_note+_32 = Duration 32 0 1++_1',_2',_4',_8',_16',_32' :: Duration+_1' = dotted_whole_note+_2' = dotted_half_note+_4' = dotted_quarter_note+_8' = dotted_eighth_note+_16' = dotted_sixteenth_note+_32' = Duration 32 1 1++_1'',_2'',_4'',_8'',_16'',_32'' :: Duration+_1'' = Duration 1 2 1+_2'' = Duration 2 2 1+_4'' = Duration 4 2 1+_8'' = Duration 8 2 1+_16'' = Duration 16 2 1+_32'' = Duration 32 2 1

@@ -0,0 +1,378 @@+module Music.Theory.Duration.Sequence.Notate+    (Duration_A+    ,notate+    ,ascribe+    ,group_boundary) where++import Data.List+import Data.Ratio+import Music.Theory.Duration++{-+import Debug.Trace+debug :: (Show a) => a -> x -> x+debug = traceShow+-}++debug :: (Show a) => a -> x -> x+debug _ x = x++type R = Rational+type D = (R,R,Bool,Bool) {- start_time duration tied_left tied_right -}+type Duration_A = (Duration,[D_Annotation])++d_duration :: D -> R+d_duration (_,x,_,_) = x++da_tied_right :: Duration_A -> Bool+da_tied_right = elem Tie_Right . snd++-- | dx -> d+integrate :: (Num a) => [a] -> [a]+integrate [] = []+integrate (x:xs) =+    let fn i c = (i + c, i + c)+    in x : snd (mapAccumL fn x xs)++-- xs = boundaries+-- d = duration+step_dur :: (Ord a, Num a) => [a] -> a -> ([a], [a])+step_dur [] _ = error "step_dur: no boundaries"+step_dur _ 0 = error "step_dur: zero duration"+step_dur (x:xs) d =+    let jn a (a',b) = (a:a',b)+    in case compare d x of+         EQ -> ([d],xs)+         LT -> ([d],(x-d):xs)+         GT -> jn x (step_dur xs (d - x))++{-+step_dur [2,1,3] 5+step_dur [3%2,3%2,3%2] 2+-}++-- xs = boundaries+-- d(s) = duration(s)+boundaries :: (Num a, Ord a) => [a] -> [a] -> [[a]]+boundaries =+    let go [] _ = []+        go _ [] = []+        go xs (d:ds) =+            let (d',xs') = step_dur xs d+            in d' : go xs' ds+    in go++{-+boundaries (repeat 3) [1..5]+boundaries (repeat (3%2)) [1%2,1..5]+-}++-- i = initial start time+-- xs = durations+with_start_times :: (Num a) => a -> [a] -> [(a,a)]+with_start_times i xs =+    let is = map (+i) (0 : integrate xs)+    in zip is xs++-- variant starting at zero and processing sets of durations+with_start_times' :: (Num a) => [[a]] -> [[(a, a)]]+with_start_times' xs =+    let is = 0 : integrate (map sum xs)+    in zipWith with_start_times is xs++{-+with_start_times 0 [4,3,5,2,1]+with_start_times' [[4,3,5],[2,1],[6,3]]+with_start_times' (boundaries [3,3,3,3,3] [4,3,5,2,1])+let xs = [3%4,2%1,5%4,9%4,1%4,3%2,1%2,7%4,1%1,5%2,11%4,3%2]+with_start_times 0 xs+with_start_times' (boundaries (repeat (3%2)) xs)+-}++-- split list into first element, possibly empty 'middle' elements,+-- and end element+start_middle_end :: [x] -> (x,[x],x)+start_middle_end xs =+    case xs of+      (_:_:_) -> let n = length xs+                     x0 = xs !! 0+                     xn = xs !! (n - 1)+                 in (x0,take (n - 2) (drop 1 xs),xn)+      _ -> error "start_middle_end: list must have at least two elements"++{-+start_middle_end []+start_middle_end [1..6]+-}++-- xs = [(start-time,duration)]+tied_r_to_d :: [(R,R)] -> [D]+tied_r_to_d xs =+    case xs of+      [] -> []+      [(s,d)] -> [(s,d,False,False)]+      _ -> let ((s0,d0),xs',(sn,dn)) = start_middle_end xs+               f (s,d) = (s,d,True,True)+            in (s0,d0,False,True) : map f xs' ++ [(sn,dn,True,False)]++boundaries_d :: [R] -> [R] -> [D]+boundaries_d xs ds =+    let bs = boundaries xs ds+    in concatMap tied_r_to_d (with_start_times' bs)++{-+boundaries_d [3,3,3,3,3,3,3,3] [4,3,5,2,1,7,2]+-}++-- | rational modulo+r_mod :: R -> R -> R+r_mod i j+    | i == j = 0+    | i < 0 = r_mod (i + j) j+    | i > j = r_mod (i - j) j+    | otherwise = i++{-+-- n = boundary+-- i = phase+sep_at :: R -> R -> R -> [D]+sep_at =+    let go l n i x =+            let i' = n - (i `r_mod` n)+            in if x > i'+               then let d = (i,i',l,True)+                    in d : go True n (i + i') (x - i')+               else [(i,x,l,False)]+    in go False++{-+sep_at 1 (1%2) 1+sep_at 1 (1%3) (6%3)+-}+-}++-- unrep = un-representable by single cmn duration (ie. requires tie)+-- i = phase+-- x = duration+sep_unrep :: R -> R -> Maybe (R,R)+sep_unrep i x =+    let i' = denominator i == 1+        j = case numerator x of+              5 -> Just (1,4)+              7 -> Just (3,4)+              _ -> Nothing+        f (n,m) = (n % denominator x,m % denominator x)+        swap (a,b) = (b,a)+    in case j of+         Nothing -> Nothing+         Just j' -> Just (f (if i' then swap j' else j'))++sep_unrep_d :: D -> [D]+sep_unrep_d d =+    let (i,x,l,r) = d+    in case sep_unrep i x of+         Nothing -> [d]+         Just (x0,x1) -> [(i,x0,l,True),(i+x0,x1,True,r)]++{-+zipWith sep_unrep [1,3%8,1] [5%4,5%8,4]+zipWith (\i x -> sep_unrep_d (i,x,False,False)) [1,3%8,1] [5%4,5%8,4]+-}++separate :: [R] -> [R] -> [D]+separate ns = concatMap sep_unrep_d . boundaries_d ns++{-+let xs = [3%4,2%1,5%4,9%4,1%4,3%2,1%2,7%4,1%1,5%2,11%4,3%2]+separate (repeat (1%2)) xs+-}++-- | group to n, or to multiple of+group_boundary :: (a -> R) -> [R] -> [a] -> [[a]]+group_boundary dur_f =+    let go _ [] [] _ = []+        go _ _ [] _ = error "group_boundary: no boundaries?"+        go _ js _ [] = [reverse js]+        go _ js _ [x] = [reverse (x:js)]+        go c js (n:ns) (x:xs) =+            let c' = c + dur_f x+            in case compare c' n of+                 EQ -> reverse (x:js) : go 0 [] ns xs+                 LT -> go c' (x:js) (n:ns) xs+                 GT -> let c'' = c' - n+                       in if c'' `divisible_by` n+                          then reverse (x:js) : go 0 [] ns xs+                          else go c'' (x:js) ns xs+    in go 0 []++{-+group_boundary id [1,1,1] [2,1%2,1%2]+-}++group_boundary_d :: [R] -> [D] -> [[D]]+group_boundary_d = group_boundary d_duration++{-+group_boundary id [3,3,3] (cycle [1,2,3])++let i = [1,1%2,2,1%3,5%3,1%8,1%2,7%8]+in group_boundary_d (repeat 1) (separate (repeat 1) i)+-}++derive_tuplet :: [D] -> Maybe (Integer,Integer)+derive_tuplet xs =+    let xs' = map d_duration xs+        i = maximum (map denominator xs')+        smpl n = if even n then smpl (n `div` 2) else n+        i' = smpl i+        j = case i' of+              3 -> (3,2)+              5 -> (5,4)+              7 -> (7,4)+              9 -> (9,8)+              _ -> error ("derive_tuplet: " ++ show (i,i'))+    in if i' == 1+       then Nothing+       else Just j++{-+let i = [1,1%2,2,1%3,5%3,1%8,1%2,7%8]+in map derive_tuplet (group_boundary_d 1 (separate 1 i))+-}++-- remove tuplet multiplier from value (ie. to give notated duration)+-- this seems odd but is neccessary to avoid ambiguity (ie. is 1 a+-- quarter note or a 3:2 tuplet dotted-quarter-note etc.+un_tuplet :: (Integer,Integer) -> R -> R+un_tuplet (i,j) x = x * (i%j)++d_join_aligned :: D -> D -> Maybe D+d_join_aligned (s1,x1,l1,r1) (_,x2,_,r2)+    | (x1 == (1%4) && r1 && x2 `elem` [1%4,1%2,3%4]) ||+      (x1 == (1%2) && r1 && x2 `elem` [1%4,1%2,1,3%2]) ||+      (x1 == 1 && r1 && x2 `elem` [1%2,1,2]) ||+      (x1 == (3%2) && r1 && x2 `elem` [1%2,3%2]) ||+      (x1 == 2 && r1 && x2 `elem` [1,2]) = debug ("aligned-join",s1,x1,x2) (Just (s1,x1+x2,l1,r2))+    | otherwise = debug ("aligned-no-join",s1,x1,r1,x2) Nothing++divisible_by :: R -> R -> Bool+divisible_by i j = denominator (i / j) == 1++-- partial/incomplete/inaccurate+d_join :: R -> D -> D -> Maybe D+d_join a (s1,x1,l1,r1) (s2,x2,l2,r2)+    | s1 `divisible_by` a = d_join_aligned (s1,x1,l1,r1) (s2,x2,l2,r2)+    | denominator (s1 `r_mod` 1) == 4 &&+      x1 == 1%4 &&+      r1 &&+      x2 == 1%4 &&+      not (s2 `divisible_by` a) =+      debug ("non-aligned-join",a,s1,x1) (Just (s1,x1+x2,l1,r2))+    | s1 `r_mod` 1 == 2%3 &&+      x1 == 1%3 &&+      r1 &&+      x2 == 1%3 =+      debug ("non-aligned-join",a,s1,x1) (Just (s1,x1+x2,l1,r2))+    | otherwise = debug ("non-aligned-no-join",a,s1,x1) Nothing++{-+d_join 1 (7 % 4,1 % 4,False,True) (2 % 1,1 % 4,True,False)+-}++{-+-- error checking variant+d_join' :: R -> D -> D -> Maybe D+d_join' a d1 d2 =+    case d_join a d1 d2 of+      Nothing -> Nothing+      Just x -> let (_,y,_,_) = x+                in case rq_to_duration y of+                     Nothing -> error ("d_join' :" ++ show (a,d1,d2,x))+                     Just _ -> Just x+-}++coalesce :: (a -> a -> Maybe a) -> [a] -> [a]+coalesce f xs =+    case xs of+      (x1:x2:xs') -> case f x1 x2 of+                       Nothing -> x1 : coalesce f (x2:xs')+                       Just x' -> coalesce f (x':xs')+      _ -> xs++-- a = alignment+-- ns = boundaries+-- two pass, ie. [2,1%2,1%2] becomes [2,1] becomes [3]+simplify :: R -> [R] -> [D] -> [D]+simplify a ns xs =+    let xs' = group_boundary_d ns xs+        pass :: [[D]] -> [[D]]+        pass = map (coalesce (d_join a))+    in concat ((pass . pass) xs')++-- erroring variant of rq_to_duration+to_duration :: Show a => a -> R -> Duration+to_duration msg n =+    let err = error ("to_duration:" ++ show (msg,n))+    in maybe err id (rq_to_duration n)++tuplet :: (Integer,Integer) -> [Duration] -> [Duration_A]+tuplet (d,n) xs =+    let fn x = x { multiplier = n%d }+        xn = length xs+        (Just ty) = rq_to_duration (sum (map duration_to_rq xs) / (d%1))+        t0 = [Begin_Tuplet (d,n,ty)]+        ts = [t0] ++ replicate (xn - 2) [] ++ [[End_Tuplet]]+    in zip (map fn xs) ts++-- the d0:dN distinction is to catch, for instance, dotted 1/4 and+-- tuplet 1/16.  it'd be better to not simplify to that, however+-- simplifier does not look ahead.+notate_sec :: [D] -> [Duration_A]+notate_sec xs =+    let ds = map d_duration xs+        add_ties_from (_,_,l,r) (d,fs) =+            let l' = if l then [Tie_Left] else []+                r' = if r then [Tie_Right] else []+            in (d,l' ++ r' ++ fs)+        xs' = case derive_tuplet xs of+                Nothing -> let f = to_duration ("no-tuplet",ds)+                           in map (\d -> (f d,[])) ds+                Just t -> let f = to_duration ("tuplet",t,ds)+                              (d0:dN) = ds+                          in if denominator d0 == 2+                             then (f d0,[]) : tuplet t (map (f . un_tuplet t) dN)+                             else tuplet t (map (f . un_tuplet t) ds)+    in zipWith add_ties_from xs xs'++-- is = unit divisions (must not conflict with ns)+-- ns = boundaries (ie. measures)+-- xs = durations+-- note: alignments are not handled correctly+notate :: [R] -> [R] -> [R] -> [Duration_A]+notate is ns xs =+    let xs' = simplify (head is) ns (separate is xs)+    in concatMap notate_sec (group_boundary_d is xs')++{-+let xs = [2%3,2%3,2%3,3%2,3%2,2%3,2%3,2%3,1%2,1%2,5%2,3%2]+let xs = map (%4) [1,6,2,3]+let xs = [2 % 1, 3 % 5, 2 % 5]+let is = repeat (1%1)+let ns = repeat (3%1)++map (\(x,y) -> (duration_to_lilypond_type x,y)) (notate is ns xs)+separate is xs+let xs' = simplify (head is) ns (separate is xs)+group_boundary_d is xs'+-}++ascribe_fn :: (x -> Bool) -> [x] -> [a] -> [(x,a)]+ascribe_fn fn =+    let go [] _ = []+        go _ [] = error "ascribe_fn"+        go (x:xs) (i:is) = let is' = if fn x then (i:is) else is+                           in (x,i) : go xs is'+    in go++ascribe :: [Duration_A] -> [x] -> [(Duration_A,x)]+ascribe = ascribe_fn da_tied_right

@@ -0,0 +1,149 @@+module Music.Theory.Interval where++import Music.Theory.Pitch++data Interval_T = Unison | Second | Third | Fourth+                | Fifth | Sixth | Seventh+                  deriving (Eq, Ord, Enum, Show)++data Interval_Q = Diminished | Minor+                | Perfect+                | Major | Augmented+                  deriving (Eq, Ord, Enum, Show)++data Interval = Interval { interval_type :: Interval_T+                         , interval_quality :: Interval_Q+                         , interval_direction :: Ordering+                         , interval_octave :: Octave }+                deriving (Eq, Show)++interval_ty :: Note_T -> Note_T -> Interval_T+interval_ty n1 n2 = toEnum ((fromEnum n2 - fromEnum n1) `mod` 7)++interval_q_tbl :: [(Interval_T, [(Int, Interval_Q)])]+interval_q_tbl =+    [(Unison,[(11,Diminished)+             ,(0,Perfect)+             ,(1,Augmented)])+    ,(Second,[(0,Diminished)+             ,(1,Minor)+             ,(2,Major)+             ,(3,Augmented)])+    ,(Third,[(2,Diminished)+            ,(3,Minor)+            ,(4,Major)+            ,(5,Augmented)])+    ,(Fourth,[(4,Diminished)+             ,(5,Perfect)+             ,(6,Augmented)])+    ,(Fifth,[(6,Diminished)+            ,(7,Perfect)+            ,(8,Augmented)])+    ,(Sixth,[(7,Diminished)+            ,(8,Minor)+            ,(9,Major)+            ,(10,Augmented)])+    ,(Seventh,[(9,Diminished)+              ,(10,Minor)+              ,(11,Major)+              ,(12,Augmented)])]++interval_q :: Interval_T -> Int -> Maybe Interval_Q+interval_q i n =+    case lookup i interval_q_tbl of+      Just t -> lookup n t+      Nothing -> Nothing++note_span :: Note_T -> Note_T -> [Note_T]+note_span n1 n2 =+    let fn x = toEnum (x `mod` 7)+        n1' = fromEnum n1+        n2' = fromEnum n2+        n2'' = if n1' > n2' then n2' + 7 else n2'+    in map fn [n1' .. n2'']++invert_ordering :: Ordering -> Ordering+invert_ordering x =+    case x of+      GT -> LT+      LT -> GT+      EQ -> EQ++interval :: Pitch -> Pitch -> Interval+interval p1 p2 =+    let c = compare p1 p2+        (Pitch n1 _ o1) = p1+        (Pitch n2 _ o2) = p2+        p1' = pitch_to_pc p1+        p2' = pitch_to_pc p2+        st = (p2' - p1') `mod` 12+        ty = interval_ty n1 n2+        (Just qu) = interval_q ty (fromIntegral st)+        o_a = if n1 > n2 then -1 else 0+    in case c of+         GT -> (interval p2 p1) { interval_direction = GT }+         _ -> Interval ty qu c (o2 - o1 + o_a)++invert_interval :: Interval -> Interval+invert_interval (Interval t qu d o) =+    let d' = invert_ordering d+    in Interval t qu d' o++-- can this be written without knowing the Interval_T?+quality_difference :: Interval_Q -> Interval_Q -> Int+quality_difference a b =+    let rule (x,y) =+            if x == y+            then Just 0+            else case (x,y) of+                   (Diminished,Minor) -> Just 1+                   (Diminished,Major) -> Just 2+                   (Diminished,Augmented) -> Just 3+                   (Minor,Major) -> Just 1+                   (Minor,Augmented) -> Just 2+                   (Major,Augmented) -> Just 1+                   (Diminished,Perfect) -> Just 1+                   (Perfect,Augmented) -> Just 1+                   _ -> Nothing+        fwd = rule (a,b)+        rvs = rule (b,a)+        err = error ("quality_difference: " ++ show (a,b))+    in case fwd of+         Just n -> n+         Nothing -> case rvs of+                      Just n -> negate n+                      Nothing -> err++transpose :: Interval -> Pitch -> Pitch+transpose i ip =+    let (Pitch p_n p_a p_o) = ip+        (Interval i_t i_q i_d i_o) = i+        i_d' = if i_d == GT+               then -1+               else 1+        p_n' = toEnum ((fromEnum p_n + (fromEnum i_t * i_d')) `mod` 7)+        -- oa = octave alteration+        oa = if p_n' > p_n && i_d == GT+             then -1+             else if p_n' < p_n && i_d == LT+                  then 1+                  else 0+        ip' = Pitch p_n' p_a (p_o + i_o + oa)+        st = if i_d == GT+             then (pitch_to_pc ip - pitch_to_pc ip') `mod` 12+             else (pitch_to_pc ip' - pitch_to_pc ip) `mod` 12+        ty = if i_d == GT+             then interval_ty p_n' p_n+             else interval_ty p_n p_n'+        qu = maybe (error ("qu: " ++ show (ty,st))) id+             (interval_q ty (fromIntegral st))+        qd = quality_difference qu i_q * i_d'+        p_a' = toEnum (fromEnum p_a + (qd * 2))+    in ip' { alteration = p_a' }++circle_of_fifths :: Pitch -> ([Pitch], [Pitch])+circle_of_fifths x =+    let p4 = Interval Fourth Perfect LT 0+        p5 = Interval Fifth Perfect LT 0+        mk y = take 12 (iterate (transpose y) x)+    in (mk p4,mk p5)

@@ -0,0 +1,18 @@+module Music.Theory.Key where++import Data.List+import Music.Theory.Pitch+import Music.Theory.Pitch.Name+import Music.Theory.Interval++data Mode_T = Minor_Mode | Major_Mode+              deriving (Eq,Ord,Show)++key_fifths :: (Note_T,Alteration_T,Mode_T) -> Int+key_fifths (n,a,m) =+    let cf x = let (p,q) = circle_of_fifths x in p ++ q+        eq (Pitch n' a' _) = n == n' && a == a'+        (Just ix) = case m of+                      Major_Mode -> findIndex eq (cf c4)+                      Minor_Mode -> findIndex eq (cf a4)+    in if ix < 13 then negate ix else ix - 12

@@ -2,7 +2,7 @@  import Control.Monad import Data.Char-import Music.Theory.Pitch+import Music.Theory.PitchClass import Text.ParserCombinators.Parsec  type P a = GenParser Char () a@@ -21,7 +21,7 @@ rnrtnmi s =   let p = do { r <- rot              ; r' <- is_char 'R'-             ; char 'T'+             ; _ <- char 'T'              ; t <- get_int              ; m <- is_char 'M'              ; i <- is_char 'I'

@@ -3,7 +3,7 @@ import Data.Function import Data.List import Music.Theory.Prime-import Music.Theory.Pitch+import Music.Theory.PitchClass import Music.Theory.Set import Music.Theory.Table 

@@ -1,7 +1,9 @@-module Music.Theory.Permutations (permutations) where+module Music.Theory.Permutations (permutations+                                 ,multiset_permutations) where  import qualified Data.Map as M import qualified Data.Permute as P+import qualified Math.Combinatorics.Multiset as C  all_ps :: P.Permute -> [P.Permute] all_ps p =@@ -14,10 +16,14 @@         ps = all_ps p     in map P.elems ps --- Generate list of all permutations of indicated list.+-- Generate list of all permutations. permutations :: [a] -> [[a]] permutations xs =     let m = M.fromList (zip [0..] xs)         ps = n_ps (M.size m)-        r = map (\i -> M.findWithDefault undefined i m)+        r = map (\i -> M.findWithDefault (error "permutations") i m)     in map r ps++-- Generate list of all distinct permutations.+multiset_permutations :: (Ord a) => [a] -> [[a]]+multiset_permutations = C.permutations . C.fromList

@@ -1,197 +1,120 @@ module Music.Theory.Pitch where -import Music.Theory.Set-import Data.Maybe-import Data.List---- | Modulo twelve.-mod12 :: (Integral a) => a -> a-mod12 = (`mod` 12)---- | Pitch class.-pc :: (Integral a) => a -> a-pc = mod12---- | Map to pitch-class and reduce to set.-pcset :: (Integral a) => [a] -> [a]-pcset = set . map pc---- | Transpose by n.-tn :: (Integral a) => a -> [a] -> [a]-tn n = map (pc . (+ n))---- | Transpose so first element is n.-transposeTo :: (Integral a) => a -> [a] -> [a]-transposeTo _ [] = []-transposeTo n (x:xs) = n : tn (n - x) xs---- | All transpositions.-transpositions :: (Integral a) => [a] -> [[a]]-transpositions p = map (`tn` p) [0..11]---- | Invert about n.-invert :: (Integral a) => a -> [a] -> [a]-invert n = map (pc . (\p -> n - (p - n)))---- | Invert about first element.-invertSelf :: (Integral a) => [a] -> [a]-invertSelf [] = []-invertSelf (x:xs) = invert x (x:xs)---- | Composition of inversion about zero and transpose.-tni :: (Integral a) => a -> [a] -> [a]-tni n = tn n . invert 0---- | Rotate left by n places.-rotate :: (Integral n) => n -> [a] -> [a]-rotate n p =-    let m = n `mod` genericLength p-        (b, a) = genericSplitAt m p-    in a ++ b---- | Rotate right by n places.-rotate_right :: (Integral n) => n -> [a] -> [a]-rotate_right = rotate . negate---- | All rotations.-rotations :: [a] -> [[a]]-rotations p = map (`rotate` p) [0 .. length p - 1]---- | Modulo 12 multiplication-mn :: (Integral a) => a -> [a] -> [a]-mn n = map (pc . (* n))---- | M5-m5 :: (Integral a) => [a] -> [a]-m5 = mn 5--all_Tn :: (Integral a) => [a] -> [[a]]-all_Tn p = map (`tn` p) [0..11]--all_TnI :: (Integral a) => [a] -> [[a]]-all_TnI p =-    let ps = all_Tn p -    in ps ++ map (invert 0) ps--all_RTnI :: (Integral a) => [a] -> [[a]]-all_RTnI p =-    let ps = all_TnI p-    in ps ++ map reverse ps--all_TnMI :: (Integral a) => [a] -> [[a]]-all_TnMI p =-    let ps = all_TnI p-    in ps ++ map m5 ps--all_RTnMI :: (Integral a) => [a] -> [[a]]-all_RTnMI p =-    let ps = all_TnMI p-    in ps ++ map reverse ps+import Data.Function -all_rRTnMI :: (Integral a) => [a] -> [[a]]-all_rRTnMI = map snd . sros+type PitchClass = Integer+type Octave = Integer --- | Serial Operator, of the form rRTMI.-data SRO a = SRO a Bool a Bool Bool-             deriving (Eq, Show)+data Note_T = C | D | E | F | G | A | B+              deriving (Eq, Ord, Enum, Bounded, Show) --- | Serial operation.-sro :: (Integral a) => SRO a -> [a] -> [a]-sro (SRO r r' t m i) x =-    let x1 = if i then invert 0 x else x-        x2 = if m then m5 x1 else x1-        x3 = tn t x2-        x4 = if r' then reverse x3 else x3-    in rotate r x4+data Alteration_T = DoubleFlat+                  | ThreeQuarterToneFlat | Flat | QuarterToneFlat+                  | Natural+                  | QuarterToneSharp | Sharp | ThreeQuarterToneSharp+                  | DoubleSharp+                    deriving (Eq, Ord, Enum, Show) --- | The total set of serial operations.-sros :: (Integral a) => [a] -> [(SRO a, [a])]-sros x = [ let o = (SRO r r' t m i) in (o, sro o x) | -           r <- [0 .. genericLength x - 1], -           r' <- [False, True], -           t <- [0 .. 11], -           m <- [False, True], -           i <- [False, True] ]+data Pitch = Pitch { note :: Note_T+                   , alteration :: Alteration_T+                   , octave :: Octave }+           deriving (Eq, Show) -sro_Tn :: (Integral a) => [SRO a]-sro_Tn = [ SRO 0 False n False False | -           n <- [0..11] ]+instance Ord Pitch where+    compare = pitch_compare -sro_TnI :: (Integral a) => [SRO a]-sro_TnI = [ SRO 0 False n False i | -            n <- [0..11], -            i <- [False, True] ]+note_to_pc :: Note_T -> Integer+note_to_pc n =+    case n of+      C -> 0+      D -> 2+      E -> 4+      F -> 5+      G -> 7+      A -> 9+      B -> 11 -sro_RTnI :: (Integral a) => [SRO a]-sro_RTnI = [ SRO 0 r n False i | -             r <- [True, False],-             n <- [0..11], -             i <- [False, True] ] +alteration_to_diff :: Alteration_T -> Integer+alteration_to_diff a =+    case a of+      DoubleFlat -> -2+      Flat -> -1+      Natural -> 0+      Sharp -> 1+      DoubleSharp -> 2+      _ -> error "alteration_to_diff: quarter tone" -sro_TnMI :: (Integral a) => [SRO a]-sro_TnMI = [ SRO 0 False n m i | -             n <- [0..11], -             m <- [True, False], -             i <- [True, False] ]+alteration_to_fdiff :: Alteration_T -> Double+alteration_to_fdiff a =+    case a of+      ThreeQuarterToneFlat -> -1.5+      QuarterToneFlat -> -0.5+      QuarterToneSharp -> 0.5+      ThreeQuarterToneSharp -> 1.5+      _ -> fromIntegral (alteration_to_diff a) -sro_RTnMI :: (Integral a) => [SRO a]-sro_RTnMI = [ SRO 0 r n m i | -              r <- [True, False],-              n <- [0..11],-              m <- [True, False],-              i <- [True, False] ]+pitch_to_octpc :: Pitch -> (Octave, PitchClass)+pitch_to_octpc = midi_to_octpc . pitch_to_midi --- | Intervals to values, zero is n.-dx_d :: (Num a) => a -> [a] -> [a]-dx_d = scanl (+)+pitch_to_midi :: Pitch -> Integer+pitch_to_midi (Pitch n a o) =+    let a' = alteration_to_diff a+        n' = note_to_pc n+    in 12 + o * 12 + n' + a' --- | Integrate.-d_dx :: (Num a) => [a] -> [a]-d_dx [] = []-d_dx (_:[]) = []-d_dx (x:xs) = zipWith (-) xs (x:xs)+pitch_to_fmidi :: Pitch -> Double+pitch_to_fmidi (Pitch n a o) =+    let a' = alteration_to_fdiff a+        o' = fromIntegral o+        n' = fromIntegral (note_to_pc n)+    in 12 + o' * 12 + n' + a' --- | Morris INT operator.-int :: (Integral a) => [a] -> [a]-int = map mod12 . d_dx+pitch_to_pc :: Pitch -> PitchClass+pitch_to_pc = snd . pitch_to_octpc --- | Interval class.-ic :: (Integral a) => a -> a-ic i =-    let i' = mod12 i-    in if i' <= 6 then i' else 12 - i'+pitch_compare :: Pitch -> Pitch -> Ordering+pitch_compare = compare `on` pitch_to_octpc --- | Elements of p not in q-difference :: (Eq a) => [a] -> [a] -> [a]-difference p q =-    let f e = e `notElem` q-    in filter f p+octpc_to_pitch :: (Octave, PitchClass) -> Pitch+octpc_to_pitch (o,pc) =+    let (n,a) = case pc of+                  0 -> (C,Natural)+                  1 -> (C,Sharp)+                  2 -> (D,Natural)+                  3 -> (E,Flat)+                  4 -> (E,Natural)+                  5 -> (F,Natural)+                  6 -> (F,Sharp)+                  7 -> (G,Natural)+                  8 -> (A,Flat)+                  9 -> (A,Natural)+                  10 -> (B,Flat)+                  11 -> (B,Natural)+                  _ -> error ("octpc_to_pitch: " ++ show pc)+    in Pitch n a o --- | Pitch classes not in set.-complement :: (Integral a) => [a] -> [a]-complement = difference [0..11]+octpc_nrm :: (Octave, PitchClass) -> (Octave, PitchClass)+octpc_nrm (o,pc) =+    if pc > 11+    then octpc_nrm (o+1,pc-12)+    else if pc < 0+         then octpc_nrm (o-1,pc+12)+         else (o,pc) --- | Is p a subsequence of q.-subsequence :: (Eq a) => [a] -> [a] -> Bool-subsequence = isInfixOf+octpc_trs :: Integer -> (Octave, PitchClass) -> (Octave, PitchClass)+octpc_trs n (o,pc) = octpc_nrm (o,pc+n) --- | The standard t-matrix of p.-tmatrix :: (Integral a) => [a] -> [[a]]-tmatrix p = map (`tn` p) (transposeTo 0 (invertSelf p))+octpc_to_midi :: (Octave, PitchClass) -> Integer+octpc_to_midi (o,pc) = 60 + ((o - 4) * 12) + pc --- | Interval class vector.-icv :: (Integral a) => [a] -> [a]-icv s =-    let i = map (ic . uncurry (-)) (dyads s)-        j = map f (group (sort i))-        k = map (`lookup` j) [1..6]-        f l = (head l, genericLength l)-    in map (fromMaybe 0) k+midi_to_octpc :: Integer -> (Octave, PitchClass)+midi_to_octpc n = (n - 12) `divMod` 12 --- | Is p a subset of q.-is_subset :: Eq a => [a] -> [a] -> Bool-is_subset p q = p `intersect` q == p+pitch_edit_octave :: (Integer -> Integer) -> Pitch -> Pitch+pitch_edit_octave f (Pitch n a o) = Pitch n a (f o) --- | Is p a superset of q.-is_superset :: Eq a => [a] -> [a] -> Bool-is_superset = flip is_subset+note_t_transpose :: Note_T -> Int -> Note_T+note_t_transpose x n =+    let x' = fromEnum x+        n' = fromEnum (maxBound::Note_T) + 1+    in toEnum ((x' + n) `mod` n')

@@ -0,0 +1,390 @@+module Music.Theory.Pitch.Name where++import Music.Theory.Pitch++c1,d1,e1,f1,g1,a1,b1 :: Pitch+c1 = Pitch C Natural 1+d1 = Pitch D Natural 1+e1 = Pitch E Natural 1+f1 = Pitch F Natural 1+g1 = Pitch G Natural 1+a1 = Pitch A Natural 1+b1 = Pitch B Natural 1++ces1,des1,ees1,fes1,ges1,aes1,bes1 :: Pitch+ces1 = Pitch C Flat 1+des1 = Pitch D Flat 1+ees1 = Pitch E Flat 1+fes1 = Pitch F Flat 1+ges1 = Pitch G Flat 1+aes1 = Pitch A Flat 1+bes1 = Pitch B Flat 1++cis1,dis1,eis1,fis1,gis1,ais1,bis1 :: Pitch+cis1 = Pitch C Sharp 1+dis1 = Pitch D Sharp 1+eis1 = Pitch E Sharp 1+fis1 = Pitch F Sharp 1+gis1 = Pitch G Sharp 1+ais1 = Pitch A Sharp 1+bis1 = Pitch B Sharp 1++c2,d2,e2,f2,g2,a2,b2 :: Pitch+c2 = Pitch C Natural 2+d2 = Pitch D Natural 2+e2 = Pitch E Natural 2+f2 = Pitch F Natural 2+g2 = Pitch G Natural 2+a2 = Pitch A Natural 2+b2 = Pitch B Natural 2++ces2,des2,ees2,fes2,ges2,aes2,bes2 :: Pitch+ces2 = Pitch C Flat 2+des2 = Pitch D Flat 2+ees2 = Pitch E Flat 2+fes2 = Pitch F Flat 2+ges2 = Pitch G Flat 2+aes2 = Pitch A Flat 2+bes2 = Pitch B Flat 2++cis2,dis2,eis2,fis2,gis2,ais2,bis2 :: Pitch+cis2 = Pitch C Sharp 2+dis2 = Pitch D Sharp 2+eis2 = Pitch E Sharp 2+fis2 = Pitch F Sharp 2+gis2 = Pitch G Sharp 2+ais2 = Pitch A Sharp 2+bis2 = Pitch B Sharp 2++cisis2,disis2,eisis2,fisis2,gisis2,aisis2,bisis2 :: Pitch+cisis2 = Pitch C DoubleSharp 2+disis2 = Pitch D DoubleSharp 2+eisis2 = Pitch E DoubleSharp 2+fisis2 = Pitch F DoubleSharp 2+gisis2 = Pitch G DoubleSharp 2+aisis2 = Pitch A DoubleSharp 2+bisis2 = Pitch B DoubleSharp 2++c3,d3,e3,f3,g3,a3,b3 :: Pitch+c3 = Pitch C Natural 3+d3 = Pitch D Natural 3+e3 = Pitch E Natural 3+f3 = Pitch F Natural 3+g3 = Pitch G Natural 3+a3 = Pitch A Natural 3+b3 = Pitch B Natural 3++ces3,des3,ees3,fes3,ges3,aes3,bes3 :: Pitch+ces3 = Pitch C Flat 3+des3 = Pitch D Flat 3+ees3 = Pitch E Flat 3+fes3 = Pitch F Flat 3+ges3 = Pitch G Flat 3+aes3 = Pitch A Flat 3+bes3 = Pitch B Flat 3++cis3,dis3,eis3,fis3,gis3,ais3,bis3 :: Pitch+cis3 = Pitch C Sharp 3+dis3 = Pitch D Sharp 3+eis3 = Pitch E Sharp 3+fis3 = Pitch F Sharp 3+gis3 = Pitch G Sharp 3+ais3 = Pitch A Sharp 3+bis3 = Pitch B Sharp 3++cisis3,disis3,eisis3,fisis3,gisis3,aisis3,bisis3 :: Pitch+cisis3 = Pitch C DoubleSharp 3+disis3 = Pitch D DoubleSharp 3+eisis3 = Pitch E DoubleSharp 3+fisis3 = Pitch F DoubleSharp 3+gisis3 = Pitch G DoubleSharp 3+aisis3 = Pitch A DoubleSharp 3+bisis3 = Pitch B DoubleSharp 3++ceseh3,deseh3,eeseh3,feseh3,geseh3,aeseh3,beseh3 :: Pitch+ceseh3 = Pitch C ThreeQuarterToneFlat 3+deseh3 = Pitch D ThreeQuarterToneFlat 3+eeseh3 = Pitch E ThreeQuarterToneFlat 3+feseh3 = Pitch F ThreeQuarterToneFlat 3+geseh3 = Pitch G ThreeQuarterToneFlat 3+aeseh3 = Pitch A ThreeQuarterToneFlat 3+beseh3 = Pitch B ThreeQuarterToneFlat 3++ceh3,deh3,eeh3,feh3,geh3,aeh3,beh3 :: Pitch+ceh3 = Pitch C QuarterToneFlat 3+deh3 = Pitch D QuarterToneFlat 3+eeh3 = Pitch E QuarterToneFlat 3+feh3 = Pitch F QuarterToneFlat 3+geh3 = Pitch G QuarterToneFlat 3+aeh3 = Pitch A QuarterToneFlat 3+beh3 = Pitch B QuarterToneFlat 3++cih3,dih3,eih3,fih3,gih3,aih3,bih3 :: Pitch+cih3 = Pitch C QuarterToneSharp 3+dih3 = Pitch D QuarterToneSharp 3+eih3 = Pitch E QuarterToneSharp 3+fih3 = Pitch F QuarterToneSharp 3+gih3 = Pitch G QuarterToneSharp 3+aih3 = Pitch A QuarterToneSharp 3+bih3 = Pitch B QuarterToneSharp 3++cisih3,disih3,eisih3,fisih3,gisih3,aisih3,bisih3 :: Pitch+cisih3 = Pitch C ThreeQuarterToneSharp 3+disih3 = Pitch D ThreeQuarterToneSharp 3+eisih3 = Pitch E ThreeQuarterToneSharp 3+fisih3 = Pitch F ThreeQuarterToneSharp 3+gisih3 = Pitch G ThreeQuarterToneSharp 3+aisih3 = Pitch A ThreeQuarterToneSharp 3+bisih3 = Pitch B ThreeQuarterToneSharp 3++c4,d4,e4,f4,g4,a4,b4 :: Pitch+c4 = Pitch C Natural 4+d4 = Pitch D Natural 4+e4 = Pitch E Natural 4+f4 = Pitch F Natural 4+g4 = Pitch G Natural 4+a4 = Pitch A Natural 4+b4 = Pitch B Natural 4++ces4,des4,ees4,fes4,ges4,aes4,bes4 :: Pitch+ces4 = Pitch C Flat 4+des4 = Pitch D Flat 4+ees4 = Pitch E Flat 4+fes4 = Pitch F Flat 4+ges4 = Pitch G Flat 4+aes4 = Pitch A Flat 4+bes4 = Pitch B Flat 4++cis4,dis4,eis4,fis4,gis4,ais4,bis4 :: Pitch+cis4 = Pitch C Sharp 4+dis4 = Pitch D Sharp 4+eis4 = Pitch E Sharp 4+fis4 = Pitch F Sharp 4+gis4 = Pitch G Sharp 4+ais4 = Pitch A Sharp 4+bis4 = Pitch B Sharp 4++ceses4,deses4,eeses4,feses4,geses4,aeses4,beses4 :: Pitch+ceses4 = Pitch C DoubleFlat 4+deses4 = Pitch D DoubleFlat 4+eeses4 = Pitch E DoubleFlat 4+feses4 = Pitch F DoubleFlat 4+geses4 = Pitch G DoubleFlat 4+aeses4 = Pitch A DoubleFlat 4+beses4 = Pitch B DoubleFlat 4++cisis4,disis4,eisis4,fisis4,gisis4,aisis4,bisis4 :: Pitch+cisis4 = Pitch C DoubleSharp 4+disis4 = Pitch D DoubleSharp 4+eisis4 = Pitch E DoubleSharp 4+fisis4 = Pitch F DoubleSharp 4+gisis4 = Pitch G DoubleSharp 4+aisis4 = Pitch A DoubleSharp 4+bisis4 = Pitch B DoubleSharp 4++ceseh4,deseh4,eeseh4,feseh4,geseh4,aeseh4,beseh4 :: Pitch+ceseh4 = Pitch C ThreeQuarterToneFlat 4+deseh4 = Pitch D ThreeQuarterToneFlat 4+eeseh4 = Pitch E ThreeQuarterToneFlat 4+feseh4 = Pitch F ThreeQuarterToneFlat 4+geseh4 = Pitch G ThreeQuarterToneFlat 4+aeseh4 = Pitch A ThreeQuarterToneFlat 4+beseh4 = Pitch B ThreeQuarterToneFlat 4++ceh4,deh4,eeh4,feh4,geh4,aeh4,beh4 :: Pitch+ceh4 = Pitch C QuarterToneFlat 4+deh4 = Pitch D QuarterToneFlat 4+eeh4 = Pitch E QuarterToneFlat 4+feh4 = Pitch F QuarterToneFlat 4+geh4 = Pitch G QuarterToneFlat 4+aeh4 = Pitch A QuarterToneFlat 4+beh4 = Pitch B QuarterToneFlat 4++cih4,dih4,eih4,fih4,gih4,aih4,bih4 :: Pitch+cih4 = Pitch C QuarterToneSharp 4+dih4 = Pitch D QuarterToneSharp 4+eih4 = Pitch E QuarterToneSharp 4+fih4 = Pitch F QuarterToneSharp 4+gih4 = Pitch G QuarterToneSharp 4+aih4 = Pitch A QuarterToneSharp 4+bih4 = Pitch B QuarterToneSharp 4++cisih4,disih4,eisih4,fisih4,gisih4,aisih4,bisih4 :: Pitch+cisih4 = Pitch C ThreeQuarterToneSharp 4+disih4 = Pitch D ThreeQuarterToneSharp 4+eisih4 = Pitch E ThreeQuarterToneSharp 4+fisih4 = Pitch F ThreeQuarterToneSharp 4+gisih4 = Pitch G ThreeQuarterToneSharp 4+aisih4 = Pitch A ThreeQuarterToneSharp 4+bisih4 = Pitch B ThreeQuarterToneSharp 4++c5,d5,e5,f5,g5,a5,b5 :: Pitch+c5 = Pitch C Natural 5+d5 = Pitch D Natural 5+e5 = Pitch E Natural 5+f5 = Pitch F Natural 5+g5 = Pitch G Natural 5+a5 = Pitch A Natural 5+b5 = Pitch B Natural 5++ces5,des5,ees5,fes5,ges5,aes5,bes5 :: Pitch+ces5 = Pitch C Flat 5+des5 = Pitch D Flat 5+ees5 = Pitch E Flat 5+fes5 = Pitch F Flat 5+ges5 = Pitch G Flat 5+aes5 = Pitch A Flat 5+bes5 = Pitch B Flat 5++cis5,dis5,eis5,fis5,gis5,ais5,bis5 :: Pitch+cis5 = Pitch C Sharp 5+dis5 = Pitch D Sharp 5+eis5 = Pitch E Sharp 5+fis5 = Pitch F Sharp 5+gis5 = Pitch G Sharp 5+ais5 = Pitch A Sharp 5+bis5 = Pitch B Sharp 5++ceses5,deses5,eeses5,feses5,geses5,aeses5,beses5 :: Pitch+ceses5 = Pitch C DoubleFlat 5+deses5 = Pitch D DoubleFlat 5+eeses5 = Pitch E DoubleFlat 5+feses5 = Pitch F DoubleFlat 5+geses5 = Pitch G DoubleFlat 5+aeses5 = Pitch A DoubleFlat 5+beses5 = Pitch B DoubleFlat 5++cisis5,disis5,eisis5,fisis5,gisis5,aisis5,bisis5 :: Pitch+cisis5 = Pitch C DoubleSharp 5+disis5 = Pitch D DoubleSharp 5+eisis5 = Pitch E DoubleSharp 5+fisis5 = Pitch F DoubleSharp 5+gisis5 = Pitch G DoubleSharp 5+aisis5 = Pitch A DoubleSharp 5+bisis5 = Pitch B DoubleSharp 5++ceseh5,deseh5,eeseh5,feseh5,geseh5,aeseh5,beseh5 :: Pitch+ceseh5 = Pitch C ThreeQuarterToneFlat 5+deseh5 = Pitch D ThreeQuarterToneFlat 5+eeseh5 = Pitch E ThreeQuarterToneFlat 5+feseh5 = Pitch F ThreeQuarterToneFlat 5+geseh5 = Pitch G ThreeQuarterToneFlat 5+aeseh5 = Pitch A ThreeQuarterToneFlat 5+beseh5 = Pitch B ThreeQuarterToneFlat 5++ceh5,deh5,eeh5,feh5,geh5,aeh5,beh5 :: Pitch+ceh5 = Pitch C QuarterToneFlat 5+deh5 = Pitch D QuarterToneFlat 5+eeh5 = Pitch E QuarterToneFlat 5+feh5 = Pitch F QuarterToneFlat 5+geh5 = Pitch G QuarterToneFlat 5+aeh5 = Pitch A QuarterToneFlat 5+beh5 = Pitch B QuarterToneFlat 5++cih5,dih5,eih5,fih5,gih5,aih5,bih5 :: Pitch+cih5 = Pitch C QuarterToneSharp 5+dih5 = Pitch D QuarterToneSharp 5+eih5 = Pitch E QuarterToneSharp 5+fih5 = Pitch F QuarterToneSharp 5+gih5 = Pitch G QuarterToneSharp 5+aih5 = Pitch A QuarterToneSharp 5+bih5 = Pitch B QuarterToneSharp 5++cisih5,disih5,eisih5,fisih5,gisih5,aisih5,bisih5 :: Pitch+cisih5 = Pitch C ThreeQuarterToneSharp 5+disih5 = Pitch D ThreeQuarterToneSharp 5+eisih5 = Pitch E ThreeQuarterToneSharp 5+fisih5 = Pitch F ThreeQuarterToneSharp 5+gisih5 = Pitch G ThreeQuarterToneSharp 5+aisih5 = Pitch A ThreeQuarterToneSharp 5+bisih5 = Pitch B ThreeQuarterToneSharp 5++c6,d6,e6,f6,g6,a6,b6 :: Pitch+c6 = Pitch C Natural 6+d6 = Pitch D Natural 6+e6 = Pitch E Natural 6+f6 = Pitch F Natural 6+g6 = Pitch G Natural 6+a6 = Pitch A Natural 6+b6 = Pitch B Natural 6++ces6,des6,ees6,fes6,ges6,aes6,bes6 :: Pitch+ces6 = Pitch C Flat 6+des6 = Pitch D Flat 6+ees6 = Pitch E Flat 6+fes6 = Pitch F Flat 6+ges6 = Pitch G Flat 6+aes6 = Pitch A Flat 6+bes6 = Pitch B Flat 6++cis6,dis6,eis6,fis6,gis6,ais6,bis6 :: Pitch+cis6 = Pitch C Sharp 6+dis6 = Pitch D Sharp 6+eis6 = Pitch E Sharp 6+fis6 = Pitch F Sharp 6+gis6 = Pitch G Sharp 6+ais6 = Pitch A Sharp 6+bis6 = Pitch B Sharp 6++ceseh6,deseh6,eeseh6,feseh6,geseh6,aeseh6,beseh6 :: Pitch+ceseh6 = Pitch C ThreeQuarterToneFlat 6+deseh6 = Pitch D ThreeQuarterToneFlat 6+eeseh6 = Pitch E ThreeQuarterToneFlat 6+feseh6 = Pitch F ThreeQuarterToneFlat 6+geseh6 = Pitch G ThreeQuarterToneFlat 6+aeseh6 = Pitch A ThreeQuarterToneFlat 6+beseh6 = Pitch B ThreeQuarterToneFlat 6++ceh6,deh6,eeh6,feh6,geh6,aeh6,beh6 :: Pitch+ceh6 = Pitch C QuarterToneFlat 6+deh6 = Pitch D QuarterToneFlat 6+eeh6 = Pitch E QuarterToneFlat 6+feh6 = Pitch F QuarterToneFlat 6+geh6 = Pitch G QuarterToneFlat 6+aeh6 = Pitch A QuarterToneFlat 6+beh6 = Pitch B QuarterToneFlat 6++cih6,dih6,eih6,fih6,gih6,aih6,bih6 :: Pitch+cih6 = Pitch C QuarterToneSharp 6+dih6 = Pitch D QuarterToneSharp 6+eih6 = Pitch E QuarterToneSharp 6+fih6 = Pitch F QuarterToneSharp 6+gih6 = Pitch G QuarterToneSharp 6+aih6 = Pitch A QuarterToneSharp 6+bih6 = Pitch B QuarterToneSharp 6++cisih6,disih6,eisih6,fisih6,gisih6,aisih6,bisih6 :: Pitch+cisih6 = Pitch C ThreeQuarterToneSharp 6+disih6 = Pitch D ThreeQuarterToneSharp 6+eisih6 = Pitch E ThreeQuarterToneSharp 6+fisih6 = Pitch F ThreeQuarterToneSharp 6+gisih6 = Pitch G ThreeQuarterToneSharp 6+aisih6 = Pitch A ThreeQuarterToneSharp 6+bisih6 = Pitch B ThreeQuarterToneSharp 6++c7,d7,e7,f7,g7,a7,b7 :: Pitch+c7 = Pitch C Natural 7+d7 = Pitch D Natural 7+e7 = Pitch E Natural 7+f7 = Pitch F Natural 7+g7 = Pitch G Natural 7+a7 = Pitch A Natural 7+b7 = Pitch B Natural 7++ces7,des7,ees7,fes7,ges7,aes7,bes7 :: Pitch+ces7 = Pitch C Flat 7+des7 = Pitch D Flat 7+ees7 = Pitch E Flat 7+fes7 = Pitch F Flat 7+ges7 = Pitch G Flat 7+aes7 = Pitch A Flat 7+bes7 = Pitch B Flat 7++cis7,dis7,eis7,fis7,gis7,ais7,bis7 :: Pitch+cis7 = Pitch C Sharp 7+dis7 = Pitch D Sharp 7+eis7 = Pitch E Sharp 7+fis7 = Pitch F Sharp 7+gis7 = Pitch G Sharp 7+ais7 = Pitch A Sharp 7+bis7 = Pitch B Sharp 7

@@ -0,0 +1,205 @@+module Music.Theory.PitchClass where++import Music.Theory.Set+import Data.Maybe+import Data.List++-- | Modulo twelve.+mod12 :: (Integral a) => a -> a+mod12 = (`mod` 12)++-- | Pitch class.+pc :: (Integral a) => a -> a+pc = mod12++-- | Map to pitch-class and reduce to set.+pcset :: (Integral a) => [a] -> [a]+pcset = set . map pc++-- | Transpose by n.+tn :: (Integral a) => a -> [a] -> [a]+tn n = map (pc . (+ n))++-- | Transpose so first element is n.+transposeTo :: (Integral a) => a -> [a] -> [a]+transposeTo _ [] = []+transposeTo n (x:xs) = n : tn (n - x) xs++-- | All transpositions.+transpositions :: (Integral a) => [a] -> [[a]]+transpositions p = map (`tn` p) [0..11]++-- | Invert about n.+invert :: (Integral a) => a -> [a] -> [a]+invert n = map (pc . (\p -> n - (p - n)))++-- | Invert about first element.+invertSelf :: (Integral a) => [a] -> [a]+invertSelf [] = []+invertSelf (x:xs) = invert x (x:xs)++-- | Composition of inversion about zero and transpose.+tni :: (Integral a) => a -> [a] -> [a]+tni n = tn n . invert 0++-- | Rotate left by n places.+rotate :: (Integral n) => n -> [a] -> [a]+rotate n p =+    let m = n `mod` genericLength p+        (b, a) = genericSplitAt m p+    in a ++ b++-- | Rotate right by n places.+rotate_right :: (Integral n) => n -> [a] -> [a]+rotate_right = rotate . negate++-- | All rotations.+rotations :: [a] -> [[a]]+rotations p = map (`rotate` p) [0 .. length p - 1]++-- | Modulo 12 multiplication+mn :: (Integral a) => a -> [a] -> [a]+mn n = map (pc . (* n))++-- | M5+m5 :: (Integral a) => [a] -> [a]+m5 = mn 5++all_Tn :: (Integral a) => [a] -> [[a]]+all_Tn p = map (`tn` p) [0..11]++all_TnI :: (Integral a) => [a] -> [[a]]+all_TnI p =+    let ps = all_Tn p +    in ps ++ map (invert 0) ps++all_RTnI :: (Integral a) => [a] -> [[a]]+all_RTnI p =+    let ps = all_TnI p+    in ps ++ map reverse ps++all_rR :: (Integral a) => [a] -> [[a]]+all_rR p = rotations p ++ rotations (reverse p)++all_rRTnI :: (Integral a) => [a] -> [[a]]+all_rRTnI p =+    let ps = all_RTnI p+    in ps ++ concatMap rotations ps++all_TnMI :: (Integral a) => [a] -> [[a]]+all_TnMI p =+    let ps = all_TnI p+    in ps ++ map m5 ps++all_RTnMI :: (Integral a) => [a] -> [[a]]+all_RTnMI p =+    let ps = all_TnMI p+    in ps ++ map reverse ps++all_rRTnMI :: (Integral a) => [a] -> [[a]]+all_rRTnMI = map snd . sros++-- | Serial Operator, of the form rRTMI.+data SRO a = SRO a Bool a Bool Bool+             deriving (Eq, Show)++-- | Serial operation.+sro :: (Integral a) => SRO a -> [a] -> [a]+sro (SRO r r' t m i) x =+    let x1 = if i then invert 0 x else x+        x2 = if m then m5 x1 else x1+        x3 = tn t x2+        x4 = if r' then reverse x3 else x3+    in rotate r x4++-- | The total set of serial operations.+sros :: (Integral a) => [a] -> [(SRO a, [a])]+sros x = [ let o = (SRO r r' t m i) in (o, sro o x) | +           r <- [0 .. genericLength x - 1], +           r' <- [False, True], +           t <- [0 .. 11], +           m <- [False, True], +           i <- [False, True] ]++sro_Tn :: (Integral a) => [SRO a]+sro_Tn = [ SRO 0 False n False False | +           n <- [0..11] ]++sro_TnI :: (Integral a) => [SRO a]+sro_TnI = [ SRO 0 False n False i | +            n <- [0..11], +            i <- [False, True] ]++sro_RTnI :: (Integral a) => [SRO a]+sro_RTnI = [ SRO 0 r n False i | +             r <- [True, False],+             n <- [0..11], +             i <- [False, True] ] ++sro_TnMI :: (Integral a) => [SRO a]+sro_TnMI = [ SRO 0 False n m i | +             n <- [0..11], +             m <- [True, False], +             i <- [True, False] ]++sro_RTnMI :: (Integral a) => [SRO a]+sro_RTnMI = [ SRO 0 r n m i | +              r <- [True, False],+              n <- [0..11],+              m <- [True, False],+              i <- [True, False] ]++-- | Intervals to values, zero is n.+dx_d :: (Num a) => a -> [a] -> [a]+dx_d = scanl (+)++-- | Integrate.+d_dx :: (Num a) => [a] -> [a]+d_dx [] = []+d_dx (_:[]) = []+d_dx (x:xs) = zipWith (-) xs (x:xs)++-- | Morris INT operator.+int :: (Integral a) => [a] -> [a]+int = map mod12 . d_dx++-- | Interval class.+ic :: (Integral a) => a -> a+ic i =+    let i' = mod12 i+    in if i' <= 6 then i' else 12 - i'++-- | Elements of p not in q+difference :: (Eq a) => [a] -> [a] -> [a]+difference p q =+    let f e = e `notElem` q+    in filter f p++-- | Pitch classes not in set.+complement :: (Integral a) => [a] -> [a]+complement = difference [0..11]++-- | Is p a subsequence of q.+subsequence :: (Eq a) => [a] -> [a] -> Bool+subsequence = isInfixOf++-- | The standard t-matrix of p.+tmatrix :: (Integral a) => [a] -> [[a]]+tmatrix p = map (`tn` p) (transposeTo 0 (invertSelf p))++-- | Interval class vector.+icv :: (Integral a) => [a] -> [a]+icv s =+    let i = map (ic . uncurry (-)) (dyads s)+        j = map f (group (sort i))+        k = map (`lookup` j) [1..6]+        f l = (head l, genericLength l)+    in map (fromMaybe 0) k++-- | Is p a subset of q.+is_subset :: Eq a => [a] -> [a] -> Bool+is_subset p q = p `intersect` q == p++-- | Is p a superset of q.+is_superset :: Eq a => [a] -> [a] -> Bool+is_superset = flip is_subset

@@ -5,7 +5,7 @@  import Data.Bits import Data.List-import Music.Theory.Pitch+import Music.Theory.PitchClass  -- | Prime form rule requiring comparator. cmp_prime :: (Integral a) => ([a] -> [a] -> Ordering) -> [a] -> [a]

@@ -7,14 +7,14 @@ set :: (Ord a) => [a] -> [a] set = sort . nub --- | Powerset, ie. set of all all subsets.+-- | Powerset, ie. set of all subsets. powerset :: [a] -> [[a]] powerset = filterM (const [True, False])  -- | Two element subsets (cf [2] . powerset). dyads :: [a] -> [(a,a)] dyads [] = []-dyads (x:xs) = dyads xs ++ [ (x,y) | y <- xs ]+dyads (x:xs) = [(x,y) | y <- xs] ++ dyads xs  -- | Set expansion se :: (Ord a) => Int -> [a] -> [[a]]

@@ -0,0 +1,88 @@+module Music.Theory.Spelling where++import Music.Theory.Interval+import Music.Theory.Pitch++pc_spell_natural :: PitchClass -> (Note_T, Alteration_T)+pc_spell_natural pc =+    case pc of+      0 -> (C,Natural)+      2 -> (D,Natural)+      4 -> (E,Natural)+      5 -> (F,Natural)+      7 -> (G,Natural)+      9 -> (A,Natural)+      11 -> (B,Natural)+      _ -> error ("pc_spell_natural: " ++ show pc)++-- use spelling from simplest key-signature+-- ambiguous for 8 (G#/Ab)+pc_spell_ks :: PitchClass -> (Note_T, Alteration_T)+pc_spell_ks pc =+    case pc of+      1 -> (C,Sharp) -- 2#+      3 -> (E,Flat) -- 3b+      6 -> (F,Sharp) -- 1#+      8 -> (A,Flat) -- 3b/3#+      10 -> (B,Flat) -- 1b+      _ -> pc_spell_natural pc++pc_spell_sharp :: PitchClass -> (Note_T, Alteration_T)+pc_spell_sharp pc =+    case pc of+      1 -> (C,Sharp)+      3 -> (D,Sharp)+      6 -> (F,Sharp)+      8 -> (G,Sharp)+      10 -> (A,Sharp)+      _ -> pc_spell_natural pc++pc_spell_flat :: PitchClass -> (Note_T, Alteration_T)+pc_spell_flat pc =+    case pc of+      1 -> (D,Sharp)+      3 -> (E,Flat)+      6 -> (G,Flat)+      8 -> (A,Flat)+      10 -> (B,Flat)+      _ -> pc_spell_natural pc++-- ambiguous for 6 (aug.4,dim.5)+i_to_interval :: Int -> Interval+i_to_interval x =+    let iv ty qu = Interval ty qu LT 0+    in case x of+         0 -> iv Unison Perfect+         1 -> iv Second Minor+         2 -> iv Second Major+         3 -> iv Third Minor+         4 -> iv Third Major+         5 -> iv Fourth Perfect+         6 -> iv Fourth Augmented -- Fifth Diminished+         7 -> iv Fifth Perfect+         8 -> iv Sixth Minor+         9 -> iv Sixth Major+         10 -> iv Seventh Minor+         11 -> iv Seventh Major+         _ -> error ("i_to_interval: " ++ show x)++-- for non-tonal music some spellings are poor, ie. (f,g#)+interval_simplify :: Interval -> Interval+interval_simplify x =+    let (Interval ty qu d o) = x+        (qu',ty') = case (qu,ty) of+                     (Diminished,Second) -> (Perfect,Unison)+                     (Diminished,Third) -> (Major,Second)+                     (Augmented,Second) -> (Minor,Third)+                     (Augmented,Third) -> (Perfect,Fourth)+                     (Diminished,Sixth) -> (Perfect,Fifth)+                     (Diminished,Seventh) -> (Major,Sixth)+                     (Augmented,Sixth) -> (Minor,Seventh)+                     -- (Augmented,Seventh) -> (Perfect,Octave)+                     _ -> (qu,ty)+    in Interval ty' qu' d o++{-+map pc_spell_ks [0..11]+map i_to_interval [0..11]+-}

@@ -0,0 +1,198 @@+module Music.Theory.Tuning where++import Data.List+import Data.Ratio++type Approximate_Ratio = Double+type Cents = Double++-- | Harmonic series (folded)+harmonic_series_folded :: Integer -> [Rational]+harmonic_series_folded n =+    let hs = (zipWith (%) (repeat 1) [1..n])+        fold x = if x >= 0.5+                 then x+                 else fold (x * 2)+    in nub (sort (map fold hs))++-- | Pythagorean tuning+pythagorean_r :: [Rational]+pythagorean_r =+    [1%1,243%256 {- 2048%2187 -}+    ,8%9,27%32+    ,64%81+    ,3%4,512%729+    ,2%3,81%128+    ,16%27,9%16+    ,128%243+    ,1%2]++-- | Pythagorean tuning+pythagorean_c :: [Cents]+pythagorean_c = map (to_cents.approximate_ratio) pythagorean_r++-- | Werckmeister III, Andreas Werckmeister (1645-1706)+werckmeister_iii_ar :: [Approximate_Ratio]+werckmeister_iii_ar =+    let c0 = 2 ** (1/2)+        c1 = 2 ** (1/4)+        c2 = 8 ** (1/4)+    in [1,256/243+       ,64/81 * c0,32/27+       ,256/243 * c1+       ,4/3,1024/729+       ,8/9 * c2,128/81+       ,1024/729 * c1,16/9+       ,128/81 * c1]++-- | Werckmeister III, Andreas Werckmeister (1645-1706)+werckmeister_iii_c :: [Cents]+werckmeister_iii_c = map to_cents werckmeister_iii_ar++-- | Werckmeister IV, Andreas Werckmeister (1645-1706)+werckmeister_iv_ar :: [Approximate_Ratio]+werckmeister_iv_ar =+    let c0 = 2 ** (1/3)+        c1 = 4 ** (1/3)+    in [1,16384/19683 * c0+       ,8/9 * c0,32/27+       ,64/81 * c1+       ,4/3,1024/729+       ,32/27 * c0,8192/6561 * c0+       ,256/243 * c1,9/(4*c0)+       ,4096/2187]++-- | Werckmeister IV, Andreas Werckmeister (1645-1706)+werckmeister_iv_c :: [Cents]+werckmeister_iv_c = map to_cents werckmeister_iv_ar++-- | Werckmeister V, Andreas Werckmeister (1645-1706)+werckmeister_v_ar :: [Approximate_Ratio]+werckmeister_v_ar =+    let c0 = 2 ** (1/4)+        c1 = 2 ** (1/2)+        c2 = 8 ** (1/4)+    in [1,8/9 * c0+       ,9/8,c0+       ,8/9 * c1+       ,9/8 * c0,c1+       ,3/2,128/81+       ,c2,3/c2+       ,4/3 * c1]++-- | Werckmeister V, Andreas Werckmeister (1645-1706)+werckmeister_v_c :: [Cents]+werckmeister_v_c = map to_cents werckmeister_v_ar++-- | Werckmeister VI, Andreas Werckmeister (1645-1706)+werckmeister_vi_r :: [Rational]+werckmeister_vi_r =+    [1,98%93+    ,28%25,196%165+    ,49%39+    ,4%3,196%139+    ,196%131,49%31+    ,196%117,98%55+    ,49%26]++-- | Werckmeister VI, Andreas Werckmeister (1645-1706)+werckmeister_vi_c :: [Cents]+werckmeister_vi_c = map (to_cents.approximate_ratio) werckmeister_vi_r++-- | Pietro Aaron (1523) - Meantone temperament+pietro_aaron_1523_c :: [Cents]+pietro_aaron_1523_c =+    [0,76.0+    ,193.2,310.3+    ,386.3+    ,503.4,579.5+    ,696.8,772.6+    ,889.7,1006.8+    ,1082.9+    ,1200]++-- | Thomas Young (1799) - Well Temperament+thomas_young_1799_c :: [Cents]+thomas_young_1799_c =+    [0,93.9+    ,195.8,297.8+    ,391.7+    ,499.9,591.9+    ,697.9,795.8+    ,893.8,999.8+    ,1091.8+    ,1200]++-- | Five-limit tuning+five_limit_tuning_r :: [Rational]+five_limit_tuning_r =+    [1%1,15%16+    ,8%9,5%6+    ,4%5+    ,3%4,32%45+    ,2%3,5%8+    ,3%5,9%16+    ,8%15+    ,1%2]++five_limit_tuning_c :: [Cents]+five_limit_tuning_c = map (to_cents.approximate_ratio) five_limit_tuning_r++equal_temperament_c :: [Cents]+equal_temperament_c = [0, 100 .. 1200]++mk_isomorphic_layout :: Integral a => a -> a -> (a,a) -> [[(a,a)]]+mk_isomorphic_layout n_row n_col top_left =+    let (a,b) `plus` (c,d) = (a+c,b+d)+        mk_seq 0 _ _ = []+        mk_seq n i z = z : mk_seq (n-1) i (z `plus` i)+        left = mk_seq n_row (-1,1) top_left+    in map (\i -> mk_seq n_col (-1,2) i) left++rank_two_regular_temperament :: Integral a => a -> a -> [(a,a)] -> [a]+rank_two_regular_temperament a b =+    map (\(a', b') -> a * a' + b * b')++mk_syntonic_tuning :: Int -> [Cents]+mk_syntonic_tuning b =+  let l = mk_isomorphic_layout 5 7 (3,-4)+      t = map (rank_two_regular_temperament 1200 b) l+  in nub (sort (map (\x -> fromIntegral (x `mod` 1200)) (concat t)))++syntonic_697_c :: [Cents]+syntonic_697_c = mk_syntonic_tuning 697++syntonic_702_c :: [Cents]+syntonic_702_c = mk_syntonic_tuning 702++syntonic_comma :: Rational+syntonic_comma = 81 % 80++-- ie. 3^12 % 2^19+pythagorean_comma :: Rational+pythagorean_comma = 531441 % 524288++-- ie. 3^53 % 2^84+mercators_comma :: Rational+mercators_comma = 19383245667680019896796723 % 19342813113834066795298816++approximate_ratio :: Rational -> Approximate_Ratio+approximate_ratio = fromRational++to_cents :: Approximate_Ratio -> Cents+to_cents x = 1200 * logBase 2 x++nth_root :: (Floating a) => a -> a -> a+nth_root n x =+    let f (_,x0) = (x0, ((n-1)*x0+x/x0**(n-1))/n)+        e = uncurry (==)+    in fst (until e f (x, x/n))++twelve_tone_equal_temperament_comma :: (Floating a) => a+twelve_tone_equal_temperament_comma = 12 `nth_root` 2++minimal_isomorphic_note_layout :: [[(Int,Int)]]+minimal_isomorphic_note_layout =+    [[(3,-4),(2,-2),(1,0),(0,2),(-1,4)]+       ,[(2,-3),(1,-1),(0,1),(-1,3)]+    ,[(2,-4),(1,-2),(0,0),(-1,2),(-2,4)]]

@@ -1,7 +1,8 @@ hmt - haskell music theory  Music theory operations in haskell, primarily-focussed on 'set theory'.+focused on 'set theory' and 'common music+notation'. -(c) rohan drape, 2006-2010+(c) rohan drape, 2006-2011     gpl, http://gnu.org/copyleft/

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain

@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain

@@ -1,15 +1,15 @@ Name:              hmt-Version:           0.2+Version:           0.3 Synopsis:          Haskell Music Theory Description:       Haskell music theory library License:           GPL Category:          Music-Copyright:         Rohan Drape, 2006-2010+Copyright:         Rohan Drape, 2006-2011 Author:            Rohan Drape Maintainer:        rd@slavepianos.org Stability:         Experimental Homepage:          http://slavepianos.org/rd/?t=hmt-Tested-With:       GHC == 6.10.3+Tested-With:       GHC == 6.12.1 Build-Type:        Simple Cabal-Version:     >= 1.6 @@ -19,17 +19,29 @@ Library   Build-Depends:   base == 4.*,                    containers,+                   multiset-comb,                    parsec,-                   permutation+                   permutation,+                   split   GHC-Options:     -Wall -fwarn-tabs-  Exposed-modules: Music.Theory+  Exposed-modules: Music.Theory.Bjorklund+                   Music.Theory.Contour.Polansky_1992+                   Music.Theory.Duration+                   Music.Theory.Duration.Name+                   Music.Theory.Duration.Sequence.Notate+                   Music.Theory.Interval+                   Music.Theory.Key                    Music.Theory.Parse                    Music.Theory.Pct+                   Music.Theory.Permutations                    Music.Theory.Pitch+                   Music.Theory.Pitch.Name+                   Music.Theory.PitchClass                    Music.Theory.Prime                    Music.Theory.Set+                   Music.Theory.Spelling                    Music.Theory.Table-                   Music.Theory.Permutations+                   Music.Theory.Tuning  Source-Repository  head   Type:            darcs