hmt 0.3 → 0.11
raw patch · 29 files changed
+2775/−1248 lines, 29 filesdep +cairodep +colourdep +hcg-minus
Dependencies added: cairo, colour, hcg-minus, html-minimalist, utf8-string, xml
Files
- Help/hmt.help.lhs +126/−331
- Music/Theory/Bjorklund.hs +78/−73
- Music/Theory/Contour/Polansky_1992.hs +129/−55
- Music/Theory/Diagram/Grid.hs +138/−0
- Music/Theory/Diagram/Path.hs +230/−0
- Music/Theory/Duration.hs +38/−107
- Music/Theory/Duration/Name.hs +26/−45
- Music/Theory/Duration/Name/Abbreviation.hs +62/−0
- Music/Theory/Duration/RQ.hs +71/−0
- Music/Theory/Duration/Sequence/Notate.hs +161/−111
- Music/Theory/Interval.hs +70/−21
- Music/Theory/Interval/Name.hs +9/−0
- Music/Theory/Interval/Spelling.hs +46/−0
- Music/Theory/Key.hs +14/−1
- Music/Theory/Parse.hs +17/−5
- Music/Theory/Pct.hs +184/−11
- Music/Theory/Permutations.hs +164/−19
- Music/Theory/Pitch.hs +94/−29
- Music/Theory/Pitch/Name.hs +4/−0
- Music/Theory/Pitch/Spelling.hs +75/−0
- Music/Theory/PitchClass.hs +179/−51
- Music/Theory/Prime.hs +25/−7
- Music/Theory/Set.hs +20/−8
- Music/Theory/Spelling.hs +0/−88
- Music/Theory/Table.hs +285/−272
- Music/Theory/Tuning.hs +57/−7
- Music/Theory/Xenakis/S4.hs +283/−0
- Music/Theory/Xenakis/Sieve.hs +172/−0
- hmt.cabal +18/−7
Help/hmt.help.lhs view
@@ -1,382 +1,177 @@-This file illustrates equivalent expressions in pct and hmt terms.--The file imports modules as required and so must be traversed in order.--$ sro T4 156-59A--> import Music.Theory.PitchClass--> tn 4 [1,5,6]+# Pct +> import Control.Arrow+> import Data.Function+> import Data.List+> import Data.Maybe > import Music.Theory.Parse--> sro (rnrtnmi "T4") (pco "156")--$ sro T4I 156-3BA--> tni 4 [1,5,6]--> sro (rnrtnmi "T4I") (pco "156")--$ echo 156 | sro T4 | sro T0I-732--> let f n = invert 0 . tn n-> in f 4 [1,5,6]--> (sro (rnrtnmi "T0I") . sro (rnrtnmi "T4")) (pco "156")--$ pcom pcseg iseg 01549 | pcom iseg icseg | pcom icseg icset-145-+> import Music.Theory.Pct+> import Music.Theory.Permutations+> import Music.Theory.PitchClass+> import Music.Theory.Prime+> import Music.Theory.Table > import Music.Theory.Set -> (set . map ic . int) [0,1,5,4,9]+This file illustrates equivalent expressions in pct and hmt terms. -$ pcom pcseg pcset 01549 | pcom pcset sc | pcom sc icv | pcom icv icset-1345+ $ pcom pcseg iseg 01549 | pcom iseg icseg | pcom icseg icset+ 145 -> import Data.Maybe-> import Music.Theory.Prime+> (set . map ic . int) [0,1,5,4,9] == [1,4,5] + $ pcom pcseg pcset 01549 | pcom pcset sc | pcom sc icv | pcom icv icset+ 1345+ > 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-$--> import Music.Theory.Pct--> bip [0,10,9,5,7,2,8,11,3,4,1,6]--> bip (pco "0t95728e3416")--$ 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-$+> in (icv_icset . icv . forte_prime) [0,1,5,4,9] == [1,3,4,5] -> import Data.List+ $ 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 > let f g = sort (g [1..4])-> in f Music.Theory.Permutations.permutations == f permutations--> import Music.Theory.Table+> in f permutations_l == f permutations > let f = nub . map bip . permutations . sc-> in f "5-Z17" `intersect` f "5-Z37"+> in length (f "5-Z17" `intersect` f "5-Z37") == 16 -$ 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-$+ $ 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 }+> 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-...-$--> import Data.Maybe+ $ 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)) }+> 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+ $ 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 { i = SRO 0 False 0 False True-> ; t4 = SRO 0 False 4 False False }-> in (sro i . sro t4) [1,5,6]+> 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 == ["7-34","7-35","8-28"] -$ rsg 156 3BA-T4I+ $ epmq < ~/src/pct/lib/univ "in cset 6" "in pcset 579t024" \+ > "has sc 5-35" "hasnt sc 2-6" "notin pcset 024579e"+ 02579A -> rsg [1,5,6] [3,11,10]+> 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+> ;e = filter (not . is_superset [0,2,4,5,7,9,11]) d}+> in e == [[0,2,5,7,9,10]] -$ rsg 0123 05t3-T0M+ $ echo 156 | sro T0I | sro T4+ 3BA -> rsg [0,1,2,3] [0,5,10,3]+> let {i = SRO 0 False 0 False True+> ;t4 = SRO 0 False 4 False False}+> in (sro i >>> sro t4) [1,5,6] == [3,11,10] -$ rsg 0123 4e61-RT1M+ $ echo 156 | sro T4 | sro T0I+ 732 -> rsg [0,1,2,3] [4,11,6,1]+> let {i = SRO 0 False 0 False True+> ;t4 = SRO 0 False 4 False False}+> in (sro i . sro t4) [1,5,6] == [7,3,2] -$ echo e614 | rsg 0123-r3RT1M+Note that pct uses right rotation rotation. -note: pct uses right rotation rotation.+> 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] -> rsg [0,1,2,3] [11,6,1,4]+ I = MB; TnI = TnMB, -> sro (SRO 1 True 1 True False) [0,1,2,3]+> mn 11 [0,1,4,9] == tni 0 [0,1,4,9] -> sro (SRO 1 False 4 True True) [0,1,2,3]+ MI = IM = M7 = MBM5; TnMI = TnM7 -T0 = T0M1; Tn = TnM1-I = MB; TnI = TnMB,-M = M5; TnM = TnM5,-MI = IM = M7 = MBM5; TnMI = TnM7+> sro (rnrtnmi "T0MI") [0,1,4,9] == mn 7 [0,1,4,9] -> mn 11 [0,1,4,9] == tni 0 [0,1,4,9]+ T0 = T0M1; Tn = TnM1+ M = M5; TnM = TnM5, -$ se -c5 123-12333-12233-12223-11233-11223-11123-$+ $ 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-$+ $ se -c5 1245 | pg | ici | pcom iseg sc | \+ sort -u | epmq "in cset 6" | wc -l+ 42 -> icseg [0,1,3,2,6,5,11,4,9,7,10,8]+> 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 == 42 -$ imb -c34 024579 | pfmt-024 245 457 579-0245 2457 4579-$+ $ 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]+ $ rs 0123 e614+ T1M+ $ rs 0123 641e416+ T1M -$ 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-$+ $ 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"])+> 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)+> 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") (pco "024579")
Music/Theory/Bjorklund.hs view
@@ -1,26 +1,23 @@+-- | Godfried T. Toussaint et. al.+-- \"The distance geometry of music\"+-- /Journal of Computational Geometry: Theory and Applications/+-- Volume 42, Issue 5, July, 2009+-- (<http://dx.doi.org/10.1016/j.comgeo.2008.04.005>) module Music.Theory.Bjorklund (bjorklund,xdot,iseq,iseq_str) where -{--Godfried T. Toussaint et. al.-"The distance geometry of music"-Journal of Computational Geometry: Theory and Applications-Volume 42, Issue 5, July, 2009-doi>10.1016/j.comgeo.2008.04.005--}- import Data.List.Split -type STEP a = ((Int, Int), ([[a]], [[a]]))+type STEP a = ((Int,Int),([[a]],[[a]])) left :: STEP a -> STEP a left ((i,j),(xs,ys)) = let (xs',xs'') = splitAt j xs- in ((j,i-j),(zipWith (++) xs' ys, xs''))+ in ((j,i-j),(zipWith (++) xs' ys,xs'')) right :: STEP a -> STEP a right ((i,j),(xs,ys)) = let (ys',ys'') = splitAt i ys- in ((i,j-i),(zipWith (++) xs ys', ys''))+ in ((i,j-i),(zipWith (++) xs ys',ys'')) bjorklund' :: STEP a -> STEP a bjorklund' (n,x) =@@ -29,7 +26,64 @@ then (n,x) else bjorklund' (if i > j then left (n,x) else right (n,x)) -bjorklund :: (Int, Int) -> [Bool]+-- | Bjorklund's algorithm to construct a binary sequence of /n/ bits+-- with /k/ ones such that the /k/ ones are distributed as evenly as+-- possible among the (/n/ - /k/) zeroes.+--+-- > bjorklund (5,9) == [True,False,True,False,True,False,True,False,True]+-- > xdot (bjorklund (5,9)) == "x.x.x.x.x"+--+-- > let es = [(2,3),(2,5)+-- > ,(3,4),(3,5),(3,8)+-- > ,(4,7),(4,9),(4,12),(4,15)+-- > ,(5,6),(5,7),(5,8),(5,9),(5,11),(5,12),(5,13),(5,16)+-- > ,(6,7),(6,13)+-- > ,(7,8),(7,9),(7,10),(7,12),(7,15),(7,16),(7,17),(7,18)+-- > ,(8,17),(8,19)+-- > ,(9,14),(9,16),(9,22),(9,23)+-- > ,(11,12),(11,24)+-- > ,(13,24)+-- > ,(15,34)]+-- > in map (\e -> let e' = bjorklund e in (e,xdot e',iseq_str e')) es+--+-- > [((2,3),"xx.","(12)")+-- > ,((2,5),"x.x..","(23)")+-- > ,((3,4),"xxx.","(112)")+-- > ,((3,5),"x.x.x","(221)")+-- > ,((3,8),"x..x..x.","(332)")+-- > ,((4,7),"x.x.x.x","(2221)")+-- > ,((4,9),"x.x.x.x..","(2223)")+-- > ,((4,12),"x..x..x..x..","(3333)")+-- > ,((4,15),"x...x...x...x..","(4443)")+-- > ,((5,6),"xxxxx.","(11112)")+-- > ,((5,7),"x.xx.xx","(21211)")+-- > ,((5,8),"x.xx.xx.","(21212)")+-- > ,((5,9),"x.x.x.x.x","(22221)")+-- > ,((5,11),"x.x.x.x.x..","(22223)")+-- > ,((5,12),"x..x.x..x.x.","(32322)")+-- > ,((5,13),"x..x.x..x.x..","(32323)")+-- > ,((5,16),"x..x..x..x..x...","(33334)")+-- > ,((6,7),"xxxxxx.","(111112)")+-- > ,((6,13),"x.x.x.x.x.x..","(222223)")+-- > ,((7,8),"xxxxxxx.","(1111112)")+-- > ,((7,9),"x.xxx.xxx","(2112111)")+-- > ,((7,10),"x.xx.xx.xx","(2121211)")+-- > ,((7,12),"x.xx.x.xx.x.","(2122122)")+-- > ,((7,15),"x.x.x.x.x.x.x..","(2222223)")+-- > ,((7,16),"x..x.x.x..x.x.x.","(3223222)")+-- > ,((7,17),"x..x.x..x.x..x.x.","(3232322)")+-- > ,((7,18),"x..x.x..x.x..x.x..","(3232323)")+-- > ,((8,17),"x.x.x.x.x.x.x.x..","(22222223)")+-- > ,((8,19),"x..x.x.x..x.x.x..x.","(32232232)")+-- > ,((9,14),"x.xx.xx.xx.xx.","(212121212)")+-- > ,((9,16),"x.xx.x.x.xx.x.x.","(212221222)")+-- > ,((9,22),"x..x.x..x.x..x.x..x.x.","(323232322)")+-- > ,((9,23),"x..x.x..x.x..x.x..x.x..","(323232323)")+-- > ,((11,12),"xxxxxxxxxxx.","(11111111112)")+-- > ,((11,24),"x..x.x.x.x.x..x.x.x.x.x.","(32222322222)")+-- > ,((13,24),"x.xx.x.x.x.x.xx.x.x.x.x.","(2122222122222)")+-- > ,((15,34),"x..x.x.x.x..x.x.x.x..x.x.x.x..x.x.","(322232223222322)")]+bjorklund :: (Int,Int) -> [Bool] bjorklund (i,j') = let j = j' - i x = replicate i [True]@@ -37,72 +91,23 @@ (_,(x',y')) = bjorklund' ((i,j),(x,y)) in concat x' ++ concat y' +-- | /xdot/ notation for pattern.+--+-- > xdot (bjorklund (5,9)) == "x.x.x.x.x" xdot :: [Bool] -> String xdot = map (\x -> if x then 'x' else '.') +-- | The 'iseq' of a pattern is the distance between 'True' values.+--+-- > iseq (bjorklund (5,9)) == [2,2,2,2,1] iseq :: [Bool] -> [Int]-iseq = let f = split . keepDelimsL . whenElt- in tail . map length . f (== True)+iseq =+ let f = split . keepDelimsL . whenElt+ in tail . map length . f (== True) +-- | 'iseq' of pattern as compact string.+--+-- > iseq_str (bjorklund (5,9)) == "(22221)" iseq_str :: [Bool] -> String iseq_str = let f xs = "(" ++ concatMap show xs ++ ")" in f . iseq--{--xdot (bjorklund (5,9))-iseq_str (bjorklund (5,9))--let es = [(2,3),(2,5)- ,(3,4),(3,5),(3,8)- ,(4,7),(4,9),(4,12),(4,15)- ,(5,6),(5,7),(5,8),(5,9),(5,11),(5,12),(5,13),(5,16)- ,(6,7),(6,13)- ,(7,8),(7,9),(7,10),(7,12),(7,15),(7,16),(7,17),(7,18)- ,(8,17),(8,19)- ,(9,14),(9,16),(9,22),(9,23)- ,(11,12),(11,24)- ,(13,24)- ,(15,34)]-in map (\e -> let e' = bjorklund e in (e,xdot e',iseq_str e')) es-- =>--[((2,3),"xx.","(12)")-,((2,5),"x.x..","(23)")-,((3,4),"xxx.","(112)")-,((3,5),"x.x.x","(221)")-,((3,8),"x..x..x.","(332)")-,((4,7),"x.x.x.x","(2221)")-,((4,9),"x.x.x.x..","(2223)")-,((4,12),"x..x..x..x..","(3333)")-,((4,15),"x...x...x...x..","(4443)")-,((5,6),"xxxxx.","(11112)")-,((5,7),"x.xx.xx","(21211)")-,((5,8),"x.xx.xx.","(21212)")-,((5,9),"x.x.x.x.x","(22221)")-,((5,11),"x.x.x.x.x..","(22223)")-,((5,12),"x..x.x..x.x.","(32322)")-,((5,13),"x..x.x..x.x..","(32323)")-,((5,16),"x..x..x..x..x...","(33334)")-,((6,7),"xxxxxx.","(111112)")-,((6,13),"x.x.x.x.x.x..","(222223)")-,((7,8),"xxxxxxx.","(1111112)")-,((7,9),"x.xxx.xxx","(2112111)")-,((7,10),"x.xx.xx.xx","(2121211)")-,((7,12),"x.xx.x.xx.x.","(2122122)")-,((7,15),"x.x.x.x.x.x.x..","(2222223)")-,((7,16),"x..x.x.x..x.x.x.","(3223222)")-,((7,17),"x..x.x..x.x..x.x.","(3232322)")-,((7,18),"x..x.x..x.x..x.x..","(3232323)")-,((8,17),"x.x.x.x.x.x.x.x..","(22222223)")-,((8,19),"x..x.x.x..x.x.x..x.","(32232232)")-,((9,14),"x.xx.xx.xx.xx.","(212121212)")-,((9,16),"x.xx.x.x.xx.x.x.","(212221222)")-,((9,22),"x..x.x..x.x..x.x..x.x.","(323232322)")-,((9,23),"x..x.x..x.x..x.x..x.x..","(323232323)")-,((11,12),"xxxxxxxxxxx.","(11111111112)")-,((11,24),"x..x.x.x.x.x..x.x.x.x.x.","(32222322222)")-,((13,24),"x.xx.x.x.x.x.xx.x.x.x.x.","(2122222122222)")-,((15,34),"x..x.x.x.x..x.x.x.x..x.x.x.x..x.x.","(322232223222322)")]---}
Music/Theory/Contour/Polansky_1992.hs view
@@ -1,11 +1,9 @@+-- | Polansky, Larry and Bassein, Richard+-- \"Possible and Impossible Melody: Some Formal Aspects of Contour\"+-- /Journal of Music Theory/ 36/2, 1992 (pp.259-284)+-- (<http://www.jstor.org/pss/843933>) module Music.Theory.Contour.Polansky_1992 where -{--Polansky, Larry and Bassein, Richard-"Possible and Impossible Melody: Some Formal Aspects of Contour"-JMT 36/2, 1992 (pp.259-284)--}- import Data.List import Data.List.Split import qualified Data.Map as M@@ -14,73 +12,95 @@ import qualified Music.Theory.Set as T import qualified Music.Theory.Permutations as T --- p.262+-- | Compare adjacent elements (p.262).+--+-- > compare_adjacent [0,1,3,2] == [LT,LT,GT] compare_adjacent :: Ord a => [a] -> [Ordering] compare_adjacent xs = zipWith compare xs (tail xs) -matrix_f :: (a -> a -> b) -> [a] -> [[b]]+-- | A list notation for matrices.+type Matrix a = [[a]]++-- | Apply /f/ to construct 'Matrix' from sequence.+--+-- > matrix_f (,) [1..3] == [[(1,1),(1,2),(1,3)]+-- > ,[(2,1),(2,2),(2,3)]+-- > ,[(3,1),(3,2),(3,3)]]+matrix_f :: (a -> a -> b) -> [a] -> Matrix b matrix_f f =- let g (x,xs) = map (\x' -> f x x') xs+ let g (x,xs) = map (f x) xs h xs = map (\x -> (x,xs)) xs in map g . h --- p.263-contour_matrix :: Ord a => [a] -> [[Ordering]]+-- | Construct 'matrix_f' with 'compare' (p.263).+--+-- > contour_matrix [1..3] == [[EQ,LT,LT],[GT,EQ,LT],[GT,GT,EQ]]+contour_matrix :: Ord a => [a] -> Matrix Ordering contour_matrix = matrix_f compare -data Contour_Half_Matrix = Contour_Half_Matrix {- contour_half_matrix_n :: Int- , contour_half_matrix_m :: [[Ordering]] } deriving (Eq)+-- | Half matrix notation for contour.+data Contour_Half_Matrix =+ Contour_Half_Matrix {contour_half_matrix_n :: Int+ ,contour_half_matrix_m :: Matrix Ordering}+ deriving (Eq) -half_matrix_f :: (a -> a -> b) -> [a] -> [[b]]+-- | Half 'Matrix' of contour given comparison function /f/.+--+-- > half_matrix_f (flip (-)) [2,10,6,7] == [[8,4,5],[-4,-3],[1]]+-- > half_matrix_f (flip (-)) [5,0,3,2] == [[-5,-2,-3],[3,2],[-1]]+-- > half_matrix_f compare [5,0,3,2] == [[GT,GT,GT],[LT,LT],[GT]]+half_matrix_f :: (a -> a -> b) -> [a] -> Matrix b half_matrix_f f xs = let drop_last = reverse . drop 1 . reverse m = drop_last (matrix_f f xs)- in map (\(i,ns) -> drop i ns) (zip [1..] m)--{--half_matrix_f (flip (-)) [2,10,6,7]-==> [[8,4,5],[-4,-3],[1]]-half_matrix_f (flip (-)) [5,0,3,2]-==> [[-5,-2,-3],[3,2],[-1]]--}+ in zipWith drop [1..] m --- p.264+-- | Construct 'Contour_Half_Matrix' (p.264) contour_half_matrix :: Ord a => [a] -> Contour_Half_Matrix contour_half_matrix xs = let hm = half_matrix_f compare xs in Contour_Half_Matrix (length xs) hm +-- | 'Show' function for 'Contour_Half_Matrix'. contour_half_matrix_str :: Contour_Half_Matrix -> String contour_half_matrix_str (Contour_Half_Matrix _ hm) = let hm' = map (concatMap (show . fromEnum)) hm- in intercalate " " hm'+ in unwords hm' instance Show Contour_Half_Matrix where show = contour_half_matrix_str --- p.263+-- | Generic variant of 'fromEnum' (p.263). ord_to_int :: Integral a => Ordering -> a ord_to_int = fromIntegral . fromEnum --- p.263+-- | Generic variant of 'toEnum' (p.263). int_to_ord :: Integral a => a -> Ordering int_to_ord = toEnum . fromIntegral -data Contour_Description = Contour_Description {- contour_description_n :: Int- , contour_description_m :: M.Map (Int,Int) Ordering } deriving (Eq)+-- | /Description/ notation of contour.+data Contour_Description =+ Contour_Description {contour_description_n :: Int+ ,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] --- in (i,j) indices in half matrix order+-- | 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']] --- p.264+-- | 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"] contour_description :: Ord a => [a] -> Contour_Description contour_description x = let n = length x@@ -88,37 +108,49 @@ o = zip ix (map (\(i,j) -> compare (x !! i) (x !! j)) ix) in Contour_Description n (M.fromList o) --- p.264+-- | 'Show' function for 'Contour_Description' (p.264). contour_description_str :: Contour_Description -> String contour_description_str (Contour_Description n m) = let xs = concatMap (show . fromEnum . snd) (M.toList m)- in intercalate " " (splitPlaces [n-1,n-2 .. 0] xs)+ in unwords (splitPlaces [n-1,n-2 .. 0] xs) instance Show Contour_Description where show = contour_description_str +-- | Convert from 'Contour_Half_Matrix' notation to 'Contour_Description'. half_matrix_to_description :: Contour_Half_Matrix -> Contour_Description half_matrix_to_description (Contour_Half_Matrix n hm) = let ix = all_indices n o = zip ix (concat hm) in Contour_Description n (M.fromList o) --- ordering from i-th to j-th element of sequence described at d+-- | Ordering from /i/th to /j/th element of sequence described at /d/.+--+-- > contour_description_ix (contour_description "abdc") (0,3) == LT 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+-- | 'True' if contour is all descending, equal or ascending.+--+-- > map (uniform.contour_description) ["abc","bbb","cba"] == [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+-- | 'True' if contour does not containt any 'EQ' elements.+--+-- > map (no_equalities.contour_description) ["abc","bbb","cba"] == [True,False,True] no_equalities :: Contour_Description -> Bool-no_equalities (Contour_Description _ m) = not (EQ `elem` M.elems m)+no_equalities (Contour_Description _ m) = EQ `notElem` M.elems m --- | all contour descriptions+-- | Set of all contour descriptions.+--+-- > map (length.all_contours) [3,4,5] == [27,729,59049] all_contours :: Int -> [Contour_Description] all_contours n = let n' = contour_description_lm n@@ -128,8 +160,8 @@ mk p = Contour_Description n (M.fromList (zip ix p)) in map mk ps --- p.266-violations :: Contour_Description -> [(Int, Int, Int, Ordering)]+-- | List of all violations at a 'Contour_Description' (p.266).+violations :: Contour_Description -> [(Int,Int,Int,Ordering)] violations d = let n = contour_description_n d - 1 ms = [(i,j,k) | i <- [0..n], j <- [i + 1 .. n], k <- [j + 1 .. n]]@@ -145,22 +177,33 @@ else Just (i,j,k,x) in mapMaybe complies ms +-- | Is the number of 'violations' zero. is_possible :: Contour_Description -> Bool is_possible = (== 0) . length . violations --- | all possible contour descriptions+-- | All possible contour descriptions+--+-- > map (length.possible_contours) [3,4,5] == [13,75,541] possible_contours :: Int -> [Contour_Description] possible_contours = filter is_possible . all_contours --- | all impossible contour descriptions+-- | All impossible contour descriptions+--+-- > map (length.impossible_contours) [3,4,5] == [14,654,58508] impossible_contours :: Int -> [Contour_Description] impossible_contours = filter (not.is_possible) . all_contours --- p.263+-- | 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] contour_description_lm :: Integral a => a -> a contour_description_lm l = (l * l - l) `div` 2 --- a sequence of orderings (i,j) & (j,k) may imply ordering for (i,k)+-- | 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@@ -172,13 +215,18 @@ (GT,GT) -> Just GT _ -> error "implication" --- replace the i-th value at ns with x+-- | 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 fn (j,y) = if i == j then x else y- in map fn (zip [0..] ns)+ let f j y = if i == j then x else y+ in zipWith f [0..] ns --- diverges for impossible contours+-- | Derive an 'Integral' contour that would be described by+-- 'Contour_Description'. Diverges for impossible contours.+--+-- > draw_contour (contour_description "abdc") == [0,1,3,2] draw_contour :: Integral i => Contour_Description -> [i] draw_contour d = let n = contour_description_n d@@ -195,9 +243,9 @@ in if c == c' then Nothing else let j'' = case c of- LT -> i' + (adjustment j')+ LT -> i' + adjustment j' EQ -> i'- GT -> i' - (adjustment j')+ GT -> i' - adjustment j' in Just (replace ns j j'') refine [] ns = ns refine (i:is) ns = case step i ns of@@ -205,6 +253,9 @@ 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@@ -212,23 +263,46 @@ EQ -> EQ GT -> LT +-- | Invert 'Contour_Description'.+--+-- > draw_contour (contour_description_invert (contour_description "abdc")) == [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) --- p.262 (quarter-note durations)+-- | Example from p.262 (quarter-note durations)+--+-- > ex_1 == [2,3/2,1/2,1,2]+-- > compare_adjacent ex_1 == [GT,GT,LT,LT]+-- > show (contour_half_matrix ex_1) == "2221 220 00 0"+-- > draw_contour (contour_description ex_1) == [3,2,0,1,3]+--+-- > let d = contour_description_invert (contour_description ex_1)+-- > in (show d,is_possible d) == ("0001 002 22 2",True) ex_1 :: [Rational] ex_1 = [2,3%2,1%2,1,2] --- p.265 (pitch)+-- | Example on p.265 (pitch)+--+-- > ex_2 == [0,5,3]+-- > show (contour_description ex_2) == "00 2" ex_2 :: [Integer] ex_2 = [0,5,3] --- p.265 (pitch)+-- | Example on p.265 (pitch)+--+-- > ex_3 == [12,7,6,7,8,7]+-- > show (contour_description ex_3) == "22222 2101 000 01 2"+-- > contour_description_ix (contour_description ex_3) (0,5) == GT+-- > is_possible (contour_description ex_3) == True ex_3 :: [Integer] ex_3 = [12,7,6,7,8,7] --- p.266 (impossible)+-- | Example on p.266 (impossible)+--+-- > show ex_4 == "2221 220 00 1"+-- > is_possible ex_4 == False+-- > violations ex_4 == [(0,3,4,GT),(1,3,4,GT)] ex_4 :: Contour_Description ex_4 = let ns :: [[Int]]
+ Music/Theory/Diagram/Grid.hs view
@@ -0,0 +1,138 @@+-- | Functions for drawing grid and table structure common in music+-- theory and in compositions such as Morton Feldman's durational+-- /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 qualified Text.HTML.Light as H {- html-minimalist -}+import qualified Text.XML.Light as X {- xml -}++-- * Grid++-- | Real number, synonym for 'Double'.+type R = Double++-- | Point given as pair of 'R'.+type P = (R,R)++-- | Red, green and blue colour triple.+type C = (R,R,R)++-- | Cell location as row and column indices.+type L = (Int,Int)++-- | Cell+type Cell = (L,C,String)++-- | Grid+type Grid = [Cell]++-- | Given /(x,y)/ upper-left co-ordinate of grid, /(w,h)/ cell+-- dimensions, and /(r,c)/ grid dimensions, make list of upper-left+-- co-ordinates of cells.+--+-- > grid (10,10) (50,10) (2,2) == [(10,10),(60,10),(10,20),(60,20)]+grid :: P -> (R,R) -> (Int,Int) -> [P]+grid (x,y) (w,h) (r,c) =+ let xs = take c [x, x + w ..]+ ys = take r [y, y + h ..]+ in concatMap (zip xs . repeat) ys++-- | Variant on 'grid' that constructs a single point.+--+-- > map (grid_pt (10,10) (50,10)) [(0,0),(1,1)] == [(10,10),(60,20)]+grid_pt :: (R,R) -> (R,R) -> L -> P+grid_pt (x,y) (w,h) (r,c) =+ let r' = fromIntegral r+ c' = fromIntegral c+ in (x + c' * w,y + r' * h)++-- | Displace 'P' (pointwise addition).+--+-- > displace (2,3) (1,1) == (3,4)+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]]++-- | Render 'Table' as @XHTML@ 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)]++-- | 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++-- | Write set of 'Table's to @XHTML@ file.+to_xhtml :: FilePath -> [Table] -> IO ()+to_xhtml o_fn = writeFile o_fn . page
+ Music/Theory/Diagram/Path.hs view
@@ -0,0 +1,230 @@+-- | Functions to make /path diagrams/ such as those in Fig. VIII-11+-- on I.Xenakis /Formalized Music/.+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++-- | Set of all /(pre,element,post)/ triples of a sequence.+--+-- > parts "abc" == [("",'a',"bc"),("a",'b',"c"),("ab",'c',"")]+parts :: [a] -> [([a],a,[a])]+parts inp =+ let f p i q = let r = (p,i,q)+ in case q of+ [] -> [r]+ (q':q'') -> r : f (p ++ [i]) q' q''+ in case inp of+ (x:xs) -> f [] x xs+ [] -> []++-- | All /(element,remainder)/ pairs for a sequence.+--+-- > parts' "abc" == [('a',"bc"),('b',"ac"),('c',"ab")]+parts' :: [a] -> [(a,[a])]+parts' = let f (p,i,q) = (i,p++q) in map f . parts++-- | Gather elements with equal keys.+--+-- > gather (zip "abcba" [0..]) == [('a',[0,4]),('b',[1,3]),('c',[2])]+gather :: (Ord a) => [(a,i)] -> [(a,[i])]+gather =+ let f xs = (fst (head xs),map snd xs)+ in map f . groupBy ((==) `on` fst) . sortBy (compare `on` fst)++-- * Geometry++-- | Does either endpoint of the /lhs/ 'Ln' lie on the /rhs/ 'Ln'.+--+-- > ln_on (ln' (1/2,1/2) (1/2,1)) (ln' (0,0) (1,1)) == True+-- > ln_on (ln' (1/2,0) (1/2,1)) (ln' (0,0) (1,1)) == False+ln_on :: Ln R -> Ln R -> Bool+ln_on l0 l1 =+ let (p,q) = ln_pt l0+ in pt_on_line l1 p || pt_on_line l1 q++-- | Do 'Ln's overlap in the particular sense of being 'ln_parallel'+-- and at least one endpoint of one line lying on the other.+overlap :: Ln R -> Ln R -> Bool+overlap p q = ln_parallel p q && (ln_on p q || ln_on q p)++-- | Do both points of the /rhs/ 'Ln' lie on the /lhs/ 'Ln'.+includes :: Ln R -> Ln R -> Bool+includes l0 l1 =+ let (p,q) = ln_pt l1+ f = pt_on_line l0+ in f p && f q++-- | 'flip' 'includes'.+is_included :: Ln R -> Ln R -> Bool+is_included = flip includes++-- | Apply /f/ to /x/ and /y/ duple of 'Pt'.+pt_fn :: ((a,a) -> b) -> Pt a -> b+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 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 f = ln_fn (\(p,q) -> ln (f p) (f q))++-- | Scale set of 'Ln' to lie in area given by /(0,n)/.+to_unit :: R -> [Ln R] -> [Ln R]+to_unit m p =+ let p' = concatMap (ln_fn (\(i,j) -> [i,j])) p+ x = maximum (map pt_x p')+ y = maximum (map pt_y p')+ f n = pt_fn (\(i,j) -> pt (i*m/n) (m - (j*m/n)))+ g n = ln_pt_fn (f n)+ in map (g (max x y)) p++-- * Orientation++-- | Enumeration of 'Vertical', 'Horizontal' and 'Diagonal'.+data Orientation a = Vertical | Horizontal | Diagonal a+ deriving (Eq,Show)++-- | Calculate 'Orientation' of 'Ln'.+--+-- > 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 l =+ case ln_slope l of+ Nothing -> Vertical+ Just m -> if m == 0 then Horizontal else Diagonal m++-- * Shift Map++-- | A table 'Pt' and 'Orientation' set pairs.+type Shift_Map a = [(Pt a,[Orientation a])]++-- | Construct a 'Shift_Map' from a set of 'Ln's.+mk_shift_map :: [Ln R] -> Shift_Map R+mk_shift_map =+ let f i l = if overlap i l then Just (i,orientation l) else Nothing+ g (x,i,_) = mapMaybe (f i) x+ h (l0,o) = let (p,q) = ln_pt l0 in [(p,o),(q,o)]+ in gather . concatMap h . concatMap g . parts++-- | Apply 'Shift_Map' to a 'Pt'.+shift_map_pt :: Shift_Map R -> Pt R -> Pt R+shift_map_pt tbl i =+ let n = 0.1+ (x,y) = pt_xy i+ g o = let x' = if Vertical `elem` o then x+n else x+ y' = if Horizontal `elem` o then y+n else y+ in pt x' y'+ in maybe i g (lookup i tbl)++-- | Apply 'Shift_Map' to a 'Ln'.+shift_map_ln :: Shift_Map R -> Ln R -> Ln R+shift_map_ln tbl = ln_pt_fn (shift_map_pt tbl)++-- * Shift table++-- | A table of 'Pt' pairs.+type Shift_Table a = [(Pt a,Pt a)]++-- | Make element of 'Shift_Table'.+mk_shift_tbl_m :: (Ln R,Bool) -> Maybe (Shift_Table R)+mk_shift_tbl_m (l,occ) =+ if occ+ then let (p1,p2) = ln_pt l+ ((x1,y1),(x2,y2)) = ln_pt' l+ n = 0.1+ in if x1 == x2+ then let x = x1 + n in Just [(p1,pt x y1),(p2,pt x y2)]+ else let y = y1 + n in Just [(p1,pt x1 y),(p2,pt x2 y)]+ else Nothing++-- | Make complete 'Shift_Table'.+mk_shift_tbl :: Collision_Table -> Shift_Table R+mk_shift_tbl = concat . mapMaybe mk_shift_tbl_m++-- | Apply 'Shift_Table' to 'Ln'.+shift_table_ln :: Shift_Table R -> Ln R -> Ln R+shift_table_ln tbl =+ let f i = fromMaybe i (lookup i tbl)+ in ln_fn (\(p,q) -> ln (f p) (f q))++-- * Collision table++-- | Table of 'Ln's indicating collisions.+type Collision_Table = [(Ln R,Bool)]++-- | Construct 'Collision_Table' for a set of 'Ln'.+mk_collision_table :: [Ln R] -> Collision_Table+mk_collision_table =+ let f (x,xs) = (x,any (is_included x) xs)+ in map f . parts'++-- | Construct 'Shift_Table' from 'Collision_Table' and shift all 'Ln'.+collision_table_rewrite :: Collision_Table -> [Ln R]+collision_table_rewrite xs =+ let tbl = mk_shift_tbl xs+ in map (shift_table_ln tbl . fst) xs++-- * Path diagram++-- | A diagram given as a set of 'Int' pairs.+type Path_Diagram = [(Int,Int)]++-- | Construct set of 'Ln' from 'Path_Diagram'.+path_diagram_ln :: Path_Diagram -> [Ln R]+path_diagram_ln xs =+ let xs' = map (pt_from_i . pt') xs+ in zipWith ln xs' (tail xs')++-- | 'Collision_Table' based resolution of 'Path_Diagram'.+mk_path_ct :: Path_Diagram -> [Ln R]+mk_path_ct = collision_table_rewrite . mk_collision_table . path_diagram_ln++-- | 'Shift_Map' variant of 'mk_path_ct'.+mk_path_sm :: Path_Diagram -> [Ln R]+mk_path_sm p =+ let p' = path_diagram_ln p+ in map (shift_map_ln (mk_shift_map p')) p'++-- * Drawing++-- | A set of 'Ca' and 'Ls' pairs.+type Path = [(Ca,Ls R)]++-- | Draw 'Path' with mid-point arrows.+draw_path :: Path -> C.Render ()+draw_path xs = do+ mapM_ (uncurry (arrows_mp 0.1 (pi/9))) xs+ C.showPage++-- | 'mapM_' 'draw_path'.+draw_paths :: [Path] -> C.Render ()+draw_paths = mapM_ draw_path++-- | 'draw_paths' to named @PDF@ file.+write_pdf :: FilePath -> [Path] -> IO ()+write_pdf fn xs = do+ let f s = C.renderWith s (C.translate 10 100 >>+ C.scale 100 100 >>+ draw_paths xs)+ C.withPDFSurface fn 500 500 f++-- * Path diagram++-- | Write @PDF@ of a set of 'Path_Diagram's to named file.+path_diagram :: FilePath -> [Path_Diagram] -> IO ()+path_diagram fn =+ let f (i,j) = (opaque black,[i,j])+ in write_pdf fn . map (map (ln_fn f) . to_unit 4 . mk_path_sm)
Music/Theory/Duration.hs view
@@ -1,57 +1,20 @@+-- | Common music notation duration model. module Music.Theory.Duration where -import Data.Function-import Data.List-import Data.Ratio--data Duration = Duration { division :: Integer- , dots :: Integer- , multiplier :: Rational }- deriving (Eq, Show)+import Data.Maybe -instance Ord Duration where- compare = duration_compare+-- | Standard music notation durational model+data Duration = Duration {division :: Integer -- ^ division of whole note+ ,dots :: Integer -- ^ number of dots+ ,multiplier :: Rational -- ^ tuplet modifier+ }+ deriving (Eq,Show) --- | Duration annotations+-- | Standard music notation durational model annotations data D_Annotation = Tie_Right | Tie_Left | Begin_Tuplet (Integer,Integer,Duration) | End_Tuplet deriving (Eq,Show) --- * Constants--breve,whole_note,half_note,quarter_note,eighth_note,sixteenth_note,thirtysecond_note :: Duration-breve = Duration 0 0 1-whole_note = Duration 1 0 1-half_note = Duration 2 0 1-quarter_note = Duration 4 0 1-eighth_note = Duration 8 0 1-sixteenth_note = Duration 16 0 1-thirtysecond_note = Duration 32 0 1--dotted_breve,dotted_whole_note,dotted_half_note,dotted_quarter_note,dotted_eighth_note,dotted_sixteenth_note,dotted_thirtysecond_note :: Duration-dotted_breve = Duration 0 1 1-dotted_whole_note = Duration 1 1 1-dotted_half_note = Duration 2 1 1-dotted_quarter_note = Duration 4 1 1-dotted_eighth_note = Duration 8 1 1-dotted_sixteenth_note = Duration 16 1 1-dotted_thirtysecond_note = Duration 32 1 1--double_dotted_breve,double_dotted_whole_note,double_dotted_half_note,double_dotted_quarter_note,double_dotted_eighth_note,double_dotted_sixteenth_note,double_dotted_thirtysecond_note :: Duration-double_dotted_breve = Duration 0 2 1-double_dotted_whole_note = Duration 2 2 1-double_dotted_half_note = Duration 2 2 1-double_dotted_quarter_note = Duration 4 2 1-double_dotted_eighth_note = Duration 8 2 1-double_dotted_sixteenth_note = Duration 16 2 1-double_dotted_thirtysecond_note = Duration 32 2 1---- * Operations--duration_compare :: Duration -> Duration -> Ordering-duration_compare = compare `on` duration_to_rq-- -- | Compare durations with equal multipliers. duration_compare_meq :: Duration -> Duration -> Ordering duration_compare_meq y0 y1 =@@ -65,11 +28,14 @@ then compare n0 n1 else compare x1 x0 -{--zipWith duration_compare_meq [e,e,e,e'] [e,s,q,e]--}+-- | 'Ord' instance in terms of 'duration_compare_meq'.+instance Ord Duration where+ compare = duration_compare_meq -sort_pair :: (t -> t -> Ordering) -> (t, t) -> (t, t)+-- | 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)@@ -108,65 +74,17 @@ else sum_dur_dotted (division x0, dots x0 ,division x1, dots x1) +-- | Erroring variant of 'sum_dur'. sum_dur' :: Duration -> Duration -> Duration sum_dur' y0 y1 = let y2 = sum_dur y0 y1 err = error ("sum_dur': " ++ show (y0,y1))- in maybe err id y2+ in fromMaybe err y2 -{--zipWith sum_dur [e,q,q'] [e,e,e]--} --- * RQ (Rational Quarter Note Count)---- | Rational number of quarter notes to duration value.--- It is a mistake to hope this could handle tuplets--- directly, ie. a 3:2 dotted note will be of the same--- duration as a plain undotted note.-rq_to_duration :: Rational -> Maybe Duration-rq_to_duration x =- case (numerator x,denominator x) of- (1,8) -> Just thirtysecond_note- (3,16) -> Just dotted_thirtysecond_note- (1,4) -> Just sixteenth_note- (3,8) -> Just dotted_sixteenth_note- (1,2) -> Just eighth_note- (3,4) -> Just dotted_eighth_note- (1,1) -> Just quarter_note- (3,2) -> Just dotted_quarter_note- (2,1) -> Just half_note- (3,1) -> Just dotted_half_note- (7,2) -> Just double_dotted_half_note- (4,1) -> Just whole_note- (6,1) -> Just dotted_whole_note- (8,1) -> Just breve- (12,1) -> Just dotted_breve- _ -> Nothing---- | Convert a whole note division integer to a RQ.-whole_note_division_to_rq :: Integer -> Rational-whole_note_division_to_rq x =- let f = (* 4) . recip . (%1)- in case x of- 0 -> 8- -1 -> 16- _ -> f x---- | Apply `d' dots to the duration `n'.-rq_apply_dots :: Rational -> Integer -> Rational-rq_apply_dots n d =- let m = iterate (\x -> x / 2) n- in sum (genericTake (d + 1) m)---- | Convert duration to RQ value, see rq_to_duration for partial--- inverse.-duration_to_rq :: Duration -> Rational-duration_to_rq (Duration n d m) =- let x = whole_note_division_to_rq n- in rq_apply_dots x d * m---- | +-- | Give @MusicXML@ type for division.+--+-- > map whole_note_division_to_musicxml_type [2,4] == ["half","quarter"] whole_note_division_to_musicxml_type :: Integer -> String whole_note_division_to_musicxml_type x = case x of@@ -183,23 +101,36 @@ -1 -> "long" _ -> error ("whole_note_division_to_musicxml_type: " ++ show x) +-- | Variant of 'whole_note_division_to_musicxml_type' extracting+-- 'division' from 'Duration'.+--+-- > duration_to_musicxml_type quarter_note == "quarter" duration_to_musicxml_type :: Duration -> String duration_to_musicxml_type = whole_note_division_to_musicxml_type . division --- Note the duration multiplier is *not* written.+-- | Give /Lilypond/ notation for 'Duration'. Note that the duration+-- multiplier is /not/ written.+--+-- > 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 _) = let dv' = if dv == 0 then "\\breve" else show dv in dv' ++ replicate (fromIntegral d) '.' +-- | Calculate number of beams at notated division.+--+-- > whole_note_division_to_beam_count 32 == Just 3 whole_note_division_to_beam_count :: Integer -> Maybe Integer whole_note_division_to_beam_count x = let t = [(256,6),(128,5),(64,4),(32,3),(16,2),(8,1) ,(4,0),(2,0),(1,0),(0,0),(-1,0)] in lookup x t +-- | Calculate number of beams at 'Duration'.+--+-- > map duration_beam_count [half_note,sixteenth_note] == [0,2] duration_beam_count :: Duration -> Integer duration_beam_count (Duration x _ _) =- case whole_note_division_to_beam_count x of- Nothing -> error "duration_beam_count"- Just x' -> x'+ let err = error "duration_beam_count"+ bc = whole_note_division_to_beam_count x+ in fromMaybe err bc
Music/Theory/Duration/Name.hs view
@@ -1,52 +1,33 @@+-- | Names for common music notation durations. module Music.Theory.Duration.Name where import Music.Theory.Duration --- * w,h,q,e,s--w,h,q,e,s :: Duration-w = whole_note-h = half_note-q = quarter_note-e = eighth_note-s = sixteenth_note--w',h',q',e',s' :: Duration-w' = dotted_whole_note-h' = dotted_half_note-q' = dotted_quarter_note-e' = dotted_eighth_note-s' = dotted_sixteenth_note--w'',h'',q'',e'',s'' :: Duration-w'' = Duration 1 2 1-h'' = Duration 2 2 1-q'' = Duration 4 2 1-e'' = Duration 8 2 1-s'' = Duration 16 2 1---- * _1,_2,_4,_8,_16,_32+-- * Constants -_1,_2,_4,_8,_16,_32 :: Duration-_1 = whole_note-_2 = half_note-_4 = quarter_note-_8 = eighth_note-_16 = sixteenth_note-_32 = Duration 32 0 1+breve,whole_note,half_note,quarter_note,eighth_note,sixteenth_note,thirtysecond_note :: Duration+breve = Duration 0 0 1+whole_note = Duration 1 0 1+half_note = Duration 2 0 1+quarter_note = Duration 4 0 1+eighth_note = Duration 8 0 1+sixteenth_note = Duration 16 0 1+thirtysecond_note = Duration 32 0 1 -_1',_2',_4',_8',_16',_32' :: Duration-_1' = dotted_whole_note-_2' = dotted_half_note-_4' = dotted_quarter_note-_8' = dotted_eighth_note-_16' = dotted_sixteenth_note-_32' = Duration 32 1 1+dotted_breve,dotted_whole_note,dotted_half_note,dotted_quarter_note,dotted_eighth_note,dotted_sixteenth_note,dotted_thirtysecond_note :: Duration+dotted_breve = Duration 0 1 1+dotted_whole_note = Duration 1 1 1+dotted_half_note = Duration 2 1 1+dotted_quarter_note = Duration 4 1 1+dotted_eighth_note = Duration 8 1 1+dotted_sixteenth_note = Duration 16 1 1+dotted_thirtysecond_note = Duration 32 1 1 -_1'',_2'',_4'',_8'',_16'',_32'' :: Duration-_1'' = Duration 1 2 1-_2'' = Duration 2 2 1-_4'' = Duration 4 2 1-_8'' = Duration 8 2 1-_16'' = Duration 16 2 1-_32'' = Duration 32 2 1+double_dotted_breve,double_dotted_whole_note,double_dotted_half_note,double_dotted_quarter_note,double_dotted_eighth_note,double_dotted_sixteenth_note,double_dotted_thirtysecond_note :: Duration+double_dotted_breve = Duration 0 2 1+double_dotted_whole_note = Duration 2 2 1+double_dotted_half_note = Duration 2 2 1+double_dotted_quarter_note = Duration 4 2 1+double_dotted_eighth_note = Duration 8 2 1+double_dotted_sixteenth_note = Duration 16 2 1+double_dotted_thirtysecond_note = Duration 32 2 1
+ Music/Theory/Duration/Name/Abbreviation.hs view
@@ -0,0 +1,62 @@+-- | Abbreviated names for 'Duration' values when written as literals.+-- There are /letter/ names where 'w' is 'whole_note' and so on, and+-- /numerical/ names where '_4' is 'quarter_note' and so on. In both+-- cases a @'@ extension means a @dot@ so that 'e''' is a double+-- dotted 'eighth_note'.+--+-- > zipWith duration_compare_meq [e,e,e,e'] [e,s,q,e] == [EQ,GT,LT,GT]+-- > zipWith sum_dur [e,q,q'] [e,e,e] == [Just q,Just q',Just h]+-- > zipWith sum_dur' [e,q,q'] [e,e,e] == [q,q',h]+module Music.Theory.Duration.Name.Abbreviation where++import Music.Theory.Duration+import Music.Theory.Duration.Name++-- * Letter names++w,h,q,e,s :: Duration+w = whole_note+h = half_note+q = quarter_note+e = eighth_note+s = sixteenth_note++w',h',q',e',s' :: Duration+w' = dotted_whole_note+h' = dotted_half_note+q' = dotted_quarter_note+e' = dotted_eighth_note+s' = dotted_sixteenth_note++w'',h'',q'',e'',s'' :: Duration+w'' = Duration 1 2 1+h'' = Duration 2 2 1+q'' = Duration 4 2 1+e'' = Duration 8 2 1+s'' = Duration 16 2 1++-- * Numerical names++_1,_2,_4,_8,_16,_32 :: Duration+_1 = whole_note+_2 = half_note+_4 = quarter_note+_8 = eighth_note+_16 = sixteenth_note+_32 = Duration 32 0 1++_1',_2',_4',_8',_16',_32' :: Duration+_1' = dotted_whole_note+_2' = dotted_half_note+_4' = dotted_quarter_note+_8' = dotted_eighth_note+_16' = dotted_sixteenth_note+_32' = Duration 32 1 1++_1'',_2'',_4'',_8'',_16'',_32'' :: Duration+_1'' = Duration 1 2 1+_2'' = Duration 2 2 1+_4'' = Duration 4 2 1+_8'' = Duration 8 2 1+_16'' = Duration 16 2 1+_32'' = Duration 32 2 1
+ Music/Theory/Duration/RQ.hs view
@@ -0,0 +1,71 @@+-- | Rational quarter-note notation for durations.+module Music.Theory.Duration.RQ where++import Data.Function+import Data.List+import Data.Ratio+import Music.Theory.Duration+import Music.Theory.Duration.Name++-- | 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.+--+-- > rq_to_duration (3/4) == Just dotted_eighth_note+rq_to_duration :: RQ -> Maybe Duration+rq_to_duration x =+ case (numerator x,denominator x) of+ (1,8) -> Just thirtysecond_note+ (3,16) -> Just dotted_thirtysecond_note+ (1,4) -> Just sixteenth_note+ (3,8) -> Just dotted_sixteenth_note+ (1,2) -> Just eighth_note+ (3,4) -> Just dotted_eighth_note+ (1,1) -> Just quarter_note+ (3,2) -> Just dotted_quarter_note+ (2,1) -> Just half_note+ (3,1) -> Just dotted_half_note+ (7,2) -> Just double_dotted_half_note+ (4,1) -> Just whole_note+ (6,1) -> Just dotted_whole_note+ (8,1) -> Just breve+ (12,1) -> Just dotted_breve+ _ -> Nothing++-- | Convert a whole note division integer to an 'RQ' value.+--+-- > map whole_note_division_to_rq [1,2,4,8] == [4,2,1,1/2]+whole_note_division_to_rq :: Integer -> RQ+whole_note_division_to_rq x =+ let f = (* 4) . recip . (%1)+ in case x of+ 0 -> 8+ -1 -> 16+ _ -> f x++-- | Apply dots to an 'RQ' duration.+--+-- > map (rq_apply_dots 1) [1,2] == [3/2,7/4]+rq_apply_dots :: RQ -> Integer -> RQ+rq_apply_dots n d =+ let m = iterate (/ 2) n+ in sum (genericTake (d + 1) m)++-- | Convert 'Duration' to 'RQ' value, see 'rq_to_duration' for+-- partial inverse.+--+-- > map duration_to_rq [half_note,dotted_quarter_note] == [2,3/2]+duration_to_rq :: Duration -> RQ+duration_to_rq (Duration n d m) =+ let x = whole_note_division_to_rq n+ in rq_apply_dots x d * m++-- | 'compare' function for 'Duration' via 'duration_to_rq'.+--+-- > half_note `duration_compare_rq` quarter_note == GT+duration_compare_rq :: Duration -> Duration -> Ordering+duration_compare_rq = compare `on` duration_to_rq
Music/Theory/Duration/Sequence/Notate.hs view
@@ -1,12 +1,15 @@+-- | Notation of a sequence of 'RQ' values as annotated 'Duration' values. module Music.Theory.Duration.Sequence.Notate (Duration_A- ,notate+ ,Simplify,simplify+ ,notate,notate' ,ascribe- ,group_boundary) where+ ,group_boundary_lenient,group_boundary_strict) where -import Data.List+import Data.Maybe import Data.Ratio import Music.Theory.Duration+import Music.Theory.Duration.RQ {- import Debug.Trace@@ -17,42 +20,46 @@ debug :: (Show a) => a -> x -> x debug _ x = x -type R = Rational-type D = (R,R,Bool,Bool) {- start_time duration tied_left tied_right -}+-- | Tuple of /start-time/, /duration/, /tied-left/ and /tied-right/.+type D = (RQ,RQ,Bool,Bool)++-- | Annotated 'Duration' type Duration_A = (Duration,[D_Annotation]) -d_duration :: D -> R+-- | 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 [] = []-integrate (x:xs) =- let fn i c = (i + c, i + c)- in x : snd (mapAccumL fn x xs)+integrate = scanl1 (+) --- xs = boundaries--- d = duration+-- | 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 [] _ = error "step_dur: no boundaries"-step_dur _ 0 = error "step_dur: zero duration"-step_dur (x:xs) d =- let jn a (a',b) = (a:a',b)- in case compare d x of- EQ -> ([d],xs)- LT -> ([d],(x-d):xs)- GT -> jn x (step_dur xs (d - x))--{--step_dur [2,1,3] 5-step_dur [3%2,3%2,3%2] 2--}+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)+-- | 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 [] _ = []@@ -62,51 +69,48 @@ in d' : go xs' ds in go -{--boundaries (repeat 3) [1..5]-boundaries (repeat (3%2)) [1%2,1..5]--}---- i = initial start time--- xs = durations+-- | 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+-- | 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 0 [4,3,5,2,1]-with_start_times' [[4,3,5],[2,1],[6,3]] with_start_times' (boundaries [3,3,3,3,3] [4,3,5,2,1]) let xs = [3%4,2%1,5%4,9%4,1%4,3%2,1%2,7%4,1%1,5%2,11%4,3%2] with_start_times 0 xs with_start_times' (boundaries (repeat (3%2)) xs) -} --- split list into first element, possibly empty 'middle' elements,--- and end element+-- | 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)+ _:_:_ -> let n = length xs+ x0 = xs !! 0+ xn = xs !! (n - 1)+ in (x0,take (n - 2) (drop 1 xs),xn) _ -> error "start_middle_end: list must have at least two elements" -{--start_middle_end []-start_middle_end [1..6]--}- -- xs = [(start-time,duration)]-tied_r_to_d :: [(R,R)] -> [D]+tied_r_to_d :: [(RQ,RQ)] -> [D] tied_r_to_d xs = case xs of [] -> []@@ -115,7 +119,7 @@ f (s,d) = (s,d,True,True) in (s0,d0,False,True) : map f xs' ++ [(sn,dn,True,False)] -boundaries_d :: [R] -> [R] -> [D]+boundaries_d :: [RQ] -> [RQ] -> [D] boundaries_d xs ds = let bs = boundaries xs ds in concatMap tied_r_to_d (with_start_times' bs)@@ -124,8 +128,10 @@ boundaries_d [3,3,3,3,3,3,3,3] [4,3,5,2,1,7,2] -} --- | rational modulo-r_mod :: R -> R -> R+-- | 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@@ -135,7 +141,7 @@ {- -- n = boundary -- i = phase-sep_at :: R -> R -> R -> [D]+sep_at :: RQ -> RQ -> R -> [D] sep_at = let go l n i x = let i' = n - (i `r_mod` n)@@ -145,23 +151,22 @@ else [(i,x,l,False)] in go False -{- sep_at 1 (1%2) 1 sep_at 1 (1%3) (6%3) -}--} --- unrep = un-representable by single cmn duration (ie. requires tie)--- i = phase--- x = duration-sep_unrep :: R -> R -> Maybe (R,R)+-- | 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)+ f (n,m) = (n%denominator x,m%denominator x) swap (a,b) = (b,a) in case j of Nothing -> Nothing@@ -175,11 +180,11 @@ Just (x0,x1) -> [(i,x0,l,True),(i+x0,x1,True,r)] {--zipWith sep_unrep [1,3%8,1] [5%4,5%8,4]+zipWith 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 :: [R] -> [R] -> [D]+separate :: [RQ] -> [RQ] -> [D] separate ns = concatMap sep_unrep_d . boundaries_d ns {-@@ -188,10 +193,13 @@ -} -- | group to n, or to multiple of-group_boundary :: (a -> R) -> [R] -> [a] -> [[a]]-group_boundary dur_f =+--+-- > 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: no boundaries?"+ go _ _ [] _ = error "group_boundary_lenient: no boundaries?" go _ js _ [] = [reverse js] go _ js _ [x] = [reverse (x:js)] go c js (n:ns) (x:xs) =@@ -205,20 +213,40 @@ 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+ {--group_boundary id [1,1,1] [2,1%2,1%2]+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) -} -group_boundary_d :: [R] -> [D] -> [[D]]-group_boundary_d = group_boundary d_duration+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 -{--group_boundary id [3,3,3] (cycle [1,2,3])+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) -let i = [1,1%2,2,1%3,5%3,1%8,1%2,7%8]-in group_boundary_d (repeat 1) (separate (repeat 1) i)--}+-- | 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@@ -237,13 +265,13 @@ {- let i = [1,1%2,2,1%3,5%3,1%8,1%2,7%8]-in map derive_tuplet (group_boundary_d 1 (separate 1 i))+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) -> R -> R+-- | 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@@ -255,11 +283,13 @@ (x1 == 2 && r1 && x2 `elem` [1,2]) = debug ("aligned-join",s1,x1,x2) (Just (s1,x1+x2,l1,r2)) | otherwise = debug ("aligned-no-join",s1,x1,r1,x2) Nothing -divisible_by :: R -> R -> Bool+divisible_by :: RQ -> RQ -> Bool divisible_by i j = denominator (i / j) == 1 --- partial/incomplete/inaccurate-d_join :: R -> D -> D -> Maybe D+-- | 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 &&@@ -276,12 +306,8 @@ | otherwise = debug ("non-aligned-no-join",a,s1,x1) Nothing {--d_join 1 (7 % 4,1 % 4,False,True) (2 % 1,1 % 4,True,False)--}--{- -- error checking variant-d_join' :: R -> D -> D -> Maybe D+d_join' :: RQ -> D -> D -> Maybe D d_join' a d1 d2 = case d_join a d1 d2 of Nothing -> Nothing@@ -299,34 +325,37 @@ Just x' -> coalesce f (x':xs') _ -> xs --- a = alignment--- ns = boundaries--- two pass, ie. [2,1%2,1%2] becomes [2,1] becomes [3]-simplify :: R -> [R] -> [D] -> [D]+-- | 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_d ns xs+ let xs' = group_boundary_lenient_d ns xs pass :: [[D]] -> [[D]] pass = map (coalesce (d_join a)) in concat ((pass . pass) xs') --- erroring variant of rq_to_duration-to_duration :: Show a => a -> R -> Duration+-- | 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 maybe err id (rq_to_duration 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- (Just ty) = rq_to_duration (sum (map duration_to_rq xs) / (d%1))+ 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--- simplifier does not look ahead.+-- | 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@@ -335,44 +364,65 @@ r' = if r then [Tie_Right] else [] in (d,l' ++ r' ++ fs) xs' = case derive_tuplet xs of- Nothing -> let f = to_duration ("no-tuplet",ds)+ Nothing -> let f = to_duration ("notate-sec:no-tuplet",ds) in map (\d -> (f d,[])) ds- Just t -> let f = to_duration ("tuplet",t,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' --- is = unit divisions (must not conflict with ns)--- ns = boundaries (ie. measures)--- xs = durations--- note: alignments are not handled correctly-notate :: [R] -> [R] -> [R] -> [Duration_A]-notate is ns xs =- let xs' = simplify (head is) ns (separate is xs)- in concatMap notate_sec (group_boundary_d is xs')+-- | 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 xs = [2%1, 3%5, 2%5] let is = repeat (1%1) let ns = repeat (3%1) map (\(x,y) -> (duration_to_lilypond_type x,y)) (notate is ns xs) separate is xs let xs' = simplify (head is) ns (separate is xs)-group_boundary_d is xs'+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+ 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
Music/Theory/Interval.hs view
@@ -1,26 +1,37 @@+-- | Common music notation intervals. module Music.Theory.Interval where +import Data.Maybe import Music.Theory.Pitch +-- | Interval type or degree. data Interval_T = Unison | Second | Third | Fourth | Fifth | Sixth | Seventh- deriving (Eq, Ord, Enum, Show)+ deriving (Eq,Enum,Bounded,Ord,Show) +-- | Interval quality. data Interval_Q = Diminished | Minor | Perfect | Major | Augmented- deriving (Eq, Ord, Enum, Show)+ deriving (Eq,Enum,Bounded,Ord,Show) -data Interval = Interval { interval_type :: Interval_T- , interval_quality :: Interval_Q- , interval_direction :: Ordering- , interval_octave :: Octave }- deriving (Eq, Show)+-- | Common music notation interval.+data Interval = Interval {interval_type :: Interval_T+ ,interval_quality :: Interval_Q+ ,interval_direction :: Ordering+ ,interval_octave :: Octave}+ deriving (Eq,Show) +-- | Interval type between 'Note_T' values.+--+-- > map (interval_ty C) [E,B] == [Third,Seventh] interval_ty :: Note_T -> Note_T -> Interval_T interval_ty n1 n2 = toEnum ((fromEnum n2 - fromEnum n1) `mod` 7) -interval_q_tbl :: [(Interval_T, [(Int, Interval_Q)])]+-- | 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)])] interval_q_tbl = [(Unison,[(11,Diminished) ,(0,Perfect)@@ -48,12 +59,21 @@ ,(11,Major) ,(12,Augmented)])] +-- | Lookup 'Interval_Q' for given 'Interval_T' and semitone count.+--+-- > interval_q Unison 11 == Just Diminished+-- > interval_q Third 5 == Just Augmented+-- > interval_q Fourth 5 == Just Perfect+-- > interval_q Unison 3 == Nothing interval_q :: Interval_T -> Int -> Maybe Interval_Q-interval_q i n =- case lookup i interval_q_tbl of- Just t -> lookup n t- Nothing -> Nothing+interval_q i n = lookup i interval_q_tbl >>= lookup n +-- | Inclusive set of 'Note_T' within indicated interval. This is not+-- equal to 'enumFromTo' which is not circular.+--+-- > note_span E B == [E,F,G,A,B]+-- > note_span B D == [B,C,D]+-- > enumFromTo B D == [] note_span :: Note_T -> Note_T -> [Note_T] note_span n1 n2 = let fn x = toEnum (x `mod` 7)@@ -62,6 +82,9 @@ n2'' = if n1' > n2' then n2' + 7 else n2' in map fn [n1' .. n2''] +-- | Invert 'Ordering', ie. 'GT' becomes 'LT' and vice versa.+--+-- > map invert_ordering [LT,EQ,GT] == [GT,EQ,LT] invert_ordering :: Ordering -> Ordering invert_ordering x = case x of@@ -69,6 +92,10 @@ LT -> GT EQ -> EQ +-- | Determine 'Interval' between two 'Pitch'es.+--+-- > interval (Pitch C Sharp 4) (Pitch D Flat 4) == Interval Second Diminished EQ 0+-- > interval (Pitch C Sharp 4) (Pitch E Sharp 5) == Interval Third Major LT 1 interval :: Pitch -> Pitch -> Interval interval p1 p2 = let c = compare p1 p2@@ -84,14 +111,23 @@ GT -> (interval p2 p1) { interval_direction = GT } _ -> Interval ty qu c (o2 - o1 + o_a) +-- | Apply 'invert_ordering' to 'interval_direction' of 'Interval'.+--+-- > invert_interval (Interval Third Major LT 1) == Interval Third Major GT 1 invert_interval :: Interval -> Interval invert_interval (Interval t qu d o) = let d' = invert_ordering d in Interval t qu d' o --- can this be written without knowing the Interval_T?-quality_difference :: Interval_Q -> Interval_Q -> Int-quality_difference a b =+-- | The signed difference in semitones between two 'Interval_Q'+-- values when applied to the same 'Interval_T'. Can this be written+-- correctly without knowing the Interval_T?+--+-- > quality_difference_m Minor Augmented == Just 2+-- > quality_difference_m Augmented Diminished == Just (-3)+-- > quality_difference_m Major Perfect == Nothing+quality_difference_m :: Interval_Q -> Interval_Q -> Maybe Int+quality_difference_m a b = let rule (x,y) = if x == y then Just 0@@ -107,13 +143,21 @@ _ -> Nothing fwd = rule (a,b) rvs = rule (b,a)- err = error ("quality_difference: " ++ show (a,b)) in case fwd of- Just n -> n+ Just n -> Just n Nothing -> case rvs of- Just n -> negate n- Nothing -> err+ Just n -> Just (negate n)+ Nothing -> Nothing +-- | Erroring variant of 'quality_difference_m'.+quality_difference :: Interval_Q -> Interval_Q -> Int+quality_difference a b =+ let err = error ("quality_difference: " ++ show (a,b))+ in fromMaybe err (quality_difference_m a b)++-- | Transpose a 'Pitch' by an 'Interval'.+--+-- > transpose (Interval Third Diminished LT 0) (Pitch C Sharp 4) == Pitch E Flat 4 transpose :: Interval -> Pitch -> Pitch transpose i ip = let (Pitch p_n p_a p_o) = ip@@ -135,12 +179,17 @@ ty = if i_d == GT then interval_ty p_n' p_n else interval_ty p_n p_n'- qu = maybe (error ("qu: " ++ show (ty,st))) id- (interval_q ty (fromIntegral st))+ qu = let err = error ("qu: " ++ show (ty,st))+ in fromMaybe err (interval_q ty (fromIntegral st)) qd = quality_difference qu i_q * i_d' p_a' = toEnum (fromEnum p_a + (qd * 2)) in ip' { alteration = p_a' } +-- | Make leftwards (perfect fourth) and and rightwards (perfect+-- fifth) circles from 'Pitch'.+--+-- > let c = circle_of_fifths (Pitch F Sharp 4)+-- > in map pitch_to_pc (snd c) == [6,1,8,3,10,5,12,7,2,9,4,11] circle_of_fifths :: Pitch -> ([Pitch], [Pitch]) circle_of_fifths x = let p4 = Interval Fourth Perfect LT 0
+ Music/Theory/Interval/Name.hs view
@@ -0,0 +1,9 @@+-- | Constants names for ascending 'Interval' values.+module Music.Theory.Interval.Name where++import Music.Theory.Interval++perfect_fourth,perfect_fifth,major_seventh :: Interval+perfect_fourth = Interval Fourth Perfect LT 0+perfect_fifth = Interval Fifth Perfect LT 0+major_seventh = Interval Seventh Major LT 0
+ Music/Theory/Interval/Spelling.hs view
@@ -0,0 +1,46 @@+-- | Spelling rules for 'Interval' values.+module Music.Theory.Interval.Spelling where++import Music.Theory.Interval++-- | Simplest spelling for semitone intervals. This is ambiguous for+-- @6@ which could be either /aug.4/ or /dim.5/.+--+-- > i_to_interval 6 == Interval Fourth Augmented LT 0+-- > map i_to_interval [0..11]+i_to_interval :: Int -> Interval+i_to_interval x =+ let iv ty qu = Interval ty qu LT 0+ in case x of+ 0 -> iv Unison Perfect+ 1 -> iv Second Minor+ 2 -> iv Second Major+ 3 -> iv Third Minor+ 4 -> iv Third Major+ 5 -> iv Fourth Perfect+ 6 -> iv Fourth Augmented -- Fifth Diminished+ 7 -> iv Fifth Perfect+ 8 -> iv Sixth Minor+ 9 -> iv Sixth Major+ 10 -> iv Seventh Minor+ 11 -> iv Seventh Major+ _ -> error ("i_to_interval: " ++ show x)++-- | Perform some interval simplifications. For non-tonal music some+-- spellings are poor, ie. (f,g#).+--+-- > interval_simplify (Interval Second Augmented LT 0) == Interval Third Minor LT 0+interval_simplify :: Interval -> Interval+interval_simplify x =+ let (Interval ty qu d o) = x+ (qu',ty') = case (qu,ty) of+ (Diminished,Second) -> (Perfect,Unison)+ (Diminished,Third) -> (Major,Second)+ (Augmented,Second) -> (Minor,Third)+ (Augmented,Third) -> (Perfect,Fourth)+ (Diminished,Sixth) -> (Perfect,Fifth)+ (Diminished,Seventh) -> (Major,Sixth)+ (Augmented,Sixth) -> (Minor,Seventh)+ -- (Augmented,Seventh) -> (Perfect,Octave)+ _ -> (qu,ty)+ in Interval ty' qu' d o
Music/Theory/Key.hs view
@@ -1,3 +1,4 @@+-- | Common music keys. module Music.Theory.Key where import Data.List@@ -5,10 +6,22 @@ import Music.Theory.Pitch.Name import Music.Theory.Interval +-- | Enumeration of common music notation modes. data Mode_T = Minor_Mode | Major_Mode deriving (Eq,Ord,Show) -key_fifths :: (Note_T,Alteration_T,Mode_T) -> Int+-- | A common music notation key is a 'Note_T', 'Alteration_T',+-- 'Mode_T' triple.+type Key = (Note_T,Alteration_T,Mode_T)++-- | Distance along circle of fifths path of indicated 'Key'. A+-- positive number indicates the number of sharps, a negative number+-- the number of flats.+--+-- > key_fifths (A,Natural,Minor_Mode) == 0+-- > key_fifths (A,Natural,Major_Mode) == 3+-- > key_fifths (C,Natural,Minor_Mode) == -3+key_fifths :: Key -> Int key_fifths (n,a,m) = let cf x = let (p,q) = circle_of_fifths x in p ++ q eq (Pitch n' a' _) = n == n' && a == a'
Music/Theory/Parse.hs view
@@ -1,22 +1,28 @@-module Music.Theory.Parse (rnrtnmi, pco) where+-- | 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@@ -28,15 +34,21 @@ ; 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 + 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 (\c -> elem c "0123456789taAebB") s'+ s'' = takeWhile (`elem` "0123456789taAebB") s' f c | c `elem` "taA" = 10 | c `elem` "ebB" = 11 | otherwise = read [c]
Music/Theory/Pct.hs view
@@ -1,29 +1,57 @@+-- | 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.+-- | 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 [] = [[]]-cgg (x:xs) = [ y:z | y <- x, z <- cgg xs ]+cgg l =+ case l of+ x:xs -> [ y:z | y <- x, z <- cgg xs ]+ _ -> [[]] --- | Combinations generator (cg == poweset)+-- | 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 @@ -32,14 +60,34 @@ 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 =@@ -50,13 +98,43 @@ 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)]@@ -71,15 +149,21 @@ 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 +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 +-- | 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 =@@ -91,10 +175,23 @@ 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@@ -102,11 +199,18 @@ 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 @@ -121,7 +225,14 @@ 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' 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@@ -129,10 +240,21 @@ 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 @@ -140,13 +262,27 @@ nrm_r :: (Ord a) => [a] -> [a] nrm_r = sort --- | Pitch-class invariances.+-- | 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@@ -154,8 +290,29 @@ 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)+--+-- >>> 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]]@@ -164,6 +321,22 @@ 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
Music/Theory/Permutations.hs view
@@ -1,29 +1,174 @@-module Music.Theory.Permutations (permutations+-- | 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 -import qualified Data.Map as M+import Data.List import qualified Data.Permute as P import qualified Math.Combinatorics.Multiset as C+import Numeric (showHex) -all_ps :: P.Permute -> [P.Permute]-all_ps p =- let r = P.next p- in maybe [p] (\np -> p : all_ps np) r+-- | 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" -n_ps :: Int -> [[Int]]-n_ps n =- let p = P.permute n- ps = all_ps p- in map P.elems ps+-- | Number of permutations.+--+-- > 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) --- Generate list of all permutations.-permutations :: [a] -> [[a]]-permutations xs =- let m = M.fromList (zip [0..] xs)- ps = n_ps (M.size m)- r = map (\i -> M.findWithDefault (error "permutations") i m)- in map r ps+-- | Generate the permutation from /p/ to /q/, ie. the permutation+-- that, when applied to /p/, gives /q/.+--+-- > apply_permutation (permutation [0,1,3] [1,0,3]) [0,1,3] == [1,0,3]+permutation :: (Eq a) => [a] -> [a] -> P.Permute+permutation p q =+ let n = length p+ f x = elem_index_unique x p+ in P.listPermute n (map f q) --- Generate list of all distinct permutations.+-- | Apply permutation /f/ to /p/.+apply_permutation :: (Eq a) => P.Permute -> [a] -> [a]+apply_permutation f p = map (p !!) (P.elems f)++-- | Composition of 'apply_permutation' and 'from_cycles'.+--+-- > apply_permutation_c [[0,3],[1,2]] [1..4] == [4,3,2,1]+-- > apply_permutation_c [[0,2],[1],[3,4]] [1..5] == [3,2,1,5,4]+-- > apply_permutation_c [[0,1,4],[2,3]] [1..5] == [2,5,4,3,1]+-- > apply_permutation_c [[0,1,3],[2,4]] [1..5] == [2,4,5,1,3]+apply_permutation_c :: (Eq a) => [[Int]] -> [a] -> [a]+apply_permutation_c = apply_permutation . from_cycles++-- | True if the inverse of /p/ is /p/.+--+-- > non_invertible (permutation [0,1,3] [1,0,3]) == True+non_invertible :: P.Permute -> Bool+non_invertible p = p == P.inverse p++-- | Generate a permutation from the cycles /c/.+--+-- > apply_permutation (from_cycles [[0,1,2,3]]) [1..4] == [2,3,4,1]+from_cycles :: [[Int]] -> P.Permute+from_cycles c = P.cyclesPermute (sum (map length c)) c++-- | Generate all permutations of size /n/.+--+-- > map one_line (permutations_n 3) == [[1,2,3],[1,3,2]+-- > ,[2,1,3],[2,3,1]+-- > ,[3,1,2],[3,2,1]]+permutations_n :: Int -> [P.Permute]+permutations_n n =+ let f p = let r = P.next p+ 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]]+-- > ;q = from_cycles [[0,1,4],[2,3]]+-- > ;r = p `compose` q}+-- > in apply_permutation r [1,2,3,4,5] == [2,4,5,1,3]+compose :: P.Permute -> P.Permute -> P.Permute+compose p q =+ let n = P.size q+ i = [1 .. n]+ j = apply_permutation p i+ k = apply_permutation q j+ in permutation i k++-- | Two line notation of /p/.+--+-- > two_line (permutation [0,1,3] [1,0,3]) == ([1,2,3],[2,1,3])+two_line :: P.Permute -> ([Int],[Int])+two_line p =+ let n = P.size p+ i = [1..n]+ in (i,apply_permutation p i)++-- | One line notation of /p/.+--+-- > one_line (permutation [0,1,3] [1,0,3]) == [2,1,3]+--+-- > map one_line (permutations_n 3) == [[1,2,3],[1,3,2]+-- > ,[2,1,3],[2,3,1]+-- > ,[3,1,2],[3,2,1]]+one_line :: P.Permute -> [Int]+one_line = snd . two_line++-- | Variant of 'one_line' that produces a compact string.+--+-- > one_line_compact (permutation [0,1,3] [1,0,3]) == "213"+--+-- > let p = permutations_n 3+-- > in unwords (map one_line_compact p) == "123 132 213 231 312 321"+one_line_compact :: P.Permute -> String+one_line_compact =+ let f n = if n >= 0 && n <= 15+ then showHex n ""+ else error "one_line_compact:not(0-15)"+ in concatMap f . one_line++-- | Multiplication table of symmetric group /n/.+--+-- > unlines (map (unwords . map one_line_compact) (multiplication_table 3))+--+-- @+-- ==> 123 132 213 231 312 321+-- 132 123 312 321 213 231+-- 213 231 123 132 321 312+-- 231 213 321 312 123 132+-- 312 321 132 123 231 213+-- 321 312 231 213 132 123+-- @+multiplication_table :: Int -> [[P.Permute]]+multiplication_table n =+ let ps = permutations_n n+ f p = map (compose p) ps+ 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]]+let q = permutation [1..5] [2,5,4,3,1] -- [[0,1,4],[2,3]]+let r = permutation [1..5] [2,4,5,1,3] -- [[0,1,3],[2,4]]+(non_invertible p,P.cycles p,apply_permutation p [1..5])+(non_invertible q,P.cycles q,apply_permutation q [1..5])+(non_invertible r,P.cycles r,apply_permutation r [1..5])++map P.cycles (permutations_n 3)+map P.cycles (permutations_n 4)+partition not (map non_invertible (permutations_n 4))+-}
Music/Theory/Pitch.hs view
@@ -1,29 +1,42 @@+-- | Common music notation pitch values. module Music.Theory.Pitch where import Data.Function +-- | Pitch classes are modulo twelve integers. type PitchClass = Integer++-- | Octaves are integers, the octave of middle C is @4@. type Octave = Integer +-- | 'Octave' and 'PitchClass' duple.+type OctPC = (Octave,PitchClass)++-- | Enumeration of common music notation note names (@C@ to @B@). data Note_T = C | D | E | F | G | A | B- deriving (Eq, Ord, Enum, Bounded, Show)+ deriving (Eq,Enum,Bounded,Ord,Show) +-- | Enumeration of common music notation note alterations. data Alteration_T = DoubleFlat | ThreeQuarterToneFlat | Flat | QuarterToneFlat | Natural | QuarterToneSharp | Sharp | ThreeQuarterToneSharp | DoubleSharp- deriving (Eq, Ord, Enum, Show)+ deriving (Eq,Enum,Bounded,Ord,Show) -data Pitch = Pitch { note :: Note_T- , alteration :: Alteration_T- , octave :: Octave }+-- | Common music notation pitch value.+data Pitch = Pitch {note :: Note_T+ ,alteration :: Alteration_T+ ,octave :: Octave} deriving (Eq, Show) instance Ord Pitch where compare = pitch_compare -note_to_pc :: Note_T -> Integer+-- | Transform 'Note_T' to 'PitchClass'.+--+-- > map note_to_pc [C,E,G] == [0,4,7]+note_to_pc :: Note_T -> PitchClass note_to_pc n = case n of C -> 0@@ -34,6 +47,9 @@ A -> 9 B -> 11 +-- | Transform 'Alteration_T' to semitone alteration.+--+-- > map alteration_to_diff [Flat,Sharp] == [-1,1] alteration_to_diff :: Alteration_T -> Integer alteration_to_diff a = case a of@@ -44,6 +60,10 @@ DoubleSharp -> 2 _ -> error "alteration_to_diff: quarter tone" +-- | 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 a = case a of@@ -53,15 +73,43 @@ ThreeQuarterToneSharp -> 1.5 _ -> fromIntegral (alteration_to_diff a) -pitch_to_octpc :: Pitch -> (Octave, PitchClass)+-- | 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]+alteration_symbol :: Alteration_T -> Char+alteration_symbol a =+ case a of+ DoubleFlat -> '𝄫'+ ThreeQuarterToneFlat -> '𝄭'+ Flat -> '♭'+ QuarterToneFlat -> '𝄳'+ Natural -> '♮'+ QuarterToneSharp -> '𝄲'+ Sharp -> '♯'+ ThreeQuarterToneSharp -> '𝄰'+ DoubleSharp -> '𝄪'++-- | 'Pitch' to 'Octave' and 'PitchClass' notation.+--+-- > pitch_to_octpc (Pitch F Sharp 4) == (4,6)+pitch_to_octpc :: Pitch -> OctPC 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 (Pitch n a o) = let a' = alteration_to_diff a n' = note_to_pc n in 12 + o * 12 + n' + a' +-- | 'Pitch' to fractional midi note number notation.+--+-- > pitch_to_fmidi (Pitch A QuarterToneSharp 4) == 69.5 pitch_to_fmidi :: Pitch -> Double pitch_to_fmidi (Pitch n a o) = let a' = alteration_to_fdiff a@@ -69,31 +117,33 @@ n' = fromIntegral (note_to_pc n) in 12 + o' * 12 + n' + a' +-- | Extract 'PitchClass' of 'Pitch'+--+-- > pitch_to_pc (Pitch A Natural 4) == 9+-- > pitch_to_pc (Pitch F Sharp 4) == 6 pitch_to_pc :: Pitch -> PitchClass-pitch_to_pc = snd . pitch_to_octpc+pitch_to_pc (Pitch n a _) = note_to_pc n + alteration_to_diff a +-- | 'Pitch' comparison, implemented via 'pitch_to_fmidi'.+--+-- > pitch_compare (Pitch A Natural 4) (Pitch A QuarterToneSharp 4) == LT pitch_compare :: Pitch -> Pitch -> Ordering-pitch_compare = compare `on` pitch_to_octpc+pitch_compare = compare `on` pitch_to_fmidi -octpc_to_pitch :: (Octave, PitchClass) -> Pitch-octpc_to_pitch (o,pc) =- let (n,a) = case pc of- 0 -> (C,Natural)- 1 -> (C,Sharp)- 2 -> (D,Natural)- 3 -> (E,Flat)- 4 -> (E,Natural)- 5 -> (F,Natural)- 6 -> (F,Sharp)- 7 -> (G,Natural)- 8 -> (A,Flat)- 9 -> (A,Natural)- 10 -> (B,Flat)- 11 -> (B,Natural)- _ -> error ("octpc_to_pitch: " ++ show pc)+-- | Function to spell a 'PitchClass'.+type Spelling = PitchClass -> (Note_T, Alteration_T)++-- | Given 'Spelling' function translate from 'OctPC' notation to+-- 'Pitch'.+octpc_to_pitch :: Spelling -> OctPC -> Pitch+octpc_to_pitch sp (o,pc) =+ let (n,a) = sp pc in Pitch n a o -octpc_nrm :: (Octave, PitchClass) -> (Octave, PitchClass)+-- | Normalise 'OctPC' value, ie. ensure 'PitchClass' is in (0,11).+--+-- > octpc_nrm (4,16) == (5,4)+octpc_nrm :: OctPC -> OctPC octpc_nrm (o,pc) = if pc > 11 then octpc_nrm (o+1,pc-12)@@ -101,18 +151,33 @@ then octpc_nrm (o-1,pc+12) else (o,pc) -octpc_trs :: Integer -> (Octave, PitchClass) -> (Octave, PitchClass)+-- | 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_to_midi :: (Octave, PitchClass) -> Integer+-- | 'OctPC' value to /midi/ value.+--+-- > octpc_to_midi (4,9) == 69+octpc_to_midi :: OctPC -> Integer octpc_to_midi (o,pc) = 60 + ((o - 4) * 12) + pc -midi_to_octpc :: Integer -> (Octave, PitchClass)+-- | Inverse of 'octpc_to_midi'.+--+-- > midi_to_octpc 69 == (4,9)+midi_to_octpc :: Integer -> OctPC midi_to_octpc n = (n - 12) `divMod` 12 +-- | Apply function to 'octave' of 'PitchClass'.+--+-- > pitch_edit_octave (+ 1) (Pitch A Natural 4) == Pitch A Natural 5 pitch_edit_octave :: (Integer -> Integer) -> Pitch -> Pitch pitch_edit_octave f (Pitch n a o) = Pitch n a (f o) +-- | Modal transposition of 'Note_T' value.+--+-- > note_t_transpose C 2 == E note_t_transpose :: Note_T -> Int -> Note_T note_t_transpose x n = let x' = fromEnum x
Music/Theory/Pitch/Name.hs view
@@ -1,3 +1,7 @@+-- | Constants names for 'Pitch' values. /eses/ indicates double+-- flat, /eseh/ three quarter tone flat, /es/ flat, /eh/ quarter tone+-- flat, /ih/ quarter tone sharp, /is/ sharp, /isih/ three quarter+-- tone sharp and /isis/ double sharp. module Music.Theory.Pitch.Name where import Music.Theory.Pitch
+ Music/Theory/Pitch/Spelling.hs view
@@ -0,0 +1,75 @@+-- | Spelling rules for common music notation.+module Music.Theory.Pitch.Spelling where++import Music.Theory.Pitch++-- | Variant of 'Spelling' for incomplete functions.+type Spelling_M = PitchClass -> 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 pc =+ case pc of+ 0 -> Just (C,Natural)+ 2 -> Just (D,Natural)+ 4 -> Just (E,Natural)+ 5 -> Just (F,Natural)+ 7 -> Just (G,Natural)+ 9 -> Just (A,Natural)+ 11 -> Just (B,Natural)+ _ -> Nothing++-- | 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 pc =+ case pc_spell_natural_m pc of+ Just p -> p+ _ -> error ("pc_spell_natural: " ++ show pc)++-- | 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 pc =+ case pc of+ 1 -> (C,Sharp) -- 2#+ 3 -> (E,Flat) -- 3b+ 6 -> (F,Sharp) -- 1#+ 8 -> (A,Flat) -- 3b/3#+ 10 -> (B,Flat) -- 1b+ _ -> pc_spell_natural pc++-- | Use always sharp (♯) spelling.+--+-- > 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 pc =+ case pc of+ 1 -> (C,Sharp)+ 3 -> (D,Sharp)+ 6 -> (F,Sharp)+ 8 -> (G,Sharp)+ 10 -> (A,Sharp)+ _ -> pc_spell_natural pc++-- | Use always flat (♭) spelling.+--+-- > 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 pc =+ case pc of+ 1 -> (D,Flat)+ 3 -> (E,Flat)+ 6 -> (G,Flat)+ 8 -> (A,Flat)+ 10 -> (B,Flat)+ _ -> pc_spell_natural pc
Music/Theory/PitchClass.hs view
@@ -1,109 +1,201 @@+-- | 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.+-- | 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 _ [] = []-transposeTo n (x:xs) = n : tn (n - x) xs+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 [] = []-invertSelf (x:xs) = invert x (x:xs)+invertSelf p =+ case p of+ [] -> []+ x:xs -> invert x (x:xs) --- | Composition of inversion about zero and transpose.+-- | 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 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 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+-- | 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 + 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@@ -114,80 +206,80 @@ -- | 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], +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 | +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], +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 | +sro_RTnI = [ SRO 0 r n False i | r <- [True, False],- n <- [0..11], - i <- [False, True] ] + 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], +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 | +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.+-- * 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.+-- | 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 [] = []-d_dx (_:[]) = []-d_dx (x:xs) = zipWith (-) xs (x:xs)+d_dx l =+ case l of+ x:xs -> zipWith (-) xs (x:xs)+ _ -> [] --- | Morris INT operator.+-- | 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' --- | 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 [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)@@ -196,10 +288,46 @@ f l = (head l, genericLength l) in map (fromMaybe 0) k --- | Is p a subset of q.+-- * 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.+-- | Is /p/ a superset of /q/, ie. 'flip' 'is_subset'.+--+-- > is_superset [1,2,3] [1,2] == True is_superset :: Eq a => [a] -> [a] -> Bool is_superset = flip is_subset++-- * Sequence operations++-- | Is /p/ a subsequence of /q/, ie. synonym for 'isInfixOf'.+--+-- > subsequence [1,2] [1,2,3] == True+subsequence :: (Eq a) => [a] -> [a] -> Bool+subsequence = isInfixOf++-- | The standard t-matrix of /p/.+--+-- > tmatrix [0,1,3] == [[ 0, 1, 3]+-- > ,[11, 0, 2]+-- > ,[ 9,10, 0]]+tmatrix :: (Integral a) => [a] -> [[a]]+tmatrix p = map (`tn` p) (transposeTo 0 (invertSelf p))
Music/Theory/Prime.hs view
@@ -1,7 +1,8 @@-module Music.Theory.Prime ( cmp_prime- , forte_prime- , rahn_prime- , encode_prime ) where+-- | 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@@ -15,31 +16,48 @@ r = rotations (pcset p) ++ rotations (pcset q) in minimumBy f (map (transposeTo 0) r) --- | Forte comparison (rightmost first then leftmost outwards).+-- | 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.+-- | 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 (\p q -> compare (reverse p) (reverse q))+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)
Music/Theory/Set.hs view
@@ -1,23 +1,35 @@+-- | Set operations on lists. module Music.Theory.Set where import Control.Monad import Data.List --- | Remove duplicate elements and sort.+-- | 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])+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 [] = []-dyads (x:xs) = [(x,y) | y <- xs] ++ dyads xs+dyads s =+ case s of+ [] -> []+ x:xs -> [(x,y) | y <- xs] ++ dyads xs --- | Set expansion+-- | 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])+se n xs =+ if length xs == n+ then [xs]+ else nub (concatMap (se n) [sort (y : xs) | y <- xs])
− Music/Theory/Spelling.hs
@@ -1,88 +0,0 @@-module Music.Theory.Spelling where--import Music.Theory.Interval-import Music.Theory.Pitch--pc_spell_natural :: PitchClass -> (Note_T, Alteration_T)-pc_spell_natural pc =- case pc of- 0 -> (C,Natural)- 2 -> (D,Natural)- 4 -> (E,Natural)- 5 -> (F,Natural)- 7 -> (G,Natural)- 9 -> (A,Natural)- 11 -> (B,Natural)- _ -> error ("pc_spell_natural: " ++ show pc)---- use spelling from simplest key-signature--- ambiguous for 8 (G#/Ab)-pc_spell_ks :: PitchClass -> (Note_T, Alteration_T)-pc_spell_ks pc =- case pc of- 1 -> (C,Sharp) -- 2#- 3 -> (E,Flat) -- 3b- 6 -> (F,Sharp) -- 1#- 8 -> (A,Flat) -- 3b/3#- 10 -> (B,Flat) -- 1b- _ -> pc_spell_natural pc--pc_spell_sharp :: PitchClass -> (Note_T, Alteration_T)-pc_spell_sharp pc =- case pc of- 1 -> (C,Sharp)- 3 -> (D,Sharp)- 6 -> (F,Sharp)- 8 -> (G,Sharp)- 10 -> (A,Sharp)- _ -> pc_spell_natural pc--pc_spell_flat :: PitchClass -> (Note_T, Alteration_T)-pc_spell_flat pc =- case pc of- 1 -> (D,Sharp)- 3 -> (E,Flat)- 6 -> (G,Flat)- 8 -> (A,Flat)- 10 -> (B,Flat)- _ -> pc_spell_natural pc---- ambiguous for 6 (aug.4,dim.5)-i_to_interval :: Int -> Interval-i_to_interval x =- let iv ty qu = Interval ty qu LT 0- in case x of- 0 -> iv Unison Perfect- 1 -> iv Second Minor- 2 -> iv Second Major- 3 -> iv Third Minor- 4 -> iv Third Major- 5 -> iv Fourth Perfect- 6 -> iv Fourth Augmented -- Fifth Diminished- 7 -> iv Fifth Perfect- 8 -> iv Sixth Minor- 9 -> iv Sixth Major- 10 -> iv Seventh Minor- 11 -> iv Seventh Major- _ -> error ("i_to_interval: " ++ show x)---- for non-tonal music some spellings are poor, ie. (f,g#)-interval_simplify :: Interval -> Interval-interval_simplify x =- let (Interval ty qu d o) = x- (qu',ty') = case (qu,ty) of- (Diminished,Second) -> (Perfect,Unison)- (Diminished,Third) -> (Major,Second)- (Augmented,Second) -> (Minor,Third)- (Augmented,Third) -> (Perfect,Fourth)- (Diminished,Sixth) -> (Perfect,Fifth)- (Diminished,Seventh) -> (Major,Sixth)- (Augmented,Sixth) -> (Minor,Seventh)- -- (Augmented,Seventh) -> (Perfect,Octave)- _ -> (qu,ty)- in Interval ty' qu' d o--{--map pc_spell_ks [0..11]-map i_to_interval [0..11]--}
Music/Theory/Table.hs view
@@ -1,289 +1,302 @@+-- | 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) => [(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]) ]+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 given a set-class.-sc_name :: (Integral a) => [a] -> String+-- | 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+ 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))+--+-- > 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.-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.") ]+-- | Set class database with descriptors for historically and+-- theoretically significant set classes.+--+-- > lookup "6-Z17" sc_db == Just "All-Trichord Hexachord"+-- > lookup "7-35" sc_db == Just "diatonic collection (d)"+sc_db :: [(SC_Name,String)]+sc_db =+ [ ("4-Z15","All-Interval Tetrachord (see also 4-Z29)")+ ,("4-Z29","All-Interval Tetrachord (see also 4-Z15)")+ ,("6-Z17","All-Trichord Hexachord")+ ,("8-Z15","All-Tetrachord Octochord (see also 8-Z29)")+ ,("8-Z29","All-Tetrachord Octochord (see also 8-Z15)")+ ,("6-1","A-Type All-Combinatorial Hexachord")+ ,("6-8","B-Type All-Combinatorial Hexachord")+ ,("6-32","C-Type All-Combinatorial Hexachord")+ ,("6-7","D-Type All-Combinatorial Hexachord")+ ,("6-20","E-Type All-Combinatorial Hexachord")+ ,("6-35","F-Type All-Combinatorial Hexachord")+ ,("7-35","diatonic collection (d)")+ ,("7-34","ascending melodic minor collection")+ ,("8-28","octotonic collection (Messiaen Mode II)")+ ,("6-35","wholetone collection")+ ,("3-10","diminished triad")+ ,("3-11","major/minor triad")+ ,("3-12","augmented triad")+ ,("4-19","minor major-seventh chord")+ ,("4-20","major-seventh chord")+ ,("4-25","french augmented sixth chord")+ ,("4-28","dimished-seventh chord")+ ,("4-26","minor-seventh chord")+ ,("4-27","half-dimished seventh(P)/dominant-seventh(I) chord")+ ,("6-30","Petrushka Chord {0476a1},3-11 at T6")+ ,("6-34","Mystic Chord {06a492}")+ ,("6-Z44","Schoenberg Signature Set,3-3 at T5 or T7")+ ,("6-Z19","complement of 6-Z44,3-11 at T1 or TB")+ ,("9-12","Messiaen Mode III (nontonic collection)")+ ,("8-9","Messian Mode IV")+ ,("7-31","The only seven-element subset of 8-28. ")+ ,("5-31","The only five-element superset of 4-28.")+ ,("5-33","The only five-element subset of 6-35.")+ ,("7-33","The only seven-element superset of 6-35.")+ ,("5-21","The only five-element subset of 6-20.")+ ,("7-21","The only seven-element superset of 6-20.")+ ,("5-25","The only five-element subset of both 7-35 and 8-28.")+ ,("6-14","Any non-intersecting union of 3-6 and 3-12.") ]
Music/Theory/Tuning.hs view
@@ -1,12 +1,18 @@+-- | Tuning theory module Music.Theory.Tuning where import Data.List import Data.Ratio +-- | 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 (folded)+-- | Harmonic series to /n/th harmonic (folded).+--+-- > 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])@@ -15,6 +21,14 @@ else fold (x * 2) in nub (sort (map fold hs)) +-- | Harmonic series to /n/th harmonic (folded, cents).+--+-- > 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+ -- | Pythagorean tuning pythagorean_r :: [Rational] pythagorean_r =@@ -27,7 +41,7 @@ ,128%243 ,1%2] --- | Pythagorean tuning+-- | Pythagorean tuning (cents) pythagorean_c :: [Cents] pythagorean_c = map (to_cents.approximate_ratio) pythagorean_r @@ -135,62 +149,98 @@ ,8%15 ,1%2] +-- | '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 +-- | Equal temperament.+--+-- > equal_temperament_c == [0,100..1200] equal_temperament_c :: [Cents] equal_temperament_c = [0, 100 .. 1200] +-- | 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)]] mk_isomorphic_layout n_row n_col top_left = let (a,b) `plus` (c,d) = (a+c,b+d) mk_seq 0 _ _ = [] mk_seq n i z = z : mk_seq (n-1) i (z `plus` i) left = mk_seq n_row (-1,1) top_left- in map (\i -> mk_seq n_col (-1,2) i) left+ in map (mk_seq n_col (-1,2)) left +-- | 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]-rank_two_regular_temperament a b =- map (\(a', b') -> a * a' + b * b')+rank_two_regular_temperament a b = let f (i,j) = i * a + j * b in map f +-- | Syntonic tuning system based on 'mk_isomorphic_layout' of @5@+-- rows and @7@ columns starting at @(3,-4)@ and a+-- 'rank_two_regular_temperament' with /a/ of @1200@ and indicated+-- /b/. mk_syntonic_tuning :: Int -> [Cents] mk_syntonic_tuning b = let l = mk_isomorphic_layout 5 7 (3,-4) t = map (rank_two_regular_temperament 1200 b) l in nub (sort (map (\x -> fromIntegral (x `mod` 1200)) (concat t))) +-- | '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 +-- | '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 +-- | The Syntonic comma.+--+-- > syntonic_comma == 81/80 syntonic_comma :: Rational syntonic_comma = 81 % 80 --- ie. 3^12 % 2^19+-- | The Pythagorean comma.+--+-- > pythagorean_comma == 3^12 % 2^19 pythagorean_comma :: Rational pythagorean_comma = 531441 % 524288 --- ie. 3^53 % 2^84+-- | Mercators comma.+--+-- > mercators_comma == 3^53 % 2^84 mercators_comma :: Rational mercators_comma = 19383245667680019896796723 % 19342813113834066795298816 +-- | Convert from 'Rational' to 'Approximate_Ratio', ie. 'fromRational'. approximate_ratio :: Rational -> Approximate_Ratio approximate_ratio = fromRational +-- | 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 +-- | Calculate /n/th root of /x/.+--+-- > 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)) +-- | 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 +-- | 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)]
+ Music/Theory/Xenakis/S4.hs view
@@ -0,0 +1,283 @@+-- | Symetric Group S4 as related to the composition \"Nomos Alpha\"+-- by Iannis Xenakis. In particular in relation to the discussion in+-- \"Towards a Philosophy of Music\", /Formalized Music/ pp. 219 -- 221+module Music.Theory.Xenakis.S4 where++import Data.List+import Data.Maybe+import qualified Data.Permute as P+import Music.Theory.Permutations++-- * S4 notation++-- | 'Label's for elements of the symmetric group P4.+data Label = A|B|C|D|D2|E|E2|G|G2|I|L|L2+ | Q1|Q2|Q3|Q4|Q5|Q6|Q7|Q8|Q9|Q10|Q11|Q12+ deriving (Eq,Ord,Enum,Bounded,Show)++-- | Initial half of 'Seq' (ie. #4). The complete 'Seq' is formed by+-- appending the 'complement' of the 'Half_Seq'.+type Half_Seq = [Int]++-- | Complete sequence (ie. #8).+type Seq = [Int]++-- | Complement of a 'Half_Seq'.+--+-- > map complement [[4,1,3,2],[6,7,8,5]] == [[8,5,7,6],[2,3,4,1]]+complement :: Half_Seq -> Half_Seq+complement x =+ case sort x of+ [1,2,3,4] -> map (+ 4) x+ [5,6,7,8] -> map (+ (-4)) x+ _ -> error "complement"++-- | Form 'Seq' from 'Half_Seq'.+--+-- > full_seq [3,2,4,1] == [3,2,4,1,7,6,8,5]+-- > label_of (full_seq [3,2,4,1]) == G2+-- > label_of (full_seq [1,4,2,3]) == L+full_seq :: Half_Seq -> Seq+full_seq x = x ++ complement x++-- | Lower 'Half_Seq', ie. 'complement' or 'id'.+--+-- > map lower [[4,1,3,2],[6,7,8,5]] == [[4,1,3,2],[2,3,4,1]]+lower :: Half_Seq -> Half_Seq+lower x =+ case sort x of+ [1,2,3,4] -> x+ [5,6,7,8] -> complement x+ _ -> error "lower"++-- | Application of 'Label' /p/ on /q/.+--+-- > l_on Q1 I == Q1+-- > l_on D A == G+-- > [l_on L L,l_on E D,l_on D E] == [L2,C,B]+l_on :: Label -> Label -> Label+l_on p q =+ let p' = seq_of p+ q' = seq_of q+ r = map (\i -> q' !! (i - 1)) p'+ in label_of r++-- | 'Seq' of 'Label', inverse of 'label_of'.+--+-- > seq_of Q1 == [8,7,5,6,4,3,1,2]+seq_of :: Label -> Seq+seq_of i = fromMaybe (error "seq_of") (lookup i viii_6b)++-- | 'Half_Seq' of 'Label', ie. 'half_seq' '.' 'seq_of'.+--+-- > half_seq_of Q1 == [8,7,5,6]+half_seq_of :: Label -> Seq+half_seq_of = half_seq . seq_of++-- | 'Half_Seq' of 'Seq', ie. 'take' @4@.+--+-- > complement (half_seq (seq_of Q7)) == [3,4,2,1]+half_seq :: Seq -> Half_Seq+half_seq = take 4++-- | Reverse table 'lookup'.+--+-- > reverse_lookup 'b' (zip [1..] ['a'..]) == Just 2+-- > lookup 2 (zip [1..] ['a'..]) == Just 'b'+reverse_lookup :: (Eq a) => a -> [(b,a)] -> Maybe b+reverse_lookup i =+ let f (p,q) = (q,p)+ in lookup i . map f++-- | 'Label' of 'Seq', inverse of 'seq_of'.+--+-- > label_of [8,7,5,6,4,3,1,2] == Q1+-- > label_of (seq_of Q4) == Q4+label_of :: Seq -> Label+label_of i =+ let err = error ("label_of: " ++ show i)+ in fromMaybe err (reverse_lookup i viii_6b)++-- | 'True' if two 'Half_Seq's are complementary, ie. form a 'Seq'.+--+-- > complementary [4,2,1,3] [8,6,5,7] == True+complementary :: Half_Seq -> Half_Seq -> Bool+complementary p q =+ let c = concat (sort [sort p,sort q])+ in c == [1..8]++-- * Rel++-- | Relation between to 'Half_Seq' values as a+-- /(complementary,permutation)/ pair.+type Rel = (Bool,P.Permute)++-- | Determine 'Rel' of 'Half_Seq's.+--+-- > relate [1,4,2,3] [1,3,4,2] == (False,P.listPermute 4 [0,3,1,2])+-- > relate [1,4,2,3] [8,5,6,7] == (True,P.listPermute 4 [1,0,2,3])+relate :: Half_Seq -> Half_Seq -> Rel+relate p q =+ if complementary p q+ then (True,permutation (complement p) q)+ else (False,permutation p q)++-- | 'Rel' from 'Label' /p/ to /q/.+--+-- > relate_l L L2 == (False,P.listPermute 4 [0,3,1,2])+relate_l :: Label -> Label -> Rel+relate_l p q = relate (half_seq_of p) (half_seq_of q)++-- | 'relate' adjacent 'Half_Seq', see also 'relations_l'.+relations :: [Half_Seq] -> [Rel]+relations p = zipWith relate p (tail p)++-- | 'relate' adjacent 'Label's.+--+-- > relations_l [L2,L,A] == [(False,P.listPermute 4 [0,2,3,1])+-- > ,(False,P.listPermute 4 [2,0,1,3])]+relations_l :: [Label] -> [Rel]+relations_l p = zipWith relate_l p (tail p)++-- | Apply 'Rel' to 'Half_Seq'.+--+-- > apply_relation (False,P.listPermute 4 [0,3,1,2]) [1,4,2,3] == [1,3,4,2]+apply_relation :: Rel -> Half_Seq -> Half_Seq+apply_relation (c,p) i =+ let j = apply_permutation p i+ in if c then complement j else j++-- | Apply sequence of 'Rel' to initial 'Half_Seq'.+apply_relations :: [Rel] -> Half_Seq -> [Half_Seq]+apply_relations rs i =+ case rs of+ [] -> [i]+ (r:rs') -> let i' = apply_relation r i+ in i : apply_relations rs' i'++-- | Variant of 'apply_relations'.+--+-- > apply_relations_l (relations_l [L2,L,A,Q1]) L2 == [L2,L,A,Q1]+apply_relations_l :: [Rel] -> Label -> [Label]+apply_relations_l rs = map (label_of . full_seq) .+ apply_relations rs .+ half_seq_of++-- * Face++-- | Enumeration of set of /faces/ of a cube.+data Face = F_Back | F_Front | F_Right | F_Left | F_Bottom | F_Top+ deriving (Eq,Enum,Bounded,Ord,Show)++-- | Table indicating set of faces of cubes as drawn in Fig. VIII-6+-- (p.220).+--+-- > lookup [1,4,6,7] faces == Just F_Left+-- > reverse_lookup F_Right faces == Just [2,3,5,8]+faces :: [([Int],Face)]+faces =+ [([1,3,6,8],F_Back) -- (I in viii-6)+ ,([2,4,5,7],F_Front)+ ,([2,3,5,8],F_Right)+ ,([1,4,6,7],F_Left)+ ,([3,4,5,6],F_Bottom)+ ,([1,2,7,8],F_Top)]++-- * Figures++-- | Fig. VIII-6. Hexahedral (Octahedral) Group (p. 220)+--+-- > length viii_6_l == 24+-- > take 7 viii_6_l == [L2,L,A,Q1,Q7,Q3,Q9]+viii_6_l :: [Label]+viii_6_l =+ [L2,L,A,Q1,Q7,Q3,Q9+ ,G2,G,C,Q8,Q5,Q10,Q2+ ,E,E2,B,Q4,Q11,Q12,Q6+ ,D,D2,I]++-- | Fig. VIII-7 (p.221)+--+-- > map (take 4) (take 4 viii_7) == [[I,A,B,C]+-- > ,[A,I,C,B]+-- > ,[B,C,I,A]+-- > ,[C,B,A,I]]+viii_7 :: [[Label]]+viii_7 =+ let o = [I,A,B,C+ ,D,D2,E,E2+ ,G,G2,L,L2+ ,Q1,Q2,Q3,Q4+ ,Q5,Q6,Q7,Q8+ ,Q9,Q10,Q11,Q12]+ in map (\i -> map (`l_on` i) o) o++-- | Fig. VIII-6/b 'Labels' (p.221)+--+-- > length viii_6b_l == length viii_6_l+-- > take 8 viii_6b_l == [I,A,B,C,D2,D,E2,E]+viii_6b_l :: [Label]+viii_6b_l =+ [I,A,B,C,D2,D,E2,E+ ,G2,G,L2,L,Q7,Q2,Q3,Q11+ ,Q8,Q6,Q1,Q5,Q9,Q10,Q4,Q12]++-- | Fig. VIII-6/b 'Half_Seq'.+--+-- > viii_6b_p' == map half_seq_of viii_6b_l+-- > nub (map (length . nub) viii_6b_p') == [4]+viii_6b_p' :: [Half_Seq]+viii_6b_p' =+ [[1,2,3,4]+ ,[2,1,4,3]+ ,[3,4,1,2]+ ,[4,3,2,1]+ ,[2,3,1,4]+ ,[3,1,2,4]+ ,[2,4,3,1]+ ,[4,1,3,2]++ ,[3,2,4,1]+ ,[4,2,1,3]+ ,[1,3,4,2]+ ,[1,4,2,3]+ ,[7,8,6,5]+ ,[7,6,5,8]+ ,[8,6,7,5]+ ,[6,7,8,5]++ ,[6,8,5,7]+ ,[6,5,7,8]+ ,[8,7,5,6]+ ,[7,5,8,6]+ ,[5,8,7,6]+ ,[5,7,6,8]+ ,[8,5,6,7]+ ,[5,6,8,7]]++-- | Variant of 'viii_6b' with 'Half_Seq'.+viii_6b' :: [(Label,Half_Seq)]+viii_6b' = zip viii_6b_l viii_6b_p'++-- | Fig. VIII-6/b.+--+-- > map (viii_6b !!) [0,8,16] == [(I,[1,2,3,4,5,6,7,8])+-- > ,(G2,[3,2,4,1,7,6,8,5])+-- > ,(Q8,[6,8,5,7,2,4,1,3])]+viii_6b :: [(Label,Seq)]+viii_6b = zip viii_6b_l (map full_seq viii_6b_p')++-- | The sequence of 'Rel' to give 'viii_6_l' from 'L2'.+--+-- > apply_relations_l viii_6_relations L2 == viii_6_l+-- > length (nub viii_6_relations) == 14+viii_6_relations :: [Rel]+viii_6_relations = relations (map half_seq_of viii_6_l)++-- | The sequence of 'Rel' to give 'viii_6b_l' from 'I'.+--+-- > apply_relations_l viii_6b_relations I == viii_6b_l+-- > length (nub viii_6b_relations) == 10+viii_6b_relations :: [Rel]+viii_6b_relations = relations (map half_seq_of viii_6b_l)+
+ Music/Theory/Xenakis/Sieve.hs view
@@ -0,0 +1,172 @@+-- | \"Sieves\" by Iannis Xenakis and John Rahn+-- /Perspectives of New Music/+-- Vol. 28, No. 1 (Winter, 1990), pp. 58-78+module Music.Theory.Xenakis.Sieve where++import qualified Data.List as L++-- | Synonym for 'Integer'+type I = Integer++-- | A Sieve.+data Sieve = Empty -- ^ 'Empty' 'Sieve'+ | L (I,I) -- ^ Primitive 'Sieve' of /modulo/ and /index/+ | Union Sieve Sieve -- ^ 'Union' of two 'Sieve's+ | Intersection Sieve Sieve -- ^ 'Intersection' of two 'Sieve's+ deriving (Eq,Show)++-- | The 'Union' of a list of 'Sieve's, ie. 'foldl1' 'Union'.+union :: [Sieve] -> Sieve+union = foldl1 Union++-- | The 'Intersection' of a list of 'Sieve's, ie. 'foldl1' 'Intersection'.+intersection :: [Sieve] -> Sieve+intersection = foldl1 Intersection++-- | Unicode synonym for 'Union'.+(∪) :: Sieve -> Sieve -> Sieve+(∪) = Union++-- | Unicode synonym for 'Intersection'.+(∩) :: Sieve -> Sieve -> Sieve+(∩) = Intersection++-- | Variant of 'L', ie. 'curry' 'L'.+--+-- > l 15 19 == L (15,19)+l :: I -> I -> Sieve+l = curry L++-- | In a /normal/ 'Sieve' /m/ is '>' /i/.+--+-- > normalise (L (15,19)) == L (15,4)+normalise :: Sieve -> Sieve+normalise s =+ case s of+ Empty -> Empty+ L (m,i) -> L (m,i `mod` m)+ Union s0 s1 -> Union (normalise s0) (normalise s1)+ Intersection s0 s1 -> Intersection (normalise s0) (normalise s1)++-- | Predicate to test if a 'Sieve' is /normal/.+--+-- > is_normal (L (15,4)) == True+is_normal :: Sieve -> Bool+is_normal s = s == normalise s++-- | Predicate to determine if an 'I' is an element of the 'Sieve'.+--+-- > map (element (L (3,1))) [1..4] == [True,False,False,True]+-- > map (element (L (15,4))) [4,19 .. 49] == [True,True,True,True]+element :: Sieve -> I -> Bool+element s n =+ case s of+ Empty -> False+ L (m,i) -> n `mod` m == i `mod` m && n >= i+ 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])))+build :: Sieve -> [I]+build s =+ let u_f = map head . L.group+ i_f = let g [x,_] = [x]+ g _ = []+ in concatMap g . L.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))++-- | Variant of 'build' that gives the first /n/ places.+--+-- > buildn 6 (union (map (l 8) [0,3,6])) == [0,3,6,8,11,14]+buildn :: Int -> Sieve -> [I]+buildn n = take n . build++-- | Standard differentiation function.+--+-- > differentiate [1,3,6,10] == [2,3,4]+-- > differentiate [0,2,4,5,7,9,11,12] == [2,2,1,2,2,2,1]+differentiate :: (Num a) => [a] -> [a]+differentiate x = zipWith (-) (tail x) x+++-- | Euclid's algorithm for computing the greatest common divisor.+--+-- > euclid 1989 867 == 51+euclid :: (Integral a) => a -> a -> a+euclid i j =+ let k = i `mod` j+ in if k == 0 then j else euclid j k++-- | Bachet De Méziriac's algorithm.+--+-- > de_meziriac 15 4 == 3 && euclid 15 4 == 1+de_meziriac :: (Integral a) => a -> a -> a+de_meziriac i j =+ let f t = if (t * i) `mod` j /= 1+ then f (t + 1)+ else t+ in if j == 1 then 1 else f 1++-- | Attempt to reduce the 'Intersection' of two 'L' nodes to a+-- singular 'L' node.+--+-- > reduce_intersection (3,2) (4,7) == Just (12,11)+-- > reduce_intersection (12,11) (6,11) == Just (12,11)+-- > reduce_intersection (12,11) (8,7) == Just (24,23)+reduce_intersection :: (Integral t) => (t,t) -> (t,t) -> Maybe (t,t)+reduce_intersection (m1,i1) (m2,i2) =+ let d = euclid m1 m2+ i1' = i1 `mod` m1+ i2' = i2 `mod` m2+ c1 = m1 `div` d+ c2 = m2 `div` d+ m3 = d * c1 * c2+ t = de_meziriac c1 c2+ i3 = (i1' + t * (i2' - i1') * c1) `mod` m3+ in if d /= 1 && (i1' - i2') `mod` d /= 0+ then Nothing+ else Just (m3,i3)++-- | Reduce the number of nodes at a 'Sieve'.+--+-- > reduce (L (3,2) ∪ Empty) == L (3,2)+-- > 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)+reduce :: Sieve -> Sieve+reduce s =+ let f g s1 s2 =+ let s1' = reduce s1+ s2' = reduce s2+ s' = g s1' s2'+ in if s1 == s1' && s2 == s2'+ then s'+ else reduce s'+ in case s of+ Empty -> Empty+ L _ -> s+ Union s1 Empty -> s1+ Union s1 s2 -> f Union s1 s2+ Intersection s1 Empty -> s1+ Intersection (L p) (L q) -> maybe Empty L (reduce_intersection p q)+ Intersection s1 s2 -> f Intersection s1 s2
hmt.cabal view
@@ -1,5 +1,5 @@ Name: hmt-Version: 0.3+Version: 0.11 Synopsis: Haskell Music Theory Description: Haskell music theory library License: GPL@@ -9,39 +9,50 @@ Maintainer: rd@slavepianos.org Stability: Experimental Homepage: http://slavepianos.org/rd/?t=hmt-Tested-With: GHC == 6.12.1+Tested-With: GHC == 7.2.2 Build-Type: Simple-Cabal-Version: >= 1.6+Cabal-Version: >= 1.8 Data-files: README Help/hmt.help.lhs Library- Build-Depends: base == 4.*,- containers,+ Build-Depends: base==4.*,+ cairo,colour,containers,+ hcg-minus==0.11.*,html-minimalist==0.11.*, multiset-comb, parsec, permutation,- split+ split,+ utf8-string,+ xml GHC-Options: -Wall -fwarn-tabs Exposed-modules: Music.Theory.Bjorklund Music.Theory.Contour.Polansky_1992+ Music.Theory.Diagram.Grid+ Music.Theory.Diagram.Path Music.Theory.Duration Music.Theory.Duration.Name+ Music.Theory.Duration.Name.Abbreviation+ Music.Theory.Duration.RQ Music.Theory.Duration.Sequence.Notate Music.Theory.Interval+ Music.Theory.Interval.Name+ Music.Theory.Interval.Spelling Music.Theory.Key Music.Theory.Parse Music.Theory.Pct Music.Theory.Permutations Music.Theory.Pitch Music.Theory.Pitch.Name+ Music.Theory.Pitch.Spelling Music.Theory.PitchClass Music.Theory.Prime Music.Theory.Set- Music.Theory.Spelling Music.Theory.Table Music.Theory.Tuning+ Music.Theory.Xenakis.S4+ Music.Theory.Xenakis.Sieve Source-Repository head Type: darcs