hmt (empty) → 0.1
raw patch · 12 files changed
+1195/−0 lines, 12 filesdep +basedep +containersdep +parsecsetup-changed
Dependencies added: base, containers, parsec, permutation
Files
- Help/hmt.help.lhs +356/−0
- Music/Theory.hs +15/−0
- Music/Theory/Parse.hs +33/−0
- Music/Theory/Pct.hs +171/−0
- Music/Theory/Permutations.hs +23/−0
- Music/Theory/Pitch.hs +197/−0
- Music/Theory/Prime.hs +46/−0
- Music/Theory/Set.hs +23/−0
- Music/Theory/Table.hs +289/−0
- README +7/−0
- Setup.lhs +3/−0
- hmt.cabal +32/−0
+ Help/hmt.help.lhs view
@@ -0,0 +1,356 @@+> import Music.Theory++$ sro T4 156+59A++> tn 4 [1,5,6]++$ sro T4I 156+3BA++> tni 4 [1,5,6]++$ echo 156 | sro T4 | sro T0I+732++> let f n = invert 0 . tn n+> in f 4 [1,5,6]++$ pcom pcseg iseg 01549 | pcom iseg icseg | pcom icseg icset+145++> (set . map ic . int) [0,1,5,4,9]++$ pcom pcseg pcset 01549 | pcom pcset sc | pcom sc icv | pcom icv icset+1345++> import Data.Maybe++> let icv_icset x = let f x y = if x > 0 then Just y else Nothing+> in catMaybes (zipWith f x [1..6])+> in (icv_icset . icv . forte_prime) [0,1,5,4,9]++Allen Forte "The Basic Interval Patterns" JMT 17/2 (1973):234-272++$ function bip { pcom pcseg iseg $ | pcom iseg icseg | nrm -r }+$ bip 0t95728e3416+11223344556+$++> bip [0,10,9,5,7,2,8,11,3,4,1,6]++$ pg 5-Z17 | bip | sort -u > 5-Z17.bip ; \+ pg 5-Z37 | bip | sort -u > 5-Z37.bip ; \+ comm 5-Z17.bip 5-Z37.bip -1 -2 | wc -l+16+$++> import Data.List++> let f = nub . map bip . permutations . sc+> in f "5-Z17" `intersect` f "5-Z37"++$ cat ../db.sh+for sc in $(fl -c $1)+do+ pg $sc | bip | sort -u > $sc+done+$ sh ../db.sh 4+$ ls+4-1 4-12 4-16 4-19 4-21 4-24 4-27 4-4 4-7 4-Z15+4-10 4-13 4-17 4-2 4-22 4-25 4-28 4-5 4-8 4-Z29+4-11 4-14 4-18 4-20 4-23 4-26 4-3 4-6 4-9+$++> let { s = filter ((== 4) . length) scs+> ; x = map permutations s }+> in zip (map sc_name s) (map (set . (map bip)) x)++$ cat view.sh+for i in $(fl -c $1 | pg | bip | sort -u)+do+ echo $i":" $(grep -l $i * | sort -t '-' +1 -n | tr "\n" " ")+done+$ sh view.sh 4+111: 4-1+112: 4-1 4-2 4-3+113: 4-1 4-3 4-4 4-7+...+$++> let { n = 4+> ; s = filter ((== n) . length) scs+> ; x = map permutations s+> ; z = zip (map sc_name s) (map (set . (map bip)) x)+> ; f b (s, bs) = if b `elem` bs then Just s else Nothing+> ; g b = catMaybes (map (f b) z)+> ; a = set (map bip (concat x)) }+> in zip a (map g a)++$ cyc < ~/src/pct/lib/scs | epmq \+> "in cset 89" "is icset 12" "hasnt icseg 11" | scdb+7-34 ascending melodic minor collection+7-35 diatonic collection (d)+8-28 octotonic collection (Messiaen Mode II)+$++> let { cyc xs = xs ++ [head xs]+> ; a = filter (\p -> length p `elem` [8,9]) (map cyc scs)+> ; b = filter (\p -> set (int p) == [1,2]) a+> ; c = filter (\p -> not ([1,1] `isInfixOf` int p)) b }+> in map sc_name c++$ epmq < ~/src/pct/lib/univ "in cset 6" "in pcset 579t024" \+> "has sc 5-35" "hasnt sc 2-6" "notin pcset 024579e"+02579A+$++> let { a = cf [6] (powerset [0..11])+> ; b = filter (is_superset [0,2,4,5,7,9,10]) a+> ; c = filter (`has_sc` (sc "5-35")) b+> ; d = filter (not . (`has_sc` (sc "2-6"))) c }+> in filter (not . is_superset [0,2,4,5,7,9,11]) d++$ echo 024579 | sro RT4I+79B024++> sro (SRO 0 True 4 False True) [0,2,4,5,7,9]++$ sro T4I 156+3BA++> sro (SRO 0 False 4 False True) [1,5,6]++$ echo 156 | sro T0I | sro T4+3BA++> import Control.Arrow++> let { i = SRO 0 False 0 False True+> ; t4 = SRO 0 False 4 False False }+> in (sro i >>> sro t4) [1,5,6]++$ echo 156 | sro T4 | sro T0I+732++> let { i = SRO 0 False 0 False True+> ; t4 = SRO 0 False 4 False False }+> in (sro i . sro t4) [1,5,6]++$ rsg 156 3BA+T4I++> rsg [1,5,6] [3,11,10]++$ rsg 0123 05t3+T0M++> rsg [0,1,2,3] [0,5,10,3]++$ rsg 0123 4e61+RT1M++> rsg [0,1,2,3] [4,11,6,1]++$ echo e614 | rsg 0123+r3RT1M++note: pct uses right rotation rotation.++> rsg [0,1,2,3] [11,6,1,4]++> sro (SRO 1 True 1 True False) [0,1,2,3]++> sro (SRO 1 False 4 True True) [0,1,2,3]++T0 = T0M1; Tn = TnM1+I = MB; TnI = TnMB,+M = M5; TnM = TnM5,+MI = IM = M7 = MBM5; TnMI = TnM7++> mn 11 [0,1,4,9] == tni 0 [0,1,4,9]++$ se -c5 123+12333+12233+12223+11233+11223+11123+$++> se 5 [1,2,3]++$ ici -c 123+123+129+1A3+1A9+$++> ici_c [1,2,3]++> ici [1,2,3]++> cgg [[0],[1,11],[2,10],[3,9],[4,8],[5,7],[6]]++$ se -c5 1245 | pg | ici | pcom iseg sc | \+ sort -u | epmq "in cset 6" | wc -l+42+$++> let { a = se 5 [1,2,4,5]+> ; b = concatMap permutations a+> ; c = concatMap ici b+> ; d = map (forte_prime . dx_d 0) c+> ; e = nub d+> ; f = cf [6] e }+> in length f++$ cg -r3 0159+015+019+059+159+$++> cg_r 3 [0,1,5,9]++$ cmpl 02468t+13579B+$++> cmpl [0,2,4,6,8,10]++$ cyc 056+0560+$++> cyc [0,5,6]++$ dim 016+T1d+T1m+T0o+$++> dim [0,1,6]++$ dis 24+1256+$++> dis [2,4]++$ echo 024579e | doi 6 | sort -u+024579A+024679B+$ echo 01234 | doi 2 7-35 | sort -u+13568AB+$++> let p = [0,2,4,5,7,9,11] in doi 6 p p++> doi 2 (sc "7-35") [0,1,2,3,4]++$ spsc 4-11 4-12+5-26[02458]+$ spsc 3-11 3-8+4-27[0258]+4-Z29[0137]+$ spsc `fl 3`+6-Z17[012478]+$++> spsc [sc "4-11", sc "4-12"]++> spsc [sc "3-11", sc "3-8"]++> spsc (cf [3] scs)++$ echo 23a | ess 0164325+2B013A9+923507A+$++> ess [2,3,10] [0,1,6,4,3,2,5]++$ echo 22341 | icf+22341+$++> icf [[2,2,3,4,1]]++$ icseg 013265e497t8+12141655232+$++> icseg [0,1,3,2,6,5,11,4,9,7,10,8]++$ imb -c34 024579 | pfmt+024 245 457 579+0245 2457 4579+$++> imb [3,4] [0,2,4,5,7,9]++$ issb 3-7 6-32+3-7+3-2+3-11+$++> issb (sc "3-7") (sc "6-32")++$ mxs 024579 642 | sort -u+6421B9+B97642+$++> set (mxs [0,2,4,5,7,9] [6,4,2])++$ nrm 0123456543210+0123456+$++> nrm [0,1,2,3,4,5,6,5,4,3,2,1,0]++$ pi 0236 12+0236+6320+532B+B235+$++> pci [0,2,3,6] [1,2]++$ rs 0123 e614+T1M+$ rs 0123 641e+T1M+$ rs 0123 641e416+T1M+$++> rs [0,1,2,3] [6,4,1,11]++$ sb 6-32 6-8 | fn | pfmt+1-1+2-1 2-2 2-3 2-4 2-5+3-2 3-4 3-6 3-7 3-9 3-11+4-10 4-11 4-14 4-22 4-23+5-23+$ for i in `cat ~/src/pct/lib/scs | cf 6 | fn` ; \+ do echo $i >> LIST ; sb $i | cf 3 | wc -l >> LIST ; done+$++> map sc_name (sb [sc "6-32", sc "6-8"])++> let f p = let xs = cf [3] (sb [p]) +> in (sc_name p, length xs)+> in map f (cf [6] scs)++$ echo 024579 | sro RT4I+79B024++> sro (rnrtnmi "RT4I") [0,2,4,5,7,9]
+ Music/Theory.hs view
@@ -0,0 +1,15 @@+module Music.Theory (module Music.Theory.Parse,+ module Music.Theory.Pitch,+ module Music.Theory.Pct,+ module Music.Theory.Prime,+ module Music.Theory.Set,+ module Music.Theory.Table,+ module Music.Theory.Permutations) where++import Music.Theory.Parse+import Music.Theory.Pitch+import Music.Theory.Pct+import Music.Theory.Prime+import Music.Theory.Set+import Music.Theory.Table+import Music.Theory.Permutations
+ Music/Theory/Parse.hs view
@@ -0,0 +1,33 @@+module Music.Theory.Parse (rnrtnmi) where++import Control.Monad+import Music.Theory.Pitch+import Text.ParserCombinators.Parsec++type P a = GenParser Char () a++is_char :: Char -> P Bool+is_char c =+ let f '_' = False+ f _ = True+ in liftM f (option '_' (char c))++get_int :: P Int+get_int = liftM read (many1 digit)++-- | Parse a Morris format serial operator descriptor.+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)
+ Music/Theory/Pct.hs view
@@ -0,0 +1,171 @@+module Music.Theory.Pct where++import Data.Function+import Data.List+import Music.Theory.Prime+import Music.Theory.Pitch+import Music.Theory.Set+import Music.Theory.Table++-- | Basic interval pattern.+bip :: (Integral a) => [a] -> [a]+bip = sort . map ic . int++-- | Cardinality filter+cf :: (Integral n) => [n] -> [[a]] -> [[a]]+cf ns = filter (\p -> genericLength p `elem` ns)++cgg :: [[a]] -> [[a]]+cgg [] = [[]]+cgg (x:xs) = [ y:z | y <- x, z <- cgg xs ]++-- | Combinations generator (cg == poweset)+cg :: [a] -> [[a]]+cg = powerset++-- | Powerset filtered by cardinality.+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 :: (Integral a) => [a] -> [a]+cmpl = ([0..11] \\) . pcset++-- | Form cycle.+cyc :: [a] -> [a]+cyc [] = []+cyc (x:xs) = (x:xs) ++ [x]++-- | 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++-- | Diatonic interval set to interval set.+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.+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.+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.+icf :: (Num a) => [[a]] -> [[a]]+icf = filter ((== 12) . sum)++-- | Interval class set to interval sets.+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 :: [Int] -> [[Int]]+ici_c [] = []+ici_c (x:xs) = map (x:) (ici xs)++-- | Interval-class segment.+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++-- | p `issb` q gives the set-classes that can append to p to give q.+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 :: (Integral a) => [a] -> [a] -> [[a]]+mxs p q = filter (q `isInfixOf`) (all_RTnI p)++-- | Normalize.+nrm :: (Ord a) => [a] -> [a]+nrm = set++-- | Normalize, retain duplicate elements.+nrm_r :: (Ord a) => [a] -> [a]+nrm_r = sort++-- | Pitch-class invariances.+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 :: (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 :: (Integral a) => [a] -> [a] -> [(SRO a, [a])]+rsg x y = 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 :: (Integral a) => [[a]] -> [String]+spsc xs =+ let f y = all (y `has_sc`) xs+ g = (==) `on` length+ in (map sc_name . head . groupBy g . filter f) scs
+ Music/Theory/Permutations.hs view
@@ -0,0 +1,23 @@+module Music.Theory.Permutations (permutations) where++import qualified Data.Map as M+import qualified Data.Permute as P++all_ps :: P.Permute -> [P.Permute]+all_ps p =+ let r = P.next p+ in maybe [p] (\np -> p : all_ps np) r++n_ps :: Int -> [[Int]]+n_ps n =+ let p = P.permute n+ ps = all_ps p+ in map P.elems ps++-- Generate list of all permutations of indicated list.+permutations :: [a] -> [[a]]+permutations xs =+ let m = M.fromList (zip [0..] xs)+ ps = n_ps (M.size m)+ r = map (\i -> M.findWithDefault undefined i m)+ in map r ps
+ Music/Theory/Pitch.hs view
@@ -0,0 +1,197 @@+module Music.Theory.Pitch where++import Music.Theory.Set+import Data.Maybe+import Data.List++-- | Modulo twelve.+mod12 :: (Integral a) => a -> a+mod12 = (`mod` 12)++-- | Pitch class.+pc :: (Integral a) => a -> a+pc = mod12++-- | Map to pitch-class and reduce to set.+pcset :: (Integral a) => [a] -> [a]+pcset = set . map pc++-- | Transpose by n.+tn :: (Integral a) => a -> [a] -> [a]+tn n = map (pc . (+ n))++-- | Transpose so first element is n.+transposeTo :: (Integral a) => a -> [a] -> [a]+transposeTo _ [] = []+transposeTo n (x:xs) = n : tn (n - x) xs++-- | All transpositions.+transpositions :: (Integral a) => [a] -> [[a]]+transpositions p = map (`tn` p) [0..11]++-- | Invert about n.+invert :: (Integral a) => a -> [a] -> [a]+invert n = map (pc . (\p -> n - (p - n)))++-- | Invert about first element.+invertSelf :: (Integral a) => [a] -> [a]+invertSelf [] = []+invertSelf (x:xs) = invert x (x:xs)++-- | Composition on inversion about zero and transpose.+tni :: (Integral a) => a -> [a] -> [a]+tni n = tn n . invert 0++-- | Rotate left by n places.+rotate :: (Integral n) => n -> [a] -> [a]+rotate n p =+ let m = n `mod` genericLength p+ (b, a) = genericSplitAt m p+ in a ++ b++-- | Rotate right by n places.+rotate_right :: (Integral n) => n -> [a] -> [a]+rotate_right = rotate . negate++-- | All rotations.+rotations :: [a] -> [[a]]+rotations p = map (`rotate` p) [0 .. length p - 1]++-- | Modulo 12 multiplication+mn :: (Integral a) => a -> [a] -> [a]+mn n = map (pc . (* n))++-- | M5+m5 :: (Integral a) => [a] -> [a]+m5 = mn 5++all_Tn :: (Integral a) => [a] -> [[a]]+all_Tn p = map (`tn` p) [0..11]++all_TnI :: (Integral a) => [a] -> [[a]]+all_TnI p =+ let ps = all_Tn p + in ps ++ map (invert 0) ps++all_RTnI :: (Integral a) => [a] -> [[a]]+all_RTnI p =+ let ps = all_TnI p+ in ps ++ map reverse ps++all_TnMI :: (Integral a) => [a] -> [[a]]+all_TnMI p =+ let ps = all_TnI p+ in ps ++ map m5 ps++all_RTnMI :: (Integral a) => [a] -> [[a]]+all_RTnMI p =+ let ps = all_TnMI p+ in ps ++ map reverse ps++all_rRTnMI :: (Integral a) => [a] -> [[a]]+all_rRTnMI = map snd . sros++-- | Serial Operator, of the form rRTMI.+data SRO a = SRO a Bool a Bool Bool+ deriving (Eq, Show)++-- | Serial operation.+sro :: (Integral a) => SRO a -> [a] -> [a]+sro (SRO r r' t m i) x =+ let x1 = if i then invert 0 x else x+ x2 = if m then m5 x1 else x1+ x3 = tn t x2+ x4 = if r' then reverse x3 else x3+ in rotate r x4++-- | The total set of serial operations.+sros :: (Integral a) => [a] -> [(SRO a, [a])]+sros x = [ let o = (SRO r r' t m i) in (o, sro o x) | + r <- [0 .. genericLength x - 1], + r' <- [False, True], + t <- [0 .. 11], + m <- [False, True], + i <- [False, True] ]++sro_Tn :: (Integral a) => [SRO a]+sro_Tn = [ SRO 0 False n False False | + n <- [0..11] ]++sro_TnI :: (Integral a) => [SRO a]+sro_TnI = [ SRO 0 False n False i | + n <- [0..11], + i <- [False, True] ]++sro_RTnI :: (Integral a) => [SRO a]+sro_RTnI = [ SRO 0 r n False i | + r <- [True, False],+ n <- [0..11], + i <- [False, True] ] ++sro_TnMI :: (Integral a) => [SRO a]+sro_TnMI = [ SRO 0 False n m i | + n <- [0..11], + m <- [True, False], + i <- [True, False] ]++sro_RTnMI :: (Integral a) => [SRO a]+sro_RTnMI = [ SRO 0 r n m i | + r <- [True, False],+ n <- [0..11],+ m <- [True, False],+ i <- [True, False] ]++-- | Intervals to values, zero is n.+dx_d :: (Num a) => a -> [a] -> [a]+dx_d = scanl (+)++-- | Integrate.+d_dx :: (Num a) => [a] -> [a]+d_dx [] = []+d_dx (_:[]) = []+d_dx (x:xs) = zipWith (-) xs (x:xs)++-- | Morris INT operator.+int :: (Integral a) => [a] -> [a]+int = map mod12 . d_dx++-- | Interval class.+ic :: (Integral a) => a -> a+ic i =+ let i' = mod12 i+ in if i' <= 6 then i' else 12 - i'++-- | Elements of p not in q+difference :: (Eq a) => [a] -> [a] -> [a]+difference p q =+ let f e = e `notElem` q+ in filter f p++-- | Pitch classes not in set.+complement :: (Integral a) => [a] -> [a]+complement = difference [0..11]++-- | Is p a subsequence of q.+subsequence :: (Eq a) => [a] -> [a] -> Bool+subsequence = isInfixOf++-- | The standard t-matrix of p.+tmatrix :: (Integral a) => [a] -> [[a]]+tmatrix p = map (`tn` p) (transposeTo 0 (invertSelf p))++-- | Interval class vector.+icv :: (Integral a) => [a] -> [a]+icv s =+ let i = map (ic . uncurry (-)) (dyads s)+ j = map f (group (sort i))+ k = map (`lookup` j) [1..6]+ f l = (head l, genericLength l)+ in map (fromMaybe 0) k++-- | Is p a subset of q.+is_subset :: Eq a => [a] -> [a] -> Bool+is_subset p q = p `intersect` q == p++-- | Is p a superset of q.+is_superset :: Eq a => [a] -> [a] -> Bool+is_superset = flip is_subset
+ Music/Theory/Prime.hs view
@@ -0,0 +1,46 @@+module Music.Theory.Prime ( cmp_prime+ , forte_prime+ , rahn_prime+ , encode_prime ) where++import Data.Bits+import Data.List+import Music.Theory.Pitch++-- | 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 (rightmost first then leftmost outwards).+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.+forte_prime :: (Integral a) => [a] -> [a]+forte_prime = cmp_prime forte_cmp++-- | Rahn prime form (comparison is rightmost inwards).+rahn_prime :: (Integral a) => [a] -> [a]+rahn_prime = cmp_prime (\p q -> compare (reverse p) (reverse q))++-- | Binary encoding prime form algorithm, equalivalent to Rahn.+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))++encode :: (Integral a) => [a] -> a+encode = sum . map (2 ^)++decode :: (Bits a, Integral a) => a -> [a]+decode n =+ let f i = (i, testBit n i)+ in map (fromIntegral . fst) (filter snd (map f [0..11]))
+ Music/Theory/Set.hs view
@@ -0,0 +1,23 @@+module Music.Theory.Set where++import Control.Monad+import Data.List++-- | Remove duplicate elements and sort.+set :: (Ord a) => [a] -> [a]+set = sort . nub++-- | Powerset, ie. set of all all subsets.+powerset :: [a] -> [[a]]+powerset = filterM (const [True, False])++-- | Two element subsets (cf [2] . powerset).+dyads :: [a] -> [(a,a)]+dyads [] = []+dyads (x:xs) = dyads xs ++ [ (x,y) | y <- xs ]++-- | Set expansion+se :: (Ord a) => Int -> [a] -> [[a]]+se n xs = if length xs == n + then [xs] + else nub (concatMap (se n) [sort (y : xs) | y <- xs])
+ Music/Theory/Table.hs view
@@ -0,0 +1,289 @@+module Music.Theory.Table where++import Data.List+import Data.Maybe+import Music.Theory.Prime++-- | The set-class table (Forte prime forms).+sc_table :: (Integral a) => [(String, [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 given a set-class.+sc_name :: (Integral a) => [a] -> String+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 :: (Integral a) => String -> [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.+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.") ]
+ README view
@@ -0,0 +1,7 @@+hmt - haskell music theory++Music theory operations in haskell, primarily+focussed on 'set theory'.++(c) rohan drape, 2006-2009+ gpl, http://gnu.org/copyleft/
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ hmt.cabal view
@@ -0,0 +1,32 @@+Name: hmt+Version: 0.1+Synopsis: Haskell Music Theory+Description: Haskell music theory library+License: GPL+Category: Music+Copyright: Rohan Drape, 2006-2009+Author: Rohan Drape+Maintainer: rd@slavepianos.org+Stability: Experimental+Homepage: http://www.slavepianos.org/rd/+Tested-With: GHC == 6.8.2+Build-Type: Simple+Cabal-Version: >= 1.6++Data-files: README+ Help/hmt.help.lhs++Library+ Build-Depends: base == 3.*,+ containers,+ parsec,+ permutation+ GHC-Options: -Wall -fwarn-tabs+ Exposed-modules: Music.Theory+ Music.Theory.Parse+ Music.Theory.Pct+ Music.Theory.Pitch+ Music.Theory.Prime+ Music.Theory.Set+ Music.Theory.Table+ Music.Theory.Permutations