diff --git a/Music/Theory/Block_Design/Johnson_2007.hs b/Music/Theory/Block_Design/Johnson_2007.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Block_Design/Johnson_2007.hs
@@ -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:
diff --git a/Music/Theory/Clef.hs b/Music/Theory/Clef.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Clef.hs
@@ -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
+
diff --git a/Music/Theory/Combinations.hs b/Music/Theory/Combinations.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Combinations.hs
@@ -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'
diff --git a/Music/Theory/Contour/Polansky_1992.hs b/Music/Theory/Contour/Polansky_1992.hs
--- a/Music/Theory/Contour/Polansky_1992.hs
+++ b/Music/Theory/Contour/Polansky_1992.hs
@@ -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)
 --
diff --git a/Music/Theory/Diagram/Grid.hs b/Music/Theory/Diagram/Grid.hs
--- a/Music/Theory/Diagram/Grid.hs
+++ b/Music/Theory/Diagram/Grid.hs
@@ -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
diff --git a/Music/Theory/Diagram/Path.hs b/Music/Theory/Diagram/Path.hs
--- a/Music/Theory/Diagram/Path.hs
+++ b/Music/Theory/Diagram/Path.hs
@@ -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)
diff --git a/Music/Theory/Duration.hs b/Music/Theory/Duration.hs
--- a/Music/Theory/Duration.hs
+++ b/Music/Theory/Duration.hs
@@ -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
diff --git a/Music/Theory/Duration/Annotation.hs b/Music/Theory/Duration/Annotation.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Duration/Annotation.hs
@@ -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
diff --git a/Music/Theory/Duration/RQ.hs b/Music/Theory/Duration/RQ.hs
--- a/Music/Theory/Duration/RQ.hs
+++ b/Music/Theory/Duration/RQ.hs
@@ -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'
diff --git a/Music/Theory/Duration/RQ/Division.hs b/Music/Theory/Duration/RQ/Division.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Duration/RQ/Division.hs
@@ -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)
diff --git a/Music/Theory/Duration/RQ/Tied.hs b/Music/Theory/Duration/RQ/Tied.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Duration/RQ/Tied.hs
@@ -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
diff --git a/Music/Theory/Duration/Sequence/Notate.hs b/Music/Theory/Duration/Sequence/Notate.hs
--- a/Music/Theory/Duration/Sequence/Notate.hs
+++ b/Music/Theory/Duration/Sequence/Notate.hs
@@ -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')
diff --git a/Music/Theory/Dynamic_Mark.hs b/Music/Theory/Dynamic_Mark.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Dynamic_Mark.hs
@@ -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
+
+
diff --git a/Music/Theory/Interval.hs b/Music/Theory/Interval.hs
--- a/Music/Theory/Interval.hs
+++ b/Music/Theory/Interval.hs
@@ -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.
diff --git a/Music/Theory/Interval/Barlow_1987.hs b/Music/Theory/Interval/Barlow_1987.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Interval/Barlow_1987.hs
@@ -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']
diff --git a/Music/Theory/List.hs b/Music/Theory/List.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/List.hs
@@ -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')
diff --git a/Music/Theory/Meter/Barlow_1987.hs b/Music/Theory/Meter/Barlow_1987.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Meter/Barlow_1987.hs
@@ -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
diff --git a/Music/Theory/Metric/Buchler_1998.hs b/Music/Theory/Metric/Buchler_1998.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Metric/Buchler_1998.hs
@@ -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:
diff --git a/Music/Theory/Metric/Morris_1980.hs b/Music/Theory/Metric/Morris_1980.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Metric/Morris_1980.hs
@@ -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')
diff --git a/Music/Theory/Metric/Polansky_1996.hs b/Music/Theory/Metric/Polansky_1996.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Metric/Polansky_1996.hs
@@ -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)
diff --git a/Music/Theory/Parse.hs b/Music/Theory/Parse.hs
deleted file mode 100644
--- a/Music/Theory/Parse.hs
+++ /dev/null
@@ -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''
diff --git a/Music/Theory/Pct.hs b/Music/Theory/Pct.hs
deleted file mode 100644
--- a/Music/Theory/Pct.hs
+++ /dev/null
@@ -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
diff --git a/Music/Theory/Permutations.hs b/Music/Theory/Permutations.hs
--- a/Music/Theory/Permutations.hs
+++ b/Music/Theory/Permutations.hs
@@ -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]]
diff --git a/Music/Theory/Permutations/List.hs b/Music/Theory/Permutations/List.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Permutations/List.hs
@@ -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
diff --git a/Music/Theory/Pitch.hs b/Music/Theory/Pitch.hs
--- a/Music/Theory/Pitch.hs
+++ b/Music/Theory/Pitch.hs
@@ -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
diff --git a/Music/Theory/Pitch/Name.hs b/Music/Theory/Pitch/Name.hs
--- a/Music/Theory/Pitch/Name.hs
+++ b/Music/Theory/Pitch/Name.hs
@@ -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
diff --git a/Music/Theory/Pitch/Spelling.hs b/Music/Theory/Pitch/Spelling.hs
--- a/Music/Theory/Pitch/Spelling.hs
+++ b/Music/Theory/Pitch/Spelling.hs
@@ -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)
diff --git a/Music/Theory/Pitch/Spelling/Cluster.hs b/Music/Theory/Pitch/Spelling/Cluster.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Pitch/Spelling/Cluster.hs
@@ -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)
diff --git a/Music/Theory/PitchClass.hs b/Music/Theory/PitchClass.hs
deleted file mode 100644
--- a/Music/Theory/PitchClass.hs
+++ /dev/null
@@ -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))
diff --git a/Music/Theory/Prime.hs b/Music/Theory/Prime.hs
deleted file mode 100644
--- a/Music/Theory/Prime.hs
+++ /dev/null
@@ -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]))
diff --git a/Music/Theory/Set.hs b/Music/Theory/Set.hs
deleted file mode 100644
--- a/Music/Theory/Set.hs
+++ /dev/null
@@ -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])
diff --git a/Music/Theory/Set/List.hs b/Music/Theory/Set/List.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Set/List.hs
@@ -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]
diff --git a/Music/Theory/Set/Set.hs b/Music/Theory/Set/Set.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Set/Set.hs
@@ -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
diff --git a/Music/Theory/Table.hs b/Music/Theory/Table.hs
deleted file mode 100644
--- a/Music/Theory/Table.hs
+++ /dev/null
@@ -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.") ]
diff --git a/Music/Theory/Tempo_Marking.hs b/Music/Theory/Tempo_Marking.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tempo_Marking.hs
@@ -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
diff --git a/Music/Theory/Tiling/Canon.hs b/Music/Theory/Tiling/Canon.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tiling/Canon.hs
@@ -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
diff --git a/Music/Theory/Tiling/Johnson_2004.hs b/Music/Theory/Tiling/Johnson_2004.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tiling/Johnson_2004.hs
@@ -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:
diff --git a/Music/Theory/Tiling/Johnson_2009.hs b/Music/Theory/Tiling/Johnson_2009.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tiling/Johnson_2009.hs
@@ -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:
diff --git a/Music/Theory/Time_Signature.hs b/Music/Theory/Time_Signature.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Time_Signature.hs
@@ -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)
+
diff --git a/Music/Theory/Tuning.hs b/Music/Theory/Tuning.hs
--- a/Music/Theory/Tuning.hs
+++ b/Music/Theory/Tuning.hs
@@ -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:
diff --git a/Music/Theory/Tuning/Alves_1997.hs b/Music/Theory/Tuning/Alves_1997.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tuning/Alves_1997.hs
@@ -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
diff --git a/Music/Theory/Tuning/Meyer_1929.hs b/Music/Theory/Tuning/Meyer_1929.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tuning/Meyer_1929.hs
@@ -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]])
diff --git a/Music/Theory/Tuning/Polansky_1978.hs b/Music/Theory/Tuning/Polansky_1978.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tuning/Polansky_1978.hs
@@ -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:
diff --git a/Music/Theory/Tuning/Polansky_1984.hs b/Music/Theory/Tuning/Polansky_1984.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tuning/Polansky_1984.hs
@@ -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
diff --git a/Music/Theory/Tuning/Polansky_1990.hs b/Music/Theory/Tuning/Polansky_1990.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tuning/Polansky_1990.hs
@@ -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
diff --git a/Music/Theory/Tuning/Scala.hs b/Music/Theory/Tuning/Scala.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tuning/Scala.hs
@@ -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:
diff --git a/Music/Theory/Tuning/Table.hs b/Music/Theory/Tuning/Table.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Tuning/Table.hs
@@ -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])
+
diff --git a/Music/Theory/Xenakis/Sieve.hs b/Music/Theory/Xenakis/Sieve.hs
--- a/Music/Theory/Xenakis/Sieve.hs
+++ b/Music/Theory/Xenakis/Sieve.hs
@@ -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 =
diff --git a/Music/Theory/Z12.hs b/Music/Theory/Z12.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12.hs
@@ -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]
diff --git a/Music/Theory/Z12/Castren_1994.hs b/Music/Theory/Z12/Castren_1994.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Castren_1994.hs
@@ -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
diff --git a/Music/Theory/Z12/Drape_1999.hs b/Music/Theory/Z12/Drape_1999.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Drape_1999.hs
@@ -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
diff --git a/Music/Theory/Z12/Forte_1973.hs b/Music/Theory/Z12/Forte_1973.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Forte_1973.hs
@@ -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
diff --git a/Music/Theory/Z12/Lewin_1980.hs b/Music/Theory/Z12/Lewin_1980.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Lewin_1980.hs
@@ -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
diff --git a/Music/Theory/Z12/Literature.hs b/Music/Theory/Z12/Literature.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Literature.hs
@@ -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.") ]
diff --git a/Music/Theory/Z12/Morris_1974.hs b/Music/Theory/Z12/Morris_1974.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Morris_1974.hs
@@ -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
diff --git a/Music/Theory/Z12/Morris_1987.hs b/Music/Theory/Z12/Morris_1987.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Morris_1987.hs
@@ -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]]
diff --git a/Music/Theory/Z12/Morris_1987/Parse.hs b/Music/Theory/Z12/Morris_1987/Parse.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Morris_1987/Parse.hs
@@ -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''
diff --git a/Music/Theory/Z12/Rahn_1980.hs b/Music/Theory/Z12/Rahn_1980.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Rahn_1980.hs
@@ -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
diff --git a/Music/Theory/Z12/Read_1978.hs b/Music/Theory/Z12/Read_1978.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/Read_1978.hs
@@ -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))
diff --git a/Music/Theory/Z12/SRO.hs b/Music/Theory/Z12/SRO.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/SRO.hs
@@ -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))
diff --git a/Music/Theory/Z12/TTO.hs b/Music/Theory/Z12/TTO.hs
new file mode 100644
--- /dev/null
+++ b/Music/Theory/Z12/TTO.hs
@@ -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))
diff --git a/README b/README
--- a/README
+++ b/README
@@ -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/
diff --git a/hmt.cabal b/hmt.cabal
--- a/hmt.cabal
+++ b/hmt.cabal
@@ -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