packages feed

hmt 0.11 → 0.12

raw patch · 63 files changed

+7096/−2000 lines, 63 filesdep +bytestringdep +directorydep +filepathdep −cairodep ~hcg-minusdep ~html-minimalist

Dependencies added: bytestring, directory, filepath, logict, primes

Dependencies removed: cairo

Dependency ranges changed: hcg-minus, html-minimalist

Files

+ Music/Theory/Block_Design/Johnson_2007.hs view
@@ -0,0 +1,107 @@+-- | Tom Johnson. \"Networks\". In Conference on Mathematics and+-- Computation in Music, Berlin, May 2007.+module Music.Theory.Block_Design.Johnson_2007 where++import Control.Arrow+import Data.List+import qualified Music.Theory.List as L++-- * Designs++data Design i = Design [i] [[i]]++-- * Johnson (7,3,1), (13,4,1) and (12,4,3)++-- > c_7_3_1 == [1,3,4,2,7,6,5]+c_7_3_1 :: (Num i) => [i]+c_7_3_1 = [1,3,4,2,7,6,5]++-- > b_7_3_1 == ([[1,2,3],[3,4,7],[2,4,6],[2,5,7],[1,6,7],[3,5,6],[1,4,5]]+-- >            ,[[1,2,4],[2,3,7],[4,6,7],[2,5,6],[1,5,7],[1,3,6],[3,4,5]])+b_7_3_1 :: (Ord i,Num i) => ([[i]], [[i]])+b_7_3_1 =+    let c = c_7_3_1+        f i (j1,j2) = sort [i,j1,j2]+    in (zipWith f (L.rotate_left 3 c) (L.adj2_cyclic 1 c)+       ,zipWith f c (L.adj2_cyclic 1 (L.rotate_left 2 c)))++d_7_3_1 :: (Enum n,Ord n,Num n) => (Design n,Design n)+d_7_3_1 = let d = Design [1..7] in (d *** d) b_7_3_1++-- > length n_7_3_1 == 7 && sort n_7_3_1 == n_7_3_1+n_7_3_1 :: Num i => [(i,i)]+n_7_3_1 = [(3,4),(3,11),(4,1),(4,3),(4,5),(4,7),(5,2)]++-- > Music.Theory.List.histogram (concat p_9_3_1) == [(1,4),(2,4),(3,4),(4,4),(5,4),(6,4),(7,4),(8,4),(9,4)]+p_9_3_1 :: Num i => [[i]]+p_9_3_1 = [[1,8,9],[2,3,5],[4,6,7],[1,4,5],[2,6,8],[3,7,9],[1,2,7],[3,4,8],[5,6,9],[1,3,6],[2,4,9],[5,7,8]]++-- > b_13_4_1 == ([[1,2,4,10],[2,3,5,11],[3,4,6,12],[4,5,7,13],[1,5,6,8],[2,6,7,9],[3,7,8,10],[4,8,9,11],[5,9,10,12],[6,10,11,13],[1,7,11,12],[2,8,12,13]]+-- >             ,[[4,8,9,11],[5,9,10,12],[6,10,11,13],[1,7,11,12],[2,8,12,13],[1,3,9,13],[1,2,4,10],[2,3,5,11],[3,4,6,12],[4,5,7,13],[1,5,6,8],[2,6,7,9]])+b_13_4_1 :: (Enum i,Num i,Ord i) => ([[i]], [[i]])+b_13_4_1 =+    let c = [1..13]+        c' = L.rotate_left 7 c+        d = L.interleave_rotations 9 3 c+        e = L.interleave_rotations 3 10 c+        f (i1,i2) (j1,j2) = sort [i1,i2,j1,j2]+    in (zipWith f (L.adj2 1 c) (L.adj2 2 d)+       ,zipWith f (L.adj2 1 c') (L.adj2 2 e))++d_13_4_1 :: (Enum n,Ord n,Num n) => (Design n,Design n)+d_13_4_1 = let d = Design [1..13] in (d *** d) b_13_4_1++-- > length n_13_4_1 == 13 && sort n_13_4_1 == n_13_4_1+n_13_4_1 :: Num i => [(i,i)]+n_13_4_1 = [(3,0),(3,2),(3,5),(3,7),(3,10),(4,0),(4,3),(4,5),(4,8),(4,10),(5,1),(5,3),(5,6)]++-- > histogram (concat b_12_4_3) == [(1,11),(2,11),(3,11),(4,11),(5,11),(6,11),(7,11),(8,11),(9,11),(10,11),(11,11),(12,11)]+-- > histogram (map (sort.concat) (chunksOf 3 b_12_4_3)) == [([1,2,3,4,5,6,7,8,9,10,11,12],11)]+-- > map length (adj_intersect 1 b_12_4_3) == [0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0]+-- > map (map length . adj_intersect 1) (cycles 3 b_12_4_3) == [[1,1,1,1,1,1,1,1,1,1],[2,2,2,2,2,2,2,2,2,2],[1,1,1,1,1,1,1,1,1,1]]+-- > map adj_intersect 1 (cycles 3 b_12_4_3) == [[[12],[12],[12],[12],[12],[12],[12],[12],[12],[12]]+-- >                                            ,[[8,9],[7,8],[6,7],[5,6],[4,5],[3,4],[2,3],[1,2],[1,11],[10,11]]+-- >                                            ,[[3],[2],[1],[11],[10],[9],[8],[7],[6],[5]]]+b_12_4_3 :: Integral i => [[i]]+b_12_4_3 =+    [[1,5,7,12]+    ,[2,8,9,10]+    ,[3,4,6,11]+    ,[4,6,11,12]+    ,[1,7,8,9]+    ,[2,3,5,10]+    ,[3,5,10,12]+    ,[6,7,8,11]+    ,[1,2,4,9]+    ,[2,4,9,12]+    ,[5,6,7,10]+    ,[1,3,8,11]+    ,[1,3,8,12]+    ,[4,5,6,9]+    ,[2,7,10,11]+    ,[2,7,11,12]+    ,[3,4,5,8]+    ,[1,6,9,10]+    ,[1,6,10,12]+    ,[2,3,4,7]+    ,[5,8,9,11]+    ,[5,9,11,12]+    ,[1,2,3,6]+    ,[4,7,8,10]+    ,[4,8,10,12]+    ,[1,2,5,11]+    ,[3,6,7,9]+    ,[3,7,9,12]+    ,[1,4,10,11]+    ,[2,5,6,8]+    ,[2,6,8,12]+    ,[3,9,10,11]+    ,[1,4,5,7]]++-- > length n_12_4_3 == 12 && sort n_12_4_3 == n_12_4_3+n_12_4_3 :: Num i => [(i,i)]+n_12_4_3 = [(3,2),(3,5),(3,6),(3,9),(3,10),(4,1),(4,4),(4,7),(4,8),(4,11),(5,0),(5,3)]++-- Local Variables:+-- truncate-lines:t+-- End:
+ Music/Theory/Clef.hs view
@@ -0,0 +1,44 @@+-- | Common music notation clefs.+module Music.Theory.Clef where++import Music.Theory.Pitch+import Music.Theory.Pitch.Name++-- | Clef enumeration type.+data Clef_T = Bass | Tenor | Alto | Treble | Percussion+              deriving (Eq,Ord,Show)++-- | Clef with octave offset.+data Integral i => Clef i = Clef {clef_t :: Clef_T+                                 ,clef_octave :: i}+                            deriving (Eq,Ord,Show)++-- | Give clef range as a 'Pitch' pair indicating the notes below and+-- above the staff.+--+-- > map clef_range [Treble,Bass] == [Just (d4,g5),Just (f2,b3)]+-- > clef_range Percussion == Nothing+clef_range :: Clef_T -> Maybe (Pitch,Pitch)+clef_range c =+    case c of+      Bass -> Just (f2,b3)+      Tenor -> Just (c3,f4)+      Alto -> Just (e3,a4)+      Treble -> Just (d4,g5)+      Percussion -> Nothing++-- | Suggest a 'Clef' given a 'Pitch'.+--+-- > map clef_suggest [c2,c4] == [Clef Bass (-1),Clef Treble 0]+clef_suggest :: Integral i => Pitch -> Clef i+clef_suggest p | p < f1 = Clef Bass (-2)+               | p < f2 = Clef Bass (-1)+               | p < b3 = Clef Bass 0+               | p < g5 = Clef Treble 0+               | p < g6 = Clef Treble 1+               | otherwise = Clef Treble 2++-- | Set 'clef_octave' to @0@.+clef_zero :: Integral i => Clef i -> Clef i+clef_zero (Clef c_t _) = Clef c_t 0+
+ Music/Theory/Combinations.hs view
@@ -0,0 +1,21 @@+-- | Combination functions.+module Music.Theory.Combinations where++import Music.Theory.Permutations++-- | Number of /k/ element combinations of a set of /n/ elements.+--+-- > (nk_combinations 6 3,nk_combinations 13 3) == (20,286)+nk_combinations :: Integral a => a -> a -> a+nk_combinations n k = nk_permutations n k `div` factorial k++-- | /k/ element subsets of /s/.+--+-- > combinations 3 [1..4] == [[1,2,3],[1,2,4],[1,3,4],[2,3,4]]+-- > length (combinations 3 [1..5]) == nk_combinations 5 3+combinations :: Integral t => t -> [a] -> [[a]]+combinations k s =+    case (k,s) of+      (0,_) -> [[]]+      (_,[]) -> []+      (_,e:s') -> map (e :) (combinations (k - 1) s') ++ combinations k s'
Music/Theory/Contour/Polansky_1992.hs view
@@ -5,19 +5,83 @@ module Music.Theory.Contour.Polansky_1992 where  import Data.List-import Data.List.Split-import qualified Data.Map as M+import Data.List.Split {- split -}+import qualified Data.Map as M {- containers -} import Data.Maybe import Data.Ratio-import qualified Music.Theory.Set as T-import qualified Music.Theory.Permutations as T+import qualified Music.Theory.Set.List as S+import qualified Music.Theory.Permutations.List as P --- | Compare adjacent elements (p.262).+-- * List functions++-- | Replace the /i/th value at /ns/ with /x/. --+-- > replace "test" 2 'n' == "tent"+replace :: Integral i => [a] -> i -> a -> [a]+replace ns i x =+    let f j y = if i == j then x else y+    in zipWith f [0..] ns++-- | Are all elements equal.+--+-- > all_equal "aaa" == True+all_equal :: Eq a => [a] -> Bool+all_equal xs = all id (zipWith (==) xs (tail xs))++-- * Indices++-- | Compare adjacent elements (p.262) left to right.+-- -- > compare_adjacent [0,1,3,2] == [LT,LT,GT] compare_adjacent :: Ord a => [a] -> [Ordering] compare_adjacent xs = zipWith compare xs (tail xs) +-- | Construct set of /n/ '-' @1@ adjacent indices, left right order.+--+-- > adjacent_indices 5 == [(0,1),(1,2),(2,3),(3,4)]+adjacent_indices :: Integral i => i -> [(i,i)]+adjacent_indices n = zip [0..n-2] [1..n-1]++-- | All /(i,j)/ indices, in half matrix order.+--+-- > all_indices 4 == [(0,1),(0,2),(0,3),(1,2),(1,3),(2,3)]+all_indices :: Integral i => i -> [(i,i)]+all_indices n =+    let n' = n - 1+    in [(i,j) | i <- [0 .. n'], j <- [i + 1 .. n']]++-- * 'Enum' functions++-- | Generic variant of 'fromEnum' (p.263).+genericFromEnum :: (Integral i,Enum e) => e -> i+genericFromEnum = fromIntegral . fromEnum++-- | Generic variant of 'toEnum' (p.263).+genericToEnum :: (Integral i,Enum e) => i -> e+genericToEnum = toEnum . fromIntegral++-- * 'Ordering' functions++-- | Specialised 'genericFromEnum'.+ord_to_int :: Integral a => Ordering -> a+ord_to_int = genericFromEnum++-- | Specialised 'genericToEnum'.+int_to_ord :: Integral a => a -> Ordering+int_to_ord = genericToEnum++-- | Invert 'Ordering'.+--+-- > map ord_invert [LT,EQ,GT] == [GT,EQ,LT]+ord_invert :: Ordering -> Ordering+ord_invert x =+    case x of+      LT -> GT+      EQ -> EQ+      GT -> LT++-- * Matrix+ -- | A list notation for matrices. type Matrix a = [[a]] @@ -38,6 +102,8 @@ contour_matrix :: Ord a => [a] -> Matrix Ordering contour_matrix = matrix_f compare +-- * Half matrix+ -- | Half matrix notation for contour. data Contour_Half_Matrix =     Contour_Half_Matrix {contour_half_matrix_n :: Int@@ -70,13 +136,7 @@ instance Show Contour_Half_Matrix where     show = contour_half_matrix_str --- | Generic variant of 'fromEnum' (p.263).-ord_to_int :: Integral a => Ordering -> a-ord_to_int = fromIntegral . fromEnum---- | Generic variant of 'toEnum' (p.263).-int_to_ord :: Integral a => a -> Ordering-int_to_ord = toEnum . fromIntegral+-- * Contour description  -- | /Description/ notation of contour. data Contour_Description =@@ -84,23 +144,10 @@                         ,contour_description_m :: M.Map (Int,Int) Ordering}     deriving (Eq) --- | Construct set of /n/-1 adjacent indices.------ > adjacent_indices 5 == [(0,1),(1,2),(2,3),(3,4)]-adjacent_indices :: Integral i => i -> [(i,i)]-adjacent_indices n = zip [0..n-2] [1..n-1]---- | All /(i,j)/ indices in half matrix order.------ > all_indices 4 == [(0,1),(0,2),(0,3),(1,2),(1,3),(2,3)]-all_indices :: Integral i => i -> [(i,i)]-all_indices n =-    let n' = n - 1-    in [(i,j) | i <- [0 .. n'], j <- [i + 1 .. n']]- -- | Construct 'Contour_Description' of contour (p.264). ----- > map (show.contour_description) [[3,2,4,1],[3,2,1,4]] == ["202 02 2","220 20 0"]+-- > let c = [[3,2,4,1],[3,2,1,4]]+-- > in map (show.contour_description) c == ["202 02 2","220 20 0"] contour_description :: Ord a => [a] -> Contour_Description contour_description x =     let n = length x@@ -130,21 +177,17 @@ contour_description_ix :: Contour_Description -> (Int,Int) -> Ordering contour_description_ix d i = contour_description_m d M.! i --- | Are all elements equal.------ > all_equal "aaa" == True-all_equal :: Eq a => [a] -> Bool-all_equal xs = all id (zipWith (==) xs (tail xs))- -- | 'True' if contour is all descending, equal or ascending. ----- > map (uniform.contour_description) ["abc","bbb","cba"] == [True,True,True]+-- > let c = ["abc","bbb","cba"]+-- > in map (uniform.contour_description) c == [True,True,True] uniform :: Contour_Description -> Bool uniform (Contour_Description _ m) = all_equal (M.elems m)  -- | 'True' if contour does not containt any 'EQ' elements. ----- > map (no_equalities.contour_description) ["abc","bbb","cba"] == [True,False,True]+-- > let c = ["abc","bbb","cba"]+-- > map (no_equalities.contour_description) c == [True,False,True] no_equalities :: Contour_Description -> Bool no_equalities (Contour_Description _ m) = EQ `notElem` M.elems m @@ -155,11 +198,26 @@ 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+        cs = filter (not.null) (S.powerset [LT,EQ,GT])+        pf = concatMap P.multiset_permutations . S.expand_set n'         mk p = Contour_Description n (M.fromList (zip ix p))-    in map mk ps+    in map mk (concatMap pf cs) +-- | A sequence of orderings /(i,j)/ and /(j,k)/ may imply ordering+-- for /(i,k)/.+--+-- > map implication [(LT,EQ),(EQ,EQ),(EQ,GT)] == [Just LT,Just EQ,Just GT]+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"+ -- | List of all violations at a 'Contour_Description' (p.266). violations :: Contour_Description -> [(Int,Int,Int,Ordering)] violations d =@@ -179,7 +237,7 @@  -- | Is the number of 'violations' zero. is_possible :: Contour_Description -> Bool-is_possible = (== 0) . length . violations+is_possible = null . violations  -- | All possible contour descriptions --@@ -196,33 +254,45 @@ -- | Calculate number of contours of indicated degree (p.263). -- -- > map contour_description_lm [2..7] == [1,3,6,10,15,21]--- > map (\n -> 3 ^ n) (map contour_description_lm [2..6]) == [3,27,729,59049,14348907]+--+-- > let r = [3,27,729,59049,14348907]+-- > in map (\n -> 3 ^ n) (map contour_description_lm [2..6]) == r contour_description_lm :: Integral a => a -> a contour_description_lm l = (l * l - l) `div` 2 --- | A sequence of orderings /(i,j)/ and /(j,k)/ may imply ordering--- for /(i,k)/.+-- | Truncate a 'Contour_Description' to have at most /n/ elements. ----- > map implication [(LT,EQ),(EQ,EQ),(EQ,GT)] == [Just LT,Just EQ,Just GT]-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"+-- > let c = contour_description [3,2,4,1]+-- > in contour_truncate c 3 == contour_description [3,2,4]+contour_truncate :: Contour_Description -> Int -> Contour_Description+contour_truncate (Contour_Description n m) z =+    let n' = min n z+        f (i,j) _ = i < n' && j < n'+    in Contour_Description n' (M.filterWithKey f m) --- | Replace the /i/th value at /ns/ with /x/.+-- | Is 'Contour_Description' /p/ a prefix of /q/. ----- > replace "test" 2 'n' == "tent"-replace :: Integral i => [a] -> i -> a -> [a]-replace ns i x =-    let f j y = if i == j then x else y-    in zipWith f [0..] ns+-- > let {c = contour_description [3,2,4,1]+-- >     ;d = contour_description [3,2,4]}+-- > in d `contour_is_prefix_of` c == True+contour_is_prefix_of :: Contour_Description -> Contour_Description -> Bool+contour_is_prefix_of p q = p == contour_truncate q (contour_description_n p) +-- | Are 'Contour_Description's /p/ and /q/ equal at column /n/.+--+-- > let {c = contour_description [3,2,4,1,5]+-- >     ;d = contour_description [3,2,4,1]}+-- > in map (contour_eq_at c d) [0..4] == [True,True,True,True,False]+contour_eq_at :: Contour_Description -> Contour_Description -> Int -> Bool+contour_eq_at p q n =+    let a = contour_description_m p+        b = contour_description_m q+        f (_,j) _ = j == n+        g = M.toAscList . M.filterWithKey f+    in g a == g b++-- * Contour drawing+ -- | Derive an 'Integral' contour that would be described by -- 'Contour_Description'.  Diverges for impossible contours. --@@ -234,7 +304,7 @@         normalise :: Integral i => [Rational] -> [i]         normalise xs =             let xs' = nub (sort xs)-            in map (\i -> fromIntegral (fromJust (findIndex (== i) xs'))) xs+            in map (\i -> fromIntegral (fromJust (elemIndex 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@@ -253,22 +323,143 @@                              Just ns' -> refine ix ns'     in normalise (refine ix (replicate n 0)) --- | Invert 'Ordering'.------ > map ord_invert [LT,EQ,GT] == [GT,EQ,LT]-ord_invert :: Ordering -> Ordering-ord_invert x =-    case x of-      LT -> GT-      EQ -> EQ-      GT -> LT- -- | Invert 'Contour_Description'. ----- > draw_contour (contour_description_invert (contour_description "abdc")) == [3,2,0,1]+-- > let c = contour_description "abdc"+-- > in draw_contour (contour_description_invert c) == [3,2,0,1] contour_description_invert :: Contour_Description -> Contour_Description contour_description_invert (Contour_Description n m) =     Contour_Description n (M.map ord_invert m)++-- * Construction++-- | Function to perhaps generate an element and a new state from an+-- initial state.  This is the function provided to 'unfoldr'.+type Build_f st e = st -> Maybe (e,st)++-- | Function to test is a partial sequence conforms to the target+-- sequence.+type Conforms_f e = Int -> [e] -> Bool++-- | Transform a 'Build_f' to produce at most /n/ elements.+--+-- > let f i = Just (i,succ i)+-- > in unfoldr (build_f_n f) (5,'a') == "abcde"+build_f_n :: Build_f st e -> Build_f (Int,st) e+build_f_n f =+    let g g_st =+            let (i,f_st) = g_st+            in if i == 0+               then Nothing+               else case f f_st of+                      Nothing -> Nothing+                      Just (e,f_st') -> Just (e,(i - 1,f_st'))+    in g++-- | Attempt to construct a sequence of /n/ elements given a 'Build_f'+-- to generate possible elements, a 'Conforms_f' that the result+-- sequence must conform to at each step, an 'Int' to specify the+-- maximum number of elements to generate when searching for a+-- solution, and an initial state.+--+-- > let {b_f i = Just (i,i+1)+-- >     ;c_f i x = odd (sum x `div` i)}+-- > in build_sequence 6 b_f c_f 20 0 == (Just [1,2,6,11,15,19],20)+build_sequence :: Int -> Build_f st e -> Conforms_f e -> Int -> st ->+                  (Maybe [e],st)+build_sequence n f g z =+    let go i j r st =+            if i == n+            then (Just r,st)+            else if j == z+                 then (Nothing,st)+                 else case f st of+                        Nothing -> (Nothing,st)+                        Just (e,st') ->+                            let i' = i + 1+                                j' = j + 1+                                r' = r ++ [e]+                            in if g i' r'+                               then go i' j' r' st'+                               else go i j' r st'+    in go 0 0 []++-- | Attempt to construct a sequence that has a specified contour.+-- The arguments are a 'Build_f' to generate possible elements, a+-- 'Contour_Description' that the result sequence must conform to, an+-- 'Int' to specify the maximum number of elements to generate when+-- searching for a solution, and an initial state.+--+-- > import System.Random+--+-- > let {f = Just . randomR ('a','z')+-- >     ;c = contour_description "atdez"+-- >     ;st = mkStdGen 2347}+-- > in fst (build_contour f c 1024 st) == Just "nvruy"+build_contour :: (Ord e) =>+                 Build_f st e -> Contour_Description -> Int -> st ->+                 (Maybe [e],st)+build_contour f c z =+    let n = contour_description_n c+        g i r = let d = contour_description r -- traceShow r+                in contour_eq_at c d (i - 1)+    in build_sequence n f g z++-- | A variant on 'build_contour' that retries a specified number of+-- times using the final state of the failed attempt as the state for+-- the next try.+--+-- > let {f = Just . randomR ('a','z')+-- >     ;c = contour_description "atdezjh"+-- >     ;st = mkStdGen 2347}+-- > in fst (build_contour_retry f c 64 8 st) == Just "nystzvu"+build_contour_retry ::+    (Ord e) =>+    Build_f st e -> Contour_Description -> Int -> Int -> st ->+    (Maybe [e], st)+build_contour_retry f c z n st =+   if n == 0+   then (Nothing,st)+   else case build_contour f c z st of+          (Nothing,st') -> build_contour_retry f c z (n - 1) st'+          r -> r++-- | A variant on 'build_contour_retry' that returns the set of all+-- sequences constructed.+--+-- > let {f = Just . randomR ('a','z')+-- >     ;c = contour_description "atdezjh"+-- >     ;st = mkStdGen 2347}+-- > in length (build_contour_set f c 64 64 st) == 60+build_contour_set ::+    (Ord e) =>+    Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]]+build_contour_set f c z n st =+    case build_contour_retry f c z n st of+      (Nothing,_) -> []+      (Just r,st') -> r : build_contour_set f c z n st'++-- | Variant of 'build_contour_set' that halts when an generated+-- sequence is a duplicate of an already generated sequence.+--+-- > let {f = randomR ('a','f')+-- >     ;c = contour_description "cafe"+-- >     ;st = mkStdGen 2346836+-- >     ;r = build_contour_set_nodup f c 64 64 st}+-- > in filter ("c" `isPrefixOf`) r == ["cafe","cbed","caed"]+build_contour_set_nodup ::+    Ord e =>+    Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]]+build_contour_set_nodup f c z n =+    let go r st =+            case build_contour_retry f c z n st of+              (Nothing,_) -> []+              (Just r',st') -> if r' `elem` r+                               then r+                               else go (r' : r) st'+    in go []++-- * Examples  -- | Example from p.262 (quarter-note durations) --
Music/Theory/Diagram/Grid.hs view
@@ -3,9 +3,9 @@ -- /grid/ music of the 1950's. module Music.Theory.Diagram.Grid where -import qualified Codec.Binary.UTF8.String as U {- utf8-string -}-import qualified Graphics.Rendering.Cairo as C {- cairo -}+import Data.Maybe import qualified Text.HTML.Light as H {- html-minimalist -}+import qualified Text.HTML.Light.Composite as H import qualified Text.XML.Light as X {- xml -}  -- * Grid@@ -54,85 +54,70 @@ displace :: (R,R) -> P -> P displace (dx,dy) (x,y) = (x+dx,y+dy) --- | Render line.-line :: [P] -> C.Render ()-line l =-    case l of-      [] -> return ()-      (x0,y0):l' -> do C.moveTo x0 y0-                       mapM_ (uncurry C.lineTo) l'---- | Render rectangle given colour 'C', upper-left 'P' and--- /(width,height)/.-rect :: C -> P -> (R,R) -> C.Render ()-rect c (x,y) (w,h) = do-  let (r,g,b) = c-  C.save-  C.setSourceRGBA r g b 1-  C.setLineWidth 0.05-  C.translate x y-  C.rectangle 0 0 w h-  C.stroke-  C.restore---- | Render text 'String' in colour 'C' and point 'P' in font size 'R'.-txt_at :: C -> P -> R -> String -> C.Render ()-txt_at c (x,y) sz txt = do-  let (r,g,b) = c-  C.save-  C.selectFontFace "Times" C.FontSlantNormal C.FontWeightNormal-  C.setFontSize sz-  C.setSourceRGBA r g b 1-  C.moveTo x y-  C.showText (U.utf8Encode txt)-  C.restore---- | Render 'Grid' of /(rows,columns)/ with displacement /(dx,dy)/ in--- indicated font size.-mk_grid :: (Int,Int) -> (R,R) -> R -> Grid -> C.Render ()-mk_grid (r,c) (dx,dy) fs xs = do-  let g = grid (10,10) (10,10) (r,c)-      grid_pt' = displace (dx,dy) . grid_pt (10,10) (10,10)-  mapM_ (\(x,y) -> rect (0,0,0) (x,y) (10,10)) g-  mapM_ (\(l,clr,i) -> txt_at clr (grid_pt' l) (10/fs) i) xs-  C.showPage- -- | Make a bounding box from /row/ and /column/ dimensions. mk_bbox :: (Int,Int) -> (R,R) mk_bbox (r,c) =     let f n = (fromIntegral n + 2) * 10     in (f c,f r) --- | Run render to @PDF@ file.-to_pdf :: FilePath -> (R,R) -> C.Render () -> IO ()-to_pdf nm (w,h) f = do-  let g s = C.renderWith s f-  C.withPDFSurface nm w h g- -- * Table --- | Table of row order 'X.Content'.-type Table = [[X.Content]]+-- | A table cell is an 'X.Attr' and 'X.Content' duple.+type Table_Cell = ([X.Attr],[X.Content]) --- | Render 'Table' as @XHTML@ table.+type Caption = [X.Content]++-- | Table of row order 'Table_Cell's.+type Table = (Caption,[[Table_Cell]])++-- | Construct a 'Table' with one 'X.Content' per cell.+simple_table :: Caption -> [[X.Content]] -> Table+simple_table c z = (c,map (map (\x -> ([],[x]))) z)++-- | Construct a 'Table' with one 'X.Content' per cell, and an+-- associated class.+simple_table_class :: Caption -> [[(String,X.Content)]] -> Table+simple_table_class c z = (c,map (map (\(nm,x) -> ([H.class' nm],[x]))) z)++type Build_F = ((Int,Int) -> Maybe Table_Cell)++-- | Build a table of @(rows,columns)@ dimensions given a function+-- from @(row,column)@ to 'Maybe' 'Table_Cell'.  If the function is+-- 'Nothing' the cell is skipped, becase another cell has claimed it's+-- locations with 'H.colspan' or 'H.rowspan'.+build_table_m :: Caption -> (Int,Int) -> Build_F -> Table+build_table_m c (m,n) f =+    let mk_row i = mapMaybe (\j -> f (i,j)) [0 .. n - 1]+    in (c,map mk_row [0 .. m - 1])++-- | Build a table of @(rows,columns)@ dimensions given a function+-- from @(row,column)@ to 'Table_Cell'.+build_table :: Caption -> (Int,Int) -> ((Int,Int) -> Table_Cell) -> Table+build_table c (m,n) f = build_table_m c (m,n) (Just . f)++-- | Render 'Table' as @HTML@ table. table :: Table -> X.Content-table t =-    let mk_c x = H.td [] [x]-        mk_r = H.tr [] . map mk_c-    in H.div [] [H.table [] (map mk_r t)]+table (c,z) =+    let mk_r = H.tr [] . map (uncurry H.td)+    in H.table [] (H.caption [] c : map mk_r z) --- | Render set of 'Table's as @XHTML@.-page :: [Table] -> String-page xs = do-    let tb = map table xs-        bd = H.body [] tb-        css = H.link [H.rel "stylesheet"-                     ,H.type' "text/css"-                     ,H.href "css/grid.css"]-        hd = H.head [] [css]-        e = H.html [H.xmlns "http://www.w3.org/1999/xhtml"] [hd, bd]-    H.renderXHTML H.xhtml_1_0_strict e+-- | A set of related tables.+type Table_Set = [Table] --- | Write set of 'Table's to @XHTML@ file.-to_xhtml :: FilePath -> [Table] -> IO ()-to_xhtml o_fn = writeFile o_fn . page+-- | Render a 'Table_Set's in a @div@ with class @table-set@.+table_set :: Table_Set -> X.Content+table_set = H.div [H.class' "table-set"] . map table++-- | Render set of 'Table_Set's as @HTML@.+page :: Maybe FilePath -> [Table_Set] -> String+page css xs = do+    let tb = map table_set xs+        bd = H.body [H.class' "table-page"] tb+        css' = H.link_css "all" (fromMaybe "css/grid.css" css)+        hd = H.head [] [css']+        e = H.html [H.lang "en"] [hd, bd]+    H.renderHTML5 e++-- | Write set of 'Table_Set's to @HTML@ file.+to_html :: FilePath -> Maybe FilePath -> [Table_Set] -> IO ()+to_html o_fn css = writeFile o_fn . page css
Music/Theory/Diagram/Path.hs view
@@ -3,13 +3,9 @@ module Music.Theory.Diagram.Path where  import Data.CG.Minus {- hcg-minus -}-import Data.CG.Minus.Colour-import Data.Colour {- colour -} import Data.Function import Data.List import Data.Maybe-import qualified Graphics.Rendering.Cairo as C {- cairo -}-import Render.CG.Minus.Arrow  -- * Genera @@ -72,11 +68,11 @@ pt_fn f p = let (x,y) = pt_xy p in f (x,y)  -- | Apply /f/ to /start/ and /end/ 'Pt' duple of 'Ln'.-ln_fn :: Num a => ((Pt a,Pt a) -> b) -> Ln a -> b+ln_fn :: (Num a,Eq a) => ((Pt a,Pt a) -> b) -> Ln a -> b ln_fn f l = let (p,q) = ln_pt l in f (p,q)  -- | Apply /f/ to /start/ and /end/ 'Pt's of 'Ln' and construct 'Ln'.-ln_pt_fn :: (Num a, Num b) => (Pt a -> Pt b) -> Ln a -> Ln b+ln_pt_fn :: (Num a,Eq a,Num b,Eq b) => (Pt a -> Pt b) -> Ln a -> Ln b ln_pt_fn f = ln_fn (\(p,q) -> ln (f p) (f q))  -- | Scale set of 'Ln' to lie in area given by /(0,n)/.@@ -100,7 +96,7 @@ -- > orientation (ln' (0,0) (0,1)) == Vertical -- > orientation (ln' (0,0) (1,0)) == Horizontal -- > orientation (ln' (0,0) (1,1)) == Diagonal 1-orientation :: (Fractional a) => Ln a -> Orientation a+orientation :: (Fractional a,Eq a) => Ln a -> Orientation a orientation l =     case ln_slope l of       Nothing -> Vertical@@ -198,33 +194,3 @@     let p' = path_diagram_ln p     in map (shift_map_ln (mk_shift_map p')) p' --- * Drawing---- | A set of 'Ca' and 'Ls' pairs.-type Path = [(Ca,Ls R)]---- | Draw 'Path' with mid-point arrows.-draw_path :: Path -> C.Render ()-draw_path xs = do-  mapM_ (uncurry (arrows_mp 0.1 (pi/9))) xs-  C.showPage---- | 'mapM_' 'draw_path'.-draw_paths :: [Path] -> C.Render ()-draw_paths = mapM_ draw_path---- | 'draw_paths' to named @PDF@ file.-write_pdf :: FilePath -> [Path] -> IO ()-write_pdf fn xs = do-  let f s = C.renderWith s (C.translate 10 100 >>-                            C.scale 100 100 >>-                            draw_paths xs)-  C.withPDFSurface fn 500 500 f---- * Path diagram---- | Write @PDF@ of a set of 'Path_Diagram's to named file.-path_diagram :: FilePath -> [Path_Diagram] -> IO ()-path_diagram fn =-    let f (i,j) = (opaque black,[i,j])-    in write_pdf fn . map (map (ln_fn f) . to_unit 4 . mk_path_sm)
Music/Theory/Duration.hs view
@@ -1,7 +1,10 @@ -- | Common music notation duration model. module Music.Theory.Duration where +import Control.Monad+import Data.List import Data.Maybe+import Data.Ratio  -- | Standard music notation durational model data Duration = Duration {division :: Integer -- ^ division of whole note@@ -10,38 +13,49 @@                          }                 deriving (Eq,Show) --- | Standard music notation durational model annotations-data D_Annotation = Tie_Right | Tie_Left-                  | Begin_Tuplet (Integer,Integer,Duration) | End_Tuplet-                    deriving (Eq,Show)+-- | Are multipliers equal?+duration_meq :: Duration -> Duration -> Bool+duration_meq p q = multiplier p == multiplier q  -- | Compare durations with equal multipliers.-duration_compare_meq :: Duration -> Duration -> Ordering+duration_compare_meq :: Duration -> Duration -> Maybe 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+    let (Duration x0 n0 m0) = y0+        (Duration x1 n1 m1) = y1+    in if y0 == y1+       then Just EQ+       else if m0 /= m1+            then Nothing+            else Just (if x0 == x1+                       then compare n0 n1+                       else compare x1 x0) --- | 'Ord' instance in terms of 'duration_compare_meq'.+-- | Erroring variant of 'duration_compare_meq'.+duration_compare_meq_err :: Duration -> Duration -> Ordering+duration_compare_meq_err p =+    let err = error "duration_compare_meq_err: non-equal multipliers"+    in fromMaybe err . duration_compare_meq p++-- | 'Ord' instance in terms of 'duration_compare_meq_err'. instance Ord Duration where-    compare = duration_compare_meq+    compare = duration_compare_meq_err +order_pair :: Ordering -> (t,t) -> (t,t)+order_pair o (x,y) =+    case o of+      LT -> (x,y)+      EQ -> (x,y)+      GT -> (y,x)+ -- | Sort a pair of equal type values using given comparison function. -- -- > sort_pair compare ('b','a') == ('a','b') 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)+sort_pair fn (x,y) = order_pair (fn x y) (x,y) +sort_pair_m :: (t -> t -> Maybe Ordering) -> (t,t) -> Maybe (t,t)+sort_pair_m fn (x,y) = fmap (`order_pair` (x,y)) (fn x y)+ -- | True if neither duration is dotted. no_dots :: (Duration, Duration) -> Bool no_dots (x0,x1) = dots x0 == 0 && dots x1 == 0@@ -54,6 +68,11 @@     | otherwise = Nothing  -- | Sum dotted divisions, input is required to be sorted.+--+-- > sum_dur_dotted (4,1,4,1) == Just (Duration 2 1 1)+-- > sum_dur_dotted (4,0,2,1) == Just (Duration 1 0 1)+-- > sum_dur_dotted (8,1,4,0) == Just (Duration 4 2 1)+-- > sum_dur_dotted (16,0,4,2) == Just (Duration 2 0 1) sum_dur_dotted :: (Integer,Integer,Integer,Integer) -> Maybe Duration sum_dur_dotted (x0, n0, x1, n1)     | x0 == x1 &&@@ -62,17 +81,28 @@     | x0 == x1 * 2 &&       n0 == 0 &&       n1 == 1 = Just (Duration (x1 `div` 2) 0 1)+    | x0 == x1 * 4 &&+      n0 == 0 &&+      n1 == 2 = Just (Duration (x1 `div` 2) 0 1)+    | x0 == x1 * 2 &&+      n0 == 1 &&+      n1 == 0 = Just (Duration x1 2 1)     | otherwise = Nothing  -- | Sum durations.  Not all durations can be summed, and the present --   algorithm is not exhaustive.+--+-- > import Music.Theory.Duration.Name+-- > sum_dur quarter_note eighth_note == Just dotted_quarter_note+-- > sum_dur dotted_quarter_note eighth_note == Just half_note+-- > sum_dur quarter_note dotted_eighth_note == Just double_dotted_quarter_note 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)+    let f (x0,x1) = 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)+    in join (fmap f (sort_pair_m duration_compare_meq (y0,y1)))  -- | Erroring variant of 'sum_dur'. sum_dur' :: Duration -> Duration -> Duration@@ -81,7 +111,6 @@         err = error ("sum_dur': " ++ show (y0,y1))     in fromMaybe err y2 - -- | Give @MusicXML@ type for division. -- -- > map whole_note_division_to_musicxml_type [2,4] == ["half","quarter"]@@ -111,6 +140,7 @@ -- | Give /Lilypond/ notation for 'Duration'.  Note that the duration -- multiplier is /not/ written. --+-- > import Music.Theory.Duration.Name -- > map duration_to_lilypond_type [half_note,dotted_quarter_note] == ["2","4."] duration_to_lilypond_type :: Duration -> String duration_to_lilypond_type (Duration dv d _) =@@ -134,3 +164,21 @@     let err = error "duration_beam_count"         bc = whole_note_division_to_beam_count x     in fromMaybe err bc++whole_note_division_pp :: Integer -> Maybe Char+whole_note_division_pp x =+    let t = [(16,'s'),(8,'e'),(4,'q'),(2,'h'),(1,'w')]+    in lookup x t++-- > import Music.Theory.Duration.Name.Abbreviation+-- > map duration_pp [q,h',e''] == [Just "q",Just "h'",Just "e''"]+duration_pp :: Duration -> Maybe String+duration_pp (Duration x d m) =+    let d' = genericReplicate d '\''+        m' = case (numerator m,denominator m) of+               (1,1) -> ""+               (1,i) -> '/' : show i+               (i,j) -> '*' : show i ++ "/" ++ show j+    in case whole_note_division_pp x of+         Just x' -> Just (x' : d' ++ m')+         _ -> Nothing
+ Music/Theory/Duration/Annotation.hs view
@@ -0,0 +1,227 @@+-- | Duration annotations.+module Music.Theory.Duration.Annotation where++--import Control.Applicative+import Data.Maybe+import Data.Ratio+import qualified Data.Traversable as T+import Data.Tree+import Music.Theory.Duration+import Music.Theory.Duration.RQ++-- | Standard music notation durational model annotations+data D_Annotation = Tie_Right+                  | Tie_Left+                  | Begin_Tuplet (Integer,Integer,Duration)+                  | End_Tuplet+                    deriving (Eq,Show)++-- | Annotated 'Duration'.+type Duration_A = (Duration,[D_Annotation])++begin_tuplet :: D_Annotation -> Maybe (Integer,Integer,Duration)+begin_tuplet a =+    case a of+      Begin_Tuplet t -> Just t+      _ -> Nothing++da_begin_tuplet :: Duration_A -> Maybe (Integer,Integer,Duration)+da_begin_tuplet (_,a) =+    case mapMaybe begin_tuplet a of+      [t] -> Just t+      _ -> Nothing++begins_tuplet :: D_Annotation -> Bool+begins_tuplet a =+    case a of+      Begin_Tuplet _ -> True+      _ -> False++-- | Does 'Duration_A' being a tuplet?+da_begins_tuplet :: Duration_A -> Bool+da_begins_tuplet (_,a) = any begins_tuplet a++-- | Does 'Duration_A' end a tuplet?+da_ends_tuplet :: Duration_A -> Bool+da_ends_tuplet (_,a) = End_Tuplet `elem` a++-- | Is 'Duration_A' tied to the the right?+da_tied_right :: Duration_A -> Bool+da_tied_right = elem Tie_Right . snd++-- | Annotate a sequence of 'Duration_A' as a tuplet.+--+-- > import Music.Theory.Duration.Name+-- > da_tuplet (3,2) [(quarter_note,[Tie_Left]),(eighth_note,[Tie_Right])]+da_tuplet :: (Integer,Integer) -> [Duration_A] -> [Duration_A]+da_tuplet (d,n) x =+    let fn (p,q) = (p {multiplier = n%d},q)+        k = sum (map (duration_to_rq . fst) x) / (d%1)+        ty = rq_to_duration_err (show ("da_tuplet",d,n,x,k)) k+        t0 = [Begin_Tuplet (d,n,ty)]+        ts = [t0] ++ replicate (length x - 2) [] ++ [[End_Tuplet]]+        jn (p,q) z = (p,q++z)+    in zipWith jn (map fn x) ts++-- | Transform predicates into 'Ordering' predicate such that if /f/+-- holds then 'LT', if /g/ holds then 'GT' else 'EQ'.+--+-- > map (begin_end_cmp (== '{') (== '}')) "{a}" == [LT,EQ,GT]+begin_end_cmp :: (t -> Bool) -> (t -> Bool) -> t -> Ordering+begin_end_cmp f g x = if f x then LT else if g x then GT else EQ++-- | Variant of 'begin_end_cmp', predicates are constructed by '=='.+--+-- > map (begin_end_cmp_eq '{' '}') "{a}" == [LT,EQ,GT]+begin_end_cmp_eq :: Eq t => t -> t -> t -> Ordering+begin_end_cmp_eq p q = begin_end_cmp (== p) (== q)++-- | Given an 'Ordering' predicate where 'LT' opens a group, 'GT'+-- closes a group, and 'EQ' continues current group, construct tree+-- from list.+--+-- > let {l = "a {b {c d} e f} g h i"+-- >     ;t = group_tree (begin_end_cmp_eq '{' '}') l}+-- > in catMaybes (flatten t) == l+--+-- > let d = putStrLn . drawTree . fmap show+-- > in d (group_tree (begin_end_cmp_eq '(' ')') "a(b(cd)ef)ghi")+group_tree :: (a -> Ordering) -> [a] -> Tree (Maybe a)+group_tree f =+    let unit e = Node (Just e) []+        nil = Node Nothing []+        insert_e (Node t l) e = Node t (e:l)+        reverse_n (Node t l) = Node t (reverse l)+        push (r,z) e = case z of+                         h:z' -> (r,insert_e h (unit e) : z')+                         [] -> (unit e : r,[])+        open (r,z) = (r,nil:z)+        close (r,z) = case z of+                        h0:h1:z' -> (r,insert_e h1 (reverse_n h0) : z')+                        h:z' -> (reverse_n h : r,z')+                        [] -> (r,z)+        go st x =+            case x of+              [] -> Node Nothing (reverse (fst st))+              e:x' -> case f e of+                        LT -> go (push (open st) e) x'+                        EQ -> go (push st e) x'+                        GT -> go (close (push st e)) x'+    in go ([],[])++-- | Group tuplets into a 'Tree'.  Branch nodes have label 'Nothing',+-- leaf nodes label 'Just' 'Duration_A'.+--+-- > import Music.Theory.Duration.Name.Abbreviation+--+-- > let d = [(q,[])+-- >         ,(e,[Begin_Tuplet (3,2,e)])+-- >         ,(s,[Begin_Tuplet (3,2,s)]),(s,[]),(s,[End_Tuplet])+-- >         ,(e,[End_Tuplet])+-- >         ,(q,[])]+-- > in catMaybes (flatten (da_group_tuplets d)) == d+da_group_tuplets :: [Duration_A] -> Tree (Maybe Duration_A)+da_group_tuplets =+    let f = begin_end_cmp da_begins_tuplet da_ends_tuplet+    in group_tree f++-- | Variant of 'break' that places separator at left.+--+-- > break_left (== 3) [1..6] == ([1..3],[4..6])+-- > break_left (== 3) [1..3] == ([1..3],[])+break_left :: (a -> Bool) -> [a] -> ([a], [a])+break_left f x =+    let (p,q) = break f x+    in case q of+         [] -> (p,q)+         i:j -> (p++[i],j)++-- | Variant of 'break_left' that balances begin & end predicates.+--+-- > break_left (== ')') "test (sep) _) balanced"+-- > sep_balanced True (== '(') (== ')') "test (sep) _) balanced"+-- > sep_balanced False (== '(') (== ')') "(test (sep) _) balanced"+sep_balanced :: Bool -> (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a])+sep_balanced u f g =+    let go n x =+            case x of+              [] -> ([],[])+              p:q -> let n' = if f p then n + 1 else n+                         r = g p+                         n'' = if r then n' - 1 else n'+                     in if r && n'' == 0+                        then ([p],q)+                        else let (i,j) = go n'' q in (p:i,j)+    in go (fromEnum u)++-- | Group non-nested tuplets, ie. groups nested tuplets at one level.+da_group_tuplets_nn :: [Duration_A] -> [Either Duration_A [Duration_A]]+da_group_tuplets_nn x =+    case x of+      [] -> []+      d:x' -> if da_begins_tuplet d+              then let f = sep_balanced True da_begins_tuplet da_ends_tuplet+                       (t,x'') = f x'+                   in Right (d : t) : da_group_tuplets_nn x''+              else Left d : da_group_tuplets_nn x'++-- | Keep right variant of 'zipWith', unused rhs values are returned.+--+-- > zip_with_kr (,) [1..3] ['a'..'e'] == ([(1,'a'),(2,'b'),(3,'c')],"de")+zip_with_kr :: (a -> b -> c) -> [a] -> [b] -> ([c],[b])+zip_with_kr f =+    let go r p q =+            case (p,q) of+              (i:p',j:q') -> go (f i j : r) p' q'+              _ -> (reverse r,q)+    in go []++-- | Keep right variant of 'zip', unused rhs values are returned.+--+-- > zip_kr [1..4] ['a'..'f'] == ([(1,'a'),(2,'b'),(3,'c'),(4,'d')],"ef")+zip_kr :: [a] -> [b] -> ([(a,b)],[b])+zip_kr = zip_with_kr (,)++-- | 'zipWith' variant that adopts the shape of the lhs.+--+-- > let {p = [Left 1,Right [2,3],Left 4]+-- >     ;q = "abcd"}+-- > in nn_reshape (,) p q == [Left (1,'a'),Right [(2,'b'),(3,'c')],Left (4,'d')]+nn_reshape :: (a -> b -> c) -> [Either a [a]] -> [b] -> [Either c [c]]+nn_reshape f p q =+    case (p,q) of+      (e:p',i:q') -> case e of+                       Left j -> Left (f j i) : nn_reshape f p' q'+                       Right j -> let (j',q'') = zip_with_kr f j q+                                  in Right j' : nn_reshape f p' q''+      _ -> []++-- | Replace elements at 'Traversable' with result of joining with+-- elements from list.+adopt_shape :: T.Traversable t => (a -> b -> c) -> [b] -> t a -> t c+adopt_shape jn l =+    let f (i:j) k = (j,jn k i)+        f [] _ = error "adopt_shape: rhs ends"+    in snd . T.mapAccumL f l++-- | Variant of 'adopt_shape' that considers only 'Just' elements at+-- 'Traversable'.+--+-- > let {s = "a(b(cd)ef)ghi"+-- >     ;t = group_tree (begin_end_cmp_eq '(' ')') s}+-- > in adopt_shape_m (,) [1..13] t+adopt_shape_m :: T.Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> t (Maybe c)+adopt_shape_m jn l =+    let f (i:j) k = case k of+                      Nothing -> (i:j,Nothing)+                      Just k' -> (j,Just (jn k' i))+        f [] _ = error "adopt_shape_m: rhs ends"+    in snd . T.mapAccumL f l++-- | Does /a/ have 'Tie_Left' and 'Tie_Right'?+d_annotated_tied_lr :: [D_Annotation] -> (Bool,Bool)+d_annotated_tied_lr a = (Tie_Left `elem` a,Tie_Right `elem` a)++-- | Does /d/ have 'Tie_Left' and 'Tie_Right'?+duration_a_tied_lr :: Duration_A -> (Bool,Bool)+duration_a_tied_lr (_,a) = d_annotated_tied_lr a
Music/Theory/Duration/RQ.hs view
@@ -3,6 +3,7 @@  import Data.Function import Data.List+import Data.Maybe import Data.Ratio import Music.Theory.Duration import Music.Theory.Duration.Name@@ -10,10 +11,9 @@ -- | Rational Quarter-Note type RQ = Rational --- | 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.+-- | Rational quarter note to duration value.  It is a mistake to hope+-- this could handle tuplets directly since, for instance, a @3:2@+-- dotted note will be of the same duration as a plain undotted note. -- -- > rq_to_duration (3/4) == Just dotted_eighth_note rq_to_duration :: RQ -> Maybe Duration@@ -36,6 +36,18 @@       (12,1) -> Just dotted_breve       _ -> Nothing +-- | Is 'RQ' a /cmn/ duration.+--+-- > map rq_is_cmn [1/4,1/5,1/8] == [True,False,True]+rq_is_cmn :: RQ -> Bool+rq_is_cmn = isJust . rq_to_duration++-- | Variant of 'rq_to_duration' with error message.+rq_to_duration_err :: Show a => a -> RQ -> Duration+rq_to_duration_err msg n =+    let err = error ("rq_to_duration:" ++ show (msg,n))+    in fromMaybe err (rq_to_duration n)+ -- | Convert a whole note division integer to an 'RQ' value. -- -- > map whole_note_division_to_rq [1,2,4,8] == [4,2,1,1/2]@@ -69,3 +81,104 @@ -- > half_note `duration_compare_rq` quarter_note == GT duration_compare_rq :: Duration -> Duration -> Ordering duration_compare_rq = compare `on` duration_to_rq++-- | 'RQ' modulo.+--+-- > map (rq_mod (5/2)) [3/2,3/4,5/2] == [1,1/4,0]+rq_mod :: RQ -> RQ -> RQ+rq_mod i j+    | i == j = 0+    | i < 0 = rq_mod (i + j) j+    | i > j = rq_mod (i - j) j+    | otherwise = i++-- | Is /p/ divisible by /q/, ie. is the 'denominator' of @p/q@ '==' @1@.+--+-- > map (rq_divisible_by (3%2)) [1%2,1%3] == [True,False]+rq_divisible_by :: RQ -> RQ -> Bool+rq_divisible_by i j = denominator (i / j) == 1++-- | Is 'RQ' a whole number (ie. is 'denominator' '==' @1@.+--+-- > map rq_is_integral [1,3/2,2] == [True,False,True]+rq_is_integral :: RQ -> Bool+rq_is_integral = (== 1) . denominator++-- | Return 'numerator' of 'RQ' if 'denominator' '==' @1@.+--+-- > map rq_integral [1,3/2,2] == [Just 1,Nothing,Just 2]+rq_integral :: RQ -> Maybe Integer+rq_integral n = if rq_is_integral n then Just (numerator n) else Nothing++-- | Derive the tuplet structure of a set of 'RQ' values.+--+-- > rq_derive_tuplet_plain [1/2] == Nothing+-- > rq_derive_tuplet_plain [1/2,1/2] == Nothing+-- > rq_derive_tuplet_plain [1/4,1/4] == Nothing+-- > rq_derive_tuplet_plain [1/3,2/3] == Just (3,2)+-- > rq_derive_tuplet_plain [1/2,1/3,1/6] == Just (6,4)+-- > rq_derive_tuplet_plain [1/3,1/6] == Just (6,4)+-- > rq_derive_tuplet_plain [2/5,3/5] == Just (5,4)+-- > rq_derive_tuplet_plain [1/3,1/6,2/5,1/10] == Just (30,16)+--+-- > map rq_derive_tuplet_plain [[1/3,1/6],[2/5,1/10]] == [Just (6,4)+-- >                                                      ,Just (10,8)]+rq_derive_tuplet_plain :: [RQ] -> Maybe (Integer,Integer)+rq_derive_tuplet_plain x =+    let i = foldl lcm 1 (map denominator x)+        j = let z = iterate (* 2) 2+            in fromJust (find (>= i) z) `div` 2+    in if i `rem` j == 0 then Nothing else Just (i,j)++-- | Derive the tuplet structure of a set of 'RQ' values.+--+-- > rq_derive_tuplet [1/4,1/8,1/8] == Nothing+-- > rq_derive_tuplet [1/3,2/3] == Just (3,2)+-- > rq_derive_tuplet [1/2,1/3,1/6] == Just (3,2)+-- > rq_derive_tuplet [2/5,3/5] == Just (5,4)+-- > rq_derive_tuplet [1/3,1/6,2/5,1/10] == Just (15,8)+rq_derive_tuplet :: [RQ] -> Maybe (Integer,Integer)+rq_derive_tuplet =+    let f (i,j) = let k = i % j+                  in (numerator k,denominator k)+    in fmap f . rq_derive_tuplet_plain++-- | 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.+--+-- > map (rq_un_tuplet (3,2)) [1,2/3,1/2,1/3] == [3/2,1,3/4,1/2]+rq_un_tuplet :: (Integer,Integer) -> RQ -> RQ+rq_un_tuplet (i,j) x = x * (i % j)++-- | If an 'RQ' duration is un-representable by a single /cmn/+-- duration, give tied notation.+--+-- > catMaybes (map rq_to_cmn [1..9]) == [(4,1),(4,3),(8,1)]+--+-- > map rq_to_cmn [5/4,5/8] == [Just (1,1/4),Just (1/2,1/8)]+rq_to_cmn :: RQ -> Maybe (RQ,RQ)+rq_to_cmn x =+    let (i,j) = (numerator x,denominator x)+        k = case i of+              5 -> Just (4,1)+              7 -> Just (4,3)+              9 -> Just (8,1)+              _ -> Nothing+        f (n,m) = (n%j,m%j)+    in fmap f k++-- | Predicate to determine if a segment can be notated either without+-- a tuplet or with a single tuplet.+--+-- > rq_can_notate [1/2,1/4,1/4] == True+-- > rq_can_notate [1/3,1/6] == True+-- > rq_can_notate [2/5,1/10] == True+-- > rq_can_notate [1/3,1/6,2/5,1/10] == False+-- > rq_can_notate [4/7,1/7,6/7,3/7] == True+rq_can_notate :: [RQ] -> Bool+rq_can_notate x =+    let x' = case rq_derive_tuplet x of+               Nothing -> x+               Just t -> map (rq_un_tuplet t) x+    in all rq_is_cmn x'
+ Music/Theory/Duration/RQ/Division.hs view
@@ -0,0 +1,91 @@+-- | 'RQ' sub-divisions.+module Music.Theory.Duration.RQ.Division where++import Data.List.Split {- split -}+import Data.Ratio++import Music.Theory.Duration.RQ+import Music.Theory.Duration.RQ.Tied+import Music.Theory.List+import Music.Theory.Permutations.List++-- | Divisions of /n/ 'RQ' into /i/ equal parts grouped as /j/.+-- A quarter and eighth note triplet is written @(1,1,[2,1],False)@.+type RQ_Div = (Rational,Integer,[Integer],Tied_Right)++-- | Variant of 'RQ_Div' where /n/ is @1@.+type RQ1_Div = (Integer,[Integer],Tied_Right)++-- | Lift 'RQ1_Div' to 'RQ_Div'.+rq1_div_to_rq_div :: RQ1_Div -> RQ_Div+rq1_div_to_rq_div (i,j,k) = (1,i,j,k)++-- | Verify that grouping /j/ sums to the divisor /i/.+rq_div_verify :: RQ_Div -> Bool+rq_div_verify (_,n,m,_) = n == sum m++rq_div_mm_verify :: Int -> [RQ_Div] -> [(Integer,[RQ])]+rq_div_mm_verify n x =+    let q = map (sum . fst . rq_div_to_rq_set_t) x+    in zip [1..] (chunksOf n q)++-- | Translate from 'RQ_Div' to a sequence of 'RQ' values.+--+-- > rq_div_to_rq_set_t (1,5,[1,3,1],True) == ([1/5,3/5,1/5],True)+-- > rq_div_to_rq_set_t (1/2,6,[3,1,2],False) == ([1/4,1/12,1/6],False)+rq_div_to_rq_set_t :: RQ_Div -> ([RQ],Tied_Right)+rq_div_to_rq_set_t (n,k,d,t) =+    let q = map ((* n) . (% k)) d+    in (q,t)++-- | Translate from result of 'rq_div_to_rq_set_t' to seqeunce of 'RQ_T'.+--+-- > rq_set_t_to_rqt ([1/5,3/5,1/5],True) == [(1/5,_f),(3/5,_f),(1/5,_t)]+rq_set_t_to_rqt :: ([RQ],Tied_Right) -> [RQ_T]+rq_set_t_to_rqt (x,t) = at_last (\i -> (i,False)) (\i -> (i,t)) x++-- | Transform sequence of 'RQ_Div' into sequence of 'RQ', discarding+-- any final tie.+--+-- > let q = [(1,5,[1,3,1],True),(1/2,6,[3,1,2],True)]+-- > in rq_div_seq_rq q == [1/5,3/5,9/20,1/12,1/6]+rq_div_seq_rq :: [RQ_Div] -> [RQ]+rq_div_seq_rq =+    let f i qq = case qq of+                  [] -> maybe [] return i+                  q:qq' -> let (r,t) = rq_div_to_rq_set_t q+                               r' = maybe r (\j -> at_head (+ j) id r) i+                           in if t+                              then let (r'',i') = separate_last r'+                                   in r'' ++ f (Just i') qq'+                              else r' ++ f Nothing qq'+    in f Nothing++-- | Partitions of an 'Integral' that sum to /n/.  This includes the+-- two 'trivial paritions, into a set /n/ @1@, and a set of @1@ /n/.+--+-- > partitions_sum 4 == [[1,1,1,1],[2,1,1],[2,2],[3,1],[4]]+--+-- > map (length . partitions_sum) [9..15] == [30,42,56,77,101,135,176]+partitions_sum :: Integral i => i -> [[i]]+partitions_sum n =+    let f p = if null p then 0 else head p+    in case n of+         0 -> [[]]+         _ -> [x:y | x <- [1..n], y <- partitions_sum (n - x), x >= f y]++-- | The 'multiset_permutations' of 'partitions_sum'.+--+-- > map (length . partitions_sum_p) [9..12] == [256,512,1024,2048]+partitions_sum_p :: Integral i => i -> [[i]]+partitions_sum_p = concatMap multiset_permutations . partitions_sum++-- | The set of all 'RQ1_Div' that sum to /n/, a variant on+-- 'partitions_sum_p'.+--+-- > map (length . rq1_div_univ) [3..5] == [8,16,32]+-- > map (length . rq1_div_univ) [9..12] == [512,1024,2048,4096]+rq1_div_univ :: Integer -> [RQ1_Div]+rq1_div_univ n =+    let f l = [(n,l,k) | k <- [False,True]]+    in concatMap f (partitions_sum_p n)
+ Music/Theory/Duration/RQ/Tied.hs view
@@ -0,0 +1,91 @@+-- | 'RQ' values with /tie right/ qualifier.+module Music.Theory.Duration.RQ.Tied where++import Data.Maybe+import Music.Theory.Duration.Annotation+import Music.Theory.Duration.RQ+import Music.Theory.List++-- | Boolean.+type Tied_Right = Bool++-- | 'RQ' with /tie right/.+type RQ_T = (RQ,Tied_Right)++-- | Construct 'RQ_T'.+rqt :: Tied_Right -> RQ -> RQ_T+rqt t d = (d,t)++-- | 'RQ' field of 'RQ_T'.+rqt_rq :: RQ_T -> RQ+rqt_rq = fst++-- | 'Tied' field of 'RQ_T'.+rqt_tied :: RQ_T -> Tied_Right+rqt_tied = snd++-- | Is 'RQ_T' tied right.+is_tied_right :: RQ_T -> Bool+is_tied_right = snd++-- | 'RQ_T' variant of 'rq_un_tuplet'.+--+-- > rqt_un_tuplet (3,2) (1,T) == (3/2,T)+--+-- > let f = rqt_un_tuplet (7,4)+-- > in map f [(2/7,F),(4/7,T),(1/7,F)] == [(1/2,F),(1,T),(1/4,F)]+rqt_un_tuplet :: (Integer,Integer) -> RQ_T -> RQ_T+rqt_un_tuplet i (d,t) = (rq_un_tuplet i d,t)++-- | Transform 'RQ' to untied 'RQ_T'.+--+-- > rq_rqt 3 == (3,F)+rq_rqt :: RQ -> RQ_T+rq_rqt n = (n,False)++-- | Tie last element only of list of 'RQ'.+--+-- > rq_tie_last [1,2,3] == [(1,F),(2,F),(3,T)]+rq_tie_last :: [RQ] -> [RQ_T]+rq_tie_last = at_last rq_rqt (\d -> (d,True))++-- | Transform a list of 'RQ_T' to a list of 'Duration_A'.  The flag+-- indicates if the initial value is tied left.+--+-- > rqt_to_duration_a False [(1,T),(1/4,T),(3/4,F)]+rqt_to_duration_a :: Bool -> [RQ_T] -> [Duration_A]+rqt_to_duration_a z x =+    let rt = map is_tied_right x+        lt = z : rt+        f p e = if p then Just e else Nothing+        g r l = catMaybes [f r Tie_Right,f l Tie_Left]+        h = rq_to_duration_err (show ("rqt_to_duration_a",z,x)) . rqt_rq+    in zip (map h x) (zipWith g rt lt)++-- | 'RQ_T' variant of 'rq_can_notate'.+rqt_can_notate :: [RQ_T] -> Bool+rqt_can_notate = rq_can_notate . map rqt_rq++-- | 'RQ_T' variant of 'rq_to_cmn'.+--+-- > rqt_to_cmn (5,T) == Just ((4,T),(1,T))+-- > rqt_to_cmn (5/4,T) == Just ((1,T),(1/4,T))+-- > rqt_to_cmn (5/7,F) == Just ((4/7,T),(1/7,F))+rqt_to_cmn :: RQ_T -> Maybe (RQ_T,RQ_T)+rqt_to_cmn (k,t) =+    let f (i,j) = ((i,True),(j,t))+    in fmap f (rq_to_cmn k)++-- | List variant of 'rqt_to_cmn'.+--+-- > rqt_to_cmn_l (5,T) == [(4,T),(1,T)]+rqt_to_cmn_l :: RQ_T -> [RQ_T]+rqt_to_cmn_l x = maybe [x] (\(i,j) -> [i,j]) (rqt_to_cmn x)++-- | 'concatMap' 'rqt_to_cmn_l'.+--+-- > rqt_set_to_cmn [(1,T),(5/4,F)] == [(1,T),(1,T),(1/4,F)]+--+-- > rqt_set_to_cmn [(1/5,True),(1/20,False),(1/2,False),(1/4,True)]+rqt_set_to_cmn :: [RQ_T] -> [RQ_T]+rqt_set_to_cmn = concatMap rqt_to_cmn_l
Music/Theory/Duration/Sequence/Notate.hs view
@@ -1,428 +1,756 @@ -- | Notation of a sequence of 'RQ' values as annotated 'Duration' values.-module Music.Theory.Duration.Sequence.Notate-    (Duration_A-    ,Simplify,simplify-    ,notate,notate'-    ,ascribe-    ,group_boundary_lenient,group_boundary_strict) where--import Data.Maybe-import Data.Ratio-import Music.Theory.Duration-import Music.Theory.Duration.RQ--{--import Debug.Trace-debug :: (Show a) => a -> x -> x-debug = traceShow--}--debug :: (Show a) => a -> x -> x-debug _ x = x---- | Tuple of /start-time/, /duration/, /tied-left/ and /tied-right/.-type D = (RQ,RQ,Bool,Bool)---- | Annotated 'Duration'-type Duration_A = (Duration,[D_Annotation])---- | Duration of 'D'.-d_duration :: D -> RQ-d_duration (_,x,_,_) = x---- | Is 'Duration_A' tied to the the right?-da_tied_right :: Duration_A -> Bool-da_tied_right = elem Tie_Right . snd---- | dx -> d------ > integrate [1,2,3,4] == [1,3,6,10]-integrate :: (Num a) => [a] -> [a]-integrate = scanl1 (+)---- | Given /boundaries/ and /duration/ calculate step.------ > step_dur [2,1,3] 5 == ([2,1,2],[1])--- > step_dur [3%2,3%2,3%2] 2 == ([3%2,1%2],[1%1,3%2])-step_dur :: (Ord a, Num a) => [a] -> a -> ([a], [a])-step_dur l d =-    case d of-      0 -> error "step_dur: zero duration"-      _ -> case l of-             [] -> error "step_dur: no boundaries"-             x:xs -> 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))---- | xs = boundaries, d(s) = duration(s)------ > boundaries (repeat 3) [1..5] == [[1],[2],[3],[3,1],[2,3]]--- > boundaries (repeat (3%2)) [1%2,1..5]-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---- | Given an initial start time and a list of durations make--- /start-time/ and /duration/ pairs.------ > with_start_times 0 [4,3,5,2,1] == [(0,4),(4,3),(7,5),(12,2),(14,1)]-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' [[4,3],[2,1]] == [[(0,4),(4,3)],[(7,2),(9,1)]]--- > last (with_start_times' [[4,3,5],[2,1],[6,3]]) == [(15,6),(21,3)]-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' (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 /xs/ into first, possibly empty 'middle', and last parts.--- /xs/ must have at least two elements.------ > start_middle_end [] == undefined--- > start_middle_end [1,2] == (1,[],2)--- > start_middle_end [1..6] == (1,[2..5],6)-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"---- xs = [(start-time,duration)]-tied_r_to_d :: [(RQ,RQ)] -> [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 :: [RQ] -> [RQ] -> [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------ > map (r_mod (5/2)) [3/2,3/4] == [1,1/4]-r_mod :: RQ -> RQ -> RQ-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 :: RQ -> RQ -> 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)--}---- | Given /phase/ separate a /RQ/ duration if un-representable by a--- single /CMN/ duration (ie. requires tie).------ > sep_unrep 0 5 == Just (4,1)-sep_unrep :: RQ -> RQ -> Maybe (RQ,RQ)-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] == [Just (1%1,1%4),Just (1%8,1%2),Nothing]-zipWith (\i x -> sep_unrep_d (i,x,False,False)) [1,3%8,1] [5%4,5%8,4]--}--separate :: [RQ] -> [RQ] -> [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_lenient id [1,1,1] [2,1%2,1%2] == [[2%1],[1%2,1%2]]--- > group_boundary_lenient id [3,3,3] (cycle [1,2,3]) == [[1,2],[3],[1,2]]-group_boundary_lenient :: (a -> RQ) -> [RQ] -> [a] -> [[a]]-group_boundary_lenient dur_f =-    let go _ [] [] _ = []-        go _ _ [] _ = error "group_boundary_lenient: 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_lenient_d :: [RQ] -> [D] -> [[D]]-group_boundary_lenient_d = group_boundary_lenient d_duration--{--let i = [1,1%2,2,1%3,5%3,1%8,1%2,7%8]-in group_boundary_lenient_d (repeat 1) (separate (repeat 1) i)--}--with_sum :: (Num i) => (a -> i) -> [a] -> [(i,a)]-with_sum f =-    let go _ [] = []-        go i (x:xs) = (i,x) : go (i + f x) xs-    in go 0--to_boundary :: (Num i,Ord i) => (a->i) -> i -> [(i,a)] -> ([(i,a)],[(i,a)])-to_boundary f b = span (\(i,j) -> i + f j <= b)---- | Keeps the /zero/ duration chord element in the same measure.-group_boundary_strict' :: (Ord i,Num i) => (a->i) -> [i] -> [a] -> [[(i,a)]]-group_boundary_strict' f bs is =-    let is' = with_sum f is-        bs' = integrate bs-        go [] _ = []-        go (j:js) zs = let (x,y) = to_boundary f j zs-                       in x : go js y-    in go bs' is'---- | Variant on 'group_boundary_lenient'.------ > let g = group_boundary_strict id--- > in g [3,2,3] [1,0,1,1,0,2,0,1,1,1] == [[1,0,1,1,0],[2,0],[1,1,1]]-group_boundary_strict :: (Ord a, Num a) => (b -> a) -> [a] -> [b] -> [[b]]-group_boundary_strict f bs = map (map snd) . group_boundary_strict' f bs--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_lenient_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) -> RQ -> RQ-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 :: RQ -> RQ -> Bool-divisible_by i j = denominator (i / j) == 1---- | partial/incomplete/inaccurate------ > d_join 1 (7%4,1%4,False,True) (2%1,1%4,True,False) == Nothing-d_join :: RQ -> 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--{---- error checking variant-d_join' :: RQ -> 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---- | Type of function used by 'notate' to simplify duration sequence.---   Arguments specify /alignment/ and /boundaries/.-type Simplify = (RQ -> [RQ] -> [D] -> [D])---- | Simple minded two pass 'Simplify' function.  The two pass--- structure is so that @[2,1%2,1%2]@ becomes @[2,1]@ becomes @[3]@.-simplify :: Simplify-simplify a ns xs =-    let xs' = group_boundary_lenient_d ns xs-        pass :: [[D]] -> [[D]]-        pass = map (coalesce (d_join a))-    in concat ((pass . pass) xs')---- | Variant of 'rq_to_duration' with error message.-to_duration :: Show a => a -> RQ -> Duration-to_duration msg n =-    let err = error ("to_duration:" ++ show (msg,n))-    in fromMaybe err (rq_to_duration n)--tuplet :: (Integer,Integer) -> [Duration] -> [Duration_A]-tuplet (d,n) xs =-    let fn x = x { multiplier = n%d }-        xn = length xs-        ty = to_duration "tuplet" (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 the 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 ("notate-sec:no-tuplet",ds)-                           in map (\d -> (f d,[])) ds-                Just t -> let f = to_duration ("notate-sec: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'---- | Notate sequence of rational quarter note durations given a--- 'Simplify' function, a list of /unit divisions/ which must not--- conflict with a list of /boundaries/ (ie. measures).------ IMPORTANT NOTE: alignments are not handled correctly------ > let n = notate (Just simplify) (repeat 1) (repeat 4)--- > in n [3,3] == [(dotted_half_note,[]),(quarter_note,[Tie_Right]),(half_note,[Tie_Left])]-notate :: Maybe Simplify -> [RQ] -> [RQ] -> [RQ] -> [Duration_A]-notate smp is ns xs =-    let xs' = case smp of-                Nothing -> separate is xs-                Just f -> f (head is) ns (separate is xs)-    in concatMap notate_sec (group_boundary_lenient_d is xs')---- | Variant with default 'simplify' function and constant unit--- division of @1@.------ > map (duration_to_rq . fst) (notate' [4,4] [3,3,2]) == [3,1,2,2]-notate' :: [RQ] -> [RQ] -> [Duration_A]-notate' = notate (Just simplify) (repeat 1)--{--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_lenient_d is xs'--let is = [1,1,1,1%2,1%2,1,1]-let ns = [2%5,1%5,1%5,1%5+1%2,1%2,1,1%10,1%10,1%10,1%10,1%10,1%6,1%6,1%6+1%7,2%7,4%7,1]-notate (Just simplify) is [1,5] ns == notate Nothing is [1,5] ns--}--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---- | Zip a list of 'Duration_A' elements duplicating elements of the--- right hand sequence for tied durations.------ > map snd (ascribe (notate' [4,4] [3,3,2]) "xyz") == "xyyz"-ascribe :: [Duration_A] -> [x] -> [(Duration_A,x)]-ascribe = ascribe_fn da_tied_right+--+-- 1. Separate input sequence into measures, adding tie annotations as+-- required (see 'to_measures_ts').  Ensure all 'RQ_T' values can be+-- notated as /common music notation/ durations.+--+-- 2. Separate each measure into pulses (see 'm_divisions_ts').+-- Further subdivides pulses to ensure /cmn/ tuplet notation.  See+-- 'to_divisions_ts' for a composition of 'to_measures_ts' and+-- 'm_divisions_ts'.+--+-- 3. Simplify each measure (see 'm_simplify' and 'default_rule').+-- Coalesces tied durations where appropriate.+--+-- 4. Notate measures (see 'm_notate' or 'mm_notate').+--+-- 5. Ascribe values to notated durations, see 'ascribe'.+module Music.Theory.Duration.Sequence.Notate where++import Control.Applicative+import Control.Monad+import Data.List+import Data.List.Split {- split -}+import Data.Ratio+import Music.Theory.Duration+import Music.Theory.Duration.Annotation+import Music.Theory.Duration.RQ+import Music.Theory.Duration.RQ.Tied+import Music.Theory.List+import Music.Theory.Time_Signature++-- * Lists++-- | Variant of 'catMaybes'.  If all elements of the list are @Just+-- a@, then gives @Just [a]@ else gives 'Nothing'.+--+-- > all_just (map Just [1..3]) == Just [1..3]+-- > all_just [Just 1,Nothing,Just 3] == Nothing+all_just :: [Maybe a] -> Maybe [a]+all_just x =+    case x of+      [] -> Just []+      Just i:x' -> fmap (i :) (all_just x')+      Nothing:_ -> Nothing++-- | Variant of 'Data.Either.rights' that preserves first 'Left'.+--+-- > all_right (map Right [1..3]) == Right [1..3]+-- > all_right [Right 1,Left 'a',Left 'b'] == Left 'a'+all_right :: [Either a b] -> Either a [b]+all_right x =+    case x of+      [] -> Right []+      Right i:x' -> fmap (i :) (all_right x')+      Left i:_ -> Left i++-- | Applies a /join/ function to the first two elements of the list.+-- If the /join/ function succeeds the joined element is considered+-- for further coalescing.+--+-- > coalesce (\p q -> Just (p + q)) [1..5] == [15]+--+-- > let jn p q = if even p then Just (p + q) else Nothing+-- > in coalesce jn [1..5] == map sum [[1],[2,3],[4,5]]+coalesce :: (a -> a -> Maybe a) -> [a] -> [a]+coalesce f x =+    case x of+      (p:q:x') ->+          case f p q of+            Nothing -> p : coalesce f (q : x')+            Just r -> coalesce f (r : x')+      _ -> x++-- | Variant of 'coalesce' with accumulation parameter.+--+-- > coalesce_accum (\i p q -> Left (p + q)) 0 [1..5] == [(0,15)]+--+-- > let jn i p q = if even p then Left (p + q) else Right (p + i)+-- > in coalesce_accum jn 0 [1..7] == [(0,1),(1,5),(6,9),(15,13)]+--+-- > let jn i p q = if even p then Left (p + q) else Right [p,q]+-- > in coalesce_accum jn [] [1..5] == [([],1),([1,2],5),([5,4],9)]+coalesce_accum :: (b -> a -> a -> Either a b) -> b -> [a] -> [(b,a)]+coalesce_accum f i x =+    case x of+      [] -> []+      [p] -> [(i,p)]+      (p:q:x') ->+          case f i p q of+            Right j -> (i,p) : coalesce_accum f j (q : x')+            Left r -> coalesce_accum f i (r : x')++-- | Variant of 'coalesce_accum' that accumulates running sum.+--+-- > let f i p q = if i == 1 then Just (p + q) else Nothing+-- > in coalesce_sum (+) 0 f [1,1/2,1/4,1/4] == [1,1]+coalesce_sum :: (b -> a -> b) -> b -> (b -> a -> a -> Maybe a) -> [a] -> [a]+coalesce_sum add zero f =+    let g i p q = case f i p q of+                    Just r -> Left r+                    Nothing -> Right (i `add` p)+    in map snd . coalesce_accum g zero++-- * Either++-- | Lower 'Either' to 'Maybe' by discarding 'Left'.+either_to_maybe :: Either a b -> Maybe b+either_to_maybe = either (const Nothing) Just++-- * Separate++-- | Take elements while the sum of the prefix is less than or equal+-- to the indicated value.  Returns also the difference between the+-- prefix sum and the requested sum.  Note that zero elements are kept+-- left.+--+-- > take_sum_by id 3 [2,1] == ([2,1],0,[])+-- > take_sum_by id 3 [2,2] == ([2],1,[2])+-- > take_sum_by id 3 [2,1,0,1] == ([2,1,0],0,[1])+-- > take_sum_by id 3 [4] == ([],3,[4])+-- > take_sum_by id 0 [1..5] == ([],0,[1..5])+take_sum_by :: (Ord n, Num n) => (a -> n) -> n -> [a] -> ([a], n, [a])+take_sum_by f m =+    let go r n l =+            let z = (reverse r,m-n,l)+            in case l of+                 [] -> z+                 i:l' -> let n' = f i + n+                         in if n' > m+                            then z+                            else go (i:r) n' l'+    in go [] 0++-- | Variant of 'take_sum_by' with 'id' function.+take_sum :: (Ord a, Num a) => a -> [a] -> ([a],a,[a])+take_sum = take_sum_by id++-- | Variant of 'take_sum' that requires the prefix to sum to value.+--+-- > take_sum_by_eq id 3 [2,1,0,1] == Just ([2,1,0],[1])+-- > take_sum_by_eq id 3 [2,2] == Nothing+take_sum_by_eq :: (Ord n, Num n) => (a -> n) -> n -> [a] -> Maybe ([a], [a])+take_sum_by_eq f m l =+    case take_sum_by f m l of+      (p,0,q) -> Just (p,q)+      _ -> Nothing++-- | Recursive variant of 'take_sum_by_eq'.+--+-- > split_sum_by_eq id [3,3] [2,1,0,3] == Just [[2,1,0],[3]]+-- > split_sum_by_eq id [3,3] [2,2,2] == Nothing+split_sum_by_eq :: (Ord n, Num n) => (a -> n) -> [n] -> [a] -> Maybe [[a]]+split_sum_by_eq f mm l =+    case (mm,l) of+      ([],[]) -> Just []+      (m:mm',_) -> case take_sum_by_eq f m l of+                     Just (p,l') -> fmap (p :) (split_sum_by_eq f mm' l')+                     Nothing -> Nothing+      _ -> Nothing++-- | Split sequence such that the prefix sums to precisely /m/.  The+-- third element of the result indicates if it was required to divide+-- an element.  Not that zero elements are kept left.  If the required+-- sum is non positive, or the input list does not sum to at least the+-- required sum, gives nothing.+--+-- > split_sum 5 [2,3,1] == Just ([2,3],[1],Nothing)+-- > split_sum 5 [2,1,3] == Just ([2,1,2],[1],Just (2,1))+-- > split_sum 2 [3/2,3/2,3/2] == Just ([3/2,1/2],[1,3/2],Just (1/2,1))+-- > split_sum 6 [1..10] == Just ([1..3],[4..10],Nothing)+-- > fmap (\(a,_,c)->(a,c)) (split_sum 5 [1..]) == Just ([1,2,2],Just (2,1))+-- > split_sum 0 [1..] == Nothing+-- > split_sum 3 [1,1] == Nothing+-- > split_sum 3 [2,1,0] == Just ([2,1,0],[],Nothing)+-- > split_sum 3 [2,1,0,1] == Just ([2,1,0],[1],Nothing)+split_sum :: (Ord a, Num a) => a -> [a] -> Maybe ([a],[a],Maybe (a,a))+split_sum m l =+    let (p,n,q) = take_sum m l+    in if n == 0+       then if null p+            then Nothing+            else Just (p,q,Nothing)+       else case q of+              [] -> Nothing+              z:q' -> Just (p++[n],z-n:q',Just (n,z-n))++-- | Alias for 'True', used locally for documentation.+_t :: Bool+_t = True++-- | Alias for 'False', used locally for documentation.+_f :: Bool+_f = False++-- | Variant of 'split_sum' that operates at 'RQ_T' sequences.+--+-- > let r = Just ([(3,_f),(2,_t)],[(1,_f)])+-- > in rqt_split_sum 5 [(3,_f),(2,_t),(1,_f)] == r+--+-- > let r = Just ([(3,_f),(1,_t)],[(1,_t),(1,_f)])+-- > in rqt_split_sum 4 [(3,_f),(2,_t),(1,_f)] == r+rqt_split_sum :: RQ -> [RQ_T] -> Maybe ([RQ_T],[RQ_T])+rqt_split_sum d x =+    case split_sum d (map rqt_rq x) of+      Just (i,_,k) ->+          case k of+            Nothing -> Just (splitAt (length i) x)+            Just (p,q) -> let (s,(_,z):t) = splitAt (length i - 1) x+                          in Just (s ++ [(p,True)]+                                  ,(q,z) : t)+      Nothing -> Nothing++-- | Separate 'RQ_T' values in sequences summing to 'RQ' values.  This+-- is a recursive variant of 'rqt_split_sum'.  Note that is does not+-- ensure /cmn/ notation of values.+--+-- > let d = [(2,_f),(2,_f),(2,_f)]+-- > in rqt_separate [3,3] d == Right [[(2,_f),(1,_t)]+-- >                                 ,[(1,_f),(2,_f)]]+--+-- > let d = [(5/8,_f),(1,_f),(3/8,_f)]+-- > in rqt_separate [1,1] d == Right [[(5/8,_f),(3/8,_t)]+-- >                                 ,[(5/8,_f),(3/8,_f)]]+--+-- > let d = [(4/7,_t),(1/7,_f),(1,_f),(6/7,_f),(3/7,_f)]+-- > in rqt_separate [1,1,1] d == Right [[(4/7,_t),(1/7,_f),(2/7,_t)]+-- >                                    ,[(5/7,_f),(2/7,_t)]+-- >                                    ,[(4/7,_f),(3/7,_f)]]+rqt_separate :: [RQ] -> [RQ_T] -> Either String [[RQ_T]]+rqt_separate m x =+    case (m,x) of+      ([],[]) -> Right []+      ([],_) -> Left (show ("rqt_separate",x))+      (i:m',_) ->+          case rqt_split_sum i x of+            Just (r,x') -> fmap (r :) (rqt_separate m' x')+            Nothing -> Left (show ("rqt_separate",i,m',x))++rqt_separate_m :: [RQ] -> [RQ_T] -> Maybe [[RQ_T]]+rqt_separate_m m = either_to_maybe . rqt_separate m++-- | If the input 'RQ_T' sequence cannot be notated (see+-- 'rqt_can_notate') separate into equal parts, so long as each part+-- is not less than /i/.+--+-- > rqt_separate_tuplet undefined [(1/3,_f),(1/6,_f)]+-- > rqt_separate_tuplet undefined [(4/7,_t),(1/7,_f),(2/7,_f)]+--+-- > let d = map rq_rqt [1/3,1/6,2/5,1/10]+-- > in rqt_separate_tuplet (1/8) d == Right [[(1/3,_f),(1/6,_f)]+-- >                                         ,[(2/5,_f),(1/10,_f)]]+--+-- > let d = [(1/5,True),(1/20,False),(1/2,False),(1/4,True)]+-- > in rqt_separate_tuplet (1/16) d+--+-- > let d = [(2/5,_f),(1/5,_f),(1/5,_f),(1/5,_t),(1/2,_f),(1/2,_f)]+-- > in rqt_separate_tuplet (1/2) d+--+-- > let d = [(4/10,True),(1/10,False),(1/2,True)]+-- > in rqt_separate_tuplet (1/2) d+rqt_separate_tuplet :: RQ -> [RQ_T] -> Either String [[RQ_T]]+rqt_separate_tuplet i x =+    if rqt_can_notate x+    then Left (show ("rqt_separate_tuplet: cannot notate",x))+    else let j = sum (map rqt_rq x) / 2+         in if j < i+            then Left (show ("rqt_separate_tuplet: j < i",j,i))+            else rqt_separate [j,j] x++-- | Recursive variant of 'rqt_separate_tuplet'.+--+-- > let d = map rq_rqt [1,1/3,1/6,2/5,1/10]+-- > in rqt_tuplet_subdivide (1/8) d == [[(1/1,_f)]+-- >                                    ,[(1/3,_f),(1/6,_f)]+-- >                                    ,[(2/5,_f),(1/10,_f)]]+rqt_tuplet_subdivide :: RQ -> [RQ_T] -> [[RQ_T]]+rqt_tuplet_subdivide i x =+    case rqt_separate_tuplet i x of+      Left _ -> [x]+      Right r -> concatMap (rqt_tuplet_subdivide i) r++-- | Sequence variant of 'rqt_tuplet_subdivide'.+--+-- > let d = [(1/5,True),(1/20,False),(1/2,False),(1/4,True)]+-- > in rqt_tuplet_subdivide_seq (1/2) [d]+rqt_tuplet_subdivide_seq :: RQ -> [[RQ_T]] -> [[RQ_T]]+rqt_tuplet_subdivide_seq i = concatMap (rqt_tuplet_subdivide i)++-- | If a tuplet is all tied, it ought to be a plain value?!+--+-- > rqt_tuplet_sanity_ [(4/10,_t),(1/10,_f)] == [(1/2,_f)]+rqt_tuplet_sanity_ :: [RQ_T] -> [RQ_T]+rqt_tuplet_sanity_ t =+    let last_tied = rqt_tied (last t)+        all_tied = all rqt_tied (dropRight 1 t)+    in if all_tied+       then [(sum (map rqt_rq t),last_tied)]+       else t++rqt_tuplet_subdivide_seq_sanity_ :: RQ -> [[RQ_T]] -> [[RQ_T]]+rqt_tuplet_subdivide_seq_sanity_ i =+    map rqt_tuplet_sanity_ .+    rqt_tuplet_subdivide_seq i++-- * Divisions++-- | Separate 'RQ' sequence into measures given by 'RQ' length.+--+-- > to_measures_rq [3,3] [2,2,2] == Right [[(2,_f),(1,_t)],[(1,_f),(2,_f)]]+-- > to_measures_rq [3,3] [6] == Right [[(3,_t)],[(3,_f)]]+-- > to_measures_rq [1,1,1] [3] == Right [[(1,_t)],[(1,_t)],[(1,_f)]]+-- > to_measures_rq [3,3] [2,2,1]+-- > to_measures_rq [3,2] [2,2,2]+--+-- > let d = [4/7,33/28,9/20,4/5]+-- > in to_measures_rq [3] d == Right [[(4/7,_f),(33/28,_f),(9/20,_f),(4/5,_f)]]+to_measures_rq :: [RQ] -> [RQ] -> Either String [[RQ_T]]+to_measures_rq m = rqt_separate m . map rq_rqt++-- | Variant of 'to_measures_rq' that ensures 'RQ_T' are /cmn/+-- durations.  This is not a good composition.+--+-- > to_measures_rq_cmn [6,6] [5,5,2] == Right [[(4,_t),(1,_f),(1,_t)]+-- >                                           ,[(4,_f),(2,_f)]]+--+-- > let r = [[(4/7,_t),(1/7,_f),(1,_f),(6/7,_f),(3/7,_f)]]+-- > in to_measures_rq_cmn [3] [5/7,1,6/7,3/7] == Right r+--+-- > to_measures_rq_cmn [1,1,1] [5/7,1,6/7,3/7] == Right [[(4/7,_t),(1/7,_f),(2/7,_t)]+-- >                                                     ,[(4/7,_t),(1/7,_f),(2/7,_t)]+-- >                                                     ,[(4/7,_f),(3/7,_f)]]+to_measures_rq_cmn :: [RQ] -> [RQ] -> Either String [[RQ_T]]+to_measures_rq_cmn m = fmap (map rqt_set_to_cmn) . to_measures_rq m++-- | Variant of 'to_measures_rq' with measures given by+-- 'Time_Signature' values.  Does not ensure 'RQ_T' are /cmn/+-- durations.+--+-- > to_measures_ts [(1,4)] [5/8,3/8] /= Right [[(1/2,_t),(1/8,_f),(3/8,_f)]]+-- > to_measures_ts [(1,4)] [5/7,2/7] /= Right [[(4/7,_t),(1/7,_f),(2/7,_f)]]+--+-- > let {m = replicate 18 (1,4)+-- >     ;x = [3/4,2,5/4,9/4,1/4,3/2,1/2,7/4,1,5/2,11/4,3/2]}+-- > in to_measures_ts m x == Right [[(3/4,_f),(1/4,_t)],[(1/1,_t)]+-- >                                ,[(3/4,_f),(1/4,_t)],[(1/1,_f)]+-- >                                ,[(1/1,_t)],[(1/1,_t)]+-- >                                ,[(1/4,_f),(1/4,_f),(1/2,_t)],[(1/1,_f)]+-- >                                ,[(1/2,_f),(1/2,_t)],[(1/1,_t)]+-- >                                ,[(1/4,_f),(3/4,_t)],[(1/4,_f),(3/4,_t)]+-- >                                ,[(1/1,_t)],[(3/4,_f),(1/4,_t)]+-- >                                ,[(1/1,_t)],[(1/1,_t)]+-- >                                ,[(1/2,_f),(1/2,_t)],[(1/1,_f)]]+--+-- > to_measures_ts [(3,4)] [4/7,33/28,9/20,4/5]+-- > to_measures_ts (replicate 3 (1,4)) [4/7,33/28,9/20,4/5]+to_measures_ts :: [Time_Signature] -> [RQ] -> Either String [[RQ_T]]+to_measures_ts m = to_measures_rq (map ts_rq m)++-- | Variant of 'to_measures_ts' that allows for duration field+-- operation but requires that measures be well formed.  This is+-- useful for re-grouping measures after notation and ascription.+to_measures_ts_by_eq :: (a -> RQ) -> [Time_Signature] -> [a] -> Maybe [[a]]+to_measures_ts_by_eq f m = split_sum_by_eq f (map ts_rq m)++-- | Divide measure into pulses of indicated 'RQ' durations.  Measure+-- must be of correct length but need not contain only /cmn/+-- durations.  Pulses are further subdivided if required to notate+-- tuplets correctly, see 'rqt_tuplet_subdivide_seq'.+--+-- > let d = [(1/4,_f),(1/4,_f),(2/3,_t),(1/6,_f),(16/15,_f),(1/5,_f)+-- >         ,(1/5,_f),(2/5,_t),(1/20,_f),(1/2,_f),(1/4,_t)]+-- > in m_divisions_rq [1,1,1,1] d+--+-- > m_divisions_rq [1,1,1] [(4/7,_f),(33/28,_f),(9/20,_f),(4/5,_f)]+m_divisions_rq :: [RQ] -> [RQ_T] -> Either String [[RQ_T]]+m_divisions_rq z =+    fmap (rqt_tuplet_subdivide_seq_sanity_ (1/16) .+          map rqt_set_to_cmn) .+    rqt_separate z++-- | Variant of 'm_divisions_rq' that determines pulse divisions from+-- 'Time_Signature'.+--+-- > let d = [(4/7,_t),(1/7,_f),(2/7,_f)]+-- > in m_divisions_ts (1,4) d == Just [d]+--+-- > let d = map rq_rqt [1/3,1/6,2/5,1/10]+-- > in m_divisions_ts (1,4) d == Just [[(1/3,_f),(1/6,_f)]+-- >                                   ,[(2/5,_f),(1/10,_f)]]+--+-- > let d = map rq_rqt [4/7,33/28,9/20,4/5]+-- > in m_divisions_ts (3,4) d == Just [[(4/7,_f),(3/7,_t)]+-- >                                   ,[(3/4,_f),(1/4,_t)]+-- >                                   ,[(1/5,_f),(4/5,_f)]]+m_divisions_ts :: Time_Signature -> [RQ_T] -> Either String [[RQ_T]]+m_divisions_ts ts = m_divisions_rq (ts_divisions ts)++-- | Composition of 'to_measures_rq' and 'm_divisions_rq', where+-- measures are initially given as sets of divisions.+--+-- > let m = [[1,1,1],[1,1,1]]+-- > in to_divisions_rq m [2,2,2] == Just [[[(1,_t)],[(1,_f)],[(1,_t)]]+-- >                                      ,[[(1,_f)],[(1,_t)],[(1,_f)]]]+--+-- > let d = [2/7,1/7,4/7,5/7,8/7,1,1/7]+-- > in to_divisions_rq [[1,1,1,1]] d == Just [[[(2/7,_f),(1/7,_f),(4/7,_f)]+-- >                                           ,[(4/7,_t),(1/7,_f),(2/7,_t)]+-- >                                           ,[(6/7,_f),(1/7,_t)]+-- >                                           ,[(6/7,_f),(1/7,_f)]]]+--+-- > let d = [5/7,1,6/7,3/7]+-- > in to_divisions_rq [[1,1,1]] d == Just [[[(4/7,_t),(1/7,_f),(2/7,_t)]+-- >                                         ,[(4/7,_t),(1/7,_f),(2/7,_t)]+-- >                                         ,[(4/7,_f),(3/7,_f)]]]+--+-- > let d = [2/7,1/7,4/7,5/7,1,6/7,3/7]+-- > in to_divisions_rq [[1,1,1,1]] d == Just [[[(2/7,_f),(1/7,_f),(4/7,_f)]+-- >                                           ,[(4/7,_t),(1/7,_f),(2/7,_t)]+-- >                                           ,[(4/7,_t),(1/7,_f),(2/7,_t)]+-- >                                           ,[(4/7,_f),(3/7,_f)]]]+--+-- > let d = [4/7,33/28,9/20,4/5]+-- > in to_divisions_rq [[1,1,1]] d == Just [[[(4/7,_f),(3/7,_t)]+-- >                                         ,[(3/4,_f),(1/4,_t)]+-- >                                         ,[(1/5,_f),(4/5,_f)]]]+to_divisions_rq :: [[RQ]] -> [RQ] -> Either String [[[RQ_T]]]+to_divisions_rq m x =+    let m' = map sum m+    in case to_measures_rq m' x of+         Right y -> all_right (zipWith m_divisions_rq m y)+         Left e -> Left e++-- | Variant of 'to_divisions_rq' with measures given as set of+-- 'Time_Signature'.+--+-- > let d = [3/5,2/5,1/3,1/6,7/10,17/15,1/2,1/6]+-- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,_f),(2/5,_f)]+-- >                                       ,[(1/3,_f),(1/6,_f),(1/2,_t)]+-- >                                       ,[(1/5,_f),(4/5,_t)]+-- >                                       ,[(1/3,_f),(1/2,_f),(1/6,_f)]]]+--+-- > let d = [3/5,2/5,1/3,1/6,7/10,29/30,1/2,1/3]+-- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,_f),(2/5,_f)]+-- >                                       ,[(1/3,_f),(1/6,_f),(1/2,_t)]+-- >                                       ,[(1/5,_f),(4/5,_t)]+-- >                                       ,[(1/6,_f),(1/2,_f),(1/3,_f)]]]+--+-- > let d = [3/5,2/5,1/3,1/6,7/10,4/5,1/2,1/2]+-- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,_f),(2/5,_f)]+-- >                                       ,[(1/3,_f),(1/6,_f),(1/2,_t)]+-- >                                       ,[(1/5,_f),(4/5,_f)]+-- >                                       ,[(1/2,_f),(1/2,_f)]]]+--+-- > let d = [4/7,33/28,9/20,4/5]+-- > in to_divisions_ts [(3,4)] d == Just [[[(4/7,_f),(3/7,_t)]+-- >                                       ,[(3/4,_f),(1/4,_t)]+-- >                                       ,[(1/5,_f),(4/5,_f)]]]+to_divisions_ts :: [Time_Signature] -> [RQ] -> Either String [[[RQ_T]]]+to_divisions_ts ts = to_divisions_rq (map ts_divisions ts)++-- * Durations++-- | Pulse tuplet derivation.+--+-- > p_tuplet_rqt [(2/3,_f),(1/3,_t)] == Just ((3,2),[(1,_f),(1/2,_t)])+-- > p_tuplet_rqt (map rq_rqt [1/3,1/6]) == Just ((3,2),[(1/2,_f),(1/4,_f)])+-- > p_tuplet_rqt (map rq_rqt [2/5,1/10]) == Just ((5,4),[(1/2,_f),(1/8,_f)])+-- > p_tuplet_rqt (map rq_rqt [1/3,1/6,2/5,1/10])+p_tuplet_rqt :: [RQ_T] -> Maybe ((Integer,Integer),[RQ_T])+p_tuplet_rqt x =+    let f t = (t,map (rqt_un_tuplet t) x)+    in fmap f (rq_derive_tuplet (map rqt_rq x))++-- | Notate pulse, ie. derive tuplet if neccesary. The flag indicates+-- if the initial value is tied left.+--+-- > p_notate False [(2/3,_f),(1/3,_t)]+-- > p_notate False [(2/5,_f),(1/10,_t)]+-- > p_notate False [(1/4,_t),(1/8,_f),(1/8,_f)]+-- > p_notate False (map rq_rqt [1/3,1/6])+-- > p_notate False (map rq_rqt [2/5,1/10])+-- > p_notate False (map rq_rqt [1/3,1/6,2/5,1/10]) == Nothing+p_notate :: Bool -> [RQ_T] -> Either String [Duration_A]+p_notate z x =+    let f = p_simplify . rqt_to_duration_a z+        d = case p_tuplet_rqt x of+              Just (t,x') -> da_tuplet t (f x')+              Nothing -> f x+    in if rq_can_notate (map rqt_rq x) then Right d else Left (show ("p_notate",z,x))++-- | Notate measure.+--+-- > m_notate True [[(2/3,_f),(1/3,_t)],[(1,_t)],[(1,_f)]]+--+-- > let f = m_notate False . concat+--+-- > fmap f (to_divisions_ts [(4,4)] [3/5,2/5,1/3,1/6,7/10,17/15,1/2,1/6])+-- > fmap f (to_divisions_ts [(4,4)] [3/5,2/5,1/3,1/6,7/10,29/30,1/2,1/3])+m_notate :: Bool -> [[RQ_T]] -> Either String [Duration_A]+m_notate z m =+    let z' = z : map (is_tied_right . last) m+    in fmap concat (all_right (zipWith p_notate z' m))++-- | Multiple measure notation.+--+-- > let d = [2/7,1/7,4/7,5/7,8/7,1,1/7]+-- > in fmap mm_notate (to_divisions_ts [(4,4)] d)+--+-- > let d = [2/7,1/7,4/7,5/7,1,6/7,3/7]+-- > in fmap mm_notate (to_divisions_ts [(4,4)] d)+--+-- > let d = [3/5,2/5,1/3,1/6,7/10,4/5,1/2,1/2]+-- > in fmap mm_notate (to_divisions_ts [(4,4)] d)+mm_notate :: [[[RQ_T]]] -> Either String [[Duration_A]]+mm_notate d =+    let z = False : map (is_tied_right . last . last) d+    in all_right (zipWith m_notate z d)++-- * Simplifications++-- | Structure given to 'Simplify_P' to decide simplification.  The+-- structure is /(ts,start-rq,(left-rq,right-rq))/.+type Simplify_T = (Time_Signature,RQ,(RQ,RQ))++-- | Predicate function at 'Simplify_T'.+type Simplify_P = Simplify_T -> Bool++-- | Variant of 'Simplify_T' allowing multiple rules.+type Simplify_M = ([Time_Signature],[RQ],[(RQ,RQ)])++-- | Transform 'Simplify_M' to 'Simplify_P'.+meta_table_p :: Simplify_M -> Simplify_P+meta_table_p (tt,ss,pp) (t,s,p) = t `elem` tt && s `elem` ss && p `elem` pp++-- | Transform 'Simplify_M' to set of 'Simplify_T'.+meta_table_t :: Simplify_M -> [Simplify_T]+meta_table_t (tt,ss,pp) = [(t,s,p) | t <- tt, s <- ss,p <- pp]++-- | The default table of simplifiers.+--+-- > default_table ((3,4),1,(1,1)) == True+default_table :: Simplify_P+default_table x =+    let t :: [Simplify_M]+        t = [([(3,4)],[1],[(1,1)])]+        p :: [Simplify_P]+        p = map meta_table_p t+    in or (p <*> pure x)++-- | The default eighth-note pulse simplifier rule.+--+-- > default_8_rule ((3,8),0,(1/2,1/2)) == True+-- > default_8_rule ((3,8),1/2,(1/2,1/2)) == True+-- > default_8_rule ((3,8),1,(1/2,1/2)) == True+-- > default_8_rule ((2,8),0,(1/2,1/2)) == True+-- > default_8_rule ((5,8),0,(1,1/2)) == True+-- > default_8_rule ((5,8),0,(2,1/2)) == True+default_8_rule :: Simplify_P+default_8_rule ((i,j),t,(p,q)) =+    let r = p + q+    in j == 8 &&+       denominator t `elem` [1,2] &&+       (r <= 2 || r == ts_rq (i,j) || rq_is_integral r)++-- | The default quarter note pulse simplifier rule.+--+-- > default_4_rule ((3,4),0,(1,1/2)) == True+-- > default_4_rule ((3,4),0,(1,3/4)) == True+-- > default_4_rule ((4,4),1,(1,1)) == False+-- > default_4_rule ((4,4),2,(1,1)) == True+-- > default_4_rule ((4,4),2,(1,2)) == True+-- > default_4_rule ((4,4),0,(2,1)) == True+-- > default_4_rule ((3,4),1,(1,1)) == False+default_4_rule :: Simplify_P+default_4_rule ((_,j),t,(p,q)) =+    let r = p + q+    in j == 4 &&+       denominator t == 1 &&+       even (numerator t) &&+       (r <= 2 || rq_is_integral r)++{-+-- | Any pulse-division aligned pair that sums to a division of the+-- pulse and does not cross a pulse boundary can be simplified.+--+-- > default_aligned_pulse_rule ((4,2),0,(2,1)) == True+-- > default_aligned_pulse_rule ((4,2),1,(1,1)) == False+-- > default_aligned_pulse_rule ((4,2),7,(4/10,1/10)) == True+default_aligned_pulse_rule :: Simplify_P+default_aligned_pulse_rule ((_,j),t,(p,q)) =+    let r = p + q+        w = whole_note_division_to_rq j+        tw = t `rq_mod` w+    in w `rq_mod` r == 0 &&+       t `rq_mod` (w `min` 1) == 0 &&+       (tw == 0 || tw + r <= w)+-}++-- | The default simplifier rule.  To extend provide a list of+-- 'Simplify_T'.+default_rule :: [Simplify_T] -> Simplify_P+default_rule x r = r `elem` x ||+                   {-default_aligned_pulse_rule r ||-}+                   default_4_rule r ||+                   default_8_rule r ||+                   default_table r++-- | Measure simplifier.  Apply given 'Simplify_P'.+m_simplify :: Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]+m_simplify p ts =+    let f st (d0,a0) (d1,a1) =+            let t = Tie_Right `elem` a0 && Tie_Left `elem` a1+                e = End_Tuplet `notElem` a0 || any begins_tuplet a1+                m = duration_meq d0 d1+                d = sum_dur d0 d1+                a = delete Tie_Right a0 ++ delete Tie_Left a1+                r = p (ts,st,(duration_to_rq d0,duration_to_rq d1))+                n_dots = 1+                g i = if dots i <= n_dots && t && e && m && r+                      then Just (i,a)+                      else Nothing+            in join (fmap g d)+        z i (j,_) = i + duration_to_rq j+    in coalesce_sum z 0 f++-- | Pulse simplifier predicate, which is 'const' 'True'.+p_simplify_rule :: Simplify_P+p_simplify_rule = const True++-- | Pulse simplifier.+--+-- > import Music.Theory.Duration.Name.Abbreviation+-- > p_simplify [(q,[Tie_Right]),(e,[Tie_Left])] == [(q',[])]+-- > p_simplify [(e,[Tie_Right]),(q,[Tie_Left])] == [(q',[])]+-- > p_simplify [(q,[Tie_Right]),(e',[Tie_Left])] == [(q'',[])]+-- > p_simplify [(q'',[Tie_Right]),(s,[Tie_Left])] == [(h,[])]+-- > p_simplify [(e,[Tie_Right]),(s,[Tie_Left]),(e',[])] == [(e',[]),(e',[])]+--+-- > let f = rqt_to_duration_a False+-- > in p_simplify (f [(1/8,_t),(1/4,_t),(1/8,_f)]) == f [(1/2,_f)]+p_simplify :: [Duration_A] -> [Duration_A]+p_simplify = m_simplify p_simplify_rule undefined++-- * Notate++-- | Composition of 'to_divisions_ts', 'mm_notate' 'm_simplify'.+notate :: Simplify_P -> [Time_Signature] -> [RQ] -> Either String [[Duration_A]]+notate r ts x = do+    mm <- to_divisions_ts ts x+    dd <- mm_notate mm+    return (zipWith (m_simplify r) ts dd)++-- * Ascribe++-- | Variant of 'zip' that retains elements of the right hand (rhs)+-- list where elements of the left hand (lhs) list meet the given lhs+-- predicate.  If the right hand side is longer the remaining elements+-- to be processed are given.  It is an error for the right hand side+-- to be short.+--+-- > zip_hold_lhs even [1..5] "abc" == ([],zip [1..6] "abbcc")+-- > zip_hold_lhs odd [1..6] "abc" == ([],zip [1..6] "aabbcc")+-- > zip_hold_lhs even [1] "ab" == ("b",[(1,'a')])+-- > zip_hold_lhs even [1,2] "a" == undefined+zip_hold_lhs :: (x -> Bool) -> [x] -> [t] -> ([t],[(x,t)])+zip_hold_lhs lhs_f =+    let f st e =+            case st of+              r:s -> let st' = if lhs_f e then st else s+                     in (st',(e,r))+              _ -> error "zip_hold_lhs: rhs ends"+    in flip (mapAccumL f)++-- | Variant of 'zip_hold' that requires the right hand side to be+-- precisely the required length.+--+-- > zip_hold_lhs_err even [1..5] "abc" == zip [1..6] "abbcc"+-- > zip_hold_lhs_err odd [1..6] "abc" == zip [1..6] "aabbcc"+-- > zip_hold_lhs_err id [False,False] "a" == undefined+-- > zip_hold_lhs_err id [False] "ab" == undefined+zip_hold_lhs_err :: (x -> Bool) -> [x] -> [a] -> [(x,a)]+zip_hold_lhs_err lhs_f p q =+    case zip_hold_lhs lhs_f p q of+      ([],r) -> r+      _ -> error "zip_hold_lhs_err: lhs ends"++-- | Variant of 'zip' that retains elements of the right hand (rhs)+-- list where elements of the left hand (lhs) list meet the given lhs+-- predicate, and elements of the lhs list where elements of the ths+-- meet the rhs predicate.  If the right hand side is longer the+-- remaining elements to be processed are given.  It is an error for+-- the right hand side to be short.+--+-- > zip_hold even (const False) [1..5] "abc" == ([],zip [1..6] "abbcc")+-- > zip_hold odd (const False) [1..6] "abc" == ([],zip [1..6] "aabbcc")+-- > zip_hold even (const False) [1] "ab" == ("b",[(1,'a')])+-- > zip_hold even (const False) [1,2] "a" == undefined+--+-- > zip_hold odd even [1,2,6] [1..5] == ([4,5],[(1,1),(2,1),(6,2),(6,3)])+zip_hold :: (x -> Bool) -> (t -> Bool) -> [x] -> [t] -> ([t],[(x,t)])+zip_hold lhs_f rhs_f =+    let f r x t =+            case (x,t) of+              ([],_) -> (t,reverse r)+              (_,[]) -> error "zip_hold: rhs ends"+              (x0:x',t0:t') -> let x'' = if rhs_f t0 then x else x'+                                   t'' = if lhs_f x0 then t else t'+                               in f ((x0,t0) : r) x'' t''+    in f []++-- | Zip a list of 'Duration_A' elements duplicating elements of the+-- right hand sequence for tied durations.+--+-- > let {Just d = to_divisions_ts [(4,4),(4,4)] [3,3,2]+-- >     ;f = map snd . snd . flip m_ascribe "xyz"}+-- > in fmap f (notate d) == Just "xxxyyyzz"+m_ascribe :: [Duration_A] -> [x] -> ([x],[(Duration_A,x)])+m_ascribe = zip_hold_lhs da_tied_right++-- | 'snd' '.' 'm_ascribe'.+ascribe :: [Duration_A] -> [x] -> [(Duration_A, x)]+ascribe d = snd . m_ascribe d++-- | Variant of 'm_ascribe' for a set of measures.+mm_ascribe :: [[Duration_A]] -> [x] -> [[(Duration_A,x)]]+mm_ascribe mm x =+    case mm of+      [] -> []+      m:mm' -> let (x',r) = m_ascribe m x+               in r : mm_ascribe mm' x'++-- | Group elements as /chords/ where a chord element is inidicated by+-- the given predicate.+--+-- > group_chd even [1,2,3,4,4,5,7,8] == [[1,2],[3,4,4],[5],[7,8]]+group_chd :: (x -> Bool) -> [x] -> [[x]]+group_chd f x =+    case split (keepDelimsL (whenElt (not.f))) x of+      []:r -> r+      _ -> error "group_chd: first element chd?"++-- | Variant of 'ascribe' that groups the /rhs/ elements using+-- 'group_chd' and with the indicated /chord/ function, then rejoins+-- the resulting sequence.+ascribe_chd :: (x -> Bool) -> [Duration_A] -> [x] -> [(Duration_A, x)]+ascribe_chd chd_f d x =+    let x' = group_chd chd_f x+        jn (i,j) = zip (repeat i) j+    in concatMap jn (ascribe d x')++-- | Variant of 'mm_ascribe' using 'group_chd'+mm_ascribe_chd :: (x -> Bool) -> [[Duration_A]] -> [x] -> [[(Duration_A,x)]]+mm_ascribe_chd chd_f d x =+    let x' = group_chd chd_f x+        jn (i,j) = zip (repeat i) j+    in map (concatMap jn) (mm_ascribe d x')
+ Music/Theory/Dynamic_Mark.hs view
@@ -0,0 +1,120 @@+-- | Common music notation dynamic marks.+module Music.Theory.Dynamic_Mark where++import Data.List+import Data.Maybe+import Music.Theory.List++-- | Enumeration of dynamic mark symbols.+data Dynamic_Mark_T = Niente+                    | PPPPP | PPPP | PPP | PP | P | MP+                    | MF | F | FF | FFF | FFFF | FFFFF+                    | FP | SF | SFP | SFPP | SFZ | SFFZ+                      deriving (Eq,Ord,Enum,Bounded,Show)++-- | Lookup MIDI velocity for 'Dynamic_Mark_T'.  The range is linear+-- in @0-127@.+--+-- > let r = [0,6,17,28,39,50,61,72,83,94,105,116,127]+-- > in mapMaybe dynamic_mark_midi [Niente .. FFFFF] == r+dynamic_mark_midi :: (Num n,Enum n) => Dynamic_Mark_T -> Maybe n+dynamic_mark_midi m =+    let r = zip [0..] (0 : reverse [127, 127-11 .. 0])+    in lookup (fromEnum m) r++-- | Translate /fixed/ 'Dynamic_Mark_T's to /db/ amplitude over given+-- /range/.+--+-- > mapMaybe (dynamic_mark_db 120) [Niente,P,F,FFFFF] == [-120,-70,-40,0]+-- > mapMaybe (dynamic_mark_db 60) [Niente,P,F,FFFFF] == [-60,-35,-20,0]+dynamic_mark_db :: Fractional n => n -> Dynamic_Mark_T -> Maybe n+dynamic_mark_db r m =+    let u = [Niente .. FFFFF]+        n = length u - 1+        k = r / fromIntegral n+        f i = negate r + (fromIntegral i * k)+    in fmap f (elemIndex m u)++-- | Enumeration of hairpin indicators.+data Hairpin_T = Crescendo | Diminuendo | End_Hairpin+                 deriving (Eq,Ord,Enum,Bounded,Show)++-- | The 'Hairpin_T' implied by a ordered pair of 'Dynamic_Mark_T's.+--+-- > map (implied_hairpin MF) [MP,F] == [Just Diminuendo,Just Crescendo]+implied_hairpin :: Dynamic_Mark_T -> Dynamic_Mark_T -> Maybe Hairpin_T+implied_hairpin p q =+    case compare p q of+      LT -> Just Crescendo+      EQ -> Nothing+      GT -> Just Diminuendo++-- | A node in a dynamic sequence.+type Dynamic_Node = (Maybe Dynamic_Mark_T,Maybe Hairpin_T)++-- | The empty 'Dynamic_Node'.+empty_dynamic_node :: Dynamic_Node+empty_dynamic_node = (Nothing,Nothing)++-- | Calculate a 'Dynamic_Node' sequence from a sequence of+-- 'Dynamic_Mark_T's.+--+-- > dynamic_sequence [PP,MP,MP,PP] == [(Just PP,Just Crescendo)+-- >                                   ,(Just MP,Just End_Hairpin)+-- >                                   ,(Nothing,Just Diminuendo)+-- >                                   ,(Just PP,Just End_Hairpin)]+dynamic_sequence :: [Dynamic_Mark_T] -> [Dynamic_Node]+dynamic_sequence d =+    let h = zipWith implied_hairpin d (tail d) ++ [Nothing]+        e = Just End_Hairpin+        rec i p =+            case p of+              [] -> []+              [(j,_)] -> if i then [(j,e)] else [(j,Nothing)]+              (j,k):p' -> case k of+                            Nothing -> if i+                                       then (j,e) : rec False p'+                                       else (j,k) : rec False p'+                            Just _ -> (j,k) : rec True p'+    in rec False (zip (indicate_repetitions d) h)++-- | Delete redundant (unaltered) dynamic marks.+--+-- > let s = [Just P,Nothing,Just P,Just P,Just F]+-- > in delete_redundant_marks s == [Just P,Nothing,Nothing,Nothing,Just F]+delete_redundant_marks :: [Maybe Dynamic_Mark_T] -> [Maybe Dynamic_Mark_T]+delete_redundant_marks =+    let f i j = case (i,j) of+                  (Just a,Just b) -> if a == b then (j,Nothing) else (j,j)+                  (Just _,Nothing) -> (i,Nothing)+                  (Nothing,_) -> (j,j)+    in snd . mapAccumL f Nothing++-- | Variant of 'dynamic_sequence' for sequences of 'Dynamic_Mark_T'+-- with holes (ie. rests).  Runs 'delete_redundant_marks'.+--+-- > let r = [Just (Just P,Just Crescendo),Just (Just F,Just End_Hairpin)+-- >         ,Nothing,Just (Just P,Nothing)]+-- > in dynamic_sequence_sets [Just P,Just F,Nothing,Just P] == r+--+-- > let s = [Just P,Nothing,Just P]+-- > in dynamic_sequence_sets s = [Just (Just P,Nothing),Nothing,Nothing]+dynamic_sequence_sets :: [Maybe Dynamic_Mark_T] -> [Maybe Dynamic_Node]+dynamic_sequence_sets =+    let f l = case l of+                Nothing:_ -> map (const Nothing) l+                _ -> map Just (dynamic_sequence (catMaybes l))+    in concatMap f . group_just . delete_redundant_marks++-- | Apply 'Hairpin_T' and 'Dynamic_Mark_T' functions in that order as+-- required by 'Dynamic_Node'.+--+-- > let f _ x = show x+-- > in apply_dynamic_node f f (Nothing,Just Crescendo) undefined+apply_dynamic_node :: (a -> Dynamic_Mark_T -> a) -> (a -> Hairpin_T -> a)+                   -> Dynamic_Node -> a -> a+apply_dynamic_node f g (i,j) m =+    let n = maybe m (g m) j+    in maybe n (f n) i++
Music/Theory/Interval.hs view
@@ -1,6 +1,7 @@ -- | Common music notation intervals. module Music.Theory.Interval where +import qualified Data.List as L import Data.Maybe import Music.Theory.Pitch @@ -15,7 +16,9 @@                 | Major | Augmented                   deriving (Eq,Enum,Bounded,Ord,Show) --- | Common music notation interval.+-- | Common music notation interval.  An 'Ordering' of 'LT' indicates+-- an ascending interval, 'GT' a descending interval, and 'EQ' a+-- unison. data Interval = Interval {interval_type :: Interval_T                          ,interval_quality :: Interval_Q                          ,interval_direction :: Ordering@@ -30,8 +33,9 @@  -- | Table of interval qualities.  For each 'Interval_T' gives -- directed semitone interval counts for each allowable 'Interval_Q'.--- For lookup function see 'interval_q'.-interval_q_tbl :: [(Interval_T, [(Int,Interval_Q)])]+-- For lookup function see 'interval_q', for reverse lookup see+-- 'interval_q_reverse'.+interval_q_tbl :: Integral n => [(Interval_T, [(n,Interval_Q)])] interval_q_tbl =     [(Unison,[(11,Diminished)              ,(0,Perfect)@@ -67,6 +71,27 @@ -- > interval_q Unison 3 == Nothing interval_q :: Interval_T -> Int -> Maybe Interval_Q interval_q i n = lookup i interval_q_tbl >>= lookup n++-- | Lookup semitone difference of 'Interval_T' with 'Interval_Q'.+--+-- > interval_q_reverse Third Minor == Just 3+-- > interval_q_reverse Unison Diminished == Just 11+interval_q_reverse :: Interval_T -> Interval_Q -> Maybe Integer+interval_q_reverse ty qu =+    case lookup ty interval_q_tbl of+      Nothing -> Nothing+      Just tbl -> fmap fst (L.find ((== qu) . snd) tbl)++-- | Semitone difference of 'Interval'.+--+-- > interval_semitones (interval (Pitch C Sharp 4) (Pitch E Sharp 5)) == 16+-- > interval_semitones (interval (Pitch C Natural 4) (Pitch D Sharp 3)) == -9+interval_semitones :: Interval -> Integer+interval_semitones (Interval ty qu dir oct) =+    case interval_q_reverse ty qu of+      Just n -> let o = 12 * oct+                in if dir == GT then negate n - o else n + o+      Nothing -> error "interval_semitones"  -- | Inclusive set of 'Note_T' within indicated interval.  This is not -- equal to 'enumFromTo' which is not circular.
+ Music/Theory/Interval/Barlow_1987.hs view
@@ -0,0 +1,180 @@+-- | Clarence Barlow. \"Two Essays on Theory\".+-- /Computer Music Journal/, 11(1):44-60, 1987.+-- Translated by Henning Lohner.+module Music.Theory.Interval.Barlow_1987 where++import Data.List+import Data.Maybe+import Data.Numbers.Primes {- primes -}+import Data.Ratio+import Text.Printf++-- | Barlow's /indigestibility/ function for prime numbers.+--+-- > map barlow [1,2,3,5,7,11,13] == [0,1,8/3,32/5,72/7,200/11,288/13]+barlow :: (Integral a,Fractional b) => a -> b+barlow p =+    let p' = fromIntegral p+        square n = n * n+    in 2 * (square (p' - 1) / p')++-- | Generate list of factors of /n/ from /x/.+--+-- > factor primes 315 == [3,3,5,7]+factor :: Integral a => [a] -> a -> [a]+factor x n =+    case x of+      [] -> undefined+      i:x' -> if i * i > n+              then [n]+              else if rem n i == 0+                   then i : factor x (quot n i)+                   else factor x' n++-- | 'factor' /n/ from 'primes'.+--+-- > prime_factors 315 == [3,3,5,7]+prime_factors :: Integral a => a -> [a]+prime_factors = factor primes++-- | Collect number of occurences of each element of a sorted list.+--+-- > multiplicities [1,1,1,2,2,3] == [(1,3),(2,2),(3,1)]+multiplicities :: (Eq a,Integral n) => [a] -> [(a,n)]+multiplicities =+    let f x = case x of+                [] -> undefined+                e:_ -> (e,genericLength x)+    in map f . group++-- | 'multiplicities' '.' 'prime_factors'.+--+-- > prime_factors_m 315 == [(3,2),(5,1),(7,1)]+prime_factors_m :: Integral a => a -> [(a,a)]+prime_factors_m = multiplicities . prime_factors++-- | Merging function for 'rational_prime_factors_m'.+merge :: (Ord a,Num b,Eq b) => [(a,b)] -> [(a,b)] -> [(a,b)]+merge p q =+    case (p,q) of+      (_,[]) -> p+      ([],_) -> map (\(i,j) -> (i,-j)) q+      ((a,b):p',(c,d):q') ->+          if a < c+          then (a,b) : merge p' q+          else if a > c+               then (c,-d) : merge p q'+               else if b /= d+                    then (a,b-d) : merge p' q'+                    else merge p' q'++-- | Collect the prime factors in a rational number given as a+-- numerator/ denominator pair (n,m). Prime factors are listed in+-- ascending order with their positive or negative multiplicities,+-- depending on whether the prime factor occurs in the numerator or+-- the denominator (after cancelling out common factors).+--+-- > rational_prime_factors_m (16,15) == [(2,4),(3,-1),(5,-1)]+-- > rational_prime_factors_m (10,9) == [(2,1),(3,-2),(5,1)]+-- > rational_prime_factors_m (81,64) == [(2,-6),(3,4)]+-- > rational_prime_factors_m (27,16) == [(2,-4),(3,3)]+-- > rational_prime_factors_m (12,7) == [(2,2),(3,1),(7,-1)]+rational_prime_factors_m :: Integral b => (b,b) -> [(b,b)]+rational_prime_factors_m (n,m) =+    let n' = prime_factors_m n+        m' = prime_factors_m m+    in merge n' m'++-- | Variant of 'rational_prime_factors_m' giving results in a table+-- up to the /n/th prime.+--+-- > rational_prime_factors_t 6 (12,7) == [2,1,0,-1,0,0]+rational_prime_factors_t :: Integral b => Int -> (b,b) -> [b]+rational_prime_factors_t n x =+    let r = rational_prime_factors_m x+    in map (\i -> fromMaybe 0 (lookup i r)) (take n primes)++-- | Compute the disharmonicity of the interval /(p,q)/ using the+-- prime valuation function /pv/.+--+-- > map (disharmonicity barlow) [(9,10),(8,9)] ~= [12.733333,8.333333]+disharmonicity :: (Integral a,Num b) => (a -> b) -> (a,a) -> b+disharmonicity pv (p,q) =+    let n = rational_prime_factors_m (p,q)+    in sum [abs (fromIntegral j) * pv i | (i,j) <- n]++-- | The reciprocal of 'disharmonicity'.+--+-- > map (harmonicity barlow) [(9,10),(8,9)] ~= [0.078534,0.120000]+harmonicity :: (Integral a,Fractional b) => (a -> b) -> (a,a) -> b+harmonicity pv = recip . disharmonicity pv++-- | Variant of 'harmonicity' with 'Ratio' input.+harmonicity_r :: (Integral a,Fractional b) => (a -> b) -> Ratio a -> b+harmonicity_r pv = harmonicity pv . from_rational++-- | Interval ratio to cents.+--+-- > map cents [16%15,16%9] == [111.73128526977776,996.0899982692251]+cents :: (Real a,Floating b) => a -> b+cents x = 1200 * logBase 2 (realToFrac x)++-- | 'uncurry' ('%').+to_rational :: Integral a => (a,a) -> Ratio a+to_rational = uncurry (%)++-- | Make 'numerator' 'denominator' pair of /n/.+from_rational :: Integral t => Ratio t -> (t, t)+from_rational n = (numerator n,denominator n)++-- | Set of 1. interval size (cents), 2. intervals as product of+-- powers of primes, 3. frequency ratio and 4. harmonicity value.+type Table_2_Row = (Double,[Integer],Rational,Double)++-- | Table 2 (p.45)+--+-- > length (table_2 0.06) == 24+table_2 :: Double -> [Table_2_Row]+table_2 z =+    let g n = n <= 2 && n >= 1+        r = nub (sort (filter g [p % q | p <- [1..81],q <- [1..81]]))+        h = map (harmonicity_r barlow) r+        f = (> z) . snd+        k (i,j) = (cents i,rational_prime_factors_t 6 (from_rational i),i,j)+    in map k (filter f (zip r h))++-- | Pretty printer for 'Table_2_Row' values.+--+-- > mapM_ (putStrLn . table_2_pp) (table_2 0.06)+--+-- >    0.000 |  0  0  0  0  0  0 |  1:1  | Infinity+-- >  111.731 |  4 -1 -1  0  0  0 | 15:16 | 0.076531+-- >  182.404 |  1 -2  1  0  0  0 |  9:10 | 0.078534+-- >  203.910 | -3  2  0  0  0  0 |  8:9  | 0.120000+-- >  231.174 |  3  0  0 -1  0  0 |  7:8  | 0.075269+-- >  266.871 | -1 -1  0  1  0  0 |  6:7  | 0.071672+-- >  294.135 |  5 -3  0  0  0  0 | 27:32 | 0.076923+-- >  315.641 |  1  1 -1  0  0  0 |  5:6  | 0.099338+-- >  386.314 | -2  0  1  0  0  0 |  4:5  | 0.119048+-- >  407.820 | -6  4  0  0  0  0 | 64:81 | 0.060000+-- >  435.084 |  0  2  0 -1  0  0 |  7:9  | 0.064024+-- >  498.045 |  2 -1  0  0  0  0 |  3:4  | 0.214286+-- >  519.551 | -2  3 -1  0  0  0 | 20:27 | 0.060976+-- >  701.955 | -1  1  0  0  0  0 |  2:3  | 0.272727+-- >  764.916 |  1 -2  0  1  0  0 |  9:14 | 0.060172+-- >  813.686 |  3  0 -1  0  0  0 |  5:8  | 0.106383+-- >  884.359 |  0 -1  1  0  0  0 |  3:5  | 0.110294+-- >  905.865 | -4  3  0  0  0  0 | 16:27 | 0.083333+-- >  933.129 |  2  1  0 -1  0  0 |  7:12 | 0.066879+-- >  968.826 | -2  0  0  1  0  0 |  4:7  | 0.081395+-- >  996.090 |  4 -2  0  0  0  0 |  9:16 | 0.107143+-- > 1017.596 |  0  2 -1  0  0  0 |  5:9  | 0.085227+-- > 1088.269 | -3  1  1  0  0  0 |  8:15 | 0.082873+-- > 1200.000 |  1  0  0  0  0  0 |  1:2  | 1.000000+table_2_pp :: Table_2_Row -> String+table_2_pp (i,j,k,l) =+    let i' = printf "%8.3f" i+        j' = unwords (map (printf "%2d") j)+        k' = let (p,q) = from_rational k in printf "%2d:%-2d" q p+        l' = printf "%1.6f" l+    in intercalate " | " [i',j',k',l']
+ Music/Theory/List.hs view
@@ -0,0 +1,303 @@+-- | Shared list functions.+module Music.Theory.List where++import Data.Function+import Data.List+import Data.List.Split {- split -}+import Data.Maybe++-- | Bracket sequence with left and right values.+--+-- > bracket ('<','>') "1,2,3" == "<1,2,3>"+bracket :: (a,a) -> [a] -> [a]+bracket (l,r) x = l : x ++ [r]++genericRotate_left :: Integral i => i -> [a] -> [a]+genericRotate_left n =+    let f (p,q) = q ++ p+    in f . genericSplitAt n++-- | Left rotation.+--+-- > rotate_left 1 [1..3] == [2,3,1]+-- > rotate_left 3 [1..5] == [4,5,1,2,3]+rotate_left :: Int -> [a] -> [a]+rotate_left = genericRotate_left++genericRotate_right :: Integral n => n -> [a] -> [a]+genericRotate_right n = reverse . genericRotate_left n . reverse++-- | Right rotation.+--+-- > rotate_right 1 [1..3] == [3,1,2]+rotate_right :: Int -> [a] -> [a]+rotate_right = genericRotate_right++-- | Rotate left by /n/ 'mod' /#p/ places.+--+-- > rotate 8 [1..5] == [4,5,1,2,3]+rotate :: (Integral n) => n -> [a] -> [a]+rotate n p =+    let m = n `mod` genericLength p+    in genericRotate_left m p++-- | Rotate right by /n/ places.+--+-- > rotate_r 8 [1..5] == [3,4,5,1,2]+rotate_r :: (Integral n) => n -> [a] -> [a]+rotate_r = rotate . negate++-- | All rotations.+--+-- > rotations [0,1,3] == [[0,1,3],[1,3,0],[3,0,1]]+rotations :: [a] -> [[a]]+rotations p = map (`rotate_left` p) [0 .. length p - 1]++genericAdj2 :: (Integral n) => n -> [t] -> [(t,t)]+genericAdj2 n l =+    case l of+      p:q:_ -> (p,q) : genericAdj2 n (genericDrop n l)+      _ -> []++-- | Adjacent elements of list, at indicated distance, as pairs.+--+-- > adj2 1 [1..5] == [(1,2),(2,3),(3,4),(4,5)]+-- > adj2 2 [1..4] == [(1,2),(3,4)]+-- > adj2 3 [1..5] == [(1,2),(4,5)]+adj2 :: Int -> [t] -> [(t,t)]+adj2 = genericAdj2++-- | Append first element to end of list.+--+-- > close [1..3] == [1,2,3,1]+close :: [a] -> [a]+close x =+    case x of+      [] -> []+      e:_ -> x ++ [e]++-- | 'adj2' '.' 'close'.+--+-- > adj2_cyclic 1 [1..3] == [(1,2),(2,3),(3,1)]+adj2_cyclic :: Int -> [t] -> [(t,t)]+adj2_cyclic n = adj2 n . close++-- | Interleave elements of /p/ and /q/.+--+-- > interleave [1..3] [4..6] == [1,4,2,5,3,6]+interleave :: [b] -> [b] -> [b]+interleave p q =+    let u (i,j) = [i,j]+    in concatMap u (zip p q)++-- | 'interleave' of 'rotate_left' by /i/ and /j/.+--+-- > interleave_rotations 9 3 [1..13] == [10,4,11,5,12,6,13,7,1,8,2,9,3,10,4,11,5,12,6,13,7,1,8,2,9,3]+interleave_rotations :: Int -> Int -> [b] -> [b]+interleave_rotations i j s = interleave (rotate_left i s) (rotate_left j s)++-- | Count occurences of elements in list.+--+-- > histogram "hohoh" == [('h',3),('o',2)]+histogram :: (Ord a,Integral i) => [a] -> [(a,i)]+histogram x =+    let g = group (sort x)+        n = map genericLength g+    in zip (map head g) n++-- | List segments of length /i/ at distance /j/.+--+-- > segments 2 1 [1..5] == [[1,2],[2,3],[3,4],[4,5]]+-- > segments 2 2 [1..5] == [[1,2],[3,4]]+segments :: Int -> Int -> [a] -> [[a]]+segments i j p =+    let q = take i p+        p' = drop j p+    in if length q /= i then [] else q : segments i j p'++-- | 'foldl1' 'intersect'.+--+-- > intersect_l [[1,2],[1,2,3],[1,2,3,4]] == [1,2]+intersect_l :: Eq a => [[a]] -> [a]+intersect_l = foldl1 intersect++-- | 'foldl1' 'union'.+--+-- > sort (union_l [[1,3],[2,3],[3]]) == [1,2,3]+union_l :: Eq a => [[a]] -> [a]+union_l = foldl1 union++-- | Intersection of adjacent elements of list at distance /n/.+--+-- > adj_intersect 1 [[1,2],[1,2,3],[1,2,3,4]] == [[1,2],[1,2,3]]+adj_intersect :: Eq a => Int -> [[a]] -> [[a]]+adj_intersect n = map intersect_l . segments 2 n++-- | List of cycles at distance /n/.+--+-- > cycles 2 [1..6] == [[1,3,5],[2,4,6]]+-- > cycles 3 [1..9] == [[1,4,7],[2,5,8],[3,6,9]]+-- > cycles 4 [1..8] == [[1,5],[2,6],[3,7],[4,8]]+cycles :: Int -> [a] -> [[a]]+cycles n = transpose . chunksOf n++-- * Association lists++-- | Collate values of equal keys at /assoc/ list.+--+-- > collate [(1,'a'),(2,'b'),(1,'c')] == [(1,"ac"),(2,"b")]+collate :: Ord a => [(a,b)] -> [(a,[b])]+collate =+    let f l = (fst (head l), map snd l)+    in map f . groupBy ((==) `on` fst) . sortBy (compare `on` fst)++-- | Make /assoc/ list with given /key/.+--+-- > with_key 'a' [1..3] == [('a',1),('a',2),('a',3)]+with_key :: k -> [v] -> [(k,v)]+with_key h = zip (repeat h)++-- | Intervals to values, zero is /n/.+--+-- > dx_d 5 [1,2,3] == [5,6,8,11]+dx_d :: (Num a) => a -> [a] -> [a]+dx_d = scanl (+)++-- | Integrate, ie. pitch class segment to interval sequence.+--+-- > d_dx [5,6,8,11] == [1,2,3]+d_dx :: (Num a) => [a] -> [a]+d_dx l = zipWith (-) (tail l) l++-- | Elements of /p/ not in /q/.+--+-- > [1,2,3] `difference` [1,2] == [3]+difference :: (Eq a) => [a] -> [a] -> [a]+difference p q =+    let f e = e `notElem` q+    in filter f p++-- | Is /p/ a subset of /q/, ie. is 'intersect' of /p/ and /q/ '==' /p/.+--+-- > is_subset [1,2] [1,2,3] == True+is_subset :: Eq a => [a] -> [a] -> Bool+is_subset p q = p `intersect` q == p++-- | Is /p/ a superset of /q/, ie. 'flip' 'is_subset'.+--+-- > is_superset [1,2,3] [1,2] == True+is_superset :: Eq a => [a] -> [a] -> Bool+is_superset = flip is_subset++-- | Is /p/ a subsequence of /q/, ie. synonym for 'isInfixOf'.+--+-- > subsequence [1,2] [1,2,3] == True+subsequence :: (Eq a) => [a] -> [a] -> Bool+subsequence = isInfixOf++-- | Variant of 'elemIndices' that requires /e/ to be unique in /p/.+--+-- > elem_index_unique 'a' "abcda" == undefined+elem_index_unique :: (Eq a) => a -> [a] -> Int+elem_index_unique e p =+    case elemIndices e p of+      [i] -> i+      _ -> error "elem_index_unique"++-- | Find adjacent elements of list that bound element under given+-- comparator.+--+-- > let f = find_bounds compare (adj [1..5])+-- > in map f [1,3.5,5] == [Just (1,2),Just (3,4),Nothing]+find_bounds :: (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t)+find_bounds f l x =+    case l of+      (p,q):l' -> if f p x /= GT && f q x == GT+                  then Just (p,q)+                  else find_bounds f l' x+      _ -> Nothing++-- | Variant of 'drop' from right of list.+--+-- > dropRight 1 [1..9] == [1..8]+dropRight :: Int -> [a] -> [a]+dropRight n = reverse . drop n . reverse++-- | Apply /f/ at first element, and /g/ at all other elements.+--+-- > at_head negate id [1..5] == [-1,2,3,4,5]+at_head :: (a -> b) -> (a -> b) -> [a] -> [b]+at_head f g x =+    case x of+      [] -> []+      e:x' -> f e : map g x'++-- | Apply /f/ at all but last element, and /g/ at last element.+--+-- > at_last (* 2) negate [1..4] == [2,4,6,-4]+at_last :: (a -> b) -> (a -> b) -> [a] -> [b]+at_last f g x =+    case x of+      [] -> []+      [i] -> [g i]+      i:x' -> f i : at_last f g x'++-- | Separate list into an initial list and a last element tuple.+--+-- > separate_last [1..5] == ([1..4],5)+separate_last :: [a] -> ([a],a)+separate_last x =+    let e:x' = reverse x+    in (reverse x',e)++-- | Replace directly repeated elements with 'Nothing'.+--+-- > indicate_repetitions "abba" == [Just 'a',Just 'b',Nothing,Just 'a']+indicate_repetitions :: Eq a => [a] -> [Maybe a]+indicate_repetitions =+    let f l = case l of+                [] -> []+                e:l' -> Just e : map (const Nothing) l'+    in concatMap f . group++-- > adjacent_groupBy (<) [1,2,3,2,4,1,5,9] == [[1,2,3],[2,4],[1,5,9]]+adjacent_groupBy :: (a -> a -> Bool) -> [a] -> [[a]]+adjacent_groupBy f p =+    case p of+      [] -> []+      [x] -> [[x]]+      x:y:p' -> let r = adjacent_groupBy f (y:p')+                    r0:r' = r+                in if f x y+                   then (x:r0) : r'+                   else [x] : r++-- > group_just [Just 1,Nothing,Nothing,Just 4,Just 5]+group_just :: [Maybe a] -> [[Maybe a]]+group_just = groupBy ((==) `on` isJust)++-- | Given a comparison function, merge two ascending lists.+--+-- > mergeBy compare [1,3,5] [2,4] == [1..5]+mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy f p q =+    case (p,q) of+      ([],_) -> q+      (_,[]) -> p+      (i:p',j:q') -> case f i j of+                       GT -> j : mergeBy f p q'+                       _ -> i : mergeBy f p' q++-- | 'mergeBy' 'compare'.+merge :: Ord a => [a] -> [a] -> [a]+merge = mergeBy compare++-- | 'merge' a set of ordered sequences.+--+-- > merge_set [[1,3..9],[2,4..8],[10]] == [1..10]+merge_set :: Ord a => [[a]] -> [a]+merge_set p =+    case p of+      [] -> []+      [i] -> i+      i:p' -> merge i (merge_set p')
+ Music/Theory/Meter/Barlow_1987.hs view
@@ -0,0 +1,362 @@+-- | Clarence Barlow. \"Two Essays on Theory\".+-- /Computer Music Journal/, 11(1):44-60, 1987.+-- Translated by Henning Lohner.+module Music.Theory.Meter.Barlow_1987 where++import Data.List+import Data.Numbers.Primes {- primes -}+--import Debug.Trace++traceShow :: a -> b -> b+traceShow _ x = x++-- | One indexed variant of 'genericIndex'.+--+-- > map (at [11..13]) [1..3] == [11,12,13]+at :: (Integral n) => [a] -> n -> a+at x i = x `genericIndex` (i - 1)++-- | Variant of 'at' with boundary rules and specified error message.+--+-- > map (at' 'x' [11..13]) [0..4] == [1,11,12,13,1]+-- > at' 'x' [0] 3 == undefined+at' :: (Num a,Show a,Integral n,Show n,Show m) => m -> [a] -> n -> a+at' m x i =+    let n = genericLength x+    in if i == 0 || i == n + 1+       then 1 -- error (show ("at':==",m,x,i))+       else if i < 0 || i > n + 1+            then error (show ("at'",m,x,i))+            else x `genericIndex` (i - 1)++-- | Variant of 'mod' with input constraints.+--+-- > mod' (-1) 2 == 1+mod' :: (Integral a,Show a) => a -> a -> a+mod' a b =+    let r = mod a b+    in if r < 0 || r >= b+       then error (show ("mod'",a,b,r))+       else r++-- | Alias for 'Double' (quieten compiler).+type R = Double++-- | Specialised variant of 'fromIntegral'.+to_r :: (Integral n,Show n) => n -> R+to_r = fromIntegral++-- | Variant on 'div' with input constraints.+div' :: (Integral a,Show a) => String -> a -> a -> a+div' m i j =+    if i < 0 || j < 0+    then error (show ("div'",m,i,j))+    else truncate (to_r i / to_r j)++-- | A stratification is a tree of integral subdivisions.+type Stratification t = [t]++-- | Indispensibilities from stratification.+--+-- > indispensibilities [3,2,2] == [11,0,6,3,9,1,7,4,10,2,8,5]+-- > indispensibilities [2,3,2] == [11,0,6,2,8,4,10,1,7,3,9,5]+-- > indispensibilities [2,2,3] == [11,0,4,8,2,6,10,1,5,9,3,7]+-- > indispensibilities [3,5] == [14,0,9,3,6,12,1,10,4,7,13,2,11,5,8]+indispensibilities :: (Integral n,Show n) => Stratification n -> [n]+indispensibilities x = map (lower_psi x (genericLength x)) [1 .. product x]++-- | The indispensibility measure (ψ).+--+-- > map (lower_psi [2] 1) [1..2] == [1,0]+-- > map (lower_psi [3] 1) [1..3] == [2,0,1]+-- > map (lower_psi [2,2] 2) [1..4] == [3,0,2,1]+-- > map (lower_psi [5] 1) [1..5] == [4,0,3,1,2]+-- > map (lower_psi [3,2] 2) [1..6] == [5,0,3,1,4,2]+-- > map (lower_psi [2,3] 2) [1..6] == [5,0,2,4,1,3]+lower_psi :: (Integral a,Show a) => Stratification a -> a -> a -> a+lower_psi q z n =+    let s8 r =+            let s1 = product q+                s2 = (n - 2) `mod'` s1+                s3 = let f k = at' "s3" q (z + 1 - k)+                     in product (map f [0 .. r])+                s4 = 1 + div' "s4" s2 s3+                c = at' "c" q (z - r)+                s5 = s4 `mod'` c+                s6 = upper_psi c (1 + s5)+                s7 = let f = at' "s7" q+                     in product (map f [0 .. z - r - 1])+            in traceShow ("lower_psi:s",s1,s2,s3,s4,s5,s6,s7) (s7 * s6)+    in traceShow ("lower_psi",q,z,n) (sum (map s8 [0 .. z - 1]))++-- | The first /n/th primes, reversed.+--+-- > reverse_primes 14 == [43,41,37,31,29,23,19,17,13,11,7,5,3,2]+reverse_primes :: (Integral n,Show n) => n -> [n]+reverse_primes n = reverse (genericTake n primes)++-- | Generate prime stratification for /n/.+--+-- > map prime_stratification [2,3,5,7,11] == [[2],[3],[5],[7],[11]]+-- > map prime_stratification [6,8,9,12] == [[3,2],[2,2,2],[3,3],[3,2,2]]+-- > map prime_stratification [22,10,4,1] == [[11,2],[5,2],[2,2],[]]+-- > map prime_stratification [18,16,12] == [[3,3,2],[2,2,2,2],[3,2,2]]+prime_stratification :: (Integral n,Show n) => n -> Stratification n+prime_stratification =+    let go x k =+            case x of+              p:x' -> if k `rem` p == 0+                      then p : go x (div' "ps" k p)+                      else go x' k+              [] -> []+    in go (reverse_primes 14)++-- | Fundamental indispensibilities for prime numbers (Ψ).+--+-- > map (upper_psi 2) [1..2] == [1,0]+-- > map (upper_psi 3) [1..3] == [2,0,1]+-- > map (upper_psi 5) [1..5] == [4,0,3,1,2]+-- > map (upper_psi 7) [1..7] == [6,0,4,2,5,1,3]+-- > map (upper_psi 11) [1..11] == [10,0,6,4,9,1,7,3,8,2,5]+-- > map (upper_psi 13) [1..13] == [12,0,7,4,10,1,8,5,11,2,9,3,6]+upper_psi :: (Integral a,Show a) => a -> a -> a+upper_psi p n =+    if p `notElem` reverse_primes 14+    then error (show ("upper_psi","not prime",p,n))+    else if p == 2+         then p - n+         else if n == p - 1+              then div' "upper_psi" p 4+              else let n' = n - div' "n'" n p+                       s = prime_stratification (p - 1)+                       q = lower_psi s (genericLength s) n'+                       q' = to_r q+                       p' = to_r p+                   in truncate (q' + 2 * sqrt ((q' + 1) / p'))++-- | Table such that each subsequent row deletes the least+-- indispensibile pulse.+--+-- > thinning_table [3,2] == [[True,True,True,True,True,True]+-- >                         ,[True,False,True,True,True,True]+-- >                         ,[True,False,True,False,True,True]+-- >                         ,[True,False,True,False,True,False]+-- >                         ,[True,False,False,False,True,False]+-- >                         ,[True,False,False,False,False,False]]+thinning_table :: (Integral n,Show n) => Stratification n -> [[Bool]]+thinning_table s =+    let x = indispensibilities s+        n = genericLength x+        true i = genericReplicate i True+        false i = genericReplicate i False+        f i = true (i + 1)  ++ false (n - i - 1)+    in transpose (map f x)++-- | Trivial pretty printer for 'thinning_table'.+--+-- > putStrLn (thinning_table_pp [3,2])+-- > putStrLn (thinning_table_pp [2,3])+--+-- > ******   ******+-- > *.****   *.****+-- > *.*.**   *.**.*+-- > *.*.*.   *..*.*+-- > *...*.   *..*..+-- > *.....   *.....+thinning_table_pp :: (Integral n,Show n) => Stratification n -> String+thinning_table_pp s =+    let f x = if x then '*' else '.'+    in unlines (map (map f) (thinning_table s))++-- | Scale values against length of list minus one.+--+-- > relative_to_length [0..5] == [0.0,0.2,0.4,0.6,0.8,1.0]+relative_to_length :: (Real a, Fractional b) => [a] -> [b]+relative_to_length x =+    let n = genericLength x - (1::Integer)+    in map ((/ fromIntegral n) . realToFrac) x++-- | Variant of 'indispensibilities' that scales value to lie in+-- @(0,1)@.+--+-- relative_indispensibilities [3,2] == [1,0,0.6,0.2,0.8,0.4]+relative_indispensibilities :: (Integral n,Show n) => Stratification n -> [R]+relative_indispensibilities = relative_to_length . indispensibilities++-- | Align two meters (given as stratifications) to least common+-- multiple of their degrees.  The 'indispensibilities' function is+-- given as an argument so that it may be relative if required.  This+-- generates Table 7 (p.58).+--+-- > let r = [(5,5),(0,0),(2,3),(4,1),(1,4),(3,2)]+-- > in align_meters indispensibilities [2,3] [3,2] == r+--+-- > let r = [(1,1),(0,0),(0.4,0.6),(0.8,0.2),(0.2,0.8),(0.6,0.4)]+-- > in align_meters relative_indispensibilities [2,3] [3,2] == r+--+-- > align_meters indispensibilities [2,2,3] [3,5]+-- > align_meters relative_indispensibilities [2,2,3] [3,5]+align_meters :: (t -> [b]) -> t -> t -> [(b,b)]+align_meters f s1 s2 =+    let i1 = f s1+        i2 = f s2+        n1 = length i1+        n2 = length i2+        n = lcm n1 n2+        i1' = concat (replicate (n `div` n1) i1)+        i2' = concat (replicate (n `div` n2) i2)+    in zip i1' i2'++-- | Type pairing a stratification and a tempo.+type S_MM t = ([t],t)++-- | Variant of 'div' that requires 'mod' be @0@.+whole_div :: Integral a => a -> a -> a+whole_div i j =+    case i `divMod` j of+      (k,0) -> k+      _ -> error "whole_div"++-- | Variant of 'quot' that requires 'rem' be @0@.+whole_quot :: Integral a => a -> a -> a+whole_quot i j =+    case i `quotRem` j of+      (k,0) -> k+      _ -> error "whole_quot"++-- | Rule to prolong stratification of two 'S_MM' values such that+-- pulse at the deeper level are aligned.  (Paragraph 2, p.58)+--+-- > let x = ([2,2,2],1)+-- > in prolong_stratifications x x == (fst x,fst x)+--+-- > let r = ([2,5,3,3,2],[3,2,5,5])+-- > in prolong_stratifications ([2,5],50) ([3,2],60) == r+--+-- > prolong_stratifications ([2,2,3],5) ([3,5],4) == ([2,2,3],[3,5])+prolong_stratifications :: (Integral n,Show n) => S_MM n -> S_MM n -> ([n],[n])+prolong_stratifications (s1,v1) (s2,v2) =+    let t1 = product s1 * v1+        t2 = product s2 * v2+        t = lcm t1 t2+        s1' = s1 ++ prime_stratification (t `whole_div` t1)+        s2' = s2 ++ prime_stratification (t `whole_div` t2)+    in (s1',s2')++-- | Arithmetic mean (average) of a list.+--+-- > mean [0..5] == 2.5+mean :: Fractional a => [a] -> a+mean x = sum x / fromIntegral (length x)++-- | Square of /n/.+--+-- > square 5 == 25+square :: Num a => a -> a+square n = n * n++-- | Composition of 'prolong_stratifications' and 'align_meters'.+--+-- > align_s_mm indispensibilities ([2,2,3],5) ([3,5],4)+align_s_mm :: (Integral n,Show n) => ([n] -> [t]) -> S_MM n -> S_MM n -> [(t,t)]+align_s_mm f (s1,v1) (s2,v2) =+    let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2)+    in align_meters f s1' s2'++-- | An attempt at Equation 5 of the /CMJ/ paper.  When /n/ is /h-1/+-- the output is incorrect (it is the product of the correct values+-- for /n/ at /h-1/ and /h/).+--+-- > map (upper_psi' 5) [1..5] /= [4,0,3,1,2]+-- > map (upper_psi' 7) [1..7] /= [6,0,4,2,5,1,3]+-- > map (upper_psi' 11) [1..11] /= [10,0,6,4,9,1,7,3,8,2,5]+-- > map (upper_psi' 13) [1..13] /= [12,0,7,4,10,1,8,5,11,2,9,3,6]+upper_psi' :: (Integral a,Show a) => a -> a -> a+upper_psi' h n =+    if h > 3+    then let omega x = if x == 0 then 0 else 1+             h4 = div' "h4" h 4+             n' = n - 1 + omega (h - n)+             p = prime_stratification (h - 1)+             x0 = lower_psi p (genericLength p) n'+             x1 = x0 + omega (div' "z" x0 h4)+             x2 = omega (h - n - 1)+             x3 = x2 + h4 * (1 - x2)+         in traceShow ("upper_psi'",h,n,n',x0,x1,x2,x3) (x1 * x3)+    else (h + n - 2) `mod'` h++-- | The /MPS/ limit equation given on p.58.+--+-- > mps_limit 3 == 21 + 7/9+mps_limit :: Floating a => a -> a+mps_limit n = sum [n ** 4 / 9+                  ,n ** 3 / 3+                  ,13 * (n ** 2 ) / 36+                  ,n / 6+                  ,1 / 36]++-- | The square of the product of the input sequence is summed, then+-- divided by the square of the sequence length.+--+-- > mean_square_product [(0,0),(1,1),(2,2),(3,3)] == 6.125+-- > mean_square_product [(2,3),(4,5)] == (6^2 + 20^2) / 2^2+mean_square_product :: Fractional n => [(n,n)] -> n+mean_square_product x =+    let f = square . uncurry (*)+        n = fromIntegral (length x)+    in sum (map f x) / square n++-- | An incorrect attempt at the description in paragraph two of p.58+-- of the /CMJ/ paper.+--+-- > let p ~= q = abs (p - q) < 1e-4+-- > metrical_affinity [2,3] 1 [3,2] 1 ~= 0.0324+-- > metrical_affinity [2,2,3] 20 [3,5] 16 ~= 0.0028+metrical_affinity :: (Integral n,Show n) => [n] -> n -> [n] -> n -> R+metrical_affinity s1 v1 s2 v2 =+    let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2)+        i1 = relative_indispensibilities s1'+        i2 = relative_indispensibilities s2'+        v = lcm v1 v2+        i1' = concat (genericReplicate (v `div` v1) i1)+        i2' = concat (genericReplicate (v `div` v2) i2)+    in mean_square_product (zip i1' i2')++-- | An incorrect attempt at Equation 6 of the /CMJ/ paper, see+-- omega_z.+--+-- > let p ~= q = abs (p - q) < 1e-4+-- > metrical_affinity' [2,2,2] 1 [2,2,2] 1 ~= 1.06735+-- > metrical_affinity' [2,2,2] 1 [2,2,3] 1 ~= 0.57185+-- > metrical_affinity' [2,2,2] 1 [2,3,2] 1 ~= 0.48575+-- > metrical_affinity' [2,2,2] 1 [3,2,2] 1 ~= 0.45872+--+-- > metrical_affinity' [3,2,2] 3 [2,2,3] 2 ~= 0.10282+metrical_affinity' :: (Integral t,Show t) => [t] -> t -> [t] -> t -> R+metrical_affinity' s1 v1 s2 v2 =+    let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2)+        ix :: (Integer -> x) -> Integer -> x+        ix f i = case i of+                   1 -> f 1+                   2 -> f 2+                   _ -> error (show ("ix",i))+        s = ix (at [s1,s2])+        v = ix (at [v1,v2])+        u = ix (genericLength . s)+        s' = ix (at [s1',s2'])+        z = ix (genericLength . s')+        q i j = s i `at` j+        omega_u i = product (map (q i) [1::Int .. u i])+        omega_z _ = lcm (v 1 * omega_u 1) (v 2 * omega_u 2)+        omega_0 = lcm (product (s' 1)) (product (s' 2))+        x0 n i = lower_psi (s' i) (z i) (1 + ((n - 1) `mod'` omega_z i))+        x1 n = square (product (map (x0 n) [1,2]))+        x2 = sum (map x1 [1 .. omega_0])+        x3 = 18 * x2 - 2+        x4 i = square (omega_z i - 1)+        x5 = product (map x4 [1::Integer,2])+        x6 = 7 * omega_0 * x5+        x7 = to_r x3 / to_r x6+        x8 = 2 * log x7+        x9 = negate (recip x8)+    in traceShow (omega_z,omega_0,x2,x3,x5,x6,x7,x8,x9) x9
+ Music/Theory/Metric/Buchler_1998.hs view
@@ -0,0 +1,177 @@+-- | Michael Buchler. \"Relative Saturation of Subsets and Interval+-- Cycles as a Means for Determining Set-Class Similarity\". PhD+-- thesis, University of Rochester, 1998+module Music.Theory.Metric.Buchler_1998 where++import Data.List+import Data.Ratio+import qualified Music.Theory.List as L+import qualified Music.Theory.Z12.Forte_1973 as F+import qualified Music.Theory.Set.List as S+import Music.Theory.Z12++-- | Predicate for list with cardinality /n/.+of_c :: Integral n => n -> [a] -> Bool+of_c n = (== n) . genericLength++-- | Set classes of cardinality /n/.+--+-- > sc_table_n 2 == [[0,1],[0,2],[0,3],[0,4],[0,5],[0,6]]+sc_table_n :: (Integral n) => n -> [[Z12]]+sc_table_n n = filter (of_c n) (map snd F.sc_table)++-- | Minima and maxima of ICV of SCs of cardinality /n/.+--+-- > icv_minmax 5 == ([0,0,0,1,0,0],[4,4,4,4,4,2])+icv_minmax :: (Integral n, Integral b) => n -> ([b], [b])+icv_minmax n =+    let t = sc_table_n n+        i = transpose (map F.icv t)+    in (map minimum i,map maximum i)++data R = MIN | MAX deriving (Eq,Show)+type D n = (R,n)++-- | Pretty printer for 'R'.+--+-- > map r_pp [MIN,MAX] == ["+","-"]+r_pp :: R -> String+r_pp r =+    case r of+      MIN -> "+"+      MAX -> "-"++-- | 'SATV' element measure with given funtion.+satv_f :: (Integral n) => ((n,n,n) -> D n) -> [Z12] -> [D n]+satv_f f p =+    let n = length p+        i = F.icv p+        (l,r) = icv_minmax n+    in map f (zip3 l i r)++-- | Pretty printer for SATV element.+--+-- > satv_e_pp (satv_a [0,1,2,6,7,8]) == "<-1,+2,+0,+0,-1,-0>"+satv_e_pp :: Show i => [D i] -> String+satv_e_pp =+    let f (i,j) = r_pp i ++ show j+    in L.bracket ('<','>') . intercalate "," . map f++type SATV i = ([D i],[D i])++-- | Pretty printer for 'SATV'.+satv_pp :: Show i => SATV i -> String+satv_pp (i,j) = L.bracket ('(',')') (satv_e_pp i ++ "," ++ satv_e_pp j)++-- | @SATVa@ measure.+--+-- > satv_e_pp (satv_a [0,1,2,6,7,8]) == "<-1,+2,+0,+0,-1,-0>"+-- > satv_e_pp (satv_a [0,1,2,3,4]) == "<-0,-1,-2,+0,+0,+0>"+satv_a :: Integral i => [Z12] -> [D i]+satv_a =+    let f (l,i,r) = let l' = abs (i - l)+                        r' = abs (i - r)+                    in case compare l' r' of+                         LT -> (MIN,l')+                         _ -> (MAX,r')+    in satv_f f++-- | @SATVb@ measure.+--+-- > satv_e_pp (satv_b [0,1,2,6,7,8]) == "<+4,-4,-5,-4,+4,+3>"+-- > satv_e_pp (satv_b [0,1,2,3,4]) == "<+4,+3,+2,-3,-4,-2>"+satv_b :: Integral i => [Z12] -> [D i]+satv_b =+    let f (l,i,r) = let l' = abs (i - l)+                        r' = abs (i - r)+                    in case compare l' r' of+                         LT -> (MAX,r')+                         _ -> (MIN,l')+    in satv_f f++-- | 'SATV' measure.+--+-- > satv_pp (satv [0,3,6,9]) == "(<+0,+0,-0,+0,+0,-0>,<-3,-3,+4,-3,-3,+2>)"+-- > satv_pp (satv [0,1,3,4,8]) == "(<-2,+1,-2,-1,-2,+0>,<+2,-3,+2,+2,+2,-2>)"+-- > satv_pp (satv [0,1,2,6,7,8]) == "(<-1,+2,+0,+0,-1,-0>,<+4,-4,-5,-4,+4,+3>)"+-- > satv_pp (satv [0,4]) == "(<+0,+0,+0,-0,+0,+0>,<-1,-1,-1,+1,-1,-1>)"+-- > satv_pp (satv [0,1,3,4,6,9]) == "(<+2,+2,-0,+0,+2,-1>,<-3,-4,+5,-4,-3,+2>)"+-- > satv_pp (satv [0,1,3,6,7,9]) == "(<+2,+2,-1,+0,+2,-0>,<-3,-4,+4,-4,-3,+3>)"+-- > satv_pp (satv [0,1,2,3,6]) == "(<-1,-2,-2,+0,+1,-1>,<+3,+2,+2,-3,-3,+1>)"+-- > satv_pp (satv [0,1,2,3,4,6]) == "(<-1,-2,-2,+0,+1,+1>,<+4,+4,+3,-4,-4,-2>)"+-- > satv_pp (satv [0,1,3,6,8]) == "(<+1,-2,-2,+0,-1,-1>,<-3,+2,+2,-3,+3,+1>)"+-- > satv_pp (satv [0,2,3,5,7,9]) == "(<+1,-2,-2,+0,-1,+1>,<-4,+4,+3,-4,+4,-2>)"+satv :: Integral i => [Z12] -> SATV i+satv p = (satv_a p,satv_b p)++-- | 'SATV' reorganised by 'R'.+--+-- > satv_minmax (satv [0,1,2,6,7,8]) == ([4,2,0,0,4,3],[1,4,5,4,1,0])+satv_minmax :: SATV i -> ([i],[i])+satv_minmax (p,q) =+    let f (i,j) (_,k) = if i == MIN then (j,k) else (k,j)+    in unzip (zipWith f p q)++-- | Absolute difference.+abs_dif :: Num a => a -> a -> a+abs_dif i j = abs (i - j)++-- | Sum of numerical components of @a@ and @b@ parts of 'SATV'.+--+-- > satv_n_sum (satv [0,1,2,6,7,8]) == [5,6,5,4,5,3]+-- > satv_n_sum (satv [0,3,6,9]) = [3,3,4,3,3,2]+satv_n_sum :: Num c => SATV c -> [c]+satv_n_sum (i,j) = zipWith (+) (map snd i) (map snd j)++-- > two_part_difference_vector (satv_a [0,1,2,6,7,8]) (satv [0,3,6,9]) == [2,2,4,0,2,0]+two_part_difference_vector :: (Integral i) => [D i] -> SATV i -> [i]+two_part_difference_vector i j =+    let (p,q) = satv_minmax j+        f (r,_) k = if r == MIN then p!!k else q!!k+        z = zipWith f i [0..]+    in zipWith abs_dif (map snd i) z++-- > two_part_difference_vector_set (satv [0,4]) (satv [0,1,3,4,6,9]) == ([2,2,5,4,2,2],[2,2,1,1,2,0])+two_part_difference_vector_set :: (Integral i) => SATV i -> SATV i -> ([i],[i])+two_part_difference_vector_set i j =+        (two_part_difference_vector (fst i) j+        ,two_part_difference_vector (fst j) i)++-- | @SATSIM@ metric.+--+-- > satsim [0,1,2,6,7,8] [0,3,6,9] == 25/46+-- > satsim [0,4] [0,1,3,4,6,9] == 25/34+-- > satsim [0,4] [0,1,3,6,7,9] == 25/34+-- > satsim [0,1,2,3,6] [0,1,2,3,4,6] == 1/49+-- > satsim [0,1,3,6,8] [0,2,3,5,7,9] == 1/49+-- > satsim [0,1,2,3,4] [0,1,4,5,7] == 8/21+-- > satsim [0,1,2,3,4] [0,2,4,6,8] == 4/7+-- > satsim [0,1,4,5,7] [0,2,4,6,8] == 4/7+satsim :: Integral a => [Z12] -> [Z12] -> Ratio a+satsim p q =+    let i = satv p+        j = satv q+        (d1,d2) = two_part_difference_vector_set i j+        d = sum d1 + sum d2+        (n1,n2) = (satv_n_sum i,satv_n_sum j)+        n = sum n1 + sum n2+    in if n == 0 then error (show ("satsim",p,q)) else d % n++-- | Table of 'satsim' measures for all @SC@ pairs.+--+-- > length satsim_table == 24310+satsim_table :: Integral i => [(([Z12],[Z12]),Ratio i)]+satsim_table =+    let f (i,j) = ((i,j),satsim i j)+        t = filter ((`notElem` [0,1,12]) . length) (map snd F.sc_table)+    in map f (S.pairs t)++-- | Histogram of values at 'satsim_table'.+--+-- > satsim_table_histogram == L.histogram (map snd satsim_table)+satsim_table_histogram :: Integral i => [(Ratio i,i)]+satsim_table_histogram = [(0,132),(1/49,4),(1/30,4),(2/49,16),(2/39,16),(18,8),(2/33,12),(3/49,30),(15,12),(14,144),(13,56),(4/49,72),(2/23,14),(2/21,304),(10,6),(5/49,132),(4/39,160),(1/9,264),(4/33,16),(6/49,152),(1/8,12),(5/39,108),(3/23,4),(25,44),(1/7,487),(7/46,6),(23,132),(8/49,304),(1/6,116),(4/23,86),(7/40,6),(7/39,444),(21,48),(9/49,208),(4/21,1116),(9/46,84),(1/5,68),(10/49,298),(8/39,472),(5/24,4),(7/33,88),(34,394),(5/23,176),(2/9,516),(11/49,378),(9/40,8),(33,176),(7/30,116),(11/46,172),(8/33,64),(12/49,314),(1/4,10),(10/39,336),(7/27,4),(6/23,276),(9/34,2),(13/49,374),(45,124),(31,192),(11/40,4),(58,56),(11/39,376),(13/46,298),(2/7,1297),(7/24,48),(8/27,8),(30,226),(10/33,148),(7/23,204),(15/49,228),(43,384),(11/34,6),(13/40,50),(15/46,272),(16/49,196),(1/3,1528),(17/49,132),(8/23,230),(7/20,128),(67,6),(54,82),(14/39,144),(41,160),(11/30,168),(18/49,74),(17/46,228),(10/27,32),(3/8,238),(8/21,412),(53,160),(19/49,84),(78,76),(9/23,94),(13/33,284),(2/5,310),(11/27,44),(20/49,76),(16/39,376),(77,14),(19/46,150),(52,128),(14/33,156),(17/40,154),(3/7,81),(13/30,108),(10/23,114),(17/39,236),(15/34,4),(4/9,460),(22/49,10),(9/20,96),(51,172),(21/46,124),(11/24,144),(63,112),(75,84),(23/49,6),(87,28),(19/40,96),(10/21,84),(11/23,28),(13/27,188),(16/33,52),(19/39,160),(24/49,8),(1/2,545),(25/49,2),(20/39,144),(17/33,100),(14/27,296),(12/23,64),(21/40,42),(97,48),(85,56),(15/28,1),(73,64),(13/24,32),(25/46,66),(61,36),(11/20,18),(27/49,24),(5/9,192),(19/34,132),(22/39,24),(13/23,18),(17/30,40),(4/7,176),(23/40,32),(19/33,16),(72,28),(27/46,56),(107,84),(23/39,20),(29/49,26),(16/27,72),(3/5,14),(20/33,4),(14/23,10),(30/49,24),(21/34,120),(5/8,28),(17/27,36),(31/49,22),(71,16),(94,22),(117,72),(13/20,4),(32/49,14),(2/3,14),(27/40,6),(23/34,14),(19/28,1),(70,4),(19/27,4),(127,24),(5/7,10),(25/34,4),(3/4,7),(7/9,12),(114,4),(17/21,4),(23/28,7),(5/6,20),(6/7,11),(8/9,12),(25/28,16),(19/21,38),(112,4),(134,7),(178,18),(20/21,12),(1,32)]++-- Local Variables:+-- truncate-lines:t+-- End:
+ Music/Theory/Metric/Morris_1980.hs view
@@ -0,0 +1,32 @@+-- | Robert Morris. \"A Similarity Index for Pitch-Class+-- Sets\". Perspectives of New Music, 18(2):445-460, 1980.+module Music.Theory.Metric.Morris_1980 where++import Data.Ratio+import Music.Theory.Z12+import Music.Theory.Z12.Forte_1973++-- | SIM+--+-- > icv [0,1,3,6] == [1,1,2,0,1,1] && icv [0,2,4,7] == [0,2,1,1,2,0]+-- > sim [0,1,3,6] [0,2,4,7] == 6+-- > sim [0,1,2,4,5,8] [0,1,3,7] == 9+sim :: Integral a => [Z12] -> [Z12] -> a+sim r s =+    let r' = icv r+        s' = icv s+        t = zipWith (-) r' s'+    in sum (map abs t)++-- | ASIM+--+-- > asim [0,1,3,6] [0,2,4,7] == 6/12+-- > asim [0,1,2,4,5,8] [0,1,3,7] == 9/21+-- > asim [0,1,2,3,4] [0,1,4,5,7] == 2/5+-- > asim [0,1,2,3,4] [0,2,4,6,8] == 3/5+-- > asim [0,1,4,5,7] [0,2,4,6,8] == 3/5+asim :: (Integral n) => [Z12] -> [Z12] -> Ratio n+asim r s =+    let r' = icv r+        s' = icv s+    in sim r s % (sum r' + sum s')
+ Music/Theory/Metric/Polansky_1996.hs view
@@ -0,0 +1,308 @@+-- | Larry Polansky. \"Morphological Metrics\". Journal of New Music+-- Research, 25(4):289-368, 1996.+module Music.Theory.Metric.Polansky_1996 where++import Data.List+import Data.Maybe+import Data.Ratio+import qualified Music.Theory.Contour.Polansky_1992 as C+import qualified Music.Theory.List as L++-- | Distance function, ordinarily /n/ below is in 'Num', 'Fractional'+-- or 'Real'.+type Interval a n = (a -> a -> n)++-- | 'fromIntegral' '.' '-'.+dif_i :: (Integral a,Num b) => a -> a -> b+dif_i i j = fromIntegral (i - j)++-- | 'realToFrac' '.' '-'.+dif_r :: (Real a,Fractional b) => a -> a -> b+dif_r i j = realToFrac (i - j)++-- | 'abs' '.' /f/.+abs_dif :: Num n => Interval a n -> a -> a -> n+abs_dif f i j = abs (i `f` j)++-- | Square.+sqr :: Num a => a -> a+sqr n = n * n++-- | 'sqr' '.' /f/.+sqr_dif :: Num n => Interval a n -> a -> a -> n+sqr_dif f i j = sqr (i `f` j)++-- | 'sqr' '.' 'abs' '.' /f/.+sqr_abs_dif :: Num n => Interval a n -> a -> a -> n+sqr_abs_dif f i = sqr . abs_dif f i++-- | 'sqrt' '.' 'abs' '.' /f/.+sqrt_abs_dif :: Floating c => Interval a c -> a -> a -> c+sqrt_abs_dif f i = sqrt . abs_dif f i++-- | City block metric, p.296+--+-- > city_block_metric (-) (1,2) (3,5) == 2+3+city_block_metric :: Num n => Interval a n -> (a,a) -> (a,a) -> n+city_block_metric f (x1,x2) (y1,y2) = abs_dif f x1 y1 + abs_dif f x2 y2++-- | Two-dimensional euclidean metric, p.297.+--+-- > euclidean_metric_2 (-) (1,2) (3,5) == sqrt (4+9)+euclidean_metric_2 :: Floating n => Interval a n -> (a,a) -> (a,a) -> n+euclidean_metric_2 f (x1,x2) (y1,y2) = sqrt (sqr_dif f x1 y1 + sqr_dif f x2 y2)++-- | /n/-dimensional euclidean metric+--+-- > euclidean_metric_l (-) [1,2] [3,5] == sqrt (4+9)+-- > euclidean_metric_l (-) [1,2,3] [2,4,6] == sqrt (1+4+9)+euclidean_metric_l :: Floating c => Interval b c -> [b] -> [b] -> c+euclidean_metric_l f p = sqrt . sum . zipWith (sqr_dif f) p++-- | Cube root.+--+-- > map cbrt [1,8,27] == [1,2,3]+cbrt :: Floating a => a -> a+cbrt n = n ** (1/3)++-- | /n/-th root+--+-- > map (nthrt 4) [1,16,81] == [1,2,3]+nthrt :: Floating a => a -> a -> a+nthrt r n = n ** recip r++-- | Two-dimensional Minkowski metric, p.297+--+-- > minkowski_metric_2 (-) 1 (1,2) (3,5) == 5+-- > minkowski_metric_2 (-) 2 (1,2) (3,5) == sqrt (4+9)+-- > minkowski_metric_2 (-) 3 (1,2) (3,5) == cbrt (8+27)+minkowski_metric_2 :: Floating a => Interval t a -> a -> (t,t) -> (t,t) -> a+minkowski_metric_2 f n (x1,x2) (y1,y2) =+    ((abs (x1 `f` y1) ** n) + (abs (x2 `f` y2) ** n)) ** (1/n)++-- | /n/-dimensional Minkowski metric+--+-- > minkowski_metric_l (-) 2 [1,2,3] [2,4,6] == sqrt (1+4+9)+-- > minkowski_metric_l (-) 3 [1,2,3] [2,4,6] == cbrt (1+8+27)+minkowski_metric_l :: Floating a => Interval t a -> a -> [t] -> [t] -> a+minkowski_metric_l f n p q =+    let g i j = abs (i `f` j) ** n+    in nthrt n (sum (zipWith g p q))++-- | Integration with /f/.+--+-- > d_dx (-) [0,2,4,1,0] == [2,2,-3,-1]+-- > d_dx (-) [2,3,0,4,1] == [1,-3,4,-3]+d_dx :: Interval a n -> [a] -> [n]+d_dx f l = zipWith f (tail l) l++-- | 'map' 'abs' '.' 'd_dx'.+--+-- > d_dx_abs (-) [0,2,4,1,0] == [2,2,3,1]+-- > d_dx_abs (-) [2,3,0,4,1] == [1,3,4,3]+d_dx_abs :: Num n => Interval a n -> [a] -> [n]+d_dx_abs f = map abs . d_dx f++-- | Ordered linear magnitude (no delta), p.300+--+-- > olm_no_delta' [0,2,4,1,0] [2,3,0,4,1] == 1.25+olm_no_delta' :: Fractional a => [a] -> [a] -> a+olm_no_delta' p q =+    let r = zipWith (-) (d_dx_abs (-) p) (d_dx_abs (-) q)+        z = sum (map abs r)+    in z / (fromIntegral (length p) - 1)++-- | Ordered linear magintude (general form) p.302+--+-- > olm_general (abs_dif (-)) [0,2,4,1,0] [2,3,0,4,1] == 1.25+-- > olm_general (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6+olm_general :: (Fractional a,Enum a,Fractional n) => Interval a n -> [a] -> [a] -> n+olm_general f p q =+    let r = zipWith (-) (d_dx f p) (d_dx f q)+        z = sum (map abs r)+    in z / (fromIntegral (length p) - 1)++-- | 'Delta' (Δ) determines an interval given a sequence and an index.+type Delta n a = ([n] -> Int -> a)++-- | /f/ at indices /i/ and /i+1/ of /x/.+--+-- > map (ix_dif (-) [0,1,3,6,10]) [0..3] == [-1,-2,-3,-4]+ix_dif :: Interval a t -> Delta a t+ix_dif f x i = (x !! i) `f` (x !! (i + 1))++-- | 'abs' '.' 'ix_dif'+--+-- > map (abs_ix_dif (-) [0,2,4,1,0]) [0..3] == [2,2,3,1]+abs_ix_dif :: Num n => Interval a n -> Delta a n+abs_ix_dif f x i = abs (ix_dif f x i)++-- | 'sqr' '.' 'abs_ix_dif'+--+-- > map (sqr_abs_ix_dif (-) [0,2,4,1,0]) [0..3] == [4,4,9,1]+-- > map (sqr_abs_ix_dif (-) [2,3,0,4,1]) [0..3] == [1,9,16,9]+sqr_abs_ix_dif :: Num n => Interval a n -> Delta a n+sqr_abs_ix_dif f x i = sqr (abs_ix_dif f x i)++-- | 'Psi' (Ψ) joins 'Delta' equivalent intervals from morphologies /m/ and /n/.+type Psi a = (a -> a -> a)++-- | Ordered linear magintude (generalised-interval form) p.305+--+-- > olm (abs_dif dif_r) (abs_ix_dif dif_r) (const 1) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6+-- > olm (abs_dif dif_r) (abs_ix_dif dif_r) maximum [1,5,12,2,9,6] [7,6,4,9,8,1] == 0.46+olm :: (Fractional a,Enum a) => Psi a -> Delta n a  -> ([a] -> a) -> [n] -> [n] -> a+olm psi delta maxint m n =+    let l = length m+        l' = fromIntegral l - 1+        k = [0..l-2]+        m' = map (delta m) k+        n' = map (delta n) k+    in sum (zipWith psi m' n') / (l' * maxint (m' ++ n'))++-- > olm_no_delta [0,2,4,1,0] [2,3,0,4,1] == 1.25+-- > olm_no_delta [1,6,2,5,11] [3,15,13,2,9] == 4.5+olm_no_delta :: (Real a,Real n,Enum n,Fractional n) => [a] -> [a] -> n+olm_no_delta = olm (abs_dif dif_r) (abs_ix_dif dif_r) (const 1)++-- > olm_no_delta_squared [0,2,4,1,0] [2,3,0,4,1] == sum (map sqrt [3,5,7,8]) / 4+olm_no_delta_squared :: (Enum a,Floating a) => [a] -> [a] -> a+olm_no_delta_squared = olm (sqrt_abs_dif (-)) (sqr_abs_ix_dif (-)) (const 1)++second_order :: (Num n) => ([n] -> [n] -> t) -> [n] -> [n] -> t+second_order f p q = f (d_dx_abs (-) p) (d_dx_abs (-) q)++-- > olm_no_delta_second_order [0,2,4,1,0] [2,3,0,4,1] == 1.0+olm_no_delta_second_order :: (Real a,Enum a,Fractional a) => [a] -> [a] -> a+olm_no_delta_second_order = second_order olm_no_delta++-- p.301 erroneously gives this as sum (map sqrt [2,0,1]) / 3+-- > olm_no_delta_squared_second_order [0,2,4,1,0] [2,3,0,4,1] == sum (map sqrt [4,0,3]) / 3+olm_no_delta_squared_second_order :: (Enum a,Floating a) => [a] -> [a] -> a+olm_no_delta_squared_second_order = second_order olm_no_delta_squared++-- | Second order binomial coefficient, p.307+--+-- > map second_order_binonial_coefficient [2..10] == [1,3,6,10,15,21,28,36,45]+second_order_binonial_coefficient :: Fractional a => a -> a+second_order_binonial_coefficient n = ((n * n) - n) / 2++-- | 'd_dx' of 'flip' 'compare'.+--+-- > direction_interval [5,9,3,2] == [LT,GT,GT]+-- > direction_interval [2,5,6,6] == [LT,LT,EQ]+direction_interval :: Ord i => [i] -> [Ordering]+direction_interval = d_dx (flip compare)++-- | Histogram of list of 'Ordering's.+--+-- > ord_hist [LT,GT,GT] == (1,0,2)+ord_hist :: Integral t => [Ordering] -> (t,t,t)+ord_hist x =+    let h = L.histogram x+        f n = fromMaybe 0 (lookup n h)+    in (f LT,f EQ,f GT)++-- | Histogram of /directions/ of adjacent elements, p.312.+--+-- > direction_vector [5,9,3,2] == (1,0,2)+-- > direction_vector [2,5,6,6] == (2,1,0)+direction_vector :: Integral i => (Ord a) => [a] -> (i,i,i)+direction_vector = ord_hist . direction_interval++-- | Unordered linear direction, p.311 (Fig. 5)+--+-- > uld [5,9,3,2] [2,5,6,6] == 2/3+-- > uld [5,3,6,1,4] [3,6,1,4,2] == 0+uld :: (Integral n,Ord a) => [a] -> [a] -> Ratio n+uld m n =+    let (i,j,k) = direction_vector m+        (p,q,r) = direction_vector n+        z = (i + j + k) * 2+    in (abs_dif (-) i p + abs_dif (-) j q + abs_dif (-) k r) % z++-- | Ordered linear direction, p.312+--+-- > direction_interval [5,3,6,1,4] == [GT,LT,GT,LT]+-- > direction_interval [3,6,1,4,2] == [LT,GT,LT,GT]+-- > old [5,3,6,1,4] [3,6,1,4,2] == 1+old :: (Ord i, Integral a) => [i] -> [i] -> Ratio a+old m n =+    let p = direction_interval m+        q = direction_interval n+        f i j = if i == j then 0 else 1+    in sum (zipWith f p q) % (genericLength m - 1)++-- | Ordered combinatorial direction, p.314+--+-- > ocd [5,9,3,2] [2,5,6,6] == 5/6+-- > ocd [5,3,6,1,4] [3,6,1,4,2] == 4/5+ocd :: (Ord a,Integral i) => [a] -> [a] -> Ratio i+ocd m n =+    let p = concat (C.half_matrix_f compare m)+        q = concat (C.half_matrix_f compare n)+        f i j = if i == j then 0 else 1+    in sum (zipWith f p q) % genericLength p++-- | Unordered combinatorial direction, p.314+--+-- > ucd [5,9,3,2] [2,5,6,6] == 5/6+-- > ucd [5,3,6,1,4] [3,6,1,4,2] == 0+-- > ucd [5,3,7,6] [2,1,2,1] == 1/2+-- > ucd [2,1,2,1] [8,3,5,4] == 1/3+-- > ucd [5,3,7,6] [8,3,5,4] == 1/3+ucd :: (Integral n,Ord a) => [a] -> [a] -> Ratio n+ucd m n =+    let (i,j,k) = ord_hist (concat (C.half_matrix_f compare m))+        (p,q,r) = ord_hist (concat (C.half_matrix_f compare n))+        z = (i + j + k) * 2+    in (abs_dif (-) i p + abs_dif (-) j q + abs_dif (-) k r) % z++-- | 'C.half_matrix_f', Fig.9, p.318+--+-- > let r = [[2,3,1,4]+-- >           ,[1,3,6]+-- >             ,[4,7]+-- >               ,[3]]+-- > in combinatorial_magnitude_matrix (abs_dif (-)) [5,3,2,6,9] == r+combinatorial_magnitude_matrix :: Interval a n -> [a] -> [[n]]+combinatorial_magnitude_matrix = C.half_matrix_f++-- | Unordered linear magnitude (simplified), p.320-321+--+-- > let r = abs (sum [5,4,3,6] - sum [12,2,11,7]) / 4+-- > in ulm_simplified (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == r+--+-- > ulm_simplified (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3+ulm_simplified :: Fractional n => Interval a n -> [a] -> [a] -> n+ulm_simplified f p q =+    let g = abs . sum . d_dx f+    in abs (g p - g q) / fromIntegral (length p - 1)++ocm_zcm :: (Fractional n, Num a) => Interval a n -> [a] -> [a] -> (n, n, [n])+ocm_zcm f p q =+    let p' = concat (C.half_matrix_f f p)+        q' = concat (C.half_matrix_f f q)+        r = zipWith (-) p' q'+        z = sum (map abs r)+        c = second_order_binonial_coefficient (fromIntegral (length p))+        m = p' ++ q'+    in (z,c,m)++-- | Ordered combinatorial magnitude (OCM), p.323+--+-- > ocm (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == 5.2+-- > ocm (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3.6+ocm :: (Fractional a,Enum a,Fractional n) => Interval a n -> [a] -> [a] -> n+ocm f p q =+    let (z,c,_) = ocm_zcm f p q+    in z / c++-- | Ordered combinatorial magnitude (OCM), p.323+--+-- > ocm_absolute_scaled (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == 0.4+-- > ocm_absolute_scaled (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 54/(15*11)+ocm_absolute_scaled :: (Ord a,Fractional a,Enum a,Ord n,Fractional n) => Interval a n -> [a] -> [a] -> n+ocm_absolute_scaled f p q =+    let (z,c,m) = ocm_zcm f p q+    in z / (c * maximum m)
− Music/Theory/Parse.hs 
@@ -1,55 +0,0 @@--- | Parsers for pitch class sets and sequences, and for 'SRO's.-module Music.Theory.Parse (rnrtnmi,pco) where--import Control.Monad-import Data.Char-import Music.Theory.PitchClass-import Text.ParserCombinators.Parsec---- | A 'Char' parser.-type P a = GenParser Char () a---- | Boolean 'P' for given 'Char'.-is_char :: Char -> P Bool-is_char c =-    let f '_' = False-        f _ = True-    in liftM f (option '_' (char c))---- | Parse 'Int'.-get_int :: P Int-get_int = liftM read (many1 digit)---- | Parse a Morris format serial operator descriptor.------ > rnrtnmi "r2RT3MI" == SRO 2 True 3 True True-rnrtnmi :: String -> SRO Int-rnrtnmi s =-  let p = do { r <- rot-             ; r' <- is_char 'R'-             ; _ <- char 'T'-             ; t <- get_int-             ; m <- is_char 'M'-             ; i <- is_char 'I'-             ; eof-             ; return (SRO r r' t m i) }-      rot = option 0 (char 'r' >> get_int)-  in either-         (\e -> error ("rnRTnMI parse failed\n" ++ show e))-         id-         (parse p "" s)---- | Parse a /pitch class object/ string.  Each 'Char' is either a--- number, a space which is ignored, or a letter name for the numbers--- 10 ('t' or 'a' or 'A') or 11 ('e' or 'B' or 'b').------ > pco "13te" == [1,3,10,11]--- > pco "13te" == pco "13ab"-pco :: String -> [Int]-pco s =-    let s' = dropWhile isSpace s-        s'' = takeWhile (`elem` "0123456789taAebB") s'-        f c | c `elem` "taA" = 10-            | c `elem` "ebB" = 11-            | otherwise = read [c]-    in map f s''
− Music/Theory/Pct.hs 
@@ -1,344 +0,0 @@--- | Haskell implementations of @pct@ operations.--- See <http://slavepianos.org/rd/?t=pct>.-module Music.Theory.Pct where--import Data.Function-import Data.List-import Data.Maybe-import Music.Theory.Prime-import Music.Theory.PitchClass-import Music.Theory.Set-import Music.Theory.Table---- | Basic interval pattern, see Allen Forte \"The Basic Interval Patterns\"--- /JMT/ 17/2 (1973):234-272------ >>> bip 0t95728e3416--- 11223344556------ > bip [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6]--- > bip (pco "0t95728e3416") == [1,1,2,2,3,3,4,4,5,5,6]-bip :: (Integral a) => [a] -> [a]-bip = sort . map ic . int---- | Cardinality filter------ > cf [0,3] (powerset [1..4]) == [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[]]-cf :: (Integral n) => [n] -> [[a]] -> [[a]]-cf ns = filter (\p -> genericLength p `elem` ns)---- | Combinatorial sets formed by considering each set as possible--- values for slot.------ > cgg [[0,1],[5,7],[3]] == [[0,5,3],[0,7,3],[1,5,3],[1,7,3]]-cgg :: [[a]] -> [[a]]-cgg l =-    case l of-      x:xs -> [ y:z | y <- x, z <- cgg xs ]-      _ -> [[]]---- | Combinations generator, ie. synonym for 'powerset'.------ > sort (cg [0,1,3]) == [[],[0],[0,1],[0,1,3],[0,3],[1],[1,3],[3]]-cg :: [a] -> [[a]]-cg = powerset---- | Powerset filtered by cardinality.------ >>> cg -r3 0159--- 015--- 019--- 059--- 159------ > cg_r 3 [0,1,5,9] == [[0,1,5],[0,1,9],[0,5,9],[1,5,9]]-cg_r :: (Integral n) => n -> [a] -> [[a]]-cg_r n = cf [n] . cg---- | Cyclic interval segment.-ciseg :: (Integral a) => [a] -> [a]-ciseg = int . cyc---- | pcset complement.------ >>> cmpl 02468t--- 13579B------ > cmpl [0,2,4,6,8,10] == [1,3,5,7,9,11]-cmpl :: (Integral a) => [a] -> [a]-cmpl = ([0..11] \\) . pcset---- | Form cycle.------ >>> cyc 056--- 0560------ > cyc [0,5,6] == [0,5,6,0]-cyc :: [a] -> [a]-cyc [] = []-cyc (x:xs) = (x:xs) ++ [x]---- | Diatonic set name. 'd' for diatonic set, 'm' for melodic minor--- set, 'o' for octotonic set.-d_nm :: (Integral a) => [a] -> Maybe Char-d_nm x =-    case x of-      [0,2,4,5,7,9,11] -> Just 'd'-      [0,2,3,5,7,9,11] -> Just 'm'-      [0,1,3,4,6,7,9,10] -> Just 'o'-      _ -> Nothing---- | Diatonic implications.-dim :: (Integral a) => [a] -> [(a, [a])]-dim p =-    let g (i,q) = is_subset p (tn i q)-        f = filter g . zip [0..11] . repeat-        d = [0,2,4,5,7,9,11]-        m = [0,2,3,5,7,9,11]-        o = [0,1,3,4,6,7,9,10]-    in f d ++ f m ++ f o---- | Variant of 'dim' that is closer to the 'pct' form.------ >>> dim 016--- T1d--- T1m--- T0o------ > dim_nm [0,1,6] == [(1,'d'),(1,'m'),(0,'o')]-dim_nm :: (Integral a) => [a] -> [(a,Char)]-dim_nm =-    let pk f (i,j) = (i,f j)-    in nubBy ((==) `on` snd) . map (pk (fromJust.d_nm)) . dim---- | Diatonic interval set to interval set.------ >>> dis 24--- 1256------ > dis [2,4] == [1,2,5,6]-dis :: (Integral t) => [Int] -> [t]-dis =-    let is = [[], [], [1,2], [3,4], [5,6], [6,7], [8,9], [10,11]]-    in concatMap (\j -> is !! j)---- | Degree of intersection.------ >>> echo 024579e | doi 6 | sort -u--- 024579A--- 024679B------ > let p = [0,2,4,5,7,9,11]--- > in doi 6 p p == [[0,2,4,5,7,9,10],[0,2,4,6,7,9,11]]------ >>> echo 01234 | doi 2 7-35 | sort -u--- 13568AB------ > doi 2 (sc "7-35") [0,1,2,3,4] == [[1,3,5,6,8,10,11]]-doi :: (Integral a) => Int -> [a] -> [a] -> [[a]]-doi n p q =-    let f j = [pcset (tn j p), pcset (tni j p)]-        xs = concatMap f [0..11]-    in set (filter (\x -> length (x `intersect` q) == n) xs)---- | Forte name.-fn :: (Integral a) => [a] -> String-fn = sc_name---- | p `has_ess` q is true iff p can embed q in sequence.-has_ess :: (Integral a) => [a] -> [a] -> Bool-has_ess _ [] = True-has_ess [] _ = False-has_ess (p:ps) (q:qs) = if p == q-                        then has_ess ps qs-                        else has_ess ps (q:qs)---- | Embedded segment search.------ >>> echo 23a | ess 0164325--- 2B013A9--- 923507A------ > ess [2,3,10] [0,1,6,4,3,2,5] == [[9,2,3,5,0,7,10],[2,11,0,1,3,10,9]]-ess :: (Integral a) => [a] -> [a] -> [[a]]-ess p = filter (`has_ess` p) . all_RTnMI---- | Can the set-class q (under prime form algorithm pf) be---   drawn from the pcset p.-has_sc_pf :: (Integral a) => ([a] -> [a]) -> [a] -> [a] -> Bool-has_sc_pf pf p q =-    let n = length q-    in q `elem` map pf (cf [n] (powerset p))---- | Can the set-class q be drawn from the pcset p.-has_sc :: (Integral a) => [a] -> [a] -> Bool-has_sc = has_sc_pf forte_prime---- | Interval cycle filter.------ >>> echo 22341 | icf--- 22341------ > icf [[2,2,3,4,1]] == [[2,2,3,4,1]]-icf :: (Num a) => [[a]] -> [[a]]-icf = filter ((== 12) . sum)---- | Interval class set to interval sets.------ >>> ici -c 123--- 123--- 129--- 1A3--- 1A9------ > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]]-ici :: (Num t) => [Int] -> [[t]]-ici xs =-    let is j = [[0], [1,11], [2,10], [3,9], [4,8], [5,7], [6]] !! j-        ys = map is xs-    in cgg ys---- | Interval class set to interval sets, concise variant.------ > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]]-ici_c :: [Int] -> [[Int]]-ici_c [] = []-ici_c (x:xs) = map (x:) (ici xs)---- | Interval-class segment.------ >>> icseg 013265e497t8--- 12141655232------ > icseg [0,1,3,2,6,5,11,4,9,7,10,8] == [1,2,1,4,1,6,5,5,2,3,2]-icseg :: (Integral a) => [a] -> [a]-icseg = map ic . iseg---- | Interval segment (INT).-iseg :: (Integral a) => [a] -> [a]-iseg = int---- | Imbrications.-imb :: (Integral n) => [n] -> [a] -> [[a]]-imb cs p =-    let g n = (== n) . genericLength-        f ps n = filter (g n) (map (genericTake n) ps)-    in concatMap (f (tails p)) cs---- | 'issb' gives the set-classes that can append to 'p' to give 'q'.------ >>> issb 3-7 6-32--- 3-7--- 3-2--- 3-11------ > issb (sc "3-7") (sc "6-32") == ["3-2","3-7","3-11"]-issb :: (Integral a) => [a] -> [a] -> [String]-issb p q =-    let k = length q - length p-        f = any id . map (\x -> forte_prime (p ++ x) == q) . all_TnI-    in map sc_name (filter f (cf [k] scs))---- | Matrix search.------ >>> mxs 024579 642 | sort -u--- 6421B9--- B97642------ > set (mxs [0,2,4,5,7,9] [6,4,2]) == [[6,4,2,1,11,9],[11,9,7,6,4,2]]-mxs :: (Integral a) => [a] -> [a] -> [[a]]-mxs p q = filter (q `isInfixOf`) (all_RTnI p)---- | Normalize.------ >>> nrm 0123456543210--- 0123456------ > nrm [0,1,2,3,4,5,6,5,4,3,2,1,0] == [0,1,2,3,4,5,6]-nrm :: (Ord a) => [a] -> [a]-nrm = set---- | Normalize, retain duplicate elements.-nrm_r :: (Ord a) => [a] -> [a]-nrm_r = sort---- | Pitch-class invariances (called @pi@ at @pct@).------ >>> pi 0236 12--- 0236--- 6320--- 532B--- B235------ > pci [0,2,3,6] [1,2] == [[0,2,3,6],[5,3,2,11],[6,3,2,0],[11,2,3,5]]-pci :: (Integral a) => [a] -> [a] -> [[a]]-pci p i =-    let f q = set (map (q `genericIndex`) i)-    in filter (\q -> f q == f p) (all_RTnI p)---- | Relate sets.------ >>> rs 0123 641e--- T1M------ > rs [0,1,2,3] [6,4,1,11] == [(rnrtnmi "T1M",[1,6,11,4])--- >                            ,(rnrtnmi "T4MI",[4,11,6,1])]-rs :: (Integral a) => [a] -> [a] -> [(SRO a, [a])]-rs x y =-    let xs = map (\o -> (o, o `sro` x)) sro_TnMI-        q = set y-    in filter (\(_,p) -> set p == q) xs---- | Relate segments.------ >>> rsg 156 3BA--- T4I------ > rsg [1,5,6] [3,11,10] == [rnrtnmi "T4I",rnrtnmi "r1RT4MI"]------ >>> rsg 0123 05t3--- T0M------ > rsg [0,1,2,3] [0,5,10,3] == [rnrtnmi "T0M",rnrtnmi "RT3MI"]------ >>> rsg 0123 4e61--- RT1M------ > rsg [0,1,2,3] [4,11,6,1] == [rnrtnmi "T4MI",rnrtnmi "RT1M"]------ >>> echo e614 | rsg 0123--- r3RT1M------ > rsg [0,1,2,3] [11,6,1,4] == [rnrtnmi "r1T4MI",rnrtnmi "r1RT1M"]----rsg :: (Integral a) => [a] -> [a] -> [SRO a]-rsg x y = map fst (filter (\(_,x') -> x' == y) (sros x))---- | Subsets.-sb :: (Integral a) => [[a]] -> [[a]]-sb xs =-    let f p = all id (map (`has_sc` p) xs)-    in filter f scs---- | Super set-class.------ >>> spsc 4-11 4-12--- 5-26[02458]------ > spsc [sc "4-11", sc "4-12"] == ["5-26"]------ >>> spsc 3-11 3-8--- 4-27[0258]--- 4-Z29[0137]------ > spsc [sc "3-11", sc "3-8"] == ["4-27","4-Z29"]------ >>> spsc `fl 3`--- 6-Z17[012478]------ > spsc (cf [3] scs) == ["6-Z17"]-spsc :: (Integral a) => [[a]] -> [String]-spsc xs =-    let f y = all (y `has_sc`) xs-        g = (==) `on` length-    in (map sc_name . head . groupBy g . filter f) scs
Music/Theory/Permutations.hs view
@@ -1,35 +1,28 @@ -- | Permutation functions.-module Music.Theory.Permutations (permutation-                                 ,apply_permutation,apply_permutation_c-                                 ,non_invertible-                                 ,from_cycles-                                 ,two_line,one_line,one_line_compact-                                 ,multiplication_table-                                 ,compose-                                 ,n_permutations,permutations_l-                                 ,multiset_permutations) where+module Music.Theory.Permutations where -import Data.List import qualified Data.Permute as P-import qualified Math.Combinatorics.Multiset as C+import qualified Music.Theory.List as L import Numeric (showHex) --- | Variant of 'elemIndices' that requires /e/ to be unique in /p/.+-- | Factorial function. ----- > elem_index_unique 'a' "abcda" == undefined-elem_index_unique :: (Eq a) => a -> [a] -> Int-elem_index_unique e p =-    case elemIndices e p of-      [i] -> i-      _ -> error "elem_index_unique"+-- > (factorial 13,maxBound::Int)+factorial :: (Ord a, Num a) => a -> a+factorial n = if n <= 1 then 1 else n * factorial (n - 1) --- | Number of permutations.+-- | Number of /k/ element permutations of a set of /n/ elements. --+-- > (nk_permutations 4 3,nk_permutations 13 3) == (24,1716)+nk_permutations :: Integral a => a -> a -> a+nk_permutations n k = factorial n  `div` factorial (n - k)++-- | Number of /nk/ permutations where /n/ '==' /k/.+-- -- > map n_permutations [1..8] == [1,2,6,24,120,720,5040,40320] -- > n_permutations 16 `div` 1000000 == 20922789--- > length (permutations_l [1..5]) == n_permutations 5 n_permutations :: (Integral a) => a -> a-n_permutations n = if n == 1 then 1 else n * n_permutations (n - 1)+n_permutations n = nk_permutations n n  -- | Generate the permutation from /p/ to /q/, ie. the permutation -- that, when applied to /p/, gives /q/.@@ -38,10 +31,13 @@ permutation :: (Eq a) => [a] -> [a] -> P.Permute permutation p q =     let n = length p-        f x = elem_index_unique x p+        f x = L.elem_index_unique x p     in P.listPermute n (map f q)  -- | Apply permutation /f/ to /p/.+--+-- > let p = permutation [1..4] [4,3,2,1]+-- > in apply_permutation p [1..4] == [4,3,2,1] apply_permutation :: (Eq a) => P.Permute -> [a] -> [a] apply_permutation f p = map (p !!) (P.elems f) @@ -57,6 +53,9 @@ -- | True if the inverse of /p/ is /p/. -- -- > non_invertible (permutation [0,1,3] [1,0,3]) == True+--+-- > let p = permutation [1..4] [4,3,2,1]+-- > in non_invertible p == True && P.cycles p == [[0,3],[1,2]] non_invertible :: P.Permute -> Bool non_invertible p = p == P.inverse p @@ -77,20 +76,6 @@               in maybe [p] (\np -> p : f np) r     in f (P.permute n) --- | Generate all permutations.------ > permutations_l [0,3] == [[0,3],[3,0]]-permutations_l :: (Eq a) => [a] -> [[a]]-permutations_l i =-    let f p = apply_permutation p i-    in map f (permutations_n (length i))---- | Generate all distinct permutations of a multi-set.------ > multiset_permutations [0,1,1] == [[0,1,1],[1,1,0],[1,0,1]]-multiset_permutations :: (Ord a) => [a] -> [[a]]-multiset_permutations = C.permutations . C.fromList- -- | Composition of /q/ then /p/. -- -- > let {p = from_cycles [[0,2],[1],[3,4]]@@ -156,9 +141,7 @@     in map f ps  {--let p = permutation [1..4] [4,3,2,1] -- [[0,3],[1,2]] let q = permutation [1..4] [2,3,4,1] -- [[0,1,2,3]]-(p,non_invertible p,P.cycles p,apply_permutation p [1..4]) (q,non_invertible q,P.cycles q,apply_permutation q [1..4])  let p = permutation [1..5] [3,2,1,5,4] -- [[0,2],[1],[3,4]]
+ Music/Theory/Permutations/List.hs view
@@ -0,0 +1,20 @@+-- | List permutation functions.+module Music.Theory.Permutations.List where++import qualified Math.Combinatorics.Multiset as C+import qualified Music.Theory.Permutations as P++-- | Generate all permutations.+--+-- > permutations [0,3] == [[0,3],[3,0]]+-- > length (permutations [1..5]) == P.n_permutations 5+permutations :: (Eq a) => [a] -> [[a]]+permutations i =+    let f p = P.apply_permutation p i+    in map f (P.permutations_n (length i))++-- | Generate all distinct permutations of a multi-set.+--+-- > multiset_permutations [0,1,1] == [[0,1,1],[1,1,0],[1,0,1]]+multiset_permutations :: (Ord a) => [a] -> [[a]]+multiset_permutations = C.permutations . C.fromList
Music/Theory/Pitch.hs view
@@ -1,15 +1,18 @@ -- | Common music notation pitch values. module Music.Theory.Pitch where +import Data.Char import Data.Function+import Data.Maybe  -- | Pitch classes are modulo twelve integers. type PitchClass = Integer --- | Octaves are integers, the octave of middle C is @4@.+-- | Octaves are 'Integer's, the octave of middle C is @4@. type Octave = Integer  -- | 'Octave' and 'PitchClass' duple.+type Octave_PitchClass i = (i,i) type OctPC = (Octave,PitchClass)  -- | Enumeration of common music notation note names (@C@ to @B@).@@ -28,15 +31,33 @@ data Pitch = Pitch {note :: Note_T                    ,alteration :: Alteration_T                    ,octave :: Octave}-           deriving (Eq, Show)+           deriving (Eq,Show)  instance Ord Pitch where     compare = pitch_compare --- | Transform 'Note_T' to 'PitchClass'.+-- | Pretty printer for 'Pitch' (unicode, see 'alteration_symbol'). --+-- > pitch_pp (Pitch E Flat 4) == "E♭4"+-- > pitch_pp (Pitch F QuarterToneSharp 3) == "F𝄲3"+pitch_pp :: Pitch -> String+pitch_pp (Pitch n a o) =+    let a' = if a == Natural then "" else [alteration_symbol a]+    in show n ++ a' ++ show o++-- | Pretty printer for 'Pitch' (ASCII, see 'alteration_ly_name').+--+-- > pitch_pp_ascii (Pitch E Flat 4) == "ees4"+-- > pitch_pp_ascii (Pitch F QuarterToneSharp 3) == "fih3"+pitch_pp_ascii :: Pitch -> String+pitch_pp_ascii (Pitch n a o) =+    let n' = map toLower (show n)+    in n' ++ alteration_ly_name a ++ show o++-- | Transform 'Note_T' to pitch-class number.+-- -- > map note_to_pc [C,E,G] == [0,4,7]-note_to_pc :: Note_T -> PitchClass+note_to_pc :: Integral i => Note_T -> i note_to_pc n =     case n of       C -> 0@@ -47,41 +68,68 @@       A -> 9       B -> 11 --- | Transform 'Alteration_T' to semitone alteration.+-- | Transform 'Alteration_T' to semitone alteration.  Returns+-- 'Nothing' for non-semitone alterations. ----- > map alteration_to_diff [Flat,Sharp] == [-1,1]-alteration_to_diff :: Alteration_T -> Integer+-- > map alteration_to_diff [Flat,QuarterToneSharp] == [Just (-1),Nothing]+alteration_to_diff :: Integral i => Alteration_T -> Maybe i alteration_to_diff a =     case a of-      DoubleFlat -> -2-      Flat -> -1-      Natural -> 0-      Sharp -> 1-      DoubleSharp -> 2-      _ -> error "alteration_to_diff: quarter tone"+      DoubleFlat -> Just (-2)+      Flat -> Just (-1)+      Natural -> Just 0+      Sharp -> Just 1+      DoubleSharp -> Just 2+      _ -> Nothing +-- | Transform 'Alteration_T' to semitone alteration.+--+-- > map alteration_to_diff_err [Flat,Sharp] == [-1,1]+alteration_to_diff_err :: Integral i => Alteration_T -> i+alteration_to_diff_err =+    let err = error "alteration_to_diff: quarter tone"+    in fromMaybe err . alteration_to_diff+ -- | Transform 'Alteration_T' to fractional semitone alteration, -- ie. allow quarter tones. -- -- > alteration_to_fdiff QuarterToneSharp == 0.5-alteration_to_fdiff :: Alteration_T -> Double+alteration_to_fdiff :: Fractional n => Alteration_T -> n alteration_to_fdiff a =     case a of       ThreeQuarterToneFlat -> -1.5       QuarterToneFlat -> -0.5       QuarterToneSharp -> 0.5       ThreeQuarterToneSharp -> 1.5-      _ -> fromIntegral (alteration_to_diff a)+      _ -> fromInteger (alteration_to_diff_err a) +-- | Transform fractional semitone alteration to 'Alteration_T',+-- ie. allow quarter tones.+--+-- > map fdiff_to_alteration [-0.5,0.5] == [Just QuarterToneFlat+-- >                                       ,Just QuarterToneSharp]+fdiff_to_alteration :: (Fractional n,Eq n) => n -> Maybe Alteration_T+fdiff_to_alteration d =+    case d of+      -2 -> Just DoubleFlat+      -1.5 -> Just ThreeQuarterToneFlat+      -1 -> Just Flat+      -0.5 -> Just QuarterToneFlat+      0 -> Just Natural+      0.5 -> Just QuarterToneSharp+      1 -> Just Sharp+      1.5 -> Just ThreeQuarterToneSharp+      2 -> Just DoubleSharp+      _ -> undefined+ -- | Unicode has entries for /Musical Symbols/ in the range @U+1D100@ -- through @U+1D1FF@.  The @3/4@ symbols are non-standard, here they -- correspond to @MUSICAL SYMBOL FLAT DOWN@ and @MUSICAL SYMBOL SHARP -- UP@. ----- > map alteration_symbol [minBound .. maxBound]+-- > map alteration_symbol [minBound .. maxBound] == "𝄫𝄭♭𝄳♮𝄲♯𝄰𝄪" alteration_symbol :: Alteration_T -> Char-alteration_symbol a =-    case a of+alteration_symbol a =    case a of       DoubleFlat -> '𝄫'       ThreeQuarterToneFlat -> '𝄭'       Flat -> '♭'@@ -92,20 +140,85 @@       ThreeQuarterToneSharp -> '𝄰'       DoubleSharp -> '𝄪' +-- | The @Lilypond@ ASCII spellings for alterations.+--+-- > map alteration_ly_name [Flat .. Sharp] == ["es","eh","","ih","is"]+alteration_ly_name :: Alteration_T -> String+alteration_ly_name a =+    case a of+      DoubleFlat -> "eses"+      ThreeQuarterToneFlat -> "eseh"+      Flat -> "es"+      QuarterToneFlat -> "eh"+      Natural -> ""+      QuarterToneSharp -> "ih"+      Sharp -> "is"+      ThreeQuarterToneSharp -> "isih"+      DoubleSharp -> "isis"++-- | Raise 'Alteration_T' by a quarter tone where possible.+--+-- > alteration_raise_quarter_tone Flat == Just QuarterToneFlat+-- > alteration_raise_quarter_tone DoubleSharp == Nothing+alteration_raise_quarter_tone :: Alteration_T -> Maybe Alteration_T+alteration_raise_quarter_tone a =+    if a == maxBound then Nothing else Just (toEnum (fromEnum a + 1))++-- | Lower 'Alteration_T' by a quarter tone where possible.+--+-- > alteration_lower_quarter_tone Sharp == Just QuarterToneSharp+-- > alteration_lower_quarter_tone DoubleFlat == Nothing+alteration_lower_quarter_tone :: Alteration_T -> Maybe Alteration_T+alteration_lower_quarter_tone a =+    if a == minBound then Nothing else Just (toEnum (fromEnum a - 1))++-- | Edit 'Alteration_T' by a quarter tone where possible, @-0.5@+-- lowers, @0@ retains, @0.5@ raises.+alteration_edit_quarter_tone :: (Fractional n,Eq n) =>+                                n -> Alteration_T -> Maybe Alteration_T+alteration_edit_quarter_tone n a =+    case n of+      -0.5 -> alteration_lower_quarter_tone a+      0 -> Just a+      0.5 -> alteration_raise_quarter_tone a+      _ -> Nothing++-- | Simplify 'Alteration_T' to standard 12ET by deleting quarter tones.+--+-- > Data.List.nub (map alteration_clear_quarter_tone [minBound..maxBound])+alteration_clear_quarter_tone :: Alteration_T -> Alteration_T+alteration_clear_quarter_tone x =+    case x of+      ThreeQuarterToneFlat -> Flat+      QuarterToneFlat -> Flat+      QuarterToneSharp -> Sharp+      ThreeQuarterToneSharp -> Sharp+      _ -> x++-- | Simplify 'Pitch' to standard 12ET by deleting quarter tones.+--+-- > let p = Pitch A QuarterToneSharp 4+-- > in alteration (pitch_clear_quarter_tone p) == Sharp+pitch_clear_quarter_tone :: Pitch -> Pitch+pitch_clear_quarter_tone p =+    let Pitch n a o = p+    in Pitch n (alteration_clear_quarter_tone a) o+ -- | 'Pitch' to 'Octave' and 'PitchClass' notation. -- -- > pitch_to_octpc (Pitch F Sharp 4) == (4,6)-pitch_to_octpc :: Pitch -> OctPC+pitch_to_octpc :: Integral i => Pitch -> Octave_PitchClass i pitch_to_octpc = midi_to_octpc . pitch_to_midi  -- | 'Pitch' to midi note number notation. -- -- > pitch_to_midi (Pitch A Natural 4) == 69-pitch_to_midi :: Pitch -> Integer+pitch_to_midi :: Integral i => Pitch -> i pitch_to_midi (Pitch n a o) =-    let a' = alteration_to_diff a+    let a' = alteration_to_diff_err a         n' = note_to_pc n-    in 12 + o * 12 + n' + a'+        o' = fromIntegral o+    in 12 + o' * 12 + n' + a'  -- | 'Pitch' to fractional midi note number notation. --@@ -113,8 +226,8 @@ 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)+        o' = fromInteger o+        n' = fromInteger (note_to_pc n)     in 12 + o' * 12 + n' + a'  -- | Extract 'PitchClass' of 'Pitch'@@ -122,7 +235,7 @@ -- > pitch_to_pc (Pitch A Natural 4) == 9 -- > pitch_to_pc (Pitch F Sharp 4) == 6 pitch_to_pc :: Pitch -> PitchClass-pitch_to_pc (Pitch n a _) = note_to_pc n + alteration_to_diff a+pitch_to_pc (Pitch n a _) = note_to_pc n + alteration_to_diff_err a  -- | 'Pitch' comparison, implemented via 'pitch_to_fmidi'. --@@ -131,19 +244,19 @@ pitch_compare = compare `on` pitch_to_fmidi  -- | Function to spell a 'PitchClass'.-type Spelling = PitchClass -> (Note_T, Alteration_T)+type Spelling n = n -> (Note_T,Alteration_T)  -- | Given 'Spelling' function translate from 'OctPC' notation to -- 'Pitch'.-octpc_to_pitch :: Spelling -> OctPC -> Pitch+octpc_to_pitch :: Integral i => Spelling i -> Octave_PitchClass i -> Pitch octpc_to_pitch sp (o,pc) =     let (n,a) = sp pc-    in Pitch n a o+    in Pitch n a (fromIntegral o)  -- | Normalise 'OctPC' value, ie. ensure 'PitchClass' is in (0,11). -- -- > octpc_nrm (4,16) == (5,4)-octpc_nrm :: OctPC -> OctPC+octpc_nrm :: Integral i => Octave_PitchClass i -> Octave_PitchClass i octpc_nrm (o,pc) =     if pc > 11     then octpc_nrm (o+1,pc-12)@@ -154,21 +267,78 @@ -- | Transpose 'OctPC' value. -- -- > octpc_trs 7 (4,9) == (5,4)-octpc_trs :: Integer -> OctPC -> OctPC-octpc_trs n (o,pc) = octpc_nrm (o,pc+n)+-- > octpc_trs (-11) (4,9) == (3,10)+octpc_trs :: Integral i => i -> Octave_PitchClass i -> Octave_PitchClass i+octpc_trs n (o,pc) =+    let pc' = fromIntegral pc+        k = pc' + n+        (i,j) = k `divMod` 12+    in (fromIntegral o + fromIntegral i,fromIntegral j) --- | 'OctPC' value to /midi/ value.+-- | 'OctPC' value to integral /midi/ note number. -- -- > octpc_to_midi (4,9) == 69-octpc_to_midi :: OctPC -> Integer-octpc_to_midi (o,pc) = 60 + ((o - 4) * 12) + pc+octpc_to_midi :: Integral i => Octave_PitchClass i -> i+octpc_to_midi (o,pc) = 60 + ((fromIntegral o - 4) * 12) + pc  -- | Inverse of 'octpc_to_midi'. -- -- > midi_to_octpc 69 == (4,9)-midi_to_octpc :: Integer -> OctPC+midi_to_octpc :: Integral i => i -> Octave_PitchClass i midi_to_octpc n = (n - 12) `divMod` 12 +-- | Midi note number to 'Pitch'.+--+-- > let r = ["C4","E♭4","F♯4"]+-- > in map (pitch_pp . midi_to_pitch pc_spell_ks) [60,63,66] == r+midi_to_pitch :: Integral i => Spelling i -> i -> Pitch+midi_to_pitch sp = octpc_to_pitch sp . midi_to_octpc++-- | Fractional midi note number to 'Pitch'.+--+-- > import Music.Theory.Pitch.Spelling+-- > pitch_pp (fmidi_to_pitch pc_spell_ks 65.5) == "F𝄲4"+-- > pitch_pp (fmidi_to_pitch pc_spell_ks 66.5) == "F𝄰4"+-- > pitch_pp (fmidi_to_pitch pc_spell_ks 67.5) == "A𝄭4"+-- > pitch_pp (fmidi_to_pitch pc_spell_ks 69.5) == "B𝄭4"+fmidi_to_pitch :: RealFrac n => Spelling Integer -> n -> Pitch+fmidi_to_pitch sp m =+    let m' = round m+        (Pitch n a o) = midi_to_pitch sp m'+        Just a' = alteration_edit_quarter_tone (m - fromIntegral m') a+    in Pitch n a' o++-- | Raise 'Note_T' of 'Pitch', account for octave transposition.+--+-- > pitch_note_raise (Pitch B Natural 3) == Pitch C Natural 4+pitch_note_raise :: Pitch -> Pitch+pitch_note_raise (Pitch n a o) =+    if n == maxBound+    then Pitch minBound a (o + 1)+    else Pitch (succ n) a o++-- | Lower 'Note_T' of 'Pitch', account for octave transposition.+--+-- > pitch_note_lower (Pitch C Flat 4) == Pitch B Flat 3+pitch_note_lower :: Pitch -> Pitch+pitch_note_lower (Pitch n a o) =+    if n == minBound+    then Pitch maxBound a (o - 1)+    else Pitch (pred n) a o++-- | Rewrite 'Pitch' to not use @3/4@ tone alterations, ie. re-spell+-- to @1/4@ alteration.+--+-- > let {p = Pitch A ThreeQuarterToneFlat 4+-- >     ;q = Pitch G QuarterToneSharp 4}+-- > in pitch_rewrite_threequarter_alteration p == q+pitch_rewrite_threequarter_alteration :: Pitch -> Pitch+pitch_rewrite_threequarter_alteration (Pitch n a o) =+    case a of+      ThreeQuarterToneFlat -> pitch_note_lower (Pitch n QuarterToneSharp o)+      ThreeQuarterToneSharp -> pitch_note_raise (Pitch n QuarterToneFlat o)+      _ -> Pitch n a o+ -- | Apply function to 'octave' of 'PitchClass'. -- -- > pitch_edit_octave (+ 1) (Pitch A Natural 4) == Pitch A Natural 5@@ -183,3 +353,36 @@     let x' = fromEnum x         n' = fromEnum (maxBound::Note_T) + 1     in toEnum ((x' + n) `mod` n')++-- * Frequency (CPS)++-- | /Midi/ note number to cycles per second.+--+-- > map midi_to_cps [60,69] == [261.6255653005986,440.0]+midi_to_cps :: (Integral i,Floating f) => i -> f+midi_to_cps = fmidi_to_cps . fromIntegral++-- | Fractional /midi/ note number to cycles per second.+--+-- > map fmidi_to_cps [69,69.1] == [440.0,442.5488940698553]+fmidi_to_cps :: Floating a => a -> a+fmidi_to_cps i = 440 * (2 ** ((i - 69) * (1 / 12)))++-- | Frequency (cycles per second) to /midi/ note number.+--+-- > map cps_to_midi [261.6,440] == [60,69]+cps_to_midi :: (Integral i,Floating f,RealFrac f) => f -> i+cps_to_midi = round . cps_to_fmidi++-- | Frequency (cycles per second) to fractional /midi/ note number.+--+-- > cps_to_fmidi 440 == 69+-- > cps_to_fmidi (fmidi_to_cps 60.25) == 60.25+cps_to_fmidi :: Floating a => a -> a+cps_to_fmidi a = (logBase 2 (a * (1 / 440)) * 12) + 69++-- | 'midi_to_cps' of 'octpc_to_midi'.+--+-- > octpc_to_cps (4,9) == 440+octpc_to_cps :: (Integral i,Floating n) => Octave_PitchClass i -> n+octpc_to_cps = midi_to_cps . octpc_to_midi
Music/Theory/Pitch/Name.hs view
@@ -6,6 +6,17 @@  import Music.Theory.Pitch +a0,b0 :: Pitch+a0 = Pitch A Natural 0+b0 = Pitch B Natural 0++bes0 :: Pitch+bes0 = Pitch B Flat 0++ais0,bis0 :: Pitch+ais0 = Pitch A Sharp 0+bis0 = Pitch B Sharp 0+ c1,d1,e1,f1,g1,a1,b1 :: Pitch c1 = Pitch C Natural 1 d1 = Pitch D Natural 1@@ -96,6 +107,15 @@ ais3 = Pitch A Sharp 3 bis3 = Pitch B Sharp 3 +ceses3,deses3,eeses3,feses3,geses3,aeses3,beses3 :: Pitch+ceses3 = Pitch C DoubleFlat 3+deses3 = Pitch D DoubleFlat 3+eeses3 = Pitch E DoubleFlat 3+feses3 = Pitch F DoubleFlat 3+geses3 = Pitch G DoubleFlat 3+aeses3 = Pitch A DoubleFlat 3+beses3 = Pitch B DoubleFlat 3+ cisis3,disis3,eisis3,fisis3,gisis3,aisis3,bisis3 :: Pitch cisis3 = Pitch C DoubleSharp 3 disis3 = Pitch D DoubleSharp 3@@ -392,3 +412,8 @@ gis7 = Pitch G Sharp 7 ais7 = Pitch A Sharp 7 bis7 = Pitch B Sharp 7++c8,cis8,d8 :: Pitch+c8 = Pitch C Natural 8+cis8 = Pitch C Sharp 8+d8 = Pitch D Natural 8
Music/Theory/Pitch/Spelling.hs view
@@ -4,12 +4,12 @@ import Music.Theory.Pitch  -- | Variant of 'Spelling' for incomplete functions.-type Spelling_M = PitchClass -> Maybe (Note_T, Alteration_T)+type Spelling_M i = i -> Maybe (Note_T, Alteration_T)  -- | Spelling for natural (♮) notes only. -- -- > map pc_spell_natural_m [0,1] == [Just (C,Natural),Nothing]-pc_spell_natural_m :: Spelling_M+pc_spell_natural_m :: Integral i => Spelling_M i pc_spell_natural_m pc =     case pc of       0 -> Just (C,Natural)@@ -24,18 +24,18 @@ -- | Erroring variant of 'pc_spell_natural_m'. -- -- > map pc_spell_natural [0,5,7] == [(C,Natural),(F,Natural),(G,Natural)]-pc_spell_natural :: Spelling+pc_spell_natural :: Integral i => Spelling i pc_spell_natural pc =     case pc_spell_natural_m pc of       Just p -> p-      _ -> error ("pc_spell_natural: " ++ show pc)+      _ -> error "pc_spell_natural"  -- | Use spelling from simplest key-signature.  Note that this is -- ambiguous for @8@, which could be either G Sharp (♯) in /A Major/ -- or A Flat (♭) in /E Flat (♭) Major/. -- -- > map pc_spell_ks [6,8] == [(F,Sharp),(A,Flat)]-pc_spell_ks :: Spelling+pc_spell_ks :: Integral i => Spelling i pc_spell_ks pc =     case pc of       1 -> (C,Sharp) -- 2#@@ -50,7 +50,7 @@ -- > map pc_spell_sharp [6,8] == [(F,Sharp),(G,Sharp)] -- > Data.List.nub (map (snd . pc_spell_sharp) [1,3,6,8,10]) == [Sharp] -- > octpc_to_pitch pc_spell_sharp (4,6) == Pitch F Sharp 4-pc_spell_sharp :: Spelling+pc_spell_sharp :: Integral i => Spelling i pc_spell_sharp pc =     case pc of       1 -> (C,Sharp)@@ -64,7 +64,7 @@ -- -- >  map pc_spell_flat [6,8] == [(G,Flat),(A,Flat)] -- >  Data.List.nub (map (snd . pc_spell_flat) [1,3,6,8,10]) == [Flat]-pc_spell_flat :: Spelling+pc_spell_flat :: Integral i => Spelling i pc_spell_flat pc =     case pc of       1 -> (D,Flat)
+ Music/Theory/Pitch/Spelling/Cluster.hs view
@@ -0,0 +1,157 @@+-- | Spelling for chromatic clusters.+module Music.Theory.Pitch.Spelling.Cluster where++import Data.List+import Music.Theory.Pitch+import Music.Theory.Pitch.Name++-- | Spelling table for chromatic clusters.+--+-- > let f (p,q) = p == sort (map (snd . pitch_to_octpc) q)+-- > in all f spell_cluster_c4_table == True+spell_cluster_c4_table :: [([PitchClass],[Pitch])]+spell_cluster_c4_table =+    [([0],[c4])+    ,([0,1],[c4,des4])+    ,([0,1,2],[bis3,cis4,d4])+    ,([0,1,2,3],[bis3,cis4,d4,ees4])+    ,([0,1,2,3,10,11],[ais3,b3,c4,cis4,d4,ees4]) -- overlap...+    ,([0,1,2,10],[ais3,bis3,cis4,d4])+    ,([0,1,2,11],[aisis3,bis3,cis4,d4])+    ,([0,1,3],[c4,des4,ees4])+    ,([0,1,3,10],[bes3,c4,des4,ees4])+    ,([0,1,3,11],[b3,c4,des4,ees4])+    ,([0,1,10],[bes3,c4,des4])+    ,([0,1,10,11],[ais3,b3,c4,des4])+    ,([0,1,11],[b3,c4,des4])+    ,([0,2],[c4,d4])+    ,([0,2,3],[c4,d4,ees4])+    ,([0,2,3,10],[bes3,c4,d4,ees4])+    ,([0,2,3,11],[b3,c4,d4,ees4])+    ,([0,2,11],[b3,c4,d4])+    ,([0,2,10],[bes3,c4,d4])+    ,([0,2,10,11],[ais3,b3,c4,d4])+    ,([0,3,10,11],[ais3,b3,c4,dis4])+    ,([0,3,11],[b3,c4,dis4])+    ,([0,10,11],[ais3,b3,c4])+    ,([0,11],[b3,c4])+    ,([1],[cis4])+    ,([1,2],[cis4,d4])+    ,([1,2,3],[cis4,d4,ees4])+    ,([1,2,3,10],[bes3,cis4,d4,ees4])+    ,([1,2,3,11],[b3,cis4,d4,ees4])+    ,([1,2,10],[ais3,cis4,d4])+    ,([1,2,10,11],[ais3,b3,cis4,d4])+    ,([1,2,11],[b3,cis4,d4])+    ,([1,3,11],[b3,cis4,dis4])+    ,([1,3,10,11],[ais3,b3,cis4,dis4])+    ,([1,10,11],[ais3,b3,cis4])+    ,([1,11],[b3,cis4])+    ,([2],[d4])+    ,([2,3],[d4,ees4])+    ,([2,3,4],[d4,ees4,fes4])+    ,([2,3,5],[d4,ees4,f4])+    ,([2,3,4,5],[d4,ees4,fes4,geses4])+    ,([2,3,10,11],[bes3,ces4,d4,ees4])+    ,([2,3,11],[b3,d4,ees4])+    ,([2,4],[d4,e4])+    ,([2,4,5],[d4,e4,f4])+    ,([2,5],[d4,f4])+    ,([2,10,11],[ais3,b3,d4])+    ,([2,11],[b3,d4])+    ,([3],[ees4])+    ,([3,4],[dis4,e4])+    ,([3,4,5],[dis4,e4,f4])+    ,([3,5],[ees4,f4])+    ,([4],[e4])+    ,([4,5],[e4,f4])+    ,([5],[f4])+    ,([5,6],[f4,ges4])+    ,([5,6,7],[eis4,fis4,g4])+    ,([5,6,8],[f4,ges4,aes4])+    ,([5,6,9],[f4,ges4,a4])+    ,([5,6,7,8],[eis4,fis4,g4,aes4])+    ,([5,6,7,8,9],[eis4,fis4,g4,aes4,beses4])+    ,([5,6,7,9],[eis4,fis4,g4,a4])+    ,([5,6,8,9],[eis4,fis4,gis4,a4])+    ,([5,7],[f4,g4])+    ,([5,7,8],[f4,g4,aes4])+    ,([5,7,8,9],[f4,g4,aes4,beses4])+    ,([5,7,9],[f4,g4,a4])+    ,([5,8],[f4,aes4])+    ,([5,8,9],[f4,gis4,a4])+    ,([5,9],[f4,a4])+    ,([6],[fis4])+    ,([6,7],[fis4,g4])+    ,([6,7,8],[fis4,g4,aes4])+    ,([6,7,8,9],[fis4,g4,aes4,beses4])+    ,([6,7,9],[fis4,g4,a4])+    ,([6,8],[fis4,gis4])+    ,([6,8,9],[fis4,gis4,a4])+    ,([6,9],[fis4,a4])+    ,([7],[g4])+    ,([7,8],[g4,aes4])+    ,([7,8,9],[fisis4,gis4,a4])+    ,([7,9],[g4,a4])+    ,([8],[aes4])+    ,([8,9],[gis4,a4])+    ,([8,9,10],[gis4,a4,bes4])+    ,([8,10],[aes4,bes4])+    ,([9],[a4])+    ,([9,10],[a4,bes4])+    ,([10],[bes4])+    ,([10,11],[ais4,b4])+    ,([11],[b4])]++-- | Spelling for chromatic clusters.  Sequence must be ascending.+-- Pitch class @0@ maps to 'c4', if there is no @0@ then all notes are+-- in octave @4@.+--+-- > let f = fmap (map pitch_pp) . spell_cluster_c4+-- > in map f [[11,0],[11]] == [Just ["B3","C4"],Just ["B4"]]+--+-- > fmap (map pitch_pp) (spell_cluster_c4 [10,11]) == Just ["A♯4","B4"]+spell_cluster_c4 :: [PitchClass] -> Maybe [Pitch]+spell_cluster_c4 p = lookup (sort p) spell_cluster_c4_table++-- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave'.  An+-- octave of @4@ is the identitiy, @3@ an octave below, @5@ an octave+-- above.+--+-- > fmap (map pitch_pp) (spell_cluster_c 3 [11,0]) == Just ["B2","C3"]+-- > fmap (map pitch_pp) (spell_cluster_c 3 [10,11]) == Just ["A♯3","B3"]+spell_cluster_c :: Octave -> [PitchClass] -> Maybe [Pitch]+spell_cluster_c o =+    fmap (map (pitch_edit_octave (+ (o - 4)))) .+    spell_cluster_c4++-- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave' so+-- that the left-most note is in the octave given by /f/.+--+-- > import Data.Maybe+--+-- > let {f n = if n >= 11 then 3 else 4+-- >     ;g = map pitch_pp .fromJust . spell_cluster_f f+-- >     ;r = [["B3","C4"],["B3"],["C4"],["A♯4","B4"]]}+-- > in map g [[11,0],[11],[0],[10,11]] == r+spell_cluster_f :: (PitchClass -> Octave) -> [PitchClass] -> Maybe [Pitch]+spell_cluster_f o_f p =+    let fn r = case r of+                [] -> []+                l:_ -> let (o,n) = pitch_to_octpc l+                           f = (+ (o_f n - o))+                       in (map (pitch_edit_octave f) r)+    in fmap fn (spell_cluster_c4 p)++-- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave' so+-- that the left-most note is in octave /o/.+--+-- > fmap (map pitch_pp) (spell_cluster_left 3 [11,0]) == Just ["B3","C4"]+-- > fmap (map pitch_pp) (spell_cluster_left 3 [10,11]) == Just ["A♯3","B3"]+spell_cluster_left :: Octave -> [PitchClass] -> Maybe [Pitch]+spell_cluster_left o p =+    let fn r = case r of+                [] -> []+                l:_ -> let f = (+ (o - octave l))+                       in map (pitch_edit_octave f) r+    in fmap fn (spell_cluster_c4 p)
− Music/Theory/PitchClass.hs 
@@ -1,333 +0,0 @@--- | Pitch class operations on integers.-module Music.Theory.PitchClass where--import Music.Theory.Set-import Data.Maybe-import Data.List---- * Pitch class operations---- | Modulo twelve.------ > map mod12 [11,12,-1] == [11,0,11]-mod12 :: (Integral a) => a -> a-mod12 = (`mod` 12)---- | Pitch class, synonym for 'mod12'.-pc :: (Integral a) => a -> a-pc = mod12---- | Map to pitch-class and reduce to set.------ > pcset [1,13] == [1]-pcset :: (Integral a) => [a] -> [a]-pcset = set . map pc---- | Transpose by n.------ >>> sro T4 156--- 59A------ > tn 4 [1,5,6] == [5,9,10]-tn :: (Integral a) => a -> [a] -> [a]-tn n = map (pc . (+ n))---- | Transpose so first element is n.------ > transposeTo 5 [0,1,3] == [5,6,8]-transposeTo :: (Integral a) => a -> [a] -> [a]-transposeTo n p =-    case p of-      [] -> []-      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 6 [4,5,6] == [8,7,6]--- > invert 0 [0,1,3] == [0,11,9]-invert :: (Integral a) => a -> [a] -> [a]-invert n = map (pc . (\p -> n - (p - n)))---- | Invert about first element.------ > map invertSelf [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]]-invertSelf :: (Integral a) => [a] -> [a]-invertSelf p =-    case p of-      [] -> []-      x:xs -> invert x (x:xs)---- | Composition of 'invert' about @0@ and 'tn'.------ >>> sro T4I 156--- 3BA------ > tni 4 [1,5,6] == [3,11,10]------ >>> echo 156 | sro T4  | sro T0I--- 732------ > (invert 0 . tn  4) [1,5,6] == [7,3,2]-tni :: (Integral a) => a -> [a] -> [a]-tni n = tn n . invert 0---- | Rotate left by /n/ places.------ > rotate 3 [1..5] == [4,5,1,2,3]-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 3 [1..5] == [3,4,5,1,2]-rotate_right :: (Integral n) => n -> [a] -> [a]-rotate_right = rotate . negate---- | All rotations.------ > rotations [0,1,3] == [[0,1,3],[1,3,0],[3,0,1]]-rotations :: [a] -> [[a]]-rotations p = map (`rotate` p) [0 .. length p - 1]---- | Modulo 12 multiplication------ > mn 11 [0,1,4,9] == tni 0 [0,1,4,9]-mn :: (Integral a) => a -> [a] -> [a]-mn n = map (pc . (* n))---- | M5, ie. 'mn' @5@.------ > m5 [0,1,3] == [0,5,3]-m5 :: (Integral a) => [a] -> [a]-m5 = mn 5---- | Set of all tranpositions.------ > length (all_Tn [0,1,3]) == 12-all_Tn :: (Integral a) => [a] -> [[a]]-all_Tn p = map (`tn` p) [0..11]---- | Set of all tranpositions and inversions.------ > length (all_TnI [0,1,3]) == 24-all_TnI :: (Integral a) => [a] -> [[a]]-all_TnI p =-    let ps = all_Tn p-    in ps ++ map (invert 0) ps---- | Set of all retrogrades, tranpositions and inversions.------ > length (all_RTnI [0,1,3]) == 48-all_RTnI :: (Integral a) => [a] -> [[a]]-all_RTnI p =-    let ps = all_TnI p-    in ps ++ map reverse ps---- | Set of all rotations and retrogrades.------ > map (length . all_rR) [[0,1,3],[0,1,3,6]] == [6,8]-all_rR :: (Integral a) => [a] -> [[a]]-all_rR p = rotations p ++ rotations (reverse p)---- | Set of all rotations, retrogrades, tranpositions and inversions.------ > length (all_rRTnI [0,1,3]) == 192-all_rRTnI :: (Integral a) => [a] -> [[a]]-all_rRTnI p =-    let ps = all_RTnI p-    in ps ++ concatMap rotations ps---- | Set of all tranpositions, @M5@ and inversions.-all_TnMI :: (Integral a) => [a] -> [[a]]-all_TnMI p =-    let ps = all_TnI p-    in ps ++ map m5 ps---- | Set of all retrogrades, tranpositions, @M5@ and inversions.-all_RTnMI :: (Integral a) => [a] -> [[a]]-all_RTnMI p =-    let ps = all_TnMI p-    in ps ++ map reverse ps---- | Set of all rotations, retrogrades, tranpositions, @M5@ and inversions.-all_rRTnMI :: (Integral a) => [a] -> [[a]]-all_rRTnMI = map snd . sros---- * Serial operations---- | Serial Operator, of the form rRTMI.-data SRO a = SRO a Bool a Bool Bool-             deriving (Eq, Show)---- | Serial operation.------ >>> sro T4 156--- 59A------ > sro (rnrtnmi "T4") (pco "156") == [5,9,10]------ >>> echo 024579 | sro RT4I--- 79B024------ > sro (SRO 0 True 4 False True) [0,2,4,5,7,9] == [7,9,11,0,2,4]------ >>> sro T4I 156--- 3BA------ > sro (rnrtnmi "T4I") (pco "156") == [3,11,10]--- > sro (SRO 0 False 4 False True) [1,5,6] == [3,11,10]------ >>> echo 156 | sro T4  | sro T0I--- 732------ > (sro (rnrtnmi "T0I") . sro (rnrtnmi "T4")) (pco "156") == [7,3,2]------ >>> echo 024579 | sro RT4I--- 79B024------ > sro (rnrtnmi "RT4I") (pco "024579") == [7,9,11,0,2,4]------ > sro (SRO 1 True 1 True False) [0,1,2,3] == [11,6,1,4]--- > sro (SRO 1 False 4 True True) [0,1,2,3] == [11,6,1,4]-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] ]---- | The set of transposition 'SRO's.-sro_Tn :: (Integral a) => [SRO a]-sro_Tn = [ SRO 0 False n False False |-           n <- [0..11] ]---- | The set of transposition and inversion 'SRO's.-sro_TnI :: (Integral a) => [SRO a]-sro_TnI = [ SRO 0 False n False i |-            n <- [0..11],-            i <- [False, True] ]---- | The set of retrograde and transposition and inversion 'SRO's.-sro_RTnI :: (Integral a) => [SRO a]-sro_RTnI = [ SRO 0 r n False i |-             r <- [True, False],-             n <- [0..11],-             i <- [False, True] ]---- | The set of transposition, @M5@ and inversion 'SRO's.-sro_TnMI :: (Integral a) => [SRO a]-sro_TnMI = [ SRO 0 False n m i |-             n <- [0..11],-             m <- [True, False],-             i <- [True, False] ]---- | The set of retrograde, transposition, @M5@ and inversion 'SRO's.-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] ]---- * Interval operations---- | Intervals to values, zero is /n/.------ > dx_d 5 [1,2,3] == [5,6,8,11]-dx_d :: (Num a) => a -> [a] -> [a]-dx_d = scanl (+)---- | Integrate, ie. pitch class segment to interval sequence.------ > d_dx [5,6,8,11] == [1,2,3]-d_dx :: (Num a) => [a] -> [a]-d_dx l =-    case l of-      x:xs -> zipWith (-) xs (x:xs)-      _ -> []---- | Morris @INT@ operator.------ > int [0,1,3,6,10] == [1,2,3,4]-int :: (Integral a) => [a] -> [a]-int = map mod12 . d_dx---- | Interval class.------ > map ic [5,6,7] == [5,6,5]-ic :: (Integral a) => a -> a-ic i =-    let i' = mod12 i-    in if i' <= 6 then i' else 12 - i'---- | Interval class vector.------ > icv [0,1,2,4,7,8] == [3,2,2,3,3,2]-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---- * Set operations.---- | Elements of /p/ not in /q/.------ > [1,2,3] `difference` [1,2] == [3]-difference :: (Eq a) => [a] -> [a] -> [a]-difference p q =-    let f e = e `notElem` q-    in filter f p---- | Pitch classes not in set, ie. 'difference' @[0..11]@.------ > complement [0,2,4,5,7,9,11] == [1,3,6,8,10]-complement :: (Integral a) => [a] -> [a]-complement = difference [0..11]---- | Is /p/ a subset of /q/, ie. is 'intersect' of /p/ and /q/ '==' /p/.------ > is_subset [1,2] [1,2,3] == True-is_subset :: Eq a => [a] -> [a] -> Bool-is_subset p q = p `intersect` q == p---- | Is /p/ a superset of /q/, ie. 'flip' 'is_subset'.------ > is_superset [1,2,3] [1,2] == True-is_superset :: Eq a => [a] -> [a] -> Bool-is_superset = flip is_subset---- * Sequence operations---- | Is /p/ a subsequence of /q/, ie. synonym for 'isInfixOf'.------ > subsequence [1,2] [1,2,3] == True-subsequence :: (Eq a) => [a] -> [a] -> Bool-subsequence = isInfixOf---- | The standard t-matrix of /p/.------ > tmatrix [0,1,3] == [[ 0, 1, 3]--- >                    ,[11, 0, 2]--- >                    ,[ 9,10, 0]]-tmatrix :: (Integral a) => [a] -> [[a]]-tmatrix p = map (`tn` p) (transposeTo 0 (invertSelf p))
− Music/Theory/Prime.hs 
@@ -1,64 +0,0 @@--- | Forte and Rahn prime form operations.-module Music.Theory.Prime (cmp_prime-                          ,forte_cmp,forte_prime-                          ,rahn_cmp,rahn_prime-                          ,encode_prime) where--import Data.Bits-import Data.List-import Music.Theory.PitchClass---- | Prime form rule requiring comparator.-cmp_prime :: (Integral a) => ([a] -> [a] -> Ordering) -> [a] -> [a]-cmp_prime _ [] = []-cmp_prime f p =-    let q = invert 0 p-        r = rotations (pcset p) ++ rotations (pcset q)-    in minimumBy f (map (transposeTo 0) r)---- | Forte comparison function (rightmost first then leftmost outwards).------ > forte_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == LT-forte_cmp :: (Ord t) => [t] -> [t] -> Ordering-forte_cmp [] [] = EQ-forte_cmp p  q  =-    let r = compare (last p) (last q)-    in if r == EQ then compare p q else r---- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'.------ > forte_prime [0,1,3,6,8,9] == [0,1,3,6,8,9]--- > forte_prime [0,1,3,6,8,9] /= rahn_prime [0,1,3,6,8,9]-forte_prime :: (Integral a) => [a] -> [a]-forte_prime = cmp_prime forte_cmp---- | Rahn prime form (comparison is rightmost inwards).------ > rahn_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == GT-rahn_cmp :: Ord a => [a] -> [a] -> Ordering-rahn_cmp p q = compare (reverse p) (reverse q)---- | Rahn prime form, ie. 'cmp_prime' of 'rahn_cmp'.------ > rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9]-rahn_prime :: (Integral a) => [a] -> [a]-rahn_prime = cmp_prime rahn_cmp---- | Binary encoding prime form algorithm, equalivalent to Rahn.------ > encode_prime [0,1,3,6,8,9] == rahn_prime [0,1,3,6,8,9]-encode_prime :: (Integral a, Bits a) => [a] -> [a]-encode_prime s =-    let t = map (`tn` s) [0..11]-        c = t ++ map (invert 0) t-    in decode (minimum (map encode c))---- | Encoder for 'encode_prime'.-encode :: (Integral a) => [a] -> a-encode = sum . map (2 ^)---- | Decoder for 'encode_prime'.-decode :: (Bits a, Integral a) => a -> [a]-decode n =-    let f i = (i, testBit n i)-    in map (fromIntegral . fst) (filter snd (map f [0..11]))
− Music/Theory/Set.hs 
@@ -1,35 +0,0 @@--- | Set operations on lists.-module Music.Theory.Set where--import Control.Monad-import Data.List---- | Remove duplicate elements with 'nub' and then 'sort'.------ > set [3,3,3,2,2,1] == [1,2,3]-set :: (Ord a) => [a] -> [a]-set = sort . nub---- | Powerset, ie. set of all subsets.------ > sort (powerset [1,2]) == [[],[1],[1,2],[2]]-powerset :: [a] -> [[a]]-powerset = filterM (const [True,False])---- | Two element subsets (cf [2] . powerset).------ > dyads [1,2,3] == [(1,2),(1,3),(2,3)]-dyads :: [a] -> [(a,a)]-dyads s =-    case s of-      [] -> []-      x:xs -> [(x,y) | y <- xs] ++ dyads xs---- | Set expansion.------ > se 4 [1,2,3] == [[1,1,2,3],[1,2,2,3],[1,2,3,3]]-se :: (Ord a) => Int -> [a] -> [[a]]-se n xs =-    if length xs == n-    then [xs]-    else nub (concatMap (se n) [sort (y : xs) | y <- xs])
+ Music/Theory/Set/List.hs view
@@ -0,0 +1,72 @@+-- | Set operations on lists.+module Music.Theory.Set.List where++import Control.Monad+import Data.List+import qualified Math.Combinatorics.Multiset as M {- multiset-comb -}++-- | Remove duplicate elements with 'nub' and then 'sort'.+--+-- > set_l [3,3,3,2,2,1] == [1,2,3]+set :: (Ord a) => [a] -> [a]+set = sort . nub++-- | Size of powerset of set of cardinality /n/, ie. @2@ '^' /n/.+--+-- > map n_powerset [6..9] == [64,128,256,512]+n_powerset :: Integral n => n -> n+n_powerset = (^) 2++-- | Powerset, ie. set of all subsets.+--+-- > sort (powerset [1,2]) == [[],[1],[1,2],[2]]+-- > map length (map (\n -> powerset [1..n]) [6..9]) == [64,128,256,512]+powerset :: [a] -> [[a]]+powerset = filterM (const [True,False])++-- | Two element subsets.+--+-- > pairs [1,2,3] == [(1,2),(1,3),(2,3)]+pairs :: [a] -> [(a,a)]+pairs s =+    case s of+      [] -> []+      x:s' -> [(x,y) | y <- s'] ++ pairs s'++-- | Three element subsets.+--+-- > triples [1..4] == [(1,2,3),(1,2,4),(1,3,4),(2,3,4)]+--+-- > let f n = genericLength (triples [1..n]) == nk_combinations n 3+-- > in all f [1..15]+triples :: [a] -> [(a,a,a)]+triples s =+    case s of+      [] -> []+      x:s' -> [(x,y,z) | (y,z) <- pairs s'] ++ triples s'++-- | Set expansion (ie. to multiset of degree /n/).+--+-- > expand_set 4 [1,2,3] == [[1,1,2,3],[1,2,2,3],[1,2,3,3]]+expand_set :: (Ord a) => Int -> [a] -> [[a]]+expand_set n xs =+    if length xs >= n+    then [xs]+    else nub (concatMap (expand_set n) [sort (y : xs) | y <- xs])++-- | All distinct multiset partitions, see 'M.partitions'.+--+-- > partitions "aab" == [["aab"],["a","ab"],["b","aa"],["b","a","a"]]+--+-- > partitions "abc" == [["abc"]+-- >                     ,["bc","a"],["b","ac"],["c","ab"]+-- >                     ,["c","b","a"]]+partitions :: Eq a => [a] -> [[[a]]]+partitions = map (map M.toList . M.toList) . M.partitions . M.fromListEq++-- | Cartesian product of two sets.+--+-- > let r = [('a',1),('a',2),('b',1),('b',2),('c',1),('c',2)]+-- > in cartesian_product "abc" [1,2] == r+cartesian_product :: [a] -> [b] -> [(a,b)]+cartesian_product p q = [(i,j) | i <- p, j <- q]
+ Music/Theory/Set/Set.hs view
@@ -0,0 +1,15 @@+-- | Set operations on 'Set's.+module Music.Theory.Set.Set where++import qualified Data.Set as S {- containers -}+import qualified Music.Theory.Set.List as L++set :: (Ord a) => [a] -> S.Set a+set = S.fromList++-- > powerset (set [1,2])+powerset :: Ord a => S.Set a -> S.Set (S.Set a)+powerset = S.fromList . map S.fromList . L.powerset . S.elems++pairs :: Ord a => S.Set a -> S.Set (a,a)+pairs = set . L.pairs . S.elems
− Music/Theory/Table.hs 
@@ -1,302 +0,0 @@--- | Set class tables and database.-module Music.Theory.Table where--import Data.List-import Data.Maybe-import Music.Theory.Prime---- | Synonym for 'String'.-type SC_Name = String---- | The set-class table (Forte prime forms).-sc_table :: (Integral a) => [(SC_Name,[a])]-sc_table =-    [("0-1",[])-    ,("1-1",[0])-    ,("2-1",[0,1])-    ,("2-2",[0,2])-    ,("2-3",[0,3])-    ,("2-4",[0,4])-    ,("2-5",[0,5])-    ,("2-6",[0,6])-    ,("3-1",[0,1,2])-    ,("3-2",[0,1,3])-    ,("3-3",[0,1,4])-    ,("3-4",[0,1,5])-    ,("3-5",[0,1,6])-    ,("3-6",[0,2,4])-    ,("3-7",[0,2,5])-    ,("3-8",[0,2,6])-    ,("3-9",[0,2,7])-    ,("3-10",[0,3,6])-    ,("3-11",[0,3,7])-    ,("3-12",[0,4,8])-    ,("4-1",[0,1,2,3])-    ,("4-2",[0,1,2,4])-    ,("4-3",[0,1,3,4])-    ,("4-4",[0,1,2,5])-    ,("4-5",[0,1,2,6])-    ,("4-6",[0,1,2,7])-    ,("4-7",[0,1,4,5])-    ,("4-8",[0,1,5,6])-    ,("4-9",[0,1,6,7])-    ,("4-10",[0,2,3,5])-    ,("4-11",[0,1,3,5])-    ,("4-12",[0,2,3,6])-    ,("4-13",[0,1,3,6])-    ,("4-14",[0,2,3,7])-    ,("4-Z15",[0,1,4,6])-    ,("4-16",[0,1,5,7])-    ,("4-17",[0,3,4,7])-    ,("4-18",[0,1,4,7])-    ,("4-19",[0,1,4,8])-    ,("4-20",[0,1,5,8])-    ,("4-21",[0,2,4,6])-    ,("4-22",[0,2,4,7])-    ,("4-23",[0,2,5,7])-    ,("4-24",[0,2,4,8])-    ,("4-25",[0,2,6,8])-    ,("4-26",[0,3,5,8])-    ,("4-27",[0,2,5,8])-    ,("4-28",[0,3,6,9])-    ,("4-Z29",[0,1,3,7])-    ,("5-1",[0,1,2,3,4])-    ,("5-2",[0,1,2,3,5])-    ,("5-3",[0,1,2,4,5])-    ,("5-4",[0,1,2,3,6])-    ,("5-5",[0,1,2,3,7])-    ,("5-6",[0,1,2,5,6])-    ,("5-7",[0,1,2,6,7])-    ,("5-8",[0,2,3,4,6])-    ,("5-9",[0,1,2,4,6])-    ,("5-10",[0,1,3,4,6])-    ,("5-11",[0,2,3,4,7])-    ,("5-Z12",[0,1,3,5,6])-    ,("5-13",[0,1,2,4,8])-    ,("5-14",[0,1,2,5,7])-    ,("5-15",[0,1,2,6,8])-    ,("5-16",[0,1,3,4,7])-    ,("5-Z17",[0,1,3,4,8])-    ,("5-Z18",[0,1,4,5,7])-    ,("5-19",[0,1,3,6,7])-    ,("5-20",[0,1,3,7,8])-    ,("5-21",[0,1,4,5,8])-    ,("5-22",[0,1,4,7,8])-    ,("5-23",[0,2,3,5,7])-    ,("5-24",[0,1,3,5,7])-    ,("5-25",[0,2,3,5,8])-    ,("5-26",[0,2,4,5,8])-    ,("5-27",[0,1,3,5,8])-    ,("5-28",[0,2,3,6,8])-    ,("5-29",[0,1,3,6,8])-    ,("5-30",[0,1,4,6,8])-    ,("5-31",[0,1,3,6,9])-    ,("5-32",[0,1,4,6,9])-    ,("5-33",[0,2,4,6,8])-    ,("5-34",[0,2,4,6,9])-    ,("5-35",[0,2,4,7,9])-    ,("5-Z36",[0,1,2,4,7])-    ,("5-Z37",[0,3,4,5,8])-    ,("5-Z38",[0,1,2,5,8])-    ,("6-1",[0,1,2,3,4,5])-    ,("6-2",[0,1,2,3,4,6])-    ,("6-Z3",[0,1,2,3,5,6])-    ,("6-Z4",[0,1,2,4,5,6])-    ,("6-5",[0,1,2,3,6,7])-    ,("6-Z6",[0,1,2,5,6,7])-    ,("6-7",[0,1,2,6,7,8])-    ,("6-8",[0,2,3,4,5,7])-    ,("6-9",[0,1,2,3,5,7])-    ,("6-Z10",[0,1,3,4,5,7])-    ,("6-Z11",[0,1,2,4,5,7])-    ,("6-Z12",[0,1,2,4,6,7])-    ,("6-Z13",[0,1,3,4,6,7])-    ,("6-14",[0,1,3,4,5,8])-    ,("6-15",[0,1,2,4,5,8])-    ,("6-16",[0,1,4,5,6,8])-    ,("6-Z17",[0,1,2,4,7,8])-    ,("6-18",[0,1,2,5,7,8])-    ,("6-Z19",[0,1,3,4,7,8])-    ,("6-20",[0,1,4,5,8,9])-    ,("6-21",[0,2,3,4,6,8])-    ,("6-22",[0,1,2,4,6,8])-    ,("6-Z23",[0,2,3,5,6,8])-    ,("6-Z24",[0,1,3,4,6,8])-    ,("6-Z25",[0,1,3,5,6,8])-    ,("6-Z26",[0,1,3,5,7,8])-    ,("6-27",[0,1,3,4,6,9])-    ,("6-Z28",[0,1,3,5,6,9])-    ,("6-Z29",[0,1,3,6,8,9])-    ,("6-30",[0,1,3,6,7,9])-    ,("6-31",[0,1,3,5,8,9])-    ,("6-32",[0,2,4,5,7,9])-    ,("6-33",[0,2,3,5,7,9])-    ,("6-34",[0,1,3,5,7,9])-    ,("6-35",[0,2,4,6,8,10])-    ,("6-Z36",[0,1,2,3,4,7])-    ,("6-Z37",[0,1,2,3,4,8])-    ,("6-Z38",[0,1,2,3,7,8])-    ,("6-Z39",[0,2,3,4,5,8])-    ,("6-Z40",[0,1,2,3,5,8])-    ,("6-Z41",[0,1,2,3,6,8])-    ,("6-Z42",[0,1,2,3,6,9])-    ,("6-Z43",[0,1,2,5,6,8])-    ,("6-Z44",[0,1,2,5,6,9])-    ,("6-Z45",[0,2,3,4,6,9])-    ,("6-Z46",[0,1,2,4,6,9])-    ,("6-Z47",[0,1,2,4,7,9])-    ,("6-Z48",[0,1,2,5,7,9])-    ,("6-Z49",[0,1,3,4,7,9])-    ,("6-Z50",[0,1,4,6,7,9])-    ,("7-1",[0,1,2,3,4,5,6])-    ,("7-2",[0,1,2,3,4,5,7])-    ,("7-3",[0,1,2,3,4,5,8])-    ,("7-4",[0,1,2,3,4,6,7])-    ,("7-5",[0,1,2,3,5,6,7])-    ,("7-6",[0,1,2,3,4,7,8])-    ,("7-7",[0,1,2,3,6,7,8])-    ,("7-8",[0,2,3,4,5,6,8])-    ,("7-9",[0,1,2,3,4,6,8])-    ,("7-10",[0,1,2,3,4,6,9])-    ,("7-11",[0,1,3,4,5,6,8])-    ,("7-Z12",[0,1,2,3,4,7,9])-    ,("7-13",[0,1,2,4,5,6,8])-    ,("7-14",[0,1,2,3,5,7,8])-    ,("7-15",[0,1,2,4,6,7,8])-    ,("7-16",[0,1,2,3,5,6,9])-    ,("7-Z17",[0,1,2,4,5,6,9])-    ,("7-Z18",[0,1,2,3,5,8,9])-    ,("7-19",[0,1,2,3,6,7,9])-    ,("7-20",[0,1,2,4,7,8,9])-    ,("7-21",[0,1,2,4,5,8,9])-    ,("7-22",[0,1,2,5,6,8,9])-    ,("7-23",[0,2,3,4,5,7,9])-    ,("7-24",[0,1,2,3,5,7,9])-    ,("7-25",[0,2,3,4,6,7,9])-    ,("7-26",[0,1,3,4,5,7,9])-    ,("7-27",[0,1,2,4,5,7,9])-    ,("7-28",[0,1,3,5,6,7,9])-    ,("7-29",[0,1,2,4,6,7,9])-    ,("7-30",[0,1,2,4,6,8,9])-    ,("7-31",[0,1,3,4,6,7,9])-    ,("7-32",[0,1,3,4,6,8,9])-    ,("7-33",[0,1,2,4,6,8,10])-    ,("7-34",[0,1,3,4,6,8,10])-    ,("7-35",[0,1,3,5,6,8,10])-    ,("7-Z36",[0,1,2,3,5,6,8])-    ,("7-Z37",[0,1,3,4,5,7,8])-    ,("7-Z38",[0,1,2,4,5,7,8])-    ,("8-1",[0,1,2,3,4,5,6,7])-    ,("8-2",[0,1,2,3,4,5,6,8])-    ,("8-3",[0,1,2,3,4,5,6,9])-    ,("8-4",[0,1,2,3,4,5,7,8])-    ,("8-5",[0,1,2,3,4,6,7,8])-    ,("8-6",[0,1,2,3,5,6,7,8])-    ,("8-7",[0,1,2,3,4,5,8,9])-    ,("8-8",[0,1,2,3,4,7,8,9])-    ,("8-9",[0,1,2,3,6,7,8,9])-    ,("8-10",[0,2,3,4,5,6,7,9])-    ,("8-11",[0,1,2,3,4,5,7,9])-    ,("8-12",[0,1,3,4,5,6,7,9])-    ,("8-13",[0,1,2,3,4,6,7,9])-    ,("8-14",[0,1,2,4,5,6,7,9])-    ,("8-Z15",[0,1,2,3,4,6,8,9])-    ,("8-16",[0,1,2,3,5,7,8,9])-    ,("8-17",[0,1,3,4,5,6,8,9])-    ,("8-18",[0,1,2,3,5,6,8,9])-    ,("8-19",[0,1,2,4,5,6,8,9])-    ,("8-20",[0,1,2,4,5,7,8,9])-    ,("8-21",[0,1,2,3,4,6,8,10])-    ,("8-22",[0,1,2,3,5,6,8,10])-    ,("8-23",[0,1,2,3,5,7,8,10])-    ,("8-24",[0,1,2,4,5,6,8,10])-    ,("8-25",[0,1,2,4,6,7,8,10])-    ,("8-26",[0,1,2,4,5,7,9,10])-    ,("8-27",[0,1,2,4,5,7,8,10])-    ,("8-28",[0,1,3,4,6,7,9,10])-    ,("8-Z29",[0,1,2,3,5,6,7,9])-    ,("9-1",[0,1,2,3,4,5,6,7,8])-    ,("9-2",[0,1,2,3,4,5,6,7,9])-    ,("9-3",[0,1,2,3,4,5,6,8,9])-    ,("9-4",[0,1,2,3,4,5,7,8,9])-    ,("9-5",[0,1,2,3,4,6,7,8,9])-    ,("9-6",[0,1,2,3,4,5,6,8,10])-    ,("9-7",[0,1,2,3,4,5,7,8,10])-    ,("9-8",[0,1,2,3,4,6,7,8,10])-    ,("9-9",[0,1,2,3,5,6,7,8,10])-    ,("9-10",[0,1,2,3,4,6,7,9,10])-    ,("9-11",[0,1,2,3,5,6,7,9,10])-    ,("9-12",[0,1,2,4,5,6,8,9,10])-    ,("10-1",[0,1,2,3,4,5,6,7,8,9])-    ,("10-2",[0,1,2,3,4,5,6,7,8,10])-    ,("10-3",[0,1,2,3,4,5,6,7,9,10])-    ,("10-4",[0,1,2,3,4,5,6,8,9,10])-    ,("10-5",[0,1,2,3,4,5,7,8,9,10])-    ,("10-6",[0,1,2,3,4,6,7,8,9,10])-    ,("11-1",[0,1,2,3,4,5,6,7,8,9,10])-    ,("12-1",[0,1,2,3,4,5,6,7,8,9,10,11])]---- | Lookup a set-class name.  The input set is subject to--- 'forte_prime' before lookup.------ > sc_name [0,1,4,6,7,8] == "6-Z17"-sc_name :: (Integral a) => [a] -> SC_Name-sc_name p =-    let n = find (\(_,q) -> forte_prime p == q) sc_table-    in fst (fromJust n)---- | Lookup a set-class given a set-class name.------ > sc "6-Z17" == [0,1,2,4,7,8]-sc :: (Integral a) => SC_Name -> [a]-sc n = snd (fromJust (find (\(m,_) -> n == m) sc_table))---- | List of set classes.-scs :: (Integral a) => [[a]]-scs = map snd sc_table---- | Set class database with descriptors for historically and--- theoretically significant set classes.------ > lookup "6-Z17" sc_db == Just "All-Trichord Hexachord"--- > lookup "7-35" sc_db == Just "diatonic collection (d)"-sc_db :: [(SC_Name,String)]-sc_db =-    [ ("4-Z15","All-Interval Tetrachord (see also 4-Z29)")-    ,("4-Z29","All-Interval Tetrachord (see also 4-Z15)")-    ,("6-Z17","All-Trichord Hexachord")-    ,("8-Z15","All-Tetrachord Octochord (see also 8-Z29)")-    ,("8-Z29","All-Tetrachord Octochord (see also 8-Z15)")-    ,("6-1","A-Type All-Combinatorial Hexachord")-    ,("6-8","B-Type All-Combinatorial Hexachord")-    ,("6-32","C-Type All-Combinatorial Hexachord")-    ,("6-7","D-Type All-Combinatorial Hexachord")-    ,("6-20","E-Type All-Combinatorial Hexachord")-    ,("6-35","F-Type All-Combinatorial Hexachord")-    ,("7-35","diatonic collection (d)")-    ,("7-34","ascending melodic minor collection")-    ,("8-28","octotonic collection (Messiaen Mode II)")-    ,("6-35","wholetone collection")-    ,("3-10","diminished triad")-    ,("3-11","major/minor triad")-    ,("3-12","augmented triad")-    ,("4-19","minor major-seventh chord")-    ,("4-20","major-seventh chord")-    ,("4-25","french augmented sixth chord")-    ,("4-28","dimished-seventh chord")-    ,("4-26","minor-seventh chord")-    ,("4-27","half-dimished seventh(P)/dominant-seventh(I) chord")-    ,("6-30","Petrushka Chord {0476a1},3-11 at T6")-    ,("6-34","Mystic Chord {06a492}")-    ,("6-Z44","Schoenberg Signature Set,3-3 at T5 or T7")-    ,("6-Z19","complement of 6-Z44,3-11 at T1 or TB")-    ,("9-12","Messiaen Mode III (nontonic collection)")-    ,("8-9","Messian Mode IV")-    ,("7-31","The only seven-element subset of 8-28. ")-    ,("5-31","The only five-element superset of 4-28.")-    ,("5-33","The only five-element subset of 6-35.")-    ,("7-33","The only seven-element superset of 6-35.")-    ,("5-21","The only five-element subset of 6-20.")-    ,("7-21","The only seven-element superset of 6-20.")-    ,("5-25","The only five-element subset of both 7-35 and 8-28.")-    ,("6-14","Any non-intersecting union of 3-6 and 3-12.") ]
+ Music/Theory/Tempo_Marking.hs view
@@ -0,0 +1,41 @@+-- | Common music notation tempo indications.+module Music.Theory.Tempo_Marking where++import Music.Theory.Duration+import Music.Theory.Duration.RQ+import Music.Theory.Time_Signature++-- | A tempo marking is in terms of a common music notation 'Duration'.+type Tempo_Marking = (Duration,Rational)++-- | Duration of a RQ value, in seconds, given indicated tempo.+--+-- > rq_to_seconds (quarter_note,90) 1 == 60/90+rq_to_seconds :: Tempo_Marking -> RQ -> Rational+rq_to_seconds (d,n) x =+    let d' = duration_to_rq d+        s = 60 / n+    in (x * s) / d'++-- | The duration, in seconds, of a pulse at the indicated time+--   signature and tempo marking.+--+-- > import Music.Theory.Duration.Name+-- > pulse_duration (6,8) (quarter_note,60) == 1/2+pulse_duration :: Time_Signature -> Tempo_Marking -> Rational+pulse_duration t (x,i) =+    let j = recip (ts_duration_pulses t x)+        s = 60 / i+    in j * s++-- | The duration, in seconds, of a measure at the indicated time+--   signaure and tempo marking.+--+-- > measure_duration (3,4) (quarter_note,90) == 2+-- > measure_duration (6,8) (quarter_note,120) == 3/2+measure_duration :: Time_Signature -> Tempo_Marking -> Rational+measure_duration (n,d) t = pulse_duration (n,d) t * fromIntegral n++-- | 'Fractional' variant of 'measure_duration'.+measure_duration_f :: Fractional c => Time_Signature -> Tempo_Marking -> c+measure_duration_f ts = fromRational . measure_duration ts
+ Music/Theory/Tiling/Canon.hs view
@@ -0,0 +1,209 @@+module Music.Theory.Tiling.Canon where++import Control.Monad.Logic {- logict -}+import Data.Function+import Data.List+import Data.List.Split {- split -}+import Text.Printf++-- | Sequence.+type S = [Int]++-- | Canon of /(period,sequence,multipliers,displacements)/.+type R = (Int,S,[Int],[Int])++-- | Voice.+type V = [Int]++-- | Tiling (sequence)+type T = [[Int]]++-- | Cycle at /period/.+--+-- > take 9 (p_cycle 18 [0,2,5]) == [0,2,5,18,20,23,36,38,41]+p_cycle :: Int -> [Int] -> [Int]+p_cycle n s = s ++ p_cycle n (map (+ n) s)++-- | Element of /(sequence,multiplier,displacement)/.+type E = (S,Int,Int)++-- | Resolve sequence from 'E'.+--+-- > e_to_seq ([0,2,5],2,1) == [1,5,11]+-- > e_to_seq ([0,1],3,4) == [4,7]+-- > e_to_seq ([0],1,2) == [2]+e_to_seq :: E -> [Int]+e_to_seq (s,m,o) = map ((+ o) . (* m)) s++-- | Infer 'E' from sequence.+--+-- > e_from_seq [1,5,11] == ([0,2,5],2,1)+-- > e_from_seq [4,7] == ([0,1],3,4)+-- > e_from_seq [2] == ([0],1,2)+e_from_seq :: [Int] -> E+e_from_seq p =+    let i:_ = p+        q = map (+ negate i) p+        _:r = q+        n = if null r then 1 else foldl1 gcd r+    in (map (`div` n) q,n,i)++-- | Set of 'V' from 'R'.+r_voices :: R -> [V]+r_voices (p,s,m,o) =+    let f i j = p_cycle p (e_to_seq (s,i,j))+    in zipWith f m o++-- | 'concatMap' of 'r_voices'.+rr_voices :: [R] -> [V]+rr_voices = concatMap r_voices++-- | Retrograde of 'T', the result 'T' is sorted.+--+-- > let r = [[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]+-- > in t_retrograde [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r+t_retrograde :: T -> T+t_retrograde t =+    let n = maximum (concat t)+    in sort (map (reverse . map (n -)) t)++-- | The normal form of 'T' is the 'min' of /t/ and it's 't_retrograde'.+--+-- > let r = [[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]+-- > in t_normal [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r+t_normal :: T -> T+t_normal t = min t (t_retrograde t)++-- | Derive set of 'R' from 'T'.+--+-- > let {r = [(21,[0,1,2],[10,8,2,4,7,5,1],[0,1,2,3,5,8,14])]+-- >     ;t = [[0,10,20],[1,9,17],[2,4,6],[3,7,11],[5,12,19],[8,13,18],[14,15,16]]}+-- > in r_from_t t == r+r_from_t :: T -> [R]+r_from_t t =+    let e = map e_from_seq t+        n = maximum (concat t) + 1+        t3_1 (i,_,_) = i+        f z = let (s:_,m,o) = unzip3 z in (n,s,m,o)+    in map f (groupBy ((==) `on` t3_1) e)++-- * Construction++-- | 'msum' '.' 'map' 'return'.+--+-- > observeAll (fromList [1..7]) == [1..7]+fromList :: MonadPlus m => [a] -> m a+fromList = msum . map return++-- | Search for /perfect/ tilings of the sequence 'S' using+-- multipliers from /m/ to degree /n/ with /k/ parts.+perfect_tilings_m :: MonadPlus m => [S] -> [Int] -> Int -> Int -> m T+perfect_tilings_m s m n k =+    let rec p q =+            if length q == k+            then return (sort q)+            else do m' <- fromList m+                    guard (m' `notElem` p)+                    s' <- fromList s+                    let i = n - (maximum s' * m') - 1+                    o <- fromList [0..i]+                    let s'' = e_to_seq (s',m',o)+                        q' = concat q+                    guard (all (`notElem` q') s'')+                    rec (m':p) (s'':q)+    in rec [] []++-- | 't_normal' of 'observeAll' of 'perfect_tilings_m'.+--+-- > perfect_tilings [[0,1]] [1..3] 6 3 == []+--+-- > let r = [[[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]]+-- > in perfect_tilings [[0,1,2]] [1,2,4,5,7] 15 5 == r+--+-- > length (perfect_tilings [[0,1,2]] [1..12] 15 5) == 1+--+-- > let r = [[[0,1],[2,5],[3,7],[4,6]]+-- >         ,[[0,1],[2,6],[3,5],[4,7]]+-- >         ,[[0,2],[1,4],[3,7],[5,6]]]+-- > in perfect_tilings [[0,1]] [1..4] 8 4 == r+--+-- > let r = [[[0,1],[2,5],[3,7],[4,9],[6,8]]+-- >         ,[[0,1],[2,7],[3,5],[4,8],[6,9]]+-- >         ,[[0,2],[1,4],[3,8],[5,9],[6,7]]+-- >         ,[[0,2],[1,5],[3,6],[4,9],[7,8]]+-- >         ,[[0,3],[1,6],[2,4],[5,9],[7,8]]]+-- > in perfect_tilings [[0,1]] [1..5] 10 5 == r+--+-- Johnson 2004, p.2+--+-- > let r = [[0,6,12],[1,8,15],[2,11,20],[3,5,7],[4,9,14],[10,13,16],[17,18,19]]+-- > in perfect_tilings [[0,1,2]] [1,2,3,5,6,7,9] 21 7 == [r]+--+-- > let r = [[0,10,20],[1,9,17],[2,4,6],[3,7,11],[5,12,19],[8,13,18],[14,15,16]]+-- > in perfect_tilings [[0,1,2]] [1,2,4,5,7,8,10] 21 7 == [t_retrograde r]+perfect_tilings :: [S] -> [Int] -> Int -> Int -> [T]+perfect_tilings s m n =+    nub . sort . map t_normal . observeAll . perfect_tilings_m s m n++-- * Display++-- | Variant of 'elem' for ordered sequences, which can therefore+-- return 'False' when searching infinite sequences.+--+-- > 5 `elemOrd` [0,2..] == False && 10 `elemOrd` [0,2..] == True+elemOrd :: Ord a => a -> [a] -> Bool+elemOrd i p =+    case p of+      [] -> False+      j:p' -> case compare j i of+                LT -> elemOrd i p'+                EQ -> True+                GT -> False++-- | A @.*@ diagram of /n/ places of 'V'.+--+-- > v_dot_star 18 [0,2..] == "*.*.*.*.*.*.*.*.*."+v_dot_star :: Int -> V -> String+v_dot_star n v =+    let f p i = if i `elemOrd` p then '*' else '.'+    in map (f v) [0..n-1]++-- | A white space and index diagram of /n/ places of 'V'.+--+-- >>> mapM_ (putStrLn . v_space_ix 9) [[0,2..],[1,3..]]+-- >+-- >  0   2   4   6   8+-- >    1   3   5   7+v_space_ix :: Int -> V -> String+v_space_ix n v =+    let w = length (show n)+        nil = replicate w ' '+        f p i = if i `elemOrd` p then printf "%*d" w i else nil+    in unwords (map (f v) [0..n-1])++-- | Insert @|@ every /n/ places.+--+-- > with_bars 6 (v_dot_star 18 [0,2..]) == "*.*.*.|*.*.*.|*.*.*."+with_bars :: Int -> String -> String+with_bars m = intercalate "|" . chunksOf m++-- | Variant with measure length /m/ and number of measures /n/.+--+-- > v_dot_star_m 6 3 [0,2..] == "*.*.*.|*.*.*.|*.*.*."+v_dot_star_m :: Int -> Int -> V -> String+v_dot_star_m m n = with_bars m . v_dot_star (n * m)++-- | Print @.*@ diagram.+v_print :: Int -> [V] -> IO ()+v_print n = putStrLn . unlines . ("" :) . map (v_dot_star n)++-- | Variant to print @|@ at measures.+v_print_m :: Int -> Int -> [V] -> IO ()+v_print_m m n = putStrLn . unlines . ("" :) . map (v_dot_star_m m n)++-- | Variant that discards first /k/ measures.+v_print_m_from :: Int -> Int -> Int -> [V] -> IO ()+v_print_m_from k m n =+    let k' = k * m+        f = with_bars m . drop k' . v_dot_star (n * m + k')+    in putStrLn . unlines . ("" :) . map f
+ Music/Theory/Tiling/Johnson_2004.hs view
@@ -0,0 +1,84 @@+-- | Tom Johnson. \"Perfect Rhythmic Tilings\".+-- Technical report, IRCAM, 24 January 2004. MaMuX Lecture.+module Music.Theory.Tiling.Johnson_2004 where++import Music.Theory.Tiling.Canon++-- | @{0,1,2}@ order 5, p.1+--+-- >>> v_print 15 (r_voices p1)+-- >+-- > ..***..........+-- > ........*.*.*..+-- > .....*...*...*.+-- > .*....*....*...+-- > *......*......*+p1 :: R+p1 = (15,[0,1,2],[1,2,4,5,7],[2,8,5,1,0])++-- | @{0,1,2}@ order 7, p.2+--+-- >>> v_print 21 (r_voices p2)+-- >+-- > ..............***....+-- > ..*.*.*..............+-- > ...*...*...*.........+-- > ........*....*....*..+-- > .....*......*......*.+-- > .*.......*.......*...+-- > *.........*.........*+p2 :: R+p2 = (21,[0,1,2],[1,2,4,5,7,8,10],[14,2,3,8,5,1,0])++-- | @{0,1}@ order 4, p.3+--+-- >>> v_print 8 (r_voices p3)+-- >+-- > *...*...+-- > .**.....+-- > ...*..*.+-- > .....*.*+p3 :: R+p3 = (8,[0,1],[4,1,3,2],[0,1,3,5])++-- | @{0,1}@ order 5, p.4+--+-- >>> mapM_ (v_print 10 . r_voices) p4+-- >+-- > *...*.....+-- > .**.......+-- > ...*....*.+-- > .....*.*..+-- > ......*..*+-- >+-- > *....*....+-- > .**.......+-- > ...*..*...+-- > ....*...*.+-- > .......*.*+-- >+-- > *...*.....+-- > .*....*...+-- > ..**......+-- > .....*..*.+-- > .......*.*+p4 :: [R]+p4 = [(10,[0,1],[4,1,5,2,3],[0,1,3,5,6])+     ,(10,[0,1],[5,1,3,4,2],[0,1,3,4,7])+     ,(10,[0,1],[4,5,1,3,2],[0,1,2,5,7])]++-- | Open @{1,2,3}@ order 5, p.4+--+-- >>> v_print 18 (r_voices p4_b)+-- >+-- > ...***............+-- > ........*.*.*.....+-- > .........*...*...*+-- > .*....*....*......+-- > *......*......*...+p4_b :: R+p4_b = (21,[0,1,2],[1,2,4,5,7],[3,8,9,1,0])++-- Local Variables:+-- truncate-lines:t+-- End:
+ Music/Theory/Tiling/Johnson_2009.hs view
@@ -0,0 +1,82 @@+-- | Tom Johnson. \"Tiling in my Music\".+-- /The Experimental Music Yearbook/, 1, 2009.+module Music.Theory.Tiling.Johnson_2009 where++import Music.Theory.Tiling.Canon++-- | Tilework for Clarinet, p.3+--+-- >>> v_print 36 (rr_voices p3)+-- >+-- > *.*..*............*.*..*............+-- > .*.*..*............*.*..*...........+-- > ........*.*..*............*.*..*....+-- > ....*..*.*............*..*.*........+-- > ...........*..*.*............*..*.*.+-- > ............*..*.*............*..*.*+p3 :: [R]+p3 = [(18,[0,2,5],[1,1,1],[0,1,8])+     ,(18,[0,3,5],[1,1,1],[4,11,12])]++-- | Tilework for String Quartet, p.5+--+-- >>> mapM_ (v_print 24 . r_voices) p5+-- >+-- > ******......******......+-- > ......******......******+-- >+-- > *.****.*....*.****.*....+-- > ......*.****.*....*.****+-- >+-- > **.***..*...**.***..*...+-- > ......**.***..*...**.***+-- >+-- > *..***.**...*..***.**...+-- > ......*..***.**...*..***+p5 :: [R]+p5 = [(12,[0..5],[1,1],[0,6])+     ,(12,[0,2,3,4,5,7],[1,1],[0,6])+     ,(12,[0,1,3,4,5,8],[1,1],[0,6])+     ,(12,[0,3,4,5,7,8],[1,1],[0,6])]++-- | Extra Perfect (p.7)+--+-- >>> v_print_m_from 18 6 6 (r_voices p7)+-- >+-- > **.*..|......|......|......|......|......+-- > ......|.*.*..|.*....|......|......|......+-- > ......|......|......|......|.*..*.|....*.+-- > ......|......|...*..|.*....|...*..|......+-- > ......|......|....*.|...*..|......|.*....+-- > ......|*.....|*.....|......|*.....|......+-- > ....*.|......|......|*.....|......|...*..+-- > ......|......|......|....*.|......|*.....+p7 :: R+p7 = (36,[0,1,3],[1,2,3,4,5,6,7,8],[0,7,25,51,52,78,105,130])++-- | Tilework for Log Drums (2005), p.10+--+-- >>> v_print 18 (r_voices p10)+-- >+-- > *.*.*.............+-- > .*...*...*........+-- > ...*...*...*......+-- > ......*...*...*...+-- > ........*...*...*.+-- > .............*.*.*+p10 :: R+p10 = (18,[0,1,2],[2,4,4,4,4,2],[0,1,3,6,8,13])++-- | Self-Similar Melodies (1996), p.11+--+-- >>> v_print_m 20 5 (r_voices p11)+-- >+-- > *.....*.....*..*..*.|....*.....*.....*...|..*..*..*.....*.....|*.....*.....*..*..*.|....*.....*.....*...+-- > ....................|*.....*.....*..*..*.|....*.....*.....*...|..*..*..*.....*.....|*.....*.....*..*..*.+-- > ....................|....................|*.....*.....*..*..*.|....*.....*.....*...|..*..*..*.....*.....+p11 :: R+p11 = (30,[0,6,12,15,18,24,30,36,42,45,48,54],[1,1,1],[0,20,40])++-- Local Variables:+-- truncate-lines:t+-- End:
+ Music/Theory/Time_Signature.hs view
@@ -0,0 +1,102 @@+-- | Time Signatures.+module Music.Theory.Time_Signature where++import Data.Ratio+import Music.Theory.Duration+import Music.Theory.Duration.Name+import Music.Theory.Duration.RQ++-- | A Time Signature is a /(numerator,denominator)/ pair.+type Time_Signature = (Integer,Integer)++-- | Tied, non-multiplied durations to fill a whole measure.+--+-- > ts_whole_note (3,8) == [dotted_quarter_note]+-- > ts_whole_note (2,2) == [whole_note]+ts_whole_note :: Time_Signature -> [Duration]+ts_whole_note t =+    case t of+      (1,8) -> [eighth_note]+      (2,16) -> [eighth_note]+      (3,16) -> [dotted_eighth_note]+      (1,4) -> [quarter_note]+      (2,8) -> [quarter_note]+      (4,16) -> [quarter_note]+      (5,16) -> [quarter_note,sixteenth_note]+      (3,8) -> [dotted_quarter_note]+      (6,16) -> [dotted_quarter_note]+      (7,16) -> [quarter_note,dotted_eighth_note]+      (1,2) -> [half_note]+      (2,4) -> [half_note]+      (4,8) -> [half_note]+      (5,8) -> [half_note,eighth_note]+      (3,4) -> [dotted_half_note]+      (6,8) -> [dotted_half_note]+      (1,1) -> [whole_note]+      (2,2) -> [whole_note]+      (4,4) -> [whole_note]+      (5,4) -> [whole_note,quarter_note]+      (3,2) -> [dotted_whole_note]+      (6,4) -> [dotted_whole_note]+      (7,4) -> [whole_note,dotted_half_note]+      (2,1) -> [breve]+      (4,2) -> [breve]+      (3,1) -> [dotted_breve]+      (6,2) -> [dotted_breve]+      _ -> error ("ts_whole_note: " ++ show t)++-- | Duration of measure in 'RQ'.+--+-- > map ts_whole_note_rq [(3,8),(2,2)] == [3/2,4]+ts_whole_note_rq :: Time_Signature -> RQ+ts_whole_note_rq = sum . map duration_to_rq . ts_whole_note++-- | Duration, in 'RQ', of a measure of indicated 'Time_Signature'.+--+-- > map ts_rq [(3,4),(5,8)] == [3,5/2]+ts_rq :: Time_Signature -> RQ+ts_rq (n,d) = (4 * n) % d++-- | Uniform division of time signature.+--+-- > ts_divisions (3,4) == [1,1,1]+-- > ts_divisions (3,8) == [1/2,1/2,1/2]+-- > ts_divisions (2,2) == [2,2]+-- > ts_divisions (1,1) == [4]+ts_divisions :: Time_Signature -> [RQ]+ts_divisions (i,j) =+    let k = fromIntegral i+    in replicate k (recip (j % 4))++-- | Convert a duration to a pulse count in relation to the indicated+--   time signature.+--+-- > ts_duration_pulses (3,8) quarter_note == 2+ts_duration_pulses :: Time_Signature -> Duration -> Rational+ts_duration_pulses (_, b) (Duration dv dt ml) =+    let n = b % dv+    in rq_apply_dots n dt * ml++-- | Rewrite time signature to indicated denominator.+--+-- > ts_rewrite 8 (3,4) == (6,8)+ts_rewrite :: Integer -> Time_Signature -> Time_Signature+ts_rewrite d' =+    let dv i j = let (x,y) = i `divMod` j+                 in if y == 0 then x else error "ts_rewrite"+        go (n,d) = case compare d d' of+                     EQ -> (n,d)+                     GT -> go (n `dv` 2, d `dv` 2)+                     LT -> go (n * 2, d * 2)+    in go++-- | Sum time signatures.+--+-- > ts_sum [(3,16),(1,2)] == (11,16)+ts_sum :: [Time_Signature] -> Time_Signature+ts_sum t =+    let i = maximum (map snd t)+        t' = map (ts_rewrite i) t+        j = sum (map fst t')+    in (j,i)+
Music/Theory/Tuning.hs view
@@ -4,48 +4,198 @@ import Data.List import Data.Ratio +-- * Either/Maybe++-- | Maybe 'Left' of 'Either'.+fromLeft :: Either a b -> Maybe a+fromLeft e =+    case e of+      Left x -> Just x+      _ -> Nothing++-- | Maybe 'Right' of 'Either'.+fromRight :: Either a b -> Maybe b+fromRight e =+    case e of+      Right x -> Just x+      _ -> Nothing++-- * Types+ -- | An approximation of a ratio. type Approximate_Ratio = Double  -- | A real valued division of a tone into one hundred parts. type Cents = Double --- | Harmonic series to /n/th harmonic (folded).+-- | A tuning specified 'Either' as a sequence of exact ratios, or as+-- a sequence of possibly inexact 'Cents'.+data Tuning = Tuning {ratios_or_cents :: Either [Rational] [Cents]+                     ,octave_ratio :: Rational}+              deriving (Eq,Show)++-- | Divisions of octave. ----- > harmonic_series_folded 3 == [1/2,2/3,1]-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))+-- > divisions ditone == 12+divisions :: Tuning -> Int+divisions = either length length . ratios_or_cents --- | Harmonic series to /n/th harmonic (folded, cents).+-- | 'Maybe' exact ratios of 'Tuning'.+ratios :: Tuning -> Maybe [Rational]+ratios = fromLeft . ratios_or_cents++-- | Possibly inexact 'Cents' of tuning.+cents :: Tuning -> [Cents]+cents = either (map to_cents_r) id . ratios_or_cents++-- | 'map' 'round' '.' 'cents'.+cents_i :: Integral i => Tuning -> [i]+cents_i = map round . cents++-- | Convert from cents invterval to frequency ratio. ----- > map round (harmonic_series_folded_c 3) == [-1200,-702,0]-harmonic_series_folded_c :: Integer -> [Cents]-harmonic_series_folded_c =-    let f = to_cents . approximate_ratio-    in map f . harmonic_series_folded+-- > map cents_to_ratio [0,701.9550008653874,1200] == [1,3/2,2]+cents_to_ratio :: Floating a => a -> a+cents_to_ratio n = 2 ** (n / 1200) --- | Pythagorean tuning+-- | Convert from frequency ratio to cents interval.+--+-- > map ratio_to_cents [1,4/3,2] == [0.0,498.04499913461245,1200.0]+ratio_to_cents :: Floating a => a -> a+ratio_to_cents n = logBase 2 n * 1200++-- | Possibly inexact 'Approximate_Ratio's of tuning.+approximate_ratios :: Tuning -> [Approximate_Ratio]+approximate_ratios =+    either (map approximate_ratio) (map cents_to_ratio) .+    ratios_or_cents++-- | 'Maybe' exact ratios reconstructued from possibly inexact 'Cents'+-- of 'Tuning'.+--+-- > let r = [1,17/16,9/8,13/11,5/4,4/3,7/5,3/2,11/7,5/3,16/9,15/8]+-- > in reconstructed_ratios 1e-2 werckmeister_iii == Just r+reconstructed_ratios :: Double -> Tuning -> Maybe [Rational]+reconstructed_ratios epsilon =+    fmap (map (reconstructed_ratio epsilon)) .+    fromRight .+    ratios_or_cents++-- | Convert from an 'Approximate_Ratio' to 'Cents'.+--+-- > round (to_cents (3/2)) == 702+to_cents :: Approximate_Ratio -> Cents+to_cents x = 1200 * logBase 2 x++-- | Convert from 'Rational' to 'Approximate_Ratio', ie. 'fromRational'.+approximate_ratio :: Rational -> Approximate_Ratio+approximate_ratio = fromRational++-- | 'to_cents' '.' 'approximate_ratio'.+to_cents_r :: Rational -> Cents+to_cents_r = to_cents . approximate_ratio++-- | Construct an exact 'Rational' that approximates 'Cents' to within+-- /epsilon/.+--+-- > map (reconstructed_ratio 1e-5) [0,700,1200] == [1,442/295,2]+--+-- > to_cents_r (442/295) == 699.9976981706735+reconstructed_ratio :: Double -> Cents -> Rational+reconstructed_ratio epsilon c = approxRational (cents_to_ratio c) epsilon++-- | Frequency /n/ cents from /f/.+--+-- > map (cps_shift_cents 440) [-100,100] == map octpc_to_cps [(4,8),(4,10)]+cps_shift_cents :: Floating a => a -> a -> a+cps_shift_cents f = (* f) . cents_to_ratio++-- | Interval in /cents/ from /p/ to /q/, ie. 'ratio_to_cents' of /p/+-- '/' /q/.+--+-- > cps_difference_cents 440 (octpc_to_cps (5,2)) == 500+--+-- > let abs_dif i j = abs (i - j)+-- > in cps_difference_cents 440 (fmidi_to_cps 69.1) `abs_dif` 10 < 1e9+cps_difference_cents :: Floating a => a -> a -> a+cps_difference_cents p q = ratio_to_cents (q / p)++-- * Commas++-- | The Syntonic comma.+--+-- > syntonic_comma == 81/80+syntonic_comma :: Rational+syntonic_comma = 81 % 80++-- | The Pythagorean comma.+--+-- > pythagorean_comma == 3^12 / 2^19+pythagorean_comma :: Rational+pythagorean_comma = 531441 / 524288++-- | Mercators comma.+--+-- > mercators_comma == 3^53 / 2^84+mercators_comma :: Rational+mercators_comma = 19383245667680019896796723 / 19342813113834066795298816++-- | Calculate /n/th root of /x/.+--+-- > 12 `nth_root` 2  == twelve_tone_equal_temperament_comma+nth_root :: (Floating a,Eq 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))++-- | 12-tone equal temperament comma (ie. 12th root of 2).+--+-- > twelve_tone_equal_temperament_comma == 1.0594630943592953+twelve_tone_equal_temperament_comma :: (Floating a,Eq a) => a+twelve_tone_equal_temperament_comma = 12 `nth_root` 2++-- * 12-tone tunings++-- > let c = [0,114,204,294,408,498,612,702,816,906,996,1110]+-- > in map (round.to_cents_r) ditone_r == c+ditone_r :: [Rational]+ditone_r =+    [1,2187/2048 {- 256/243 -}+    ,9/8,32/27+    ,81/64+    ,4/3,729/512+    ,3/2,6561/4096 {- 128/81 -}+    ,27/16,16/9+    ,243/128]++-- | Ditone/pythagorean tuning,+-- see <http://www.billalves.com/porgitaro/ditonesettuning.html>+--+-- > cents_i ditone == [0,114,204,294,408,498,612,702,816,906,996,1110]+ditone :: Tuning+ditone = Tuning (Left ditone_r) 2++-- > let c = [0,90,204,294,408,498,612,702,792,906,996,1110]+-- > in map (round.to_cents_r) pythagorean_r == c 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]+    [1,256/243 {- 2187/2048 -}+    ,9/8,32/27+    ,81/64+    ,4/3,729/512+    ,3/2,128/81 {- 6561/4096 -}+    ,27/16,16/9+    ,243/128] --- | Pythagorean tuning (cents)-pythagorean_c :: [Cents]-pythagorean_c = map (to_cents.approximate_ratio) pythagorean_r+-- | Pythagorean tuning.+--+-- > cents_i pythagorean == [0,90,204,294,408,498,612,702,792,906,996,1110]+pythagorean :: Tuning+pythagorean = Tuning (Left pythagorean_r) 2 --- | Werckmeister III, Andreas Werckmeister (1645-1706)+-- > let c = [0,90,192,294,390,498,588,696,792,888,996,1092]+-- > in map (round.to_cents) werckmeister_iii_ar == c werckmeister_iii_ar :: [Approximate_Ratio] werckmeister_iii_ar =     let c0 = 2 ** (1/2)@@ -59,11 +209,17 @@        ,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 III, Andreas Werckmeister (1645-1706)+--+-- > cents_i werckmeister_iii == [0,90,192,294,390,498,588,696,792,888,996,1092]+werckmeister_iii :: Tuning+werckmeister_iii = Tuning (Right werckmeister_iii_c) 2++-- > let c = [0,82,196,294,392,498,588,694,784,890,1004,1086]+-- > in map (round.to_cents) werckmeister_iv_ar == c werckmeister_iv_ar :: [Approximate_Ratio] werckmeister_iv_ar =     let c0 = 2 ** (1/3)@@ -76,11 +232,17 @@        ,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 IV, Andreas Werckmeister (1645-1706)+--+-- > cents_i werckmeister_iv == [0,82,196,294,392,498,588,694,784,890,1004,1086]+werckmeister_iv :: Tuning+werckmeister_iv = Tuning (Right werckmeister_iv_c) 2++-- > let c = [0,96,204,300,396,504,600,702,792,900,1002,1098]+-- > in map (round.to_cents) werckmeister_v_ar == c werckmeister_v_ar :: [Approximate_Ratio] werckmeister_v_ar =     let c0 = 2 ** (1/4)@@ -94,26 +256,35 @@        ,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 V, Andreas Werckmeister (1645-1706)+--+-- > cents_i werckmeister_v == [0,96,204,300,396,504,600,702,792,900,1002,1098]+werckmeister_v :: Tuning+werckmeister_v = Tuning (Right werckmeister_v_c) 2++-- > let c = [0,91,196,298,395,498,595,698,793,893,1000,1097]+-- > in map (round.to_cents_r) werckmeister_vi_r == c 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]+    [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+--+-- > cents_i werckmeister_vi == [0,91,196,298,395,498,595,698,793,893,1000,1097]+werckmeister_vi :: Tuning+werckmeister_vi = Tuning (Left werckmeister_vi_r) 2 --- | Pietro Aaron (1523) - Meantone temperament+-- > let c = [0,76,193,310,386,503,580,697,773,890,1007,1083]+-- > in map round pietro_aaron_1523_c == c pietro_aaron_1523_c :: [Cents] pietro_aaron_1523_c =     [0,76.0@@ -122,10 +293,17 @@     ,503.4,579.5     ,696.8,772.6     ,889.7,1006.8-    ,1082.9-    ,1200]+    ,1082.9] --- | Thomas Young (1799) - Well Temperament+-- | Pietro Aaron (1523) meantone temperament, see+-- <http://www.kylegann.com/histune.html>+--+-- > cents_i pietro_aaron_1523 == [0,76,193,310,386,503,580,697,773,890,1007,1083]+pietro_aaron_1523 :: Tuning+pietro_aaron_1523 = Tuning (Right pietro_aaron_1523_c) 2++-- > let c = [0,94,196,298,392,500,592,698,796,894,1000,1092]+-- > in map round thomas_young_1799_c == c thomas_young_1799_c :: [Cents] thomas_young_1799_c =     [0,93.9@@ -134,31 +312,203 @@     ,499.9,591.9     ,697.9,795.8     ,893.8,999.8-    ,1091.8-    ,1200]+    ,1091.8] --- | Five-limit tuning+-- | Thomas Young (1799) - Well Temperament+--+-- > cents_i thomas_young_1799 == [0,94,196,298,392,500,592,698,796,894,1000,1092]+thomas_young_1799 :: Tuning+thomas_young_1799 = Tuning (Right thomas_young_1799_c) 2++-- > let c = [0,112,204,316,386,498,590,702,814,884,996,1088]+-- > in map (round.to_cents_r) five_limit_tuning_r == c 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]+    [1,16/15+    ,9/8,6/5+    ,5/4+    ,4/3,45/32+    ,3/2,8/5+    ,5/3,16/9 {- 9/5 -}+    ,15/8] --- | 'Cents' variant of 'five_limit_tuning_r'.-five_limit_tuning_c :: [Cents]-five_limit_tuning_c = map (to_cents.approximate_ratio) five_limit_tuning_r+-- | Five-limit tuning (five limit just intonation).+--+-- > cents_i five_limit_tuning == [0,112,204,316,386,498,590,702,814,884,996,1088]+five_limit_tuning :: Tuning+five_limit_tuning = Tuning (Left five_limit_tuning_r) 2 +-- > equal_temperament_c == [0,100..1100]+equal_temperament_c :: [Cents]+equal_temperament_c = [0, 100 .. 1100]+ -- | Equal temperament. ----- > equal_temperament_c == [0,100..1200]-equal_temperament_c :: [Cents]-equal_temperament_c = [0, 100 .. 1200]+-- > cents equal_temperament == [0,100..1100]+equal_temperament :: Tuning+equal_temperament = Tuning (Right equal_temperament_c) 2 +-- > let c = [0,112,204,316,386,498,583,702,814,884,1018,1088]+-- > in map (round.to_cents_r) septimal_tritone_just_intonation == c+septimal_tritone_just_intonation_r :: [Rational]+septimal_tritone_just_intonation_r =+    [1,16/15+    ,9/8,6/5+    ,5/4+    ,4/3,7/5+    ,3/2,8/5+    ,5/3,9/5+    ,15/8]++-- > cents_i septimal_tritone_just_intonation == [0,112,204,316,386,498,583,702,814,884,1018,1088]+septimal_tritone_just_intonation :: Tuning+septimal_tritone_just_intonation = Tuning (Left septimal_tritone_just_intonation_r) 2++-- > let c = [0,112,204,316,386,498,583,702,814,884,969,1088]+-- > in map (round.to_cents_r) seven_limit_just_intonation == c+seven_limit_just_intonation_r :: [Rational]+seven_limit_just_intonation_r =+    [1,16/15+    ,9/8,6/5+    ,5/4+    ,4/3,7/5+    ,3/2,8/5+    ,5/3,7/4+    ,15/8]++-- > cents_i seven_limit_just_intonation == [0,112,204,316,386,498,583,702,814,884,969,1088]+seven_limit_just_intonation :: Tuning+seven_limit_just_intonation = Tuning (Left seven_limit_just_intonation_r) 2++-- > let c = [0,90,193,294,386,498,590,697,792,890,996,1088]+-- > in map (round.to_cents) kirnberger_iii_ar == c+kirnberger_iii_ar :: [Approximate_Ratio]+kirnberger_iii_ar =+    [1,256/243+    ,sqrt 5 / 2,32/27+    ,5/4+    ,4/3,45/32+    ,5 ** 0.25,128/81+    ,(5 ** 0.75)/2,16/9+    ,15/8]++-- > cents_i kirnberger_iii == [0,90,193,294,386,498,590,697,792,890,996,1088]+kirnberger_iii :: Tuning+kirnberger_iii = Tuning (Right (map to_cents kirnberger_iii_ar)) 2++-- > let c = [0,94,196,298,392,502,592,698,796,894,1000,1090]+-- > in map round vallotti_c == c+vallotti_c :: [Cents]+vallotti_c =+    [0.0,94.135+    ,196.09,298.045+    ,392.18+    ,501.955,592.18+    ,698.045,796.09+    ,894.135,1000.0+    ,1090.225]++-- > cents_i vallotti == [0,94,196,298,392,502,592,698,796,894,1000,1090]+vallotti :: Tuning+vallotti = Tuning (Right vallotti_c) 2++-- > let c = [0,128,139,359,454,563,637,746,841,911,1072,1183]+-- > in map (round.to_cents_r) mayumi_reinhard == c+mayumi_reinhard_r :: [Rational]+mayumi_reinhard_r =+    [1,14/13+    ,13/12,16/13+    ,13/10+    ,18/13,13/9+    ,20/13,13/8+    ,22/13,13/7+    ,208/105]++-- > cents_i mayumi_reinhard == [0,128,139,359,454,563,637,746,841,911,1072,1183]+mayumi_reinhard :: Tuning+mayumi_reinhard = Tuning (Left mayumi_reinhard_r) 2++-- > let c = [0,177,204,240,471,444,675,702,738,969,942,1173]+-- > in map (round.to_cents_r) la_monte_young_r == c+la_monte_young_r :: [Rational]+la_monte_young_r =+    [1,567/512+    ,9/8,147/128+    ,21/16+    ,1323/1024,189/128+    ,3/2,49/32+    ,7/4,441/256+    ,63/32]++-- | La Monte Young's \"The Well-Tuned Piano\", see+-- <http://www.kylegann.com/tuning.html>.+--+-- > cents_i la_monte_young == [0,177,204,240,471,444,675,702,738,969,942,1173]+la_monte_young :: Tuning+la_monte_young = Tuning (Left la_monte_young_r) 2++-- > let c = [0,105,204,298,386,471,551,702,841,906,969,1088]+-- > in map (round.to_cents_r) ben_johnston_r == c+ben_johnston_r :: [Rational]+ben_johnston_r =+    [1,17/16+    ,9/8,19/16+    ,5/4+    ,21/16,11/8+    ,3/2,13/8+    ,27/16,7/4+    ,15/8]++-- | Ben Johnston's \"Suite for Microtonal Piano\" (1977), see+-- <http://www.kylegann.com/tuning.html>+--+-- > cents_i ben_johnston == [0,105,204,298,386,471,551,702,841,906,969,1088]+ben_johnston :: Tuning+ben_johnston = Tuning (Left ben_johnston_r) 2++-- > let c = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088]+-- > in map (round.to_cents_r) lou_harrison_16_r == c+lou_harrison_16_r :: [Rational]+lou_harrison_16_r =+    [1,16/15+    ,10/9,8/7+    ,7/6,6/5,5/4+    ,4/3+    ,17/12+    ,3/2+    ,8/5,5/3,12/7+    ,7/4,9/5,15/8]++-- | Lou Harrison 16 tone Just Intonation scale, see+-- <http://www.microtonal-synthesis.com/scale_harrison_16.html>+--+-- > cents_i lou_harrison_16 == [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088]+lou_harrison_16 :: Tuning+lou_harrison_16 = Tuning (Left lou_harrison_16_r) 2++partch_43_r :: [Rational]+partch_43_r =+    [1,81/80,33/32,21/20,16/15,12/11,11/10,10/9,9/8,8/7+    ,7/6,32/27,6/5,11/9,5/4,14/11,9/7+    ,21/16,4/3,27/20+    ,11/8,7/5,10/7,16/11+    ,40/27,3/2,32/21,14/9,11/7,8/5,18/11,5/3,27/16,12/7+    ,7/4,16/9,9/5,20/11,11/6,15/8,40/21,64/33,160/81]++-- | Harry Partch 43 tone scale, see+-- <http://www.microtonal-synthesis.com/scale_partch.html>+--+-- > cents_i partch_43 == [0,22,53,84,112,151,165+-- >                      ,182,204,231,267,294,316+-- >                      ,347,386,418,435+-- >                      ,471,498,520,551,583,617,649+-- >                      ,680,702,729,765,782,814,853,884,906,933+-- >                      ,969,996,1018,1035,1049,1088,1116,1147,1178]+partch_43 :: Tuning+partch_43 = Tuning (Left partch_43_r) 2++-- * Syntonic tuning+ -- | Construct an isomorphic layout of /r/ rows and /c/ columns with -- an upper left value of /(i,j)/. mk_isomorphic_layout :: Integral a => a -> a -> (a,a) -> [[(a,a)]]@@ -169,6 +519,16 @@         left = mk_seq n_row (-1,1) top_left     in map (mk_seq n_col (-1,2)) left +-- | A minimal isomorphic note layout.+--+-- > let [i,j,k] = mk_isomorphic_layout 3 5 (3,-4)+-- > in [i,take 4 j,(2,-4):take 4 k] == minimal_isomorphic_note_layout+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)]]+ -- | Make a rank two regular temperament from a list of /(i,j)/ -- positions by applying the scalars /a/ and /b/. rank_two_regular_temperament :: Integral a => a -> a -> [(a,a)] -> [a]@@ -186,63 +546,86 @@  -- | 'mk_syntonic_tuning' of @697@. ----- > take 10 (map round syntonic_697_c) == [0,79,194,273,309,388,467,503,582,697]-syntonic_697_c :: [Cents]-syntonic_697_c = mk_syntonic_tuning 697+-- > divisions syntonic_697 == 17+-- > cents_i syntonic_697 == [0,79,194,273,309,388,467,503,582,697,776,812,891,970,1006,1085,1164]+syntonic_697 :: Tuning+syntonic_697 = Tuning (Right (mk_syntonic_tuning 697)) 2  -- | 'mk_syntonic_tuning' of @702@. ----- > take 11 (map round syntonic_702_c) == [0,24,114,204,294,318,408,498,522,612,702]-syntonic_702_c :: [Cents]-syntonic_702_c = mk_syntonic_tuning 702+-- > divisions syntonic_702 == 17+-- > cents_i syntonic_702 == [0,24,114,204,294,318,408,498,522,612,702,792,816,906,996,1020,1110]+syntonic_702 :: Tuning+syntonic_702 = Tuning (Right (mk_syntonic_tuning 702)) 2 --- | The Syntonic comma.+-- * Harmonic series++-- | Raise or lower the frequency /q/ by octaves until it is in the+-- octave starting at /p/. ----- > syntonic_comma == 81/80-syntonic_comma :: Rational-syntonic_comma = 81 % 80+-- > fold_to_octave_of 55 392 == 98+fold_cps_to_octave_of :: (Ord a, Fractional a) => a -> a -> a+fold_cps_to_octave_of p q =+    if q > p * 2+    then fold_cps_to_octave_of p (q / 2)+    else if q < p+         then fold_cps_to_octave_of p (q * 2)+         else q --- | The Pythagorean comma.+-- | Harmonic series on /n/.+harmonic_series_cps :: (Num t, Enum t) => t -> [t]+harmonic_series_cps n = [n,n * 2 ..]++-- | /n/ elements of 'harmonic_series_cps'. ----- > pythagorean_comma == 3^12 % 2^19-pythagorean_comma :: Rational-pythagorean_comma = 531441 % 524288+-- > harmonic_series_cps_n 14 55 == [55,110,165,220,275,330,385,440,495,550,605,660,715,770]+harmonic_series_cps_n :: (Num a, Enum a) => Int -> a -> [a]+harmonic_series_cps_n n = take n . harmonic_series_cps --- | Mercators comma.+-- | /n/th partial of /f1/, ie. one indexed. ----- > mercators_comma == 3^53 % 2^84-mercators_comma :: Rational-mercators_comma = 19383245667680019896796723 % 19342813113834066795298816+-- > map (partial 55) [1,5,3] == [55,275,165]+partial :: (Num a, Enum a) => a -> Int -> a+partial f1 k = harmonic_series_cps f1 !! (k - 1) --- | Convert from 'Rational' to 'Approximate_Ratio', ie. 'fromRational'.-approximate_ratio :: Rational -> Approximate_Ratio-approximate_ratio = fromRational+-- | Fold ratio until within an octave, ie. @1@ '<' /n/ '<=' @2@.+fold_ratio_to_octave :: Integral i => Ratio i -> Ratio i+fold_ratio_to_octave n =+    if n >= 2+    then fold_ratio_to_octave (n / 2)+    else if n < 1+         then fold_ratio_to_octave (n * 2)+         else n --- | Convert from an 'Approximate_Ratio' to 'Cents'.+-- | Derivative harmonic series, based on /k/th partial of /f1/. ----- > round (to_cents (3/2)) == 702-to_cents :: Approximate_Ratio -> Cents-to_cents x = 1200 * logBase 2 x+-- > let {r = [52,103,155,206,258,309,361,412,464,515,567,618,670,721,773]+-- >     ;d = harmonic_series_cps_derived 5 (octpc_to_cps (1,4))}+-- > in map round (take 15 d) == r+harmonic_series_cps_derived :: (Ord a, Fractional a, Enum a) => Int -> a -> [a]+harmonic_series_cps_derived k f1 =+    let f0 = fold_cps_to_octave_of f1 (partial f1 k)+    in harmonic_series_cps f0 --- | Calculate /n/th root of /x/.+-- | Harmonic series to /n/th harmonic (folded). ----- > 12 `nth_root` 2  == twelve_tone_equal_temperament_comma-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))+-- > harmonic_series_folded 17 == [1,17/16,9/8,5/4,11/8,3/2,13/8,7/4,15/8]+harmonic_series_folded :: Integer -> [Rational]+harmonic_series_folded n =+    nub (sort (map fold_ratio_to_octave [1 .. n%1])) --- | 12-tone equal temperament comma (ie. 12th root of 2).-twelve_tone_equal_temperament_comma :: (Floating a) => a-twelve_tone_equal_temperament_comma = 12 `nth_root` 2+-- | 'to_cents_r' variant of 'harmonic_series_folded'.+--+-- > map round (harmonic_series_folded_c 21) == [0,105,204,298,386,471,551,702,841,969,1088]+harmonic_series_folded_c :: Integer -> [Cents]+harmonic_series_folded_c = map to_cents_r . harmonic_series_folded --- | A minimal isomorphic note layout.+-- | @12@-tone tuning of first @21@ elements of the harmonic series. ----- > let [i,j,k] = mk_isomorphic_layout 3 5 (3,-4)--- > in [i,take 4 j,(2,-4):take 4 k] == minimal_isomorphic_note_layout-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)]]+-- > cents_i harmonic_series_folded_21 == [0,105,204,298,386,471,551,702,841,969,1088]+harmonic_series_folded_21 :: Tuning+harmonic_series_folded_21 = Tuning (Left (harmonic_series_folded 21)) 2++-- Local Variables:+-- truncate-lines:t+-- End:
+ Music/Theory/Tuning/Alves_1997.hs view
@@ -0,0 +1,50 @@+-- | Bill Alves. \"Pleng: Composing for a Justly Tuned Gender+-- Barung\". 1/1: Journal of the Just Intonation Network, 1:4-11, Spring+-- 1997.  <http://www2.hmc.edu/~alves/pleng.html>+module Music.Theory.Tuning.Alves_1997 where++import Music.Theory.Tuning++-- > let c = [0,231,498,765,996]+-- > in map (round.to_cents_r) alves_slendro_r == c+alves_slendro_r :: [Rational]+alves_slendro_r = [1,8/7,4/3,14/9,16/9]++-- | HMC /slendro/ tuning.+--+-- > cents_i alves_slendro == [0,231,498,765,996]+alves_slendro :: Tuning+alves_slendro = Tuning (Left alves_slendro_r) 2++-- > let c = [0,231,316,702,814]+-- > in map (round.to_cents_r) alves_pelog_bem_r == c+alves_pelog_bem_r :: [Rational]+alves_pelog_bem_r = [1,8/7,6/5,3/2,8/5]++-- | HMC /pelog bem/ tuning.+--+-- > cents_i alves_pelog_bem == [0,231,316,702,814]+alves_pelog_bem :: Tuning+alves_pelog_bem = Tuning (Left alves_pelog_bem_r) 2++-- > let c = [0,386,471,857,969]+-- > in map (round.to_cents_r) alves_pelog_barang_r == c+alves_pelog_barang_r :: [Rational]+alves_pelog_barang_r = [1,5/4,21/16,105/64,7/4]++-- | HMC /pelog 2,3,4,6,7/ tuning.+--+-- > cents_i alves_pelog_barang == [0,386,471,857,969]+alves_pelog_barang :: Tuning+alves_pelog_barang = Tuning (Left alves_pelog_barang_r) 2++-- > let c = [0,386,471,702,969]+-- > in map (round.to_cents_r) alves_pelog_23467 == c+alves_pelog_23467_r :: [Rational]+alves_pelog_23467_r = [1,5/4,21/16,3/2,7/4]++-- | HMC /pelog barang/ tuning.+--+-- > cents_i alves_pelog_23467 == [0,386,471,702,969]+alves_pelog_23467 :: Tuning+alves_pelog_23467 = Tuning (Left alves_pelog_23467_r) 2
+ Music/Theory/Tuning/Meyer_1929.hs view
@@ -0,0 +1,106 @@+-- | Max Meyer. \"The musician's arithmetic: drill problems for an+-- introduction to the scientific study of musical composition.\" The+-- University of Missouri, 1929.  p.22+module Music.Theory.Tuning.Meyer_1929 where++import Data.List+import Data.Ratio+import qualified Music.Theory.Tuning as T++-- | Odd numbers to /n/.+--+-- > odd_to 7 == [1,3,5,7]+odd_to :: (Num t, Enum t) => t -> [t]+odd_to n = [1,3 .. n]++-- | Generate initial row for /n/.+--+-- > row 7 == [1,5/4,3/2,7/4]+row :: Integral i => i -> [Ratio i]+row = sort . map T.fold_ratio_to_octave . odd_to . (% 1)++-- | Generate initial column for /n/.+--+-- > column 7 == [1,8/5,4/3,8/7]+column :: Integral i => i -> [Ratio i]+column = map (T.fold_ratio_to_octave . recip) . row++-- | 'T.fold_to_octave' '.' '*'.+in_oct_mul :: Integral i => Ratio i -> Ratio i -> Ratio i+in_oct_mul i j = T.fold_ratio_to_octave (i * j)++-- | Given /row/ and /column/ generate matrix value at /(i,j)/.+--+-- > inner (row 7,column 7) (1,2) == 6/5+inner :: Integral i => ([Ratio i],[Ratio i]) -> (i,i) -> Ratio i+inner (r,c) (i,j) = in_oct_mul (r `genericIndex` j) (c `genericIndex` i)++meyer_table_rck :: Integral i => i -> ([Ratio i],[Ratio i],i)+meyer_table_rck n =+    let r = row n+        c = column n+        k = n `div` 2+    in (r,c,k)++-- | Meyer table in form /(r,c,n)/.+--+-- > meyer_table_indices 7 == [(0,0,1/1),(0,1,5/4),(0,2,3/2),(0,3,7/4)+-- >                          ,(1,0,8/5),(1,1,1/1),(1,2,6/5),(1,3,7/5)+-- >                          ,(2,0,4/3),(2,1,5/3),(2,2,1/1),(2,3,7/6)+-- >                          ,(3,0,8/7),(3,1,10/7),(3,2,12/7),(3,3,1/1)]+meyer_table_indices :: Integral i => i -> [(i,i,Ratio i)]+meyer_table_indices n =+    let (r,c,k) = meyer_table_rck n+    in [(i,j,inner (r,c) (i,j)) | i <- [0..k], j <- [0..k]]++-- | Meyer table as set of rows.+--+-- > meyer_table_rows 7 == [[1/1, 5/4, 3/2,7/4]+-- >                       ,[8/5, 1/1, 6/5,7/5]+-- >                       ,[4/3, 5/3, 1/1,7/6]+-- >                       ,[8/7,10/7,12/7,1/1]]+--+-- > let r = [[ 1/1,   9/8,   5/4,  11/8,   3/2,  13/8,   7/4,  15/8]+-- >         ,[16/9,   1/1,  10/9,  11/9,   4/3,  13/9,  14/9,   5/3]+-- >         ,[ 8/5,   9/5,   1/1,  11/10,  6/5,  13/10,  7/5,   3/2]+-- >         ,[16/11, 18/11, 20/11,  1/1,  12/11, 13/11, 14/11, 15/11]+-- >         ,[ 4/3,   3/2,   5/3,  11/6,   1/1,  13/12,  7/6,   5/4]+-- >         ,[16/13, 18/13, 20/13, 22/13, 24/13,  1/1,  14/13, 15/13]+-- >         ,[ 8/7,   9/7,   10/7, 11/7,  12/7,  13/7,   1/1,  15/14]+-- >         ,[16/15,  6/5,    4/3, 22/15,  8/5,  26/15, 28/15,  1/1]]+-- > in meyer_table_rows 15 == r+meyer_table_rows :: Integral a => a -> [[Ratio a]]+meyer_table_rows n =+    let (r,c,k) = meyer_table_rck n+        rn i = [inner (r,c) (i,j) | j <- [0..k]]+    in map rn [0..k]++-- | Third element of three-tuple.+t3_3 :: (t1,t2,t3) -> t3+t3_3 (_,_,i) = i++-- | Set of unique ratios in /n/ table.+--+-- > elements 7 == [1,8/7,7/6,6/5,5/4,4/3,7/5,10/7,3/2,8/5,5/3,12/7,7/4]+--+-- > elements 9 == [1,10/9,9/8,8/7,7/6,6/5,5/4,9/7,4/3,7/5,10/7+-- >               ,3/2,14/9,8/5,5/3,12/7,7/4,16/9,9/5]+elements :: Integral i => i -> [Ratio i]+elements = nub . sort . concat . meyer_table_rows++-- | Number of unique elements at /n/ table.+--+-- > map degree [7,9,11,13,15] == [13,19,29,41,49]+degree :: Integral i => i -> i+degree = genericLength . elements++-- | <http://en.wikipedia.org/wiki/Farey_sequence>+--+-- > let r = [[0,1/2,1]+-- >         ,[0,1/3,1/2,2/3,1]+-- >         ,[0,1/4,1/3,1/2,2/3,3/4,1]+-- >         ,[0,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,1]+-- >         ,[0,1/6,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,5/6,1]]+-- > in map farey_sequence [2..6] == r+farey_sequence :: Integral a => a -> [Ratio a]+farey_sequence k = 0 : nub (sort [n%d | d <- [1..k], n <- [1..d]])
+ Music/Theory/Tuning/Polansky_1978.hs view
@@ -0,0 +1,30 @@+-- | Larry Polansky. \"Psaltery (for Lou Harrison)\". Frog Peak Music,+-- 1978.+module Music.Theory.Tuning.Polansky_1978 where++import Data.List+import qualified Music.Theory.Tuning as T++-- | Three interlocking harmonic series on 1:5:3, by Larry Polansky in+-- \"Psaltery\".+--+-- > import qualified Music.Theory.Tuning.Scala as T+-- > let fn = "/home/rohan/opt/scala/scl/polansky_ps.scl"+-- > s <- T.load fn+-- > T.scale_pitch_representations s == (0,50)+-- > 1 : Data.Either.rights (T.scale_pitches s) == psaltery+psaltery :: [Rational]+psaltery = [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,5/4,5/2,15/4,5,25/4,15/2,35/4,10,45/4,25/2,55/4,15,65/4,35/2,75/4,20,85/4,3/2,3,9/2,6,15/2,9,21/2,12,27/2,15,33/2,18,39/2,21,45/2,24,51/2]++-- | 'T.fold_ratio_to_octave' of 'psaltery'.+--+-- > length psaltery == 51 && length psaltery_o == 21+-- > psaltery_o == [1,65/64,33/32,17/16,35/32,9/8,75/64,39/32+-- >               ,5/4,21/16,85/64,11/8,45/32+-- >               ,3/2,25/16,51/32,13/8,27/16,55/32,7/4,15/8]+psaltery_o :: [Rational]+psaltery_o = nub (sort (map T.fold_ratio_to_octave psaltery))++-- Local Variables:+-- truncate-lines:t+-- End:
+ Music/Theory/Tuning/Polansky_1984.hs view
@@ -0,0 +1,152 @@+-- | Larry Polansky. \"Tuning Systems in American Gamelan, Part I:+-- Interval Sizes in Javanese Slendro\". /Balungan/, 1(2):9-11, 1984+module Music.Theory.Tuning.Polansky_1984 where++import Data.List+import Music.Theory.Tuning++k_manisrenga :: Fractional n => [n]+k_manisrenga = [219.5,266.5,227,233.5,258.5]++k_kanjutmesem :: Fractional n => [n]+k_kanjutmesem = [224,253.5,237.5,232.5,264]++k_udanriris :: Fractional n => [n]+k_udanriris = [255.5,256.5,223.5,235.5,234]++k_pengawesari :: Fractional n => [n]+k_pengawesari = [251.5,233.5,233.5,236,250]++k_rarasrum :: Fractional n => [n]+k_rarasrum = [229.5,227.5,253,232,261.5]++k_hardjanagara :: Fractional n => [n]+k_hardjanagara = [216,249.5,216,262,261.5]++k_madukentir :: Fractional n => [n]+k_madukentir = [268.5,242,243,230,221]++k_surak :: Fractional n => [n]+k_surak = [206,231.5,238.5,265,264.5]++-- | The set of /K/ slendro tunings.+--+-- > map length k_set == replicate (length k_set) 5+-- > minimum (concat k_set) == 206+-- > maximum (concat k_set) == 268.5+k_set :: Fractional n => [[n]]+k_set = [k_manisrenga+        ,k_kanjutmesem+        ,k_udanriris+        ,k_pengawesari+        ,k_rarasrum+        ,k_hardjanagara+        ,k_madukentir+        ,k_surak]++-- | Given a set of equal length lists calculate the average value of+-- each position.+--+-- > calculate_averages [[1,2,3],[3,2,1]] == [2,2,2]+calculate_averages :: Fractional n => [[n]] -> [n]+calculate_averages set =+    let n = fromIntegral (length set)+        z = map sum (transpose set)+    in map (/ n) z++-- | Averages of /K/ set, p. 10.+--+-- > k_averages == [233.8125,245.0625,234.0,240.8125,251.875]+k_averages :: Fractional n => [n]+k_averages = calculate_averages k_set++gm_1,gm_2,gm_3,gm_4,gm_5,gm_6,gm_7,gm_8 :: Fractional n => [n]+gm_1 = [237,251,248,242,258]+gm_2 = [252,239,242,236.5,253.5]+gm_3 = [237,238.5,232.5,262,238]+gm_4 = [226,252,260,234,256]+gm_5 = [232,239,248,232,259.5]+gm_6 = [218,238.5,244.5,244.5,260]+gm_7 = [238,230,257,243,250.5]+gm_8 = [232,234,249,251,257]++-- | The set of /GM/ (Gadja Mada University) slendro tunings.+--+-- > map length gm_set == replicate (length gm_set) 5+-- > minimum (concat gm_set) == 218+-- > maximum (concat gm_set) == 262+gm_set :: Fractional n => [[n]]+gm_set = [gm_1,gm_2,gm_3,gm_4,gm_5,gm_6,gm_7,gm_8]++-- | Averages of /GM/ set, p. 10.+--+-- > gm_averages == [234.0,240.25,247.625,243.125,254.0625]+gm_averages :: Fractional n => [n]+gm_averages = calculate_averages gm_set++-- | Association list giving interval boundaries for interval class+-- categories (pp.10-11).+i_categories :: Num n => [((n,n),String)]+i_categories =+    [((206,238),"S")+    ,((238,240),"S-E")+    ,((240,248),"E")+    ,((248,250),"E-L")+    ,((250,269),"L")]++-- | Categorise an interval.+i_category :: (Ord a, Num a) => a -> String+i_category x =+    let f n (i,j) = i <= n && n < j+    in maybe "U" snd (find (f x . fst) i_categories)++-- | Pad 'String' to right with spaces until at least /n/ characters.+--+-- > map (pad 3) ["S","E-L"] == ["S  ","E-L"]+pad :: Int -> String -> String+pad n s = s ++ replicate (n - length s) ' '++-- | Pretty interval category table (pp. 10-11).+--+-- > i_category_table k_set ==+-- >  ["S    L    S    S    L  "+-- >  ,"S    L    S    S    L  "+-- >  ,"L    L    S    S    S  "+-- >  ,"L    S    S    S    L  "+-- >  ,"S    S    L    S    L  "+-- >  ,"S    E-L  S    L    L  "+-- >  ,"L    E    E    S    S  "+-- >  ,"S    S    S-E  L    L  "]+--+-- > i_category_table gm_set ==+-- >  ["S    L    E-L  E    L  "+-- >  ,"L    S-E  E    S    L  "+-- >  ,"S    S-E  S    L    S-E"+-- >  ,"S    L    L    S    L  "+-- >  ,"S    S-E  E-L  S    L  "+-- >  ,"S    S-E  E    E    L  "+-- >  ,"S-E  S    L    E    L  "+-- >  ,"S    S    E-L  L    L  "]+i_category_table :: (Ord a, Num a) => [[a]] -> [String]+i_category_table = map (intercalate "  " .  map (pad 3 . i_category))++-- | Rational tuning derived from 'gm_averages', p.11.+--+-- > polansky_1984_r == sort polansky_1984_r+-- > polansky_1984_r == [1/1,8/7,21/16,512/343,12/7,96/49]+--+-- > import Music.Theory.List+-- > d_dx polansky_1984_r == [1/7,19/112,989/5488,76/343,12/49]+polansky_1984_r :: [Rational]+polansky_1984_r =+    let vi = 12/7+        v = 128/147 * vi+        i' = 21/16 * v+    in [1,8/7,21/16,v,vi,i']++-- | 'to_cents_r' of 'polansky_1984_r'.+--+-- > import Music.Theory.List+-- > map round (d_dx polansky_1984_c) == [231,240,223,240,231]+polansky_1984_c :: [Cents]+polansky_1984_c = map to_cents_r polansky_1984_r
+ Music/Theory/Tuning/Polansky_1990.hs view
@@ -0,0 +1,62 @@+-- | Larry Polansky. \"Notes on the Tunings of Three Central Javanese+-- Slendro\/Pelog Pairs\". /Experimental Musical Instruments/,+-- 6(2):12-13,16-17, 1990.+module Music.Theory.Tuning.Polansky_1990 where++import Data.Ratio+import qualified Music.Theory.List as L+import qualified Music.Theory.Tuning as T++-- | Kanjutmesem Slendro (S1,S2,S3,S5,S6,S1')+--+-- > L.d_dx kanjutmesem_s == [252,238,241,236,253]+kanjutmesem_s :: Num n => [n]+kanjutmesem_s = [0,252,490,731,967,1220]++-- | Kanjutmesem Pelog (P1,P2,P3,P4,P5,P6,P7,P1')+--+-- > L.d_dx kanjutmesem_p == [141,141,272,140,115,172,246]+kanjutmesem_p :: Num n => [n]+kanjutmesem_p = [37,178,319,591,731,846,1018,1264]++-- | Darius Slendro (S1,S2,S3,S5,S6,S1')+--+-- > L.d_dx darius_s == [204,231,267,231,267]+-- > ax_r darius_s == [9/8,8/7,7/6,8/7,7/6]+darius_s :: Num n => [n]+darius_s = [0,204,435,702,933,1200]++-- | Madeleine Pelog (P1,P2,P3,P4,P5,P6,P7,P1')+--+-- > L.d_dx madeleine_p == [139,128,336,99,94,173,231]+-- > ax_r madeleine_p == [13/12,14/13,17/14,18/17,19/18,21/19,8/7]+madeleine_p :: Num n => [n]+madeleine_p = [137,276,404,740,839,933,1106,1337]++-- | Lipur Sih Slendro (S1,S2,S3,S5,S6,S1')+--+-- > L.d_dx lipur_sih_s == [273,236,224,258,256]+lipur_sih_s :: Num n => [n]+lipur_sih_s = [0,273,509,733,991,1247]++-- | Lipur Sih Pelog (P1,P2,P3,P4,P5,P6,P7,P1')+--+-- > L.d_dx lipur_sih_p == [110,153,253,146,113,179]+lipur_sih_p :: Num n => [n]+lipur_sih_p = [216,326,479,732,878,991,1170]++-- | Idealized ET Slendro, 5-tone equal temperament (p.17)+--+-- > L.d_dx idealized_et_s == [240,240,240,240,240]+idealized_et_s :: Num n => [n]+idealized_et_s = [0,240,480,720,960,1200]++-- | Idealized ET Pelog, subset of 9-tone equal temperament (p.17)+--+-- > L.d_dx idealized_et_p == [400/3,800/3,400/3,400/3,400/3,400/3,800/3]+idealized_et_p :: Integral n => [Ratio n]+idealized_et_p = [160,293+1/3,560,693+1/3,826+2/3,960,1093+1/3,1360]++-- | Reconstruct approximate ratios to within @1e-3@ from intervals.+ax_r :: Real n => [n] -> [Rational]+ax_r = map (T.reconstructed_ratio 1e-3 . realToFrac) . L.d_dx
+ Music/Theory/Tuning/Scala.hs view
@@ -0,0 +1,196 @@+-- | Parser for the Scala scale file format.  See+-- <http://www.huygens-fokker.org/scala/scl_format.html> for details.+-- This module succesfully parses all 4115 scales in v.77 of the scale+-- library.+module Music.Theory.Tuning.Scala where++import qualified Codec.Binary.UTF8.String as U {- utf8-string -}+import qualified Data.ByteString as B {- bytestring -}+import Data.List+import Data.Ratio+import qualified Music.Theory.Tuning as T+import System.Directory {- directory -}+import System.FilePath {- filepath -}++-- | A @.scl@ pitch is either in 'Cents' or is a 'Ratio'.+type Pitch i = Either T.Cents (Ratio i)++-- | A scale has a description, a degree, and a list of 'Pitch'es.+type Scale i = (String,i,[Pitch i])++-- | Text description of scale.+scale_description :: Scale i -> String+scale_description (d,_,_) = d++-- | The degree of the scale (number of 'Pitch'es).+scale_degree :: Scale i -> i+scale_degree (_,n,_) = n++-- | The 'Pitch'es at 'Scale'.+scale_pitches :: Scale i -> [Pitch i]+scale_pitches (_,_,p) = p++-- | The last 'Pitch' element of the scale (ie. the /ocatve/).+scale_octave :: Scale i -> Maybe (Pitch i)+scale_octave (_,_,s) =+    case s of+      [] -> Nothing+      _ -> Just (last s)++-- | Is 'scale_octave' perfect, ie. 'Ratio' of @2@ or 'Cents' of+-- @1200@.+perfect_octave :: Integral i => Scale i -> Bool+perfect_octave s = scale_octave s `elem` [Just (Right 2),Just (Left 1200)]++-- | A pair giving the number of 'Cents' and number of 'Ratio' pitches+-- at 'Scale'.+scale_pitch_representations :: (Integral t) => Scale i -> (t,t)+scale_pitch_representations s =+    let f (l,r) p = case p of+                      Left _ -> (l + 1,r)+                      Right _ -> (l,r + 1)+    in foldl f (0,0) (scale_pitches s)++-- | Pitch as 'T.Cents', conversion by 'T.to_cents_r' if necessary.+pitch_cents :: Pitch Integer -> T.Cents+pitch_cents p =+    case p of+      Left c -> c+      Right r -> T.to_cents_r r++type Epsilon = Double++-- | Pitch as 'Rational', conversion by 'T.reconstructed_ratio' if+-- necessary, hence /epsilon/.+pitch_ratio :: Epsilon -> Pitch Integer -> Rational+pitch_ratio epsilon p =+    case p of+      Left c -> T.reconstructed_ratio epsilon c+      Right r -> r++-- | Make scale pitches uniform, conforming to the most promininent+-- pitch type.+scale_uniform :: Epsilon -> Scale Integer -> Scale Integer+scale_uniform epsilon s =+    let (d,n,p) = s+        (c,r) = scale_pitch_representations s :: (Int,Int)+    in if c >= r+       then (d,n,map (Left . pitch_cents) p)+       else (d,n,map (Right . pitch_ratio epsilon) p)++-- | Scale as list of 'T.Cents' (ie. 'pitch_cents') with @0@ prefix.+scale_cents :: Scale Integer -> [T.Cents]+scale_cents s = 0 : map pitch_cents (scale_pitches s)++-- | Scale as list of 'Rational' (ie. 'pitch_ratio') with @1@ prefix.+scale_ratios :: Epsilon -> Scale Integer -> [Rational]+scale_ratios epsilon s = 1 : map (pitch_ratio epsilon) (scale_pitches s)++-- | Comment lines being with @!@.+comment_p :: String -> Bool+comment_p x =+    case x of+      '!':_ -> True+      _ -> False++-- | Remove @\r@.+filter_cr :: String -> String+filter_cr = filter (not . (==) '\r')++-- | Logical /or/ of list of predicates.+p_or :: [a -> Bool] -> a -> Bool+p_or p x =+    case p of+      [] -> False+      f:p' -> f x || p_or p' x++-- | Remove to end of line @!@ comments.+remove_eol_comments :: String -> String+remove_eol_comments = takeWhile (/= '!')++-- | Remove comments and null lines.+--+-- > filter_comments ["!a","b","","c"] == ["b","c"]+filter_comments :: [String] -> [String]+filter_comments = map remove_eol_comments .+                  filter (not . p_or [comment_p,null])++-- | Delete trailing @.@, 'read' fails for @700.@.+delete_trailing_point :: String -> String+delete_trailing_point s =+    case reverse s of+      '.':s' -> reverse s'+      _ -> s++-- | Pitches are either cents (with decimal point) or ratios (with @/@).+--+-- > map pitch ["700.0","3/2","2"] == [Left 700,Right (3/2),Right 2]+pitch :: (Read i,Integral i) => String -> Pitch i+pitch p =+    if '.' `elem` p+    then Left (read (delete_trailing_point p))+    else case break (== '/') p of+             (n,'/':d) -> Right (read n % read d)+             _ -> Right (read p % 1)++-- | Pitch lines may contain commentary.+pitch_ln :: (Read i, Integral i) => String -> Pitch i+pitch_ln x =+    case words x of+      p:_ -> pitch p+      _ -> error (show ("pitch",words x))++-- | Parse @.scl@ file.+parse :: (Read i, Integral i) => String -> Scale i+parse s =+    case filter_comments (lines (filter_cr s)) of+      t:n:p -> (t,read n,map pitch_ln p)+      _ -> error "parse"++-- | Load @.scl@ file.+--+-- > s <- load "/home/rohan/opt/scala/scl/xenakis_chrom.scl"+-- > scale_pitch_representations s == (6,1)+-- > scale_ratios 1e-3 s == [1,21/20,29/23,179/134,280/187,11/7,100/53,2]+load :: (Read i, Integral i) => FilePath -> IO (Scale i)+load fn = do+  b <- B.readFile fn+  let s = U.decode (B.unpack b)+  return (parse s)++-- | Subset of files in /dir/ with an extension in /ext/.+dir_subset :: [String] -> FilePath -> IO [FilePath]+dir_subset ext dir = do+  let f nm = takeExtension nm `elem` ext+  c <- getDirectoryContents dir+  return (map (dir </>) (sort (filter f c)))++-- | Load all @.scl@ files at /dir/.+--+-- > db <- load_dir "/home/rohan/opt/scala/scl"+-- > length db == 4115+-- > length (filter ((== 0) . scale_degree) db) == 1+-- > length (filter (== Just (Right 2)) (map scale_octave db)) == 3562+--+-- > let r = [0,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24+-- >         ,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44+-- >         ,45,46,47,48,49,50,51,53,54,55,56,57,58,59,60,61,62,63,64+-- >         ,65,66,67,68,69,70,71,72,74,75,77,78,79,80,81,84,87,88+-- >         ,90,91,92,95,96,99,100,101,105,110,112,117,118,130,140,171+-- >         ,180,271,311,342,366,441,612]+-- > in nub (sort (map scale_degree db)) == r+--+-- > let r = ["Xenakis's Byzantine Liturgical mode, 5 + 19 + 6 parts"+-- >         ,"Xenakis's Byzantine Liturgical mode, 12 + 11 + 7 parts"+-- >         ,"Xenakis's Byzantine Liturgical mode, 7 + 16 + 7 parts"]+-- > in filter (isInfixOf "Xenakis") (map scale_description db) == r+--+-- > length (filter (not . perfect_octave) db) == 544+--+-- > mapM_ (putStrLn.scale_description) (filter (not . perfect_octave) db)+load_dir :: (Read i, Integral i) => FilePath -> IO [Scale i]+load_dir d = dir_subset [".scl"] d >>= mapM load++-- Local Variables:+-- truncate-lines:t+-- End:
+ Music/Theory/Tuning/Table.hs view
@@ -0,0 +1,103 @@+-- | Tuning tables+module Music.Theory.Tuning.Table where++import qualified Music.Theory.Diagram.Grid as G+import Music.Theory.List+import Music.Theory.Pitch+import Music.Theory.Pitch.Spelling+import Music.Theory.Tuning+import qualified Text.HTML.Light as H {- html-minimalist -}+import Text.Printf++-- * Equal temperament++-- | 'octpc_to_pitch' and 'octpc_to_cps'.+octpc_to_pitch_cps :: (Floating n) => OctPC -> (Pitch,n)+octpc_to_pitch_cps x = (octpc_to_pitch pc_spell_ks x,octpc_to_cps x)++-- | 12-tone equal temperament table equating 'Pitch' and frequency+-- over range of human hearing, where @A4@ = @440@hz.+--+-- > length tbl_12et == 132+-- > min_max (map (round . snd) tbl_12et) == (16,31609)+tbl_12et :: [(Pitch,Double)]+tbl_12et =+    let z = [(o,pc) | o <- [0..10], pc <- [0..11]]+    in map octpc_to_pitch_cps z++-- | 24-tone equal temperament variant of 'tbl_12et'.+--+-- > length tbl_24et == 264+-- > min_max (map (round . snd) tbl_24et) == (16,32535)+tbl_24et :: [(Pitch, Double)]+tbl_24et =+    let f x = let p = fmidi_to_pitch pc_spell_ks x+                  p' = pitch_rewrite_threequarter_alteration p+              in (p',fmidi_to_cps x)+    in map f [12,12.5 .. 143.5]++-- | Given an @ET@ table (or like) find bounds of frequency.+--+-- > let r = Just (at_pair octpc_to_pitch_cps ((3,11),(4,0)))+-- > in bounds_et_table tbl_12et 256 == r+bounds_et_table :: Ord s => [(t,s)] -> s -> Maybe ((t,s),(t,s))+bounds_et_table tbl =+    let f (_,p) = compare p+    in find_bounds f (adj2 1 tbl)++-- | 'bounds_et_table' of 'tbl_12et'.+--+-- > map bounds_12et_tone (hsn 17 55)+bounds_12et_tone :: Double -> Maybe ((Pitch,Double),(Pitch,Double))+bounds_12et_tone = bounds_et_table tbl_12et++-- | Tuple indicating nearest 'Pitch' to /frequency/ with @ET@+-- frequency, and deviation in hertz and 'Cents'.+type HS_R = (Double,Pitch,Double,Double,Cents)++-- | Form 'HS_R' for /frequency/ by consulting table.+--+-- > let {f = 256+-- >     ;f' = octpc_to_cps (4,0)+-- >     ;r = (f,Pitch C Natural 4,f',f-f',to_cents (f/f'))}+-- > in nearest_et_table_tone tbl_12et 256 == r+nearest_et_table_tone :: [(Pitch,Double)] -> Double -> HS_R+nearest_et_table_tone tbl f =+    case bounds_et_table tbl f of+      Nothing -> undefined+      Just ((lp,lf),(rp,rf)) ->+          let ld = f - lf+              rd = f - rf+          in if abs ld < abs rd+             then (f,lp,lf,ld,to_cents (f/lf))+             else (f,rp,rf,rd,to_cents (f/rf))++nearest_12et_tone :: Double -> HS_R+nearest_12et_tone = nearest_et_table_tone tbl_12et++nearest_24et_tone :: Double -> HS_R+nearest_24et_tone = nearest_et_table_tone tbl_24et++-- * Cell++-- | /n/-decimal places.+--+-- > ndp 3 (1/3) == "0.333"+ndp :: Int -> Double -> String+ndp = printf "%.*f"++-- | 'G.Table_Cell' from set of 'HS_R'.+hs_r_cell :: Int -> (Int -> String) -> [HS_R] -> (Int,Int) -> G.Table_Cell+hs_r_cell n nm_f t (i,j) =+    let dp = ndp n+        (f,p,pf,fd,c) = t !! i+        e = case j of+              0 -> nm_f i+              1 -> dp f+              2 -> pitch_pp p+              3 -> dp pf+              4 -> dp fd+              5 -> dp c+              _ -> undefined+    in ([],[H.cdata e])+
Music/Theory/Xenakis/Sieve.hs view
@@ -3,7 +3,8 @@ -- Vol. 28, No. 1 (Winter, 1990), pp. 58-78 module Music.Theory.Xenakis.Sieve where -import qualified Data.List as L+import Data.List+import Music.Theory.List  -- | Synonym for 'Integer' type I = Integer@@ -37,6 +38,14 @@ l :: I -> I -> Sieve l = curry L +-- | unicode synonym for 'l'.+(⋄) :: I -> I -> Sieve+(⋄) = l++infixl 3 ∪+infixl 4 ∩+infixl 5 ⋄+ -- | In a /normal/ 'Sieve' /m/ is '>' /i/. -- -- > normalise (L (15,19)) == L (15,4)@@ -66,40 +75,45 @@       Union s0 s1 -> element s0 n || element s1 n       Intersection s0 s1 -> element s0 n && element s1 n --- | Given a comparison function, merge two ascending lists.------ > merge compare [1,3,5] [2,4] == [1..5]-merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-merge f p q =-    case (p,q) of-      ([],q') -> q'-      (p',[]) -> p'-      (i:p',j:q') -> case i `f` j of-                       GT -> j : merge f (i:p') q'-                       _ -> i : merge f p' (j:q')- -- | Construct the sequence defined by a 'Sieve'.  Note that building -- a sieve that contains an intersection clause that has no elements -- gives @_|_@. ----- > take 8 (build (union (map (l 12) [0,2,4,5,7,9,11])))+-- > let d = [0,2,4,5,7,9,11]+-- > in take 7 (build (union (map (l 12) d))) == d build :: Sieve -> [I] build s =-    let u_f = map head . L.group+    let u_f = map head . group         i_f = let g [x,_] = [x]                   g _ = []-              in concatMap g . L.group+              in concatMap g . group     in case s of          Empty -> []          L (m,i) -> [i, i+m ..]-         Union s0 s1 -> u_f (merge compare (build s0) (build s1))-         Intersection s0 s1 -> i_f (merge compare (build s0) (build s1))+         Union s0 s1 -> u_f (merge (build s0) (build s1))+         Intersection s0 s1 -> i_f (merge (build s0) (build s1)) --- | Variant of 'build' that gives the first /n/ places.+-- | Variant of 'build' that gives the first /n/ places of the+-- 'reduce' of 'Sieve'. -- -- > buildn 6 (union (map (l 8) [0,3,6])) == [0,3,6,8,11,14]+-- > buildn 12 (L (3,2)) == [2,5,8,11,14,17,20,23,26,29,32,35]+-- > buildn 9 (L (8,0)) == [0,8,16,24,32,40,48,56,64]+-- > buildn 3 (L (3,2) ∩ L (8,0)) == [8,32,56]+-- > buildn 12 (L (3,1) ∪ L (4,0)) == [0,1,4,7,8,10,12,13,16,19,20,22]+-- > buildn 14 (5⋄4 ∪ 3⋄2 ∪ 7⋄3) == [2,3,4,5,8,9,10,11,14,17,19,20,23,24]+-- > buildn 6 (3⋄0 ∪ 4⋄0) == [0,3,4,6,8,9]+-- > buildn 8 (5⋄2 ∩ 2⋄0 ∪ 7⋄3) == [2,3,10,12,17,22,24,31]+-- > buildn 12 (5⋄1 ∪ 7⋄2) == [1,2,6,9,11,16,21,23,26,30,31,36]+--+-- > buildn 10 (3⋄2 ∩ 4⋄7 ∪ 6⋄9 ∩ 15⋄18) == [3,11,23,33,35,47,59,63,71,83]+--+-- > let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19+-- > in buildn 16 s == buildn 16 (24⋄23 ∪ 30⋄3 ∪ 104⋄70)+--+-- > buildn 10 (24⋄23 ∪ 30⋄3 ∪ 104⋄70) == [3,23,33,47,63,70,71,93,95,119] buildn :: Int -> Sieve -> [I]-buildn n = take n . build+buildn n = take n . build . reduce  -- | Standard differentiation function. --@@ -108,7 +122,6 @@ differentiate :: (Num a) => [a] -> [a] differentiate x = zipWith (-) (tail x) x - -- | Euclid's algorithm for computing the greatest common divisor. -- -- > euclid 1989 867 == 51@@ -153,6 +166,12 @@ -- > reduce (L (3,2) ∩ Empty) == L (3,2) -- > reduce (L (3,2) ∩ L (4,7)) == L (12,11) -- > reduce (L (6,9) ∩ L (15,18)) == L (30,3)+--+-- > let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19+-- > in reduce s == (24⋄23 ∪ 30⋄3 ∪ 104⋄70)+--+-- > let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19+-- > in reduce s == (24⋄23 ∪ 30⋄3 ∪ 104⋄70) reduce :: Sieve -> Sieve reduce s =     let f g s1 s2 =
+ Music/Theory/Z12.hs view
@@ -0,0 +1,35 @@+{-# Language GeneralizedNewtypeDeriving #-}+module Music.Theory.Z12 where++import Data.List++newtype Z12 = Z12 Int deriving (Eq,Ord,Enum,Bounded,Integral,Real)+instance Show Z12 where showsPrec p (Z12 i) = showsPrec p i++liftUZ12 :: (Int -> Int) -> Z12 -> Z12+liftUZ12 f (Z12 a) = Z12 (mod (f a) 12)++liftBZ12 :: (Int -> Int -> Int) -> Z12 -> Z12 -> Z12+liftBZ12 f (Z12 a) (Z12 b) = Z12 (mod (a `f` b) 12)++instance Num Z12 where+  (+) = liftBZ12 (+)+  (-) = liftBZ12 (-)+  (*) = liftBZ12 (*)+  negate = liftUZ12 negate+  fromInteger i = Z12 (fromInteger i `mod` 12)+  signum _ = error "Z12 numbers are not signed"+  abs _ = error "Z12 numbers are not signed"++-- > map toZ12 [-9,-3,0] == [3,9,0]+toZ12 :: Integral i => i -> Z12+toZ12 = fromIntegral++fromZ12 :: Integral i => Z12 -> i+fromZ12 = fromIntegral++-- | Z12 not in set.+--+-- > complement [0,2,4,5,7,9,11] == [1,3,6,8,10]+complement :: [Z12] -> [Z12]+complement = (\\) [0..11]
+ Music/Theory/Z12/Castren_1994.hs view
@@ -0,0 +1,155 @@+-- | Marcus Castrén. /RECREL: A Similarity Measure for Set-Classes/. PhD+-- thesis, Sibelius Academy, Helsinki, 1994.+module Music.Theory.Z12.Castren_1994 where++import Data.List+import Data.Maybe+import Data.Ratio+import Music.Theory.List+import Music.Theory.Z12+import Music.Theory.Z12.Forte_1973+import Music.Theory.Z12.TTO++-- | Transpositional equivalence prime form, ie. 't_cmp_prime' of+-- 'forte_cmp'.+--+-- > (forte_prime [0,2,3],t_prime [0,2,3]) == ([0,1,3],[0,2,3])+t_prime :: [Z12] -> [Z12]+t_prime = t_cmp_prime forte_cmp++-- | Is /p/ symmetrical under inversion.+--+-- > map inv_sym (scs_n 2) == [True,True,True,True,True,True]+-- > map (fromEnum.inv_sym) (scs_n 3) == [1,0,0,0,0,1,0,0,1,1,0,1]+inv_sym :: [Z12] -> Bool+inv_sym x = x `elem` map (\i -> sort (tn i (invert 0 x))) [0..11]++-- | If /p/ is not 'inv_sym' then @(p,invert 0 p)@ else 'Nothing'.+--+-- > sc_t_ti [0,2,4] == Nothing+-- > sc_t_ti [0,1,3] == Just ([0,1,3],[0,2,3])+sc_t_ti :: [Z12] -> Maybe ([Z12], [Z12])+sc_t_ti p =+    if inv_sym p+    then Nothing+    else Just (p,t_prime (invert 0 p))++-- | Transpositional equivalence variant of Forte's 'sc_table'.  The+-- inversionally related classes are distinguished by labels @A@ and+-- @B@; the class providing the /best normal order/ (Forte 1973) is+-- always the @A@ class. If neither @A@ nor @B@ appears in the name of+-- a set-class, it is inversionally symmetrical.+--+-- > (length sc_table,length t_sc_table) == (224,352)+-- > lookup "5-Z18B" t_sc_table == Just [0,2,3,6,7]+t_sc_table :: [(SC_Name,[Z12])]+t_sc_table =+    let f x = let nm = sc_name x+              in case sc_t_ti x of+                   Nothing -> [(nm,x)]+                   Just (p,q) -> [(nm++"A",p),(nm++"B",q)]+    in concatMap f scs++-- | Lookup a set-class name.  The input set is subject to+-- 't_prime' before lookup.+--+-- > t_sc_name [0,2,3,6,7] == "5-Z18B"+-- > t_sc_name [0,1,4,6,7,8] == "6-Z17B"+t_sc_name :: [Z12] -> SC_Name+t_sc_name p =+    let n = find (\(_,q) -> t_prime p == q) t_sc_table+    in fst (fromJust n)++-- | Lookup a set-class given a set-class name.+--+-- > t_sc "6-Z17A" == [0,1,2,4,7,8]+t_sc :: SC_Name -> [Z12]+t_sc n = snd (fromJust (find (\(m,_) -> n == m) t_sc_table))++-- | List of set classes.+t_scs :: [[Z12]]+t_scs = map snd t_sc_table++-- | Cardinality /n/ subset of 't_scs'.+--+-- > map (length . t_scs_n) [2..10] == [6,19,43,66,80,66,43,19,6]+t_scs_n :: Integral i => i -> [[Z12]]+t_scs_n n = filter ((== n) . genericLength) t_scs++-- | T-related /q/ that are subsets of /p/.+--+-- > t_subsets [0,1,2,3,4] [0,1]  == [[0,1],[1,2],[2,3],[3,4]]+-- > t_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4]]+-- > t_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6]]+t_subsets :: [Z12] -> [Z12] -> [[Z12]]+t_subsets x a = filter (`is_subset` x) (t_related a)++-- | T\/I-related /q/ that are subsets of /p/.+--+-- > ti_subsets [0,1,2,3,4] [0,1]  == [[0,1],[1,2],[2,3],[3,4]]+-- > ti_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4],[0,3,4]]+-- > ti_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6],[3,6,7]]+ti_subsets :: [Z12] -> [Z12] -> [[Z12]]+ti_subsets x a = filter (`is_subset` x) (ti_related a)++-- | Trivial run length encoder.+--+-- > rle "abbcccdde" == [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')]+rle :: (Eq a,Integral i) => [a] -> [(i,a)]+rle =+    let f x = (genericLength x,head x)+    in map f . group++-- | Inverse of 'rle'.+--+-- > rle_decode [(5,'a'),(4,'b')] == "aaaaabbbb"+rle_decode :: (Integral i) => [(i,a)] -> [a]+rle_decode =+    let f (i,j) = genericReplicate i j+    in concatMap f++-- | Length of /rle/ encoded sequence.+--+-- > rle_length [(5,'a'),(4,'b')] == 9+rle_length :: (Integral i) => [(i,a)] -> i+rle_length = sum . map fst++-- | T-equivalence /n/-class vector (subset-class vector, nCV).+--+-- > t_n_class_vector 2 [0..4] == [4,3,2,1,0,0]+-- > rle (t_n_class_vector 3 [0..4]) == [(1,3),(2,2),(2,1),(4,0),(1,1),(9,0)]+-- > rle (t_n_class_vector 4 [0..4]) == [(1,2),(3,1),(39,0)]+t_n_class_vector :: (Num a, Integral i) => i -> [Z12] -> [a]+t_n_class_vector n x =+    let a = t_scs_n n+    in map (genericLength . t_subsets x) a++-- | T\/I-equivalence /n/-class vector (subset-class vector, nCV).+--+-- > ti_n_class_vector 2 [0..4] == [4,3,2,1,0,0]+-- > ti_n_class_vector 3 [0,1,2,3,4] == [3,4,2,0,0,1,0,0,0,0,0,0]+-- > rle (ti_n_class_vector 4 [0,1,2,3,4]) == [(2,2),(1,1),(26,0)]+ti_n_class_vector :: (Num b, Integral i) => i -> [Z12] -> [b]+ti_n_class_vector n x =+    let a = scs_n n+    in map (genericLength . ti_subsets x) a++-- | 'icv' scaled by sum of /icv/.+--+-- > dyad_class_percentage_vector [0,1,2,3,4] == [40,30,20,10,0,0]+-- > dyad_class_percentage_vector [0,1,4,5,7] == [20,10,20,20,20,10]+dyad_class_percentage_vector :: Integral i => [Z12] -> [i]+dyad_class_percentage_vector p =+    let p' = icv p+    in map (sum p' *) p'++-- | /rel/ metric.+--+-- > rel [0,1,2,3,4] [0,1,4,5,7] == 40+-- > rel [0,1,2,3,4] [0,2,4,6,8] == 60+-- > rel [0,1,4,5,7] [0,2,4,6,8] == 60+rel :: Integral i => [Z12] -> [Z12] -> Ratio i+rel x y =+    let x' = dyad_class_percentage_vector x+        y' = dyad_class_percentage_vector y+    in sum (map abs (zipWith (-) x' y')) % 2
+ Music/Theory/Z12/Drape_1999.hs view
@@ -0,0 +1,337 @@+-- | Haskell implementations of @pct@ operations.+-- See <http://slavepianos.org/rd/?t=pct>.+module Music.Theory.Z12.Drape_1999 where++import Data.Function+import Data.List+import Data.Maybe+import Music.Theory.List+import qualified Music.Theory.Set.List as S+import Music.Theory.Z12+import Music.Theory.Z12.Forte_1973+import Music.Theory.Z12.Morris_1987+import qualified Music.Theory.Z12.TTO as T+import qualified Music.Theory.Z12.SRO as S++-- | Cardinality filter+--+-- > cf [0,3] (cg [1..4]) == [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[]]+cf :: (Integral n) => [n] -> [[a]] -> [[a]]+cf ns = filter (\p -> genericLength p `elem` ns)++-- | Combinatorial sets formed by considering each set as possible+-- values for slot.+--+-- > cgg [[0,1],[5,7],[3]] == [[0,5,3],[0,7,3],[1,5,3],[1,7,3]]+cgg :: [[a]] -> [[a]]+cgg l =+    case l of+      x:xs -> [ y:z | y <- x, z <- cgg xs ]+      _ -> [[]]++-- | Combinations generator, ie. synonym for 'S.powerset'.+--+-- > sort (cg [0,1,3]) == [[],[0],[0,1],[0,1,3],[0,3],[1],[1,3],[3]]+cg :: [a] -> [[a]]+cg = S.powerset++-- | Powerset filtered by cardinality.+--+-- >>> cg -r3 0159+-- 015+-- 019+-- 059+-- 159+--+-- > cg_r 3 [0,1,5,9] == [[0,1,5],[0,1,9],[0,5,9],[1,5,9]]+cg_r :: (Integral n) => n -> [a] -> [[a]]+cg_r n = cf [n] . cg++-- | Cyclic interval segment.+ciseg :: [Z12] -> [Z12]+ciseg = int . cyc++-- | Synonynm for 'complement'.+--+-- >>> cmpl 02468t+-- 13579B+--+-- > cmpl [0,2,4,6,8,10] == [1,3,5,7,9,11]+cmpl :: [Z12] -> [Z12]+cmpl = complement++-- | Form cycle.+--+-- >>> cyc 056+-- 0560+--+-- > cyc [0,5,6] == [0,5,6,0]+cyc :: [a] -> [a]+cyc [] = []+cyc (x:xs) = (x:xs) ++ [x]++-- | Diatonic set name. 'd' for diatonic set, 'm' for melodic minor+-- set, 'o' for octotonic set.+d_nm :: (Integral a) => [a] -> Maybe Char+d_nm x =+    case x of+      [0,2,4,5,7,9,11] -> Just 'd'+      [0,2,3,5,7,9,11] -> Just 'm'+      [0,1,3,4,6,7,9,10] -> Just 'o'+      _ -> Nothing++-- | Diatonic implications.+dim :: [Z12] -> [(Z12,[Z12])]+dim p =+    let g (i,q) = is_subset p (T.tn i q)+        f = filter g . zip [0..11] . repeat+        d = [0,2,4,5,7,9,11]+        m = [0,2,3,5,7,9,11]+        o = [0,1,3,4,6,7,9,10]+    in f d ++ f m ++ f o++-- | Variant of 'dim' that is closer to the 'pct' form.+--+-- >>> dim 016+-- T1d+-- T1m+-- T0o+--+-- > dim_nm [0,1,6] == [(1,'d'),(1,'m'),(0,'o')]+dim_nm :: [Z12] -> [(Z12,Char)]+dim_nm =+    let pk f (i,j) = (i,f j)+    in nubBy ((==) `on` snd) . map (pk (fromJust.d_nm)) . dim++-- | Diatonic interval set to interval set.+--+-- >>> dis 24+-- 1256+--+-- > dis [2,4] == [1,2,5,6]+dis :: (Integral t) => [Int] -> [t]+dis =+    let is = [[], [], [1,2], [3,4], [5,6], [6,7], [8,9], [10,11]]+    in concatMap (\j -> is !! j)++-- | Degree of intersection.+--+-- >>> echo 024579e | doi 6 | sort -u+-- 024579A+-- 024679B+--+-- > let p = [0,2,4,5,7,9,11]+-- > in doi 6 p p == [[0,2,4,5,7,9,10],[0,2,4,6,7,9,11]]+--+-- >>> echo 01234 | doi 2 7-35 | sort -u+-- 13568AB+--+-- > doi 2 (sc "7-35") [0,1,2,3,4] == [[1,3,5,6,8,10,11]]+doi :: Int -> [Z12] -> [Z12] -> [[Z12]]+doi n p q =+    let f j = [T.tn j p,T.tni j p]+        xs = concatMap f [0..11]+    in S.set (filter (\x -> length (x `intersect` q) == n) xs)++-- | Forte name.+fn :: [Z12] -> String+fn = sc_name++-- | p `has_ess` q is true iff p can embed q in sequence.+has_ess :: [Z12] -> [Z12] -> Bool+has_ess _ [] = True+has_ess [] _ = False+has_ess (p:ps) (q:qs) = if p == q+                        then has_ess ps qs+                        else has_ess ps (q:qs)++-- | Embedded segment search.+--+-- >>> echo 23a | ess 0164325+-- 2B013A9+-- 923507A+--+-- > ess [2,3,10] [0,1,6,4,3,2,5] == [[9,2,3,5,0,7,10],[2,11,0,1,3,10,9]]+ess :: [Z12] -> [Z12] -> [[Z12]]+ess p = filter (`has_ess` p) . S.rtmi_related++-- | Can the set-class q (under prime form algorithm pf) be+--   drawn from the pcset p.+has_sc_pf :: (Integral a) => ([a] -> [a]) -> [a] -> [a] -> Bool+has_sc_pf pf p q =+    let n = length q+    in q `elem` map pf (cf [n] (cg p))++-- | Can the set-class q be drawn from the pcset p.+has_sc :: [Z12] -> [Z12] -> Bool+has_sc = has_sc_pf forte_prime++-- | Interval cycle filter.+--+-- >>> echo 22341 | icf+-- 22341+--+-- > icf [[2,2,3,4,1]] == [[2,2,3,4,1]]+icf :: (Num a,Eq a) => [[a]] -> [[a]]+icf = filter ((== 12) . sum)++-- | Interval class set to interval sets.+--+-- >>> ici -c 123+-- 123+-- 129+-- 1A3+-- 1A9+--+-- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]]+ici :: (Num t) => [Int] -> [[t]]+ici xs =+    let is j = [[0], [1,11], [2,10], [3,9], [4,8], [5,7], [6]] !! j+        ys = map is xs+    in cgg ys++-- | Interval class set to interval sets, concise variant.+--+-- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]]+ici_c :: [Int] -> [[Int]]+ici_c [] = []+ici_c (x:xs) = map (x:) (ici xs)++-- | Interval-class segment.+--+-- >>> icseg 013265e497t8+-- 12141655232+--+-- > icseg [0,1,3,2,6,5,11,4,9,7,10,8] == [1,2,1,4,1,6,5,5,2,3,2]+icseg :: [Z12] -> [Z12]+icseg = map ic . iseg++-- | Interval segment (INT).+iseg :: [Z12] -> [Z12]+iseg = int++-- | Imbrications.+imb :: (Integral n) => [n] -> [a] -> [[a]]+imb cs p =+    let g n = (== n) . genericLength+        f ps n = filter (g n) (map (genericTake n) ps)+    in concatMap (f (tails p)) cs++-- | 'issb' gives the set-classes that can append to 'p' to give 'q'.+--+-- >>> issb 3-7 6-32+-- 3-7+-- 3-2+-- 3-11+--+-- > issb (sc "3-7") (sc "6-32") == ["3-2","3-7","3-11"]+issb :: [Z12] -> [Z12] -> [String]+issb p q =+    let k = length q - length p+        f = any id . map (\x -> forte_prime (p ++ x) == q) . T.ti_related+    in map sc_name (filter f (cf [k] scs))++-- | Matrix search.+--+-- >>> mxs 024579 642 | sort -u+-- 6421B9+-- B97642+--+-- > S.set (mxs [0,2,4,5,7,9] [6,4,2]) == [[6,4,2,1,11,9],[11,9,7,6,4,2]]+mxs :: [Z12] -> [Z12] -> [[Z12]]+mxs p q = filter (q `isInfixOf`) (S.rti_related p)++-- | Normalize.+--+-- >>> nrm 0123456543210+-- 0123456+--+-- > nrm [0,1,2,3,4,5,6,5,4,3,2,1,0] == [0,1,2,3,4,5,6]+nrm :: (Ord a) => [a] -> [a]+nrm = S.set++-- | Normalize, retain duplicate elements.+nrm_r :: (Ord a) => [a] -> [a]+nrm_r = sort++-- | Pitch-class invariances (called @pi@ at @pct@).+--+-- >>> pi 0236 12+-- 0236+-- 6320+-- 532B+-- B235+--+-- > pci [0,2,3,6] [1,2] == [[0,2,3,6],[5,3,2,11],[6,3,2,0],[11,2,3,5]]+pci :: [Z12] -> [Z12] -> [[Z12]]+pci p i =+    let f q = S.set (map (q `genericIndex`) i)+    in filter (\q -> f q == f p) (S.rti_related p)++-- | Relate sets.+--+-- >>> rs 0123 641e+-- T1M+--+-- > import Music.Theory.Z12.Morris_1987.Parse+-- > rs [0,1,2,3] [6,4,1,11] == [(rnrtnmi "T1M",[1,6,11,4])+-- >                            ,(rnrtnmi "T4MI",[4,11,6,1])]+rs :: [Z12] -> [Z12] -> [(SRO, [Z12])]+rs x y =+    let xs = map (\o -> (o, o `sro` x)) sro_TnMI+        q = S.set y+    in filter (\(_,p) -> S.set p == q) xs++-- | Relate segments.+--+-- >>> rsg 156 3BA+-- T4I+--+-- > rsg [1,5,6] [3,11,10] == [rnrtnmi "T4I",rnrtnmi "r1RT4MI"]+--+-- >>> rsg 0123 05t3+-- T0M+--+-- > rsg [0,1,2,3] [0,5,10,3] == [rnrtnmi "T0M",rnrtnmi "RT3MI"]+--+-- >>> rsg 0123 4e61+-- RT1M+--+-- > rsg [0,1,2,3] [4,11,6,1] == [rnrtnmi "T4MI",rnrtnmi "RT1M"]+--+-- >>> echo e614 | rsg 0123+-- r3RT1M+--+-- > rsg [0,1,2,3] [11,6,1,4] == [rnrtnmi "r1T4MI",rnrtnmi "r1RT1M"]+--+rsg :: [Z12] -> [Z12] -> [SRO]+rsg x y = map fst (filter (\(_,x') -> x' == y) (sros x))++-- | Subsets.+sb :: [[Z12]] -> [[Z12]]+sb xs =+    let f p = all id (map (`has_sc` p) xs)+    in filter f scs++-- | Super set-class.+--+-- >>> spsc 4-11 4-12+-- 5-26[02458]+--+-- > spsc [sc "4-11", sc "4-12"] == ["5-26"]+--+-- >>> spsc 3-11 3-8+-- 4-27[0258]+-- 4-Z29[0137]+--+-- > spsc [sc "3-11", sc "3-8"] == ["4-27","4-Z29"]+--+-- >>> spsc `fl 3`+-- 6-Z17[012478]+--+-- > spsc (cf [3] scs) == ["6-Z17"]+spsc :: [[Z12]] -> [String]+spsc xs =+    let f y = all (y `has_sc`) xs+        g = (==) `on` length+    in (map sc_name . head . groupBy g . filter f) scs
+ Music/Theory/Z12/Forte_1973.hs view
@@ -0,0 +1,348 @@+-- | Allen Forte. /The Structure of Atonal Music/. Yale University+-- Press, New Haven, 1973.+module Music.Theory.Z12.Forte_1973 where++import Data.List+import Data.Maybe+import Music.Theory.List+import qualified Music.Theory.Set.List as S+import Music.Theory.Z12+import Music.Theory.Z12.SRO++-- * Prime form++-- | T-related rotations of /p/.+--+-- > t_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]]+t_rotations :: [Z12] -> [[Z12]]+t_rotations p =+    let r = rotations (sort p)+    in map (tn_to 0) r++-- | T\/I-related rotations of /p/.+--+-- > ti_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]+-- >                         ,[0,9,11],[0,2,3],[0,1,10]]+ti_rotations :: [Z12] -> [[Z12]]+ti_rotations p =+    let q = invert 0 p+        r = rotations (sort p) ++ rotations (sort q)+    in map (tn_to 0) r++-- | Variant with default value for empty input list case.+minimumBy_or :: a -> (a -> a -> Ordering) -> [a] -> a+minimumBy_or p f q = if null q then p else minimumBy f q++-- | Prime form rule requiring comparator, considering 't_rotations'.+t_cmp_prime :: ([Z12] -> [Z12] -> Ordering) -> [Z12] -> [Z12]+t_cmp_prime f = minimumBy_or [] f . t_rotations++-- | Prime form rule requiring comparator, considering 'ti_rotations'.+ti_cmp_prime :: ([Z12] -> [Z12] -> Ordering) -> [Z12] -> [Z12]+ti_cmp_prime f = minimumBy_or [] f . ti_rotations++-- | Forte comparison function (rightmost first then leftmost outwards).+--+-- > forte_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == LT+forte_cmp :: (Ord t) => [t] -> [t] -> Ordering+forte_cmp [] [] = EQ+forte_cmp p  q  =+    let r = compare (last p) (last q)+    in if r == EQ then compare p q else r++-- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'.+--+-- > forte_prime [0,1,3,6,8,9] == [0,1,3,6,8,9]+forte_prime :: [Z12] -> [Z12]+forte_prime = ti_cmp_prime forte_cmp++-- * Set Class Table++-- | Synonym for 'String'.+type SC_Name = String++-- | The set-class table (Forte prime forms).+sc_table :: [(SC_Name,[Z12])]+sc_table =+    [("0-1",[])+    ,("1-1",[0])+    ,("2-1",[0,1])+    ,("2-2",[0,2])+    ,("2-3",[0,3])+    ,("2-4",[0,4])+    ,("2-5",[0,5])+    ,("2-6",[0,6])+    ,("3-1",[0,1,2])+    ,("3-2",[0,1,3])+    ,("3-3",[0,1,4])+    ,("3-4",[0,1,5])+    ,("3-5",[0,1,6])+    ,("3-6",[0,2,4])+    ,("3-7",[0,2,5])+    ,("3-8",[0,2,6])+    ,("3-9",[0,2,7])+    ,("3-10",[0,3,6])+    ,("3-11",[0,3,7])+    ,("3-12",[0,4,8])+    ,("4-1",[0,1,2,3])+    ,("4-2",[0,1,2,4])+    ,("4-3",[0,1,3,4])+    ,("4-4",[0,1,2,5])+    ,("4-5",[0,1,2,6])+    ,("4-6",[0,1,2,7])+    ,("4-7",[0,1,4,5])+    ,("4-8",[0,1,5,6])+    ,("4-9",[0,1,6,7])+    ,("4-10",[0,2,3,5])+    ,("4-11",[0,1,3,5])+    ,("4-12",[0,2,3,6])+    ,("4-13",[0,1,3,6])+    ,("4-14",[0,2,3,7])+    ,("4-Z15",[0,1,4,6])+    ,("4-16",[0,1,5,7])+    ,("4-17",[0,3,4,7])+    ,("4-18",[0,1,4,7])+    ,("4-19",[0,1,4,8])+    ,("4-20",[0,1,5,8])+    ,("4-21",[0,2,4,6])+    ,("4-22",[0,2,4,7])+    ,("4-23",[0,2,5,7])+    ,("4-24",[0,2,4,8])+    ,("4-25",[0,2,6,8])+    ,("4-26",[0,3,5,8])+    ,("4-27",[0,2,5,8])+    ,("4-28",[0,3,6,9])+    ,("4-Z29",[0,1,3,7])+    ,("5-1",[0,1,2,3,4])+    ,("5-2",[0,1,2,3,5])+    ,("5-3",[0,1,2,4,5])+    ,("5-4",[0,1,2,3,6])+    ,("5-5",[0,1,2,3,7])+    ,("5-6",[0,1,2,5,6])+    ,("5-7",[0,1,2,6,7])+    ,("5-8",[0,2,3,4,6])+    ,("5-9",[0,1,2,4,6])+    ,("5-10",[0,1,3,4,6])+    ,("5-11",[0,2,3,4,7])+    ,("5-Z12",[0,1,3,5,6])+    ,("5-13",[0,1,2,4,8])+    ,("5-14",[0,1,2,5,7])+    ,("5-15",[0,1,2,6,8])+    ,("5-16",[0,1,3,4,7])+    ,("5-Z17",[0,1,3,4,8])+    ,("5-Z18",[0,1,4,5,7])+    ,("5-19",[0,1,3,6,7])+    ,("5-20",[0,1,3,7,8])+    ,("5-21",[0,1,4,5,8])+    ,("5-22",[0,1,4,7,8])+    ,("5-23",[0,2,3,5,7])+    ,("5-24",[0,1,3,5,7])+    ,("5-25",[0,2,3,5,8])+    ,("5-26",[0,2,4,5,8])+    ,("5-27",[0,1,3,5,8])+    ,("5-28",[0,2,3,6,8])+    ,("5-29",[0,1,3,6,8])+    ,("5-30",[0,1,4,6,8])+    ,("5-31",[0,1,3,6,9])+    ,("5-32",[0,1,4,6,9])+    ,("5-33",[0,2,4,6,8])+    ,("5-34",[0,2,4,6,9])+    ,("5-35",[0,2,4,7,9])+    ,("5-Z36",[0,1,2,4,7])+    ,("5-Z37",[0,3,4,5,8])+    ,("5-Z38",[0,1,2,5,8])+    ,("6-1",[0,1,2,3,4,5])+    ,("6-2",[0,1,2,3,4,6])+    ,("6-Z3",[0,1,2,3,5,6])+    ,("6-Z4",[0,1,2,4,5,6])+    ,("6-5",[0,1,2,3,6,7])+    ,("6-Z6",[0,1,2,5,6,7])+    ,("6-7",[0,1,2,6,7,8])+    ,("6-8",[0,2,3,4,5,7])+    ,("6-9",[0,1,2,3,5,7])+    ,("6-Z10",[0,1,3,4,5,7])+    ,("6-Z11",[0,1,2,4,5,7])+    ,("6-Z12",[0,1,2,4,6,7])+    ,("6-Z13",[0,1,3,4,6,7])+    ,("6-14",[0,1,3,4,5,8])+    ,("6-15",[0,1,2,4,5,8])+    ,("6-16",[0,1,4,5,6,8])+    ,("6-Z17",[0,1,2,4,7,8])+    ,("6-18",[0,1,2,5,7,8])+    ,("6-Z19",[0,1,3,4,7,8])+    ,("6-20",[0,1,4,5,8,9])+    ,("6-21",[0,2,3,4,6,8])+    ,("6-22",[0,1,2,4,6,8])+    ,("6-Z23",[0,2,3,5,6,8])+    ,("6-Z24",[0,1,3,4,6,8])+    ,("6-Z25",[0,1,3,5,6,8])+    ,("6-Z26",[0,1,3,5,7,8])+    ,("6-27",[0,1,3,4,6,9])+    ,("6-Z28",[0,1,3,5,6,9])+    ,("6-Z29",[0,1,3,6,8,9])+    ,("6-30",[0,1,3,6,7,9])+    ,("6-31",[0,1,3,5,8,9])+    ,("6-32",[0,2,4,5,7,9])+    ,("6-33",[0,2,3,5,7,9])+    ,("6-34",[0,1,3,5,7,9])+    ,("6-35",[0,2,4,6,8,10])+    ,("6-Z36",[0,1,2,3,4,7])+    ,("6-Z37",[0,1,2,3,4,8])+    ,("6-Z38",[0,1,2,3,7,8])+    ,("6-Z39",[0,2,3,4,5,8])+    ,("6-Z40",[0,1,2,3,5,8])+    ,("6-Z41",[0,1,2,3,6,8])+    ,("6-Z42",[0,1,2,3,6,9])+    ,("6-Z43",[0,1,2,5,6,8])+    ,("6-Z44",[0,1,2,5,6,9])+    ,("6-Z45",[0,2,3,4,6,9])+    ,("6-Z46",[0,1,2,4,6,9])+    ,("6-Z47",[0,1,2,4,7,9])+    ,("6-Z48",[0,1,2,5,7,9])+    ,("6-Z49",[0,1,3,4,7,9])+    ,("6-Z50",[0,1,4,6,7,9])+    ,("7-1",[0,1,2,3,4,5,6])+    ,("7-2",[0,1,2,3,4,5,7])+    ,("7-3",[0,1,2,3,4,5,8])+    ,("7-4",[0,1,2,3,4,6,7])+    ,("7-5",[0,1,2,3,5,6,7])+    ,("7-6",[0,1,2,3,4,7,8])+    ,("7-7",[0,1,2,3,6,7,8])+    ,("7-8",[0,2,3,4,5,6,8])+    ,("7-9",[0,1,2,3,4,6,8])+    ,("7-10",[0,1,2,3,4,6,9])+    ,("7-11",[0,1,3,4,5,6,8])+    ,("7-Z12",[0,1,2,3,4,7,9])+    ,("7-13",[0,1,2,4,5,6,8])+    ,("7-14",[0,1,2,3,5,7,8])+    ,("7-15",[0,1,2,4,6,7,8])+    ,("7-16",[0,1,2,3,5,6,9])+    ,("7-Z17",[0,1,2,4,5,6,9])+    ,("7-Z18",[0,1,2,3,5,8,9])+    ,("7-19",[0,1,2,3,6,7,9])+    ,("7-20",[0,1,2,4,7,8,9])+    ,("7-21",[0,1,2,4,5,8,9])+    ,("7-22",[0,1,2,5,6,8,9])+    ,("7-23",[0,2,3,4,5,7,9])+    ,("7-24",[0,1,2,3,5,7,9])+    ,("7-25",[0,2,3,4,6,7,9])+    ,("7-26",[0,1,3,4,5,7,9])+    ,("7-27",[0,1,2,4,5,7,9])+    ,("7-28",[0,1,3,5,6,7,9])+    ,("7-29",[0,1,2,4,6,7,9])+    ,("7-30",[0,1,2,4,6,8,9])+    ,("7-31",[0,1,3,4,6,7,9])+    ,("7-32",[0,1,3,4,6,8,9])+    ,("7-33",[0,1,2,4,6,8,10])+    ,("7-34",[0,1,3,4,6,8,10])+    ,("7-35",[0,1,3,5,6,8,10])+    ,("7-Z36",[0,1,2,3,5,6,8])+    ,("7-Z37",[0,1,3,4,5,7,8])+    ,("7-Z38",[0,1,2,4,5,7,8])+    ,("8-1",[0,1,2,3,4,5,6,7])+    ,("8-2",[0,1,2,3,4,5,6,8])+    ,("8-3",[0,1,2,3,4,5,6,9])+    ,("8-4",[0,1,2,3,4,5,7,8])+    ,("8-5",[0,1,2,3,4,6,7,8])+    ,("8-6",[0,1,2,3,5,6,7,8])+    ,("8-7",[0,1,2,3,4,5,8,9])+    ,("8-8",[0,1,2,3,4,7,8,9])+    ,("8-9",[0,1,2,3,6,7,8,9])+    ,("8-10",[0,2,3,4,5,6,7,9])+    ,("8-11",[0,1,2,3,4,5,7,9])+    ,("8-12",[0,1,3,4,5,6,7,9])+    ,("8-13",[0,1,2,3,4,6,7,9])+    ,("8-14",[0,1,2,4,5,6,7,9])+    ,("8-Z15",[0,1,2,3,4,6,8,9])+    ,("8-16",[0,1,2,3,5,7,8,9])+    ,("8-17",[0,1,3,4,5,6,8,9])+    ,("8-18",[0,1,2,3,5,6,8,9])+    ,("8-19",[0,1,2,4,5,6,8,9])+    ,("8-20",[0,1,2,4,5,7,8,9])+    ,("8-21",[0,1,2,3,4,6,8,10])+    ,("8-22",[0,1,2,3,5,6,8,10])+    ,("8-23",[0,1,2,3,5,7,8,10])+    ,("8-24",[0,1,2,4,5,6,8,10])+    ,("8-25",[0,1,2,4,6,7,8,10])+    ,("8-26",[0,1,2,4,5,7,9,10])+    ,("8-27",[0,1,2,4,5,7,8,10])+    ,("8-28",[0,1,3,4,6,7,9,10])+    ,("8-Z29",[0,1,2,3,5,6,7,9])+    ,("9-1",[0,1,2,3,4,5,6,7,8])+    ,("9-2",[0,1,2,3,4,5,6,7,9])+    ,("9-3",[0,1,2,3,4,5,6,8,9])+    ,("9-4",[0,1,2,3,4,5,7,8,9])+    ,("9-5",[0,1,2,3,4,6,7,8,9])+    ,("9-6",[0,1,2,3,4,5,6,8,10])+    ,("9-7",[0,1,2,3,4,5,7,8,10])+    ,("9-8",[0,1,2,3,4,6,7,8,10])+    ,("9-9",[0,1,2,3,5,6,7,8,10])+    ,("9-10",[0,1,2,3,4,6,7,9,10])+    ,("9-11",[0,1,2,3,5,6,7,9,10])+    ,("9-12",[0,1,2,4,5,6,8,9,10])+    ,("10-1",[0,1,2,3,4,5,6,7,8,9])+    ,("10-2",[0,1,2,3,4,5,6,7,8,10])+    ,("10-3",[0,1,2,3,4,5,6,7,9,10])+    ,("10-4",[0,1,2,3,4,5,6,8,9,10])+    ,("10-5",[0,1,2,3,4,5,7,8,9,10])+    ,("10-6",[0,1,2,3,4,6,7,8,9,10])+    ,("11-1",[0,1,2,3,4,5,6,7,8,9,10])+    ,("12-1",[0,1,2,3,4,5,6,7,8,9,10,11])]++-- | Lookup a set-class name.  The input set is subject to+-- 'forte_prime' before lookup.+--+-- > sc_name [0,2,3,6,7] == "5-Z18"+-- > sc_name [0,1,4,6,7,8] == "6-Z17"+sc_name :: [Z12] -> SC_Name+sc_name p =+    let n = find (\(_,q) -> forte_prime p == q) sc_table+    in fst (fromJust n)++-- | Lookup a set-class given a set-class name.+--+-- > sc "6-Z17" == [0,1,2,4,7,8]+sc :: SC_Name -> [Z12]+sc n = snd (fromJust (find (\(m,_) -> n == m) sc_table))++-- | List of set classes.+scs :: [[Z12]]+scs = map snd sc_table++-- | Cardinality /n/ subset of 'scs'.+--+-- > map (length . scs_n) [2..10] == [6,12,29,38,50,38,29,12,6]+scs_n :: Integral i => i -> [[Z12]]+scs_n n = filter ((== n) . genericLength) scs++-- * BIP Metric++-- | Basic interval pattern, see Allen Forte \"The Basic Interval Patterns\"+-- /JMT/ 17/2 (1973):234-272+--+-- >>> bip 0t95728e3416+-- 11223344556+--+-- > bip [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6]+-- > bip (pco "0t95728e3416") == [1,1,2,2,3,3,4,4,5,5,6]+bip :: [Z12] -> [Z12]+bip = sort . map ic . d_dx++-- * ICV Metric++-- | Interval class of Z12 interval /i/.+--+-- > map ic [5,6,7] == [5,6,5]+ic :: Z12 -> Z12+ic i = if i <= 6 then i else 12 - i++-- | Forte notation for interval class vector.+--+-- > icv [0,1,2,4,7,8] == [3,2,2,3,3,2]+icv :: Integral i => [Z12] -> [i]+icv s =+    let i = map (ic . uncurry (-)) (S.pairs s)+        j = map f (group (sort i))+        k = map (`lookup` j) [1..6]+        f l = (head l,genericLength l)+    in map (fromMaybe 0) k
+ Music/Theory/Z12/Lewin_1980.hs view
@@ -0,0 +1,47 @@+-- | David Lewin. \"A Response to a Response: On PC Set+-- Relatedness\". /Perspectives of New Music/, 18(1-2):498-502, 1980.+module Music.Theory.Z12.Lewin_1980 where++import Data.List+import Music.Theory.Z12+import qualified Music.Theory.Z12.Castren_1994 as C++-- | REL function with given /ncv/ function (see 't_rel' and 'ti_rel').+rel :: Floating n => (Int -> [a] -> [n]) -> [a] -> [a] -> n+rel ncv x y =+    let n = min (genericLength x) (genericLength y)+        p = map (`ncv` x) [2..n]+        q = map (`ncv` y) [2..n]+        f = zipWith (\i j -> sqrt (i * j))+        pt = sum (map sum p)+        qt = sum (map sum q)+    in sum (map sum (zipWith f p q)) / sqrt (pt * qt)++-- | T-equivalence REL function.+--+-- Kuusi 2001, 7.5.2+--+-- > let (~=) p q = abs (p - q) < 1e-2+-- > t_rel [0,1,2,3,4] [0,2,3,6,7] ~= 0.44+-- > t_rel [0,1,2,3,4] [0,2,4,6,8] ~= 0.28+-- > t_rel [0,2,3,6,7] [0,2,4,6,8] ~= 0.31+t_rel :: Floating n => [Z12] -> [Z12] -> n+t_rel = rel C.t_n_class_vector++-- | T/I-equivalence REL function.+--+-- Buchler 1998, Fig. 3.38+--+-- > let (~=) p q = abs (p - q) < 1e-3+-- > let a = [0,2,3,5,7]::[Z12]+-- > let b = [0,2,3,4,5,8]::[Z12]+-- > let g = [0,1,2,3,5,6,8,10]::[Z12]+-- > let j = [0,2,3,4,5,6,8]::[Z12]+-- > ti_rel a b ~= 0.593+-- > ti_rel a g ~= 0.648+-- > ti_rel a j ~= 0.509+-- > ti_rel b g ~= 0.712+-- > ti_rel b j ~= 0.892+-- > ti_rel g j ~= 0.707+ti_rel :: Floating n => [Z12] -> [Z12] -> n+ti_rel = rel C.ti_n_class_vector
+ Music/Theory/Z12/Literature.hs view
@@ -0,0 +1,48 @@+-- | Z12 set class database.+module Music.Theory.Z12.Literature where++-- | Set class database with descriptors for historically and+-- theoretically significant set classes, indexed by Forte name.+--+-- > lookup "6-Z17" sc_db == Just "All-Trichord Hexachord"+-- > lookup "7-35" sc_db == Just "diatonic collection (d)"+sc_db :: [(String,String)]+sc_db =+    [("4-Z15","All-Interval Tetrachord (see also 4-Z29)")+    ,("4-Z29","All-Interval Tetrachord (see also 4-Z15)")+    ,("6-Z17","All-Trichord Hexachord")+    ,("8-Z15","All-Tetrachord Octochord (see also 8-Z29)")+    ,("8-Z29","All-Tetrachord Octochord (see also 8-Z15)")+    ,("6-1","A-Type All-Combinatorial Hexachord")+    ,("6-8","B-Type All-Combinatorial Hexachord")+    ,("6-32","C-Type All-Combinatorial Hexachord")+    ,("6-7","D-Type All-Combinatorial Hexachord")+    ,("6-20","E-Type All-Combinatorial Hexachord")+    ,("6-35","F-Type All-Combinatorial Hexachord")+    ,("7-35","diatonic collection (d)")+    ,("7-34","ascending melodic minor collection")+    ,("8-28","octotonic collection (Messiaen Mode II)")+    ,("6-35","wholetone collection")+    ,("3-10","diminished triad")+    ,("3-11","major/minor triad")+    ,("3-12","augmented triad")+    ,("4-19","minor major-seventh chord")+    ,("4-20","major-seventh chord")+    ,("4-25","french augmented sixth chord")+    ,("4-28","dimished-seventh chord")+    ,("4-26","minor-seventh chord")+    ,("4-27","half-dimished seventh(P)/dominant-seventh(I) chord")+    ,("6-30","Petrushka Chord {0476a1},3-11 at T6")+    ,("6-34","Mystic Chord {06a492}")+    ,("6-Z44","Schoenberg Signature Set,3-3 at T5 or T7")+    ,("6-Z19","complement of 6-Z44,3-11 at T1 or TB")+    ,("9-12","Messiaen Mode III (nontonic collection)")+    ,("8-9","Messian Mode IV")+    ,("7-31","The only seven-element subset of 8-28. ")+    ,("5-31","The only five-element superset of 4-28.")+    ,("5-33","The only five-element subset of 6-35.")+    ,("7-33","The only seven-element superset of 6-35.")+    ,("5-21","The only five-element subset of 6-20.")+    ,("7-21","The only seven-element superset of 6-20.")+    ,("5-25","The only five-element subset of both 7-35 and 8-28.")+    ,("6-14","Any non-intersecting union of 3-6 and 3-12.") ]
+ Music/Theory/Z12/Morris_1974.hs view
@@ -0,0 +1,36 @@+-- | Robert Morris and D. Starr. \"The Structure of All-Interval Series\".+-- /Journal of Music Theory/, 18:364-389, 1974.+module Music.Theory.Z12.Morris_1974 where++import Control.Monad.Logic {- logict -}++-- | 'msum' '.' 'map' 'return'.+--+-- > observeAll (fromList [1..7]) == [1..7]+fromList :: MonadPlus m => [a] -> m a+fromList = msum . map return++-- | 'MonadPlus' all-interval series.+--+-- > [0,1,3,2,9,5,10,4,7,11,8,6] `elem` observeAll (all_interval_m 12)+-- > length (observeAll (all_interval_m 12)) == 3856+-- > map (length . observeAll . all_interval_m) [4,6,8,10] == [2,4,24,288]+all_interval_m :: MonadPlus m => Int -> m [Int]+all_interval_m n =+    let rec p q =+            if length p == n+            then return (reverse p)+            else do i <- fromList [1 .. n - 1]+                    guard (i `notElem` p)+                    let j:_ = p+                        m = abs ((i - j) `mod` n)+                    guard (m `notElem` q)+                    rec (i:p) (m:q)+    in rec [0] []++-- | 'observeAll' of 'all_interval_m'.+--+-- > let r = [[0,1,5,2,4,3],[0,2,1,4,5,3],[0,4,5,2,1,3],[0,5,1,4,2,3]]+-- > in all_interval 6 == r+all_interval :: Int -> [[Int]]+all_interval = observeAll . all_interval_m
+ Music/Theory/Z12/Morris_1987.hs view
@@ -0,0 +1,99 @@+-- | Robert Morris. /Composition with Pitch-Classes: A Theory of+-- Compositional Design/. Yale University Press, New Haven, 1987.+module Music.Theory.Z12.Morris_1987 where++import Data.List+import Music.Theory.List+import Music.Theory.Z12+import Music.Theory.Z12.SRO++-- | @INT@ operator.+--+-- > int [0,1,3,6,10] == [1,2,3,4]+int :: [Z12] -> [Z12]+int = d_dx++-- * Serial operations++-- | Serial Operator,of the form rRTMI.+data SRO = SRO Z12 Bool Z12 Bool Bool+           deriving (Eq,Show)++-- | Serial operation.+--+-- >>> sro T4 156+-- 59A+--+-- > sro (rnrtnmi "T4") (pco "156") == [5,9,10]+--+-- >>> echo 024579 | sro RT4I+-- 79B024+--+-- > sro (SRO 0 True 4 False True) [0,2,4,5,7,9] == [7,9,11,0,2,4]+--+-- >>> sro T4I 156+-- 3BA+--+-- > sro (rnrtnmi "T4I") (pco "156") == [3,11,10]+-- > sro (SRO 0 False 4 False True) [1,5,6] == [3,11,10]+--+-- >>> echo 156 | sro T4  | sro T0I+-- 732+--+-- > (sro (rnrtnmi "T0I") . sro (rnrtnmi "T4")) (pco "156") == [7,3,2]+--+-- >>> echo 024579 | sro RT4I+-- 79B024+--+-- > sro (rnrtnmi "RT4I") (pco "024579") == [7,9,11,0,2,4]+--+-- > sro (SRO 1 True 1 True False) [0,1,2,3] == [11,6,1,4]+-- > sro (SRO 1 False 4 True True) [0,1,2,3] == [11,6,1,4]+sro :: SRO -> [Z12] -> [Z12]+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 genericRotate_left r x4++-- | The total set of serial operations.+sros :: [Z12] -> [(SRO,[Z12])]+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]]++-- | The set of transposition 'SRO's.+sro_Tn ::[SRO]+sro_Tn = [SRO 0 False n False False | n <- [0..11]]++-- | The set of transposition and inversion 'SRO's.+sro_TnI ::[SRO]+sro_TnI = [SRO 0 False n False i |+           n <- [0..11],+           i <- [False,True]]++-- | The set of retrograde and transposition and inversion 'SRO's.+sro_RTnI ::[SRO]+sro_RTnI = [SRO 0 r n False i |+            r <- [True,False],+            n <- [0..11],+            i <- [False,True]]++-- | The set of transposition,@M5@ and inversion 'SRO's.+sro_TnMI ::[SRO]+sro_TnMI = [SRO 0 False n m i |+            n <- [0..11],+            m <- [True,False],+            i <- [True,False]]++-- | The set of retrograde,transposition,@M5@ and inversion 'SRO's.+sro_RTnMI ::[SRO]+sro_RTnMI = [SRO 0 r n m i |+             r <- [True,False],+             n <- [0..11],+             m <- [True,False],+             i <- [True,False]]
+ Music/Theory/Z12/Morris_1987/Parse.hs view
@@ -0,0 +1,56 @@+-- | Parsers for pitch class sets and sequences, and for 'SRO's.+module Music.Theory.Z12.Morris_1987.Parse (rnrtnmi,pco) where++import Control.Monad+import Data.Char+import Music.Theory.Z12+import Music.Theory.Z12.Morris_1987+import Text.ParserCombinators.Parsec++-- | A 'Char' parser.+type P a = GenParser Char () a++-- | Boolean 'P' for given 'Char'.+is_char :: Char -> P Bool+is_char c =+    let f '_' = False+        f _ = True+    in liftM f (option '_' (char c))++-- | Parse 'Int'.+get_int :: P Z12+get_int = liftM (fromInteger . read) (many1 digit)++-- | Parse a Morris format serial operator descriptor.+--+-- > rnrtnmi "r2RT3MI" == SRO 2 True 3 True True+rnrtnmi :: String -> SRO+rnrtnmi s =+  let p = do { r <- rot+             ; r' <- is_char 'R'+             ; _ <- char 'T'+             ; t <- get_int+             ; m <- is_char 'M'+             ; i <- is_char 'I'+             ; eof+             ; return (SRO r r' t m i) }+      rot = option 0 (char 'r' >> get_int)+  in either+         (\e -> error ("rnRTnMI parse failed\n" ++ show e))+         id+         (parse p "" s)++-- | Parse a /pitch class object/ string.  Each 'Char' is either a+-- number, a space which is ignored, or a letter name for the numbers+-- 10 ('t' or 'a' or 'A') or 11 ('e' or 'B' or 'b').+--+-- > pco "13te" == [1,3,10,11]+-- > pco "13te" == pco "13ab"+pco :: String -> [Z12]+pco s =+    let s' = dropWhile isSpace s+        s'' = takeWhile (`elem` "0123456789taAebB") s'+        f c | c `elem` "taA" = 10+            | c `elem` "ebB" = 11+            | otherwise = fromInteger (read [c])+    in map f s''
+ Music/Theory/Z12/Rahn_1980.hs view
@@ -0,0 +1,23 @@+-- | John Rahn. /Basic Atonal Theory/. Longman, New York, 1980.+module Music.Theory.Z12.Rahn_1980 where++import Music.Theory.Z12+import Music.Theory.Z12.Forte_1973++-- | Rahn prime form (comparison is rightmost inwards).+--+-- > rahn_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == GT+rahn_cmp :: Ord a => [a] -> [a] -> Ordering+rahn_cmp p q = compare (reverse p) (reverse q)++-- | Rahn prime form, ie. 'ti_cmp_prime' of 'rahn_cmp'.+--+-- > rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9]+--+-- > let s = [[0,1,3,7,8]+-- >         ,[0,1,3,6,8,9],[0,1,3,5,8,9]+-- >         ,[0,1,2,4,7,8,9]+-- >         ,[0,1,2,4,5,7,9,10]]+-- > in all (\p -> forte_prime p /= rahn_prime p) s == True+rahn_prime :: [Z12] -> [Z12]+rahn_prime = ti_cmp_prime rahn_cmp
+ Music/Theory/Z12/Read_1978.hs view
@@ -0,0 +1,31 @@+-- | Ronald C. Read. \"Every one a winner or how to avoid isomorphism+-- search when cataloguing combinatorial configurations.\" /Annals of+-- Discrete Mathematics/ 2:107–20, 1978.+module Music.Theory.Z12.Read_1978 where++import Data.Bits+import Music.Theory.Z12+import Music.Theory.Z12.SRO++-- | Encoder for 'encode_prime'.+--+-- > encode [0,1,3,6,8,9] == 843+encode :: [Z12] -> Integer+encode = sum . map ((2 ^) . (fromZ12::Z12->Integer))++-- | Decoder for 'encode_prime'.+--+-- > decode 843 == [0,1,3,6,8,9]+decode :: Integer -> [Z12]+decode n =+    let f i = (i, testBit n i)+    in map (toZ12 . fst) (filter snd (map f [0..11]))++-- | Binary encoding prime form algorithm, equalivalent to Rahn.+--+-- > encode_prime [0,1,3,6,8,9] == rahn_prime [0,1,3,6,8,9]+encode_prime :: [Z12] -> [Z12]+encode_prime s =+    let t = map (`tn` s) [0..11]+        c = t ++ map (invert 0) t+    in decode (minimum (map encode c))
+ Music/Theory/Z12/SRO.hs view
@@ -0,0 +1,97 @@+-- | Serial (ordered) pitch-class operations on 'Z12'.+module Music.Theory.Z12.SRO where++import Data.List+import qualified Music.Theory.List as T+import Music.Theory.Z12++-- | Transpose /p/ by /n/.+--+-- > tn 4 [1,5,6] == [5,9,10]+tn :: Z12 -> [Z12] -> [Z12]+tn n = fmap (+ n)++-- | Invert /p/ about /n/.+--+-- > invert 6 [4,5,6] == [8,7,6]+-- > invert 0 [0,1,3] == [0,11,9]+invert :: Z12 -> [Z12] -> [Z12]+invert n = fmap (\p -> n - (p - n))++-- | Composition of 'invert' about @0@ and 'tn'.+--+-- > tni 4 [1,5,6] == [3,11,10]+-- > (invert 0 . tn  4) [1,5,6] == [7,3,2]+tni :: Z12 -> [Z12] -> [Z12]+tni n = tn n . invert 0++-- | Modulo 12 multiplication+--+-- > mn 11 [0,1,4,9] == tni 0 [0,1,4,9]+mn :: Z12 -> [Z12] -> [Z12]+mn n = fmap (* n)++-- | M5, ie. 'mn' @5@.+--+-- > m5 [0,1,3] == [0,5,3]+m5 :: [Z12] -> [Z12]+m5 = mn 5++-- | T-related sequences of /p/.+--+-- > length (t_related [0,3,6,9]) == 12+t_related :: [Z12] -> [[Z12]]+t_related p = fmap (`tn` p) [0..11]++-- | T\/I-related sequences of /p/.+--+-- > length (ti_related [0,1,3]) == 24+-- > length (ti_related [0,3,6,9]) == 24+-- > ti_related [0] == map return [0..11]+ti_related :: [Z12] -> [[Z12]]+ti_related p = nub (t_related p ++ t_related (invert 0 p))++-- | R\/T\/I-related sequences of /p/.+--+-- > length (rti_related [0,1,3]) == 48+-- > length (rti_related [0,3,6,9]) == 24+rti_related :: [Z12] -> [[Z12]]+rti_related p = let q = ti_related p in nub (q ++ map reverse q)++-- | T\/M\/I-related sequences of /p/.+tmi_related :: [Z12] -> [[Z12]]+tmi_related p = let q = ti_related p in nub (q ++ map m5 q)++-- | R\/T\/M\/I-related sequences of /p/.+rtmi_related :: [Z12] -> [[Z12]]+rtmi_related p = let q = tmi_related p in nub (q ++ map reverse q)++-- | r\/R\/T\/M\/I-related sequences of /p/.+rrtmi_related :: [Z12] -> [[Z12]]+rrtmi_related p = nub (concatMap rtmi_related (T.rotations p))++-- * Sequence operations++-- | Variant of 'tn', transpose /p/ so first element is /n/.+--+-- > tn_to 5 [0,1,3] == [5,6,8]+tn_to :: Z12 -> [Z12] -> [Z12]+tn_to n p =+    case p of+      [] -> []+      x:xs -> n : tn (n - x) xs++-- | Variant of 'invert', inverse about /n/th element.+--+-- > map (invert_ix 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]]+-- > map (invert_ix 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]]+invert_ix :: Int -> [Z12] -> [Z12]+invert_ix n p = invert (p!!n) p++-- | The standard t-matrix of /p/.+--+-- > tmatrix [0,1,3] == [[0,1,3]+-- >                    ,[11,0,2]+-- >                    ,[9,10,0]]+tmatrix :: [Z12] -> [[Z12]]+tmatrix p = map (`tn` p) (tn_to 0 (invert_ix 0 p))
+ Music/Theory/Z12/TTO.hs view
@@ -0,0 +1,58 @@+-- | Pitch-class set (unordered) operations on 'Z12'.+module Music.Theory.Z12.TTO where++import Data.List+import Music.Theory.Z12++-- | Map to pitch-class and reduce to set.+--+-- > pcset [1,13] == [1]+pcset :: (Integral a) => [a] -> [Z12]+pcset = nub . sort . map fromIntegral++-- | Transpose by n.+--+-- > tn 4 [1,5,6] == [5,9,10]+-- > tn 4 [0,4,8] == [0,4,8]+tn :: Z12 -> [Z12] -> [Z12]+tn n = sort . map (+ n)++-- | Invert about n.+--+-- > invert 6 [4,5,6] == [6,7,8]+-- > invert 0 [0,1,3] == [0,9,11]+invert :: Z12 -> [Z12] -> [Z12]+invert n = sort . map (\p -> n - (p - n))++-- | Composition of 'invert' about @0@ and 'tn'.+--+-- > tni 4 [1,5,6] == [3,10,11]+-- > (invert 0 . tn  4) [1,5,6] == [2,3,7]+tni :: Z12 -> [Z12] -> [Z12]+tni n = tn n . invert 0++-- | Modulo 12 multiplication+--+-- > mn 11 [0,1,4,9] == invert 0 [0,1,4,9]+mn :: Z12 -> [Z12] -> [Z12]+mn n = sort . map (* n)++-- | M5, ie. 'mn' @5@.+--+-- > m5 [0,1,3] == [0,3,5]+m5 :: [Z12] -> [Z12]+m5 = mn 5++-- | T-related sets of /p/.+--+-- > length (t_related [0,1,3]) == 12+-- > t_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]]+t_related :: [Z12] -> [[Z12]]+t_related p = nub (map (`tn` p) [0..11])++-- | T\/I-related set of /p/.+--+-- > length (ti_related [0,1,3]) == 24+-- > ti_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]]+ti_related :: [Z12] -> [[Z12]]+ti_related p = nub (t_related p ++ t_related (invert 0 p))
README view
@@ -1,8 +1,11 @@ hmt - haskell music theory+-------------------------- -Music theory operations in haskell, primarily-focused on 'set theory' and 'common music-notation'.+Music theory operations in [haskell][hs], primarily focused on 'set+theory' and 'common music notation'. -(c) rohan drape, 2006-2011-    gpl, http://gnu.org/copyleft/+© [rohan drape][rd], 2006-2012, [gpl][gpl].++[hs]: http://haskell.org/+[rd]:  http://rd.slavepianos.org/+[gpl]: http://gnu.org/copyleft/
hmt.cabal view
@@ -1,15 +1,15 @@ Name:              hmt-Version:           0.11+Version:           0.12 Synopsis:          Haskell Music Theory Description:       Haskell music theory library License:           GPL Category:          Music-Copyright:         Rohan Drape, 2006-2011+Copyright:         Rohan Drape, 2006-2012 Author:            Rohan Drape Maintainer:        rd@slavepianos.org Stability:         Experimental-Homepage:          http://slavepianos.org/rd/?t=hmt-Tested-With:       GHC == 7.2.2+Homepage:          http://rd.slavepianos.org/?t=hmt+Tested-With:       GHC == 7.6.1 Build-Type:        Simple Cabal-Version:     >= 1.8 @@ -18,42 +18,85 @@  Library   Build-Depends:   base==4.*,-                   cairo,colour,containers,-                   hcg-minus==0.11.*,html-minimalist==0.11.*,+                   bytestring,+                   colour,+                   containers,+                   directory,+                   filepath,+                   hcg-minus==0.12.*,+                   html-minimalist==0.12.*,+                   logict,                    multiset-comb,                    parsec,                    permutation,+                   primes,                    split,                    utf8-string,                    xml   GHC-Options:     -Wall -fwarn-tabs   Exposed-modules: Music.Theory.Bjorklund+                   Music.Theory.Block_Design.Johnson_2007+                   Music.Theory.Clef+                   Music.Theory.Combinations                    Music.Theory.Contour.Polansky_1992                    Music.Theory.Diagram.Grid                    Music.Theory.Diagram.Path                    Music.Theory.Duration+                   Music.Theory.Duration.Annotation                    Music.Theory.Duration.Name                    Music.Theory.Duration.Name.Abbreviation                    Music.Theory.Duration.RQ+                   Music.Theory.Duration.RQ.Division+                   Music.Theory.Duration.RQ.Tied                    Music.Theory.Duration.Sequence.Notate+                   Music.Theory.Dynamic_Mark                    Music.Theory.Interval+                   Music.Theory.Interval.Barlow_1987                    Music.Theory.Interval.Name                    Music.Theory.Interval.Spelling+                   Music.Theory.Pitch.Spelling.Cluster                    Music.Theory.Key-                   Music.Theory.Parse-                   Music.Theory.Pct+                   Music.Theory.List+                   Music.Theory.Meter.Barlow_1987+                   Music.Theory.Metric.Buchler_1998+                   Music.Theory.Metric.Morris_1980+                   Music.Theory.Metric.Polansky_1996                    Music.Theory.Permutations+                   Music.Theory.Permutations.List                    Music.Theory.Pitch                    Music.Theory.Pitch.Name                    Music.Theory.Pitch.Spelling-                   Music.Theory.PitchClass-                   Music.Theory.Prime-                   Music.Theory.Set-                   Music.Theory.Table+                   Music.Theory.Set.List+                   Music.Theory.Set.Set+                   Music.Theory.Tempo_Marking+                   Music.Theory.Tiling.Canon+                   Music.Theory.Tiling.Johnson_2004+                   Music.Theory.Tiling.Johnson_2009+                   Music.Theory.Time_Signature                    Music.Theory.Tuning+                   Music.Theory.Tuning.Alves_1997+                   Music.Theory.Tuning.Meyer_1929+                   Music.Theory.Tuning.Polansky_1978+                   Music.Theory.Tuning.Polansky_1984+                   Music.Theory.Tuning.Polansky_1990+                   Music.Theory.Tuning.Scala+                   Music.Theory.Tuning.Table                    Music.Theory.Xenakis.S4                    Music.Theory.Xenakis.Sieve+                   Music.Theory.Z12+                   Music.Theory.Z12.Castren_1994+                   Music.Theory.Z12.Drape_1999+                   Music.Theory.Z12.Forte_1973+                   Music.Theory.Z12.Lewin_1980+                   Music.Theory.Z12.Literature+                   Music.Theory.Z12.Morris_1974+                   Music.Theory.Z12.Morris_1987+                   Music.Theory.Z12.Morris_1987.Parse+                   Music.Theory.Z12.Rahn_1980+                   Music.Theory.Z12.Read_1978+                   Music.Theory.Z12.SRO+                   Music.Theory.Z12.TTO  Source-Repository  head   Type:            darcs-  Location:        http://slavepianos.org/rd/sw/hmt+  Location:        http://rd.slavepianos.org/sw/hmt