diff --git a/Help/hmt.help.lhs b/Help/hmt.help.lhs --- a/Help/hmt.help.lhs +++ b/Help/hmt.help.lhs @@ -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") diff --git a/Music/Theory/Bjorklund.hs b/Music/Theory/Bjorklund.hs --- a/Music/Theory/Bjorklund.hs +++ b/Music/Theory/Bjorklund.hs @@ -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 +-- () 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)")] - --} diff --git a/Music/Theory/Contour/Polansky_1992.hs b/Music/Theory/Contour/Polansky_1992.hs --- a/Music/Theory/Contour/Polansky_1992.hs +++ b/Music/Theory/Contour/Polansky_1992.hs @@ -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) +-- () 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]] diff --git a/Music/Theory/Diagram/Grid.hs b/Music/Theory/Diagram/Grid.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Diagram/Grid.hs @@ -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 diff --git a/Music/Theory/Diagram/Path.hs b/Music/Theory/Diagram/Path.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Diagram/Path.hs @@ -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) diff --git a/Music/Theory/Duration.hs b/Music/Theory/Duration.hs --- a/Music/Theory/Duration.hs +++ b/Music/Theory/Duration.hs @@ -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 diff --git a/Music/Theory/Duration/Name.hs b/Music/Theory/Duration/Name.hs --- a/Music/Theory/Duration/Name.hs +++ b/Music/Theory/Duration/Name.hs @@ -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 diff --git a/Music/Theory/Duration/Name/Abbreviation.hs b/Music/Theory/Duration/Name/Abbreviation.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Duration/Name/Abbreviation.hs @@ -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 diff --git a/Music/Theory/Duration/RQ.hs b/Music/Theory/Duration/RQ.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Duration/RQ.hs @@ -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 diff --git a/Music/Theory/Duration/Sequence/Notate.hs b/Music/Theory/Duration/Sequence/Notate.hs --- a/Music/Theory/Duration/Sequence/Notate.hs +++ b/Music/Theory/Duration/Sequence/Notate.hs @@ -1,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 diff --git a/Music/Theory/Interval.hs b/Music/Theory/Interval.hs --- a/Music/Theory/Interval.hs +++ b/Music/Theory/Interval.hs @@ -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 diff --git a/Music/Theory/Interval/Name.hs b/Music/Theory/Interval/Name.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Interval/Name.hs @@ -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 diff --git a/Music/Theory/Interval/Spelling.hs b/Music/Theory/Interval/Spelling.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Interval/Spelling.hs @@ -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 diff --git a/Music/Theory/Key.hs b/Music/Theory/Key.hs --- a/Music/Theory/Key.hs +++ b/Music/Theory/Key.hs @@ -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' diff --git a/Music/Theory/Parse.hs b/Music/Theory/Parse.hs --- a/Music/Theory/Parse.hs +++ b/Music/Theory/Parse.hs @@ -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] diff --git a/Music/Theory/Pct.hs b/Music/Theory/Pct.hs --- a/Music/Theory/Pct.hs +++ b/Music/Theory/Pct.hs @@ -1,29 +1,57 @@ +-- | Haskell implementations of @pct@ operations. +-- See . 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 diff --git a/Music/Theory/Permutations.hs b/Music/Theory/Permutations.hs --- a/Music/Theory/Permutations.hs +++ b/Music/Theory/Permutations.hs @@ -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)) +-} diff --git a/Music/Theory/Pitch.hs b/Music/Theory/Pitch.hs --- a/Music/Theory/Pitch.hs +++ b/Music/Theory/Pitch.hs @@ -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 diff --git a/Music/Theory/Pitch/Name.hs b/Music/Theory/Pitch/Name.hs --- a/Music/Theory/Pitch/Name.hs +++ b/Music/Theory/Pitch/Name.hs @@ -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 diff --git a/Music/Theory/Pitch/Spelling.hs b/Music/Theory/Pitch/Spelling.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Spelling.hs @@ -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 diff --git a/Music/Theory/PitchClass.hs b/Music/Theory/PitchClass.hs --- a/Music/Theory/PitchClass.hs +++ b/Music/Theory/PitchClass.hs @@ -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)) diff --git a/Music/Theory/Prime.hs b/Music/Theory/Prime.hs --- a/Music/Theory/Prime.hs +++ b/Music/Theory/Prime.hs @@ -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) diff --git a/Music/Theory/Set.hs b/Music/Theory/Set.hs --- a/Music/Theory/Set.hs +++ b/Music/Theory/Set.hs @@ -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]) diff --git a/Music/Theory/Spelling.hs b/Music/Theory/Spelling.hs deleted file mode 100644 --- a/Music/Theory/Spelling.hs +++ /dev/null @@ -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] --} diff --git a/Music/Theory/Table.hs b/Music/Theory/Table.hs --- a/Music/Theory/Table.hs +++ b/Music/Theory/Table.hs @@ -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.") ] diff --git a/Music/Theory/Tuning.hs b/Music/Theory/Tuning.hs --- a/Music/Theory/Tuning.hs +++ b/Music/Theory/Tuning.hs @@ -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)] diff --git a/Music/Theory/Xenakis/S4.hs b/Music/Theory/Xenakis/S4.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Xenakis/S4.hs @@ -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) + diff --git a/Music/Theory/Xenakis/Sieve.hs b/Music/Theory/Xenakis/Sieve.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Xenakis/Sieve.hs @@ -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 diff --git a/hmt.cabal b/hmt.cabal --- a/hmt.cabal +++ b/hmt.cabal @@ -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