diff --git a/Help/hmt.help.lhs b/Help/hmt.help.lhs new file mode 100644 --- /dev/null +++ b/Help/hmt.help.lhs @@ -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] diff --git a/Music/Theory.hs b/Music/Theory.hs new file mode 100644 --- /dev/null +++ b/Music/Theory.hs @@ -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 diff --git a/Music/Theory/Parse.hs b/Music/Theory/Parse.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Parse.hs @@ -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) diff --git a/Music/Theory/Pct.hs b/Music/Theory/Pct.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pct.hs @@ -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 diff --git a/Music/Theory/Permutations.hs b/Music/Theory/Permutations.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Permutations.hs @@ -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 diff --git a/Music/Theory/Pitch.hs b/Music/Theory/Pitch.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch.hs @@ -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 diff --git a/Music/Theory/Prime.hs b/Music/Theory/Prime.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Prime.hs @@ -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])) diff --git a/Music/Theory/Set.hs b/Music/Theory/Set.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Set.hs @@ -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]) diff --git a/Music/Theory/Table.hs b/Music/Theory/Table.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Table.hs @@ -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.") ] diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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/ diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/hmt.cabal b/hmt.cabal new file mode 100644 --- /dev/null +++ b/hmt.cabal @@ -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