hmt-0.15/0000755000000000000000000000000012416136065010421 5ustar0000000000000000hmt-0.15/hmt.cabal0000644000000000000000000001216412416136065012201 0ustar0000000000000000Name: hmt Version: 0.15 Synopsis: Haskell Music Theory Description: Haskell music theory library License: GPL Category: Music Copyright: Rohan Drape, 2006-2014 Author: Rohan Drape Maintainer: rd@slavepianos.org Stability: Experimental Homepage: http://rd.slavepianos.org/t/hmt Tested-With: GHC == 7.8.2 Build-Type: Simple Cabal-Version: >= 1.8 Data-files: README Help/hmt.help.lhs Library Build-Depends: array, base == 4.*, bytestring, colour, containers, data-ordlist, directory, filepath, lazy-csv, logict, multiset-comb, parsec, permutation, primes, safe, split, utf8-string GHC-Options: -Wall -fwarn-tabs Exposed-modules: Music.Theory.Array.CSV Music.Theory.Array.CSV.Midi Music.Theory.Array.MD Music.Theory.Bjorklund Music.Theory.Block_Design.Johnson_2007 Music.Theory.Clef Music.Theory.Combinations Music.Theory.Contour.Polansky_1992 Music.Theory.Duration Music.Theory.Duration.Annotation Music.Theory.Duration.CT Music.Theory.Duration.Name Music.Theory.Duration.Name.Abbreviation Music.Theory.Duration.RQ Music.Theory.Duration.RQ.Division Music.Theory.Duration.RQ.Tied Music.Theory.Duration.Sequence.Notate Music.Theory.Dynamic_Mark Music.Theory.Either Music.Theory.Function Music.Theory.Instrument.Choir Music.Theory.Interval Music.Theory.Interval.Barlow_1987 Music.Theory.Interval.Name Music.Theory.Interval.Spelling Music.Theory.Key Music.Theory.List Music.Theory.Math Music.Theory.Maybe Music.Theory.Meter.Barlow_1987 Music.Theory.Metric.Buchler_1998 Music.Theory.Metric.Morris_1980 Music.Theory.Metric.Polansky_1996 Music.Theory.Permutations Music.Theory.Permutations.List Music.Theory.Permutations.Morris_1984 Music.Theory.Pitch Music.Theory.Pitch.Name Music.Theory.Pitch.Note Music.Theory.Pitch.Spelling Music.Theory.Pitch.Spelling.Cluster Music.Theory.Set.List Music.Theory.Set.Set Music.Theory.Tempo_Marking Music.Theory.Tiling.Canon Music.Theory.Tiling.Johnson_2004 Music.Theory.Tiling.Johnson_2009 Music.Theory.Time.Bel1990.R Music.Theory.Time.Duration Music.Theory.Time.Notation Music.Theory.Time.Seq Music.Theory.Time_Signature Music.Theory.Tuple Music.Theory.Tuning Music.Theory.Tuning.Alves Music.Theory.Tuning.Alves_1997 Music.Theory.Tuning.ET Music.Theory.Tuning.Gann Music.Theory.Tuning.Meyer_1929 Music.Theory.Tuning.Microtonal_Synthesis Music.Theory.Tuning.Polansky_1978 Music.Theory.Tuning.Polansky_1984 Music.Theory.Tuning.Polansky_1985c Music.Theory.Tuning.Polansky_1990 Music.Theory.Tuning.Riley Music.Theory.Tuning.Scala Music.Theory.Tuning.Syntonic Music.Theory.Tuning.Werckmeister Music.Theory.Unicode Music.Theory.Xenakis.S4 Music.Theory.Xenakis.Sieve Music.Theory.Z Music.Theory.Z.Forte_1973 Music.Theory.Z.Read_1978 Music.Theory.Z.SRO Music.Theory.Z12 Music.Theory.Z12.Castren_1994 Music.Theory.Z12.Drape_1999 Music.Theory.Z12.Forte_1973 Music.Theory.Z12.Lewin_1980 Music.Theory.Z12.Literature Music.Theory.Z12.Morris_1974 Music.Theory.Z12.Morris_1987 Music.Theory.Z12.Morris_1987.Parse Music.Theory.Z12.Rahn_1980 Music.Theory.Z12.Read_1978 Music.Theory.Z12.SRO Music.Theory.Z12.TTO Source-Repository head Type: darcs Location: http://rd.slavepianos.org/sw/hmt hmt-0.15/Setup.hs0000644000000000000000000000011012416136065012045 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain hmt-0.15/README0000644000000000000000000000060712416136065011304 0ustar0000000000000000hmt - haskell music theory -------------------------- Music theory operations in [haskell][hs], primarily focused on 'set theory' and 'common music notation'. - [hmt-diagrams][hmt-diagrams] [hs]: http://haskell.org/ [hmt-diagrams]: http://rd.slavepianos.org/?t=hmt-diagrams © [rohan drape][rd], 2006-2014, [gpl][gpl]. [rd]: http://rd.slavepianos.org/ [gpl]: http://gnu.org/copyleft/ hmt-0.15/Help/0000755000000000000000000000000012416136065011311 5ustar0000000000000000hmt-0.15/Help/hmt.help.lhs0000644000000000000000000001120112416136065013533 0ustar0000000000000000# Pct > import Control.Arrow {- base -} > import Data.Function {- base -} > import Data.List {- base -} > import Data.Maybe {- base -} > import Music.Theory.List {- hmt -} > import Music.Theory.Permutations {- hmt -} > import Music.Theory.Set.List {- hmt -} > import Music.Theory.Z12.Drape_1999 {- hmt -} > import Music.Theory.Z12.Forte_1973 {- hmt -} > import Music.Theory.Z12.Morris_1987 {- hmt -} > import Music.Theory.Z12.Morris_1987.Parse {- hmt -} > import Music.Theory.Z12.SRO {- hmt -} This file illustrates equivalent expressions in pct and hmt terms. $ pcom pcseg iseg 01549 | pcom iseg icseg | pcom icseg icset 145 > (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] == [1,3,4,5] $ 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 = nub . map bip . permutations . sc > 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 > let {s = filter ((== 4) . length) scs > ;x = map permutations s} > in zip (map sc_name s) (map (set . (map bip)) x) $ cat view.sh for i in $(fl -c $1 | pg | bip | sort -u) do echo $i":" $(grep -l $i * | sort -t '-' +1 -n | tr "\n" " ") done $ sh view.sh 4 111: 4-1 112: 4-1 4-2 4-3 113: 4-1 4-3 4-4 4-7 ... > let {n = 4 > ;s = filter ((== n) . length) scs > ;x = map permutations s > ;z = zip (map sc_name s) (map (set . (map bip)) x) > ;f b (s,bs) = if b `elem` bs then Just s else Nothing > ;g b = catMaybes (map (f b) z) > ;a = set (map bip (concat x))} > in zip a (map g a) $ cyc < ~/src/pct/lib/scs | epmq \ > "in cset 89" "is icset 12" "hasnt icseg 11" | scdb 7-34 ascending melodic minor collection 7-35 diatonic collection (d) 8-28 octotonic collection (Messiaen Mode II) > let {cyc xs = xs ++ [head xs] > ;a = filter (\p -> length p `elem` [8,9]) (map cyc scs) > ;b = filter (\p -> set (int p) == [1,2]) a > ;c = filter (\p -> not ([1,1] `isInfixOf` int p)) b} > in map (sc_name . nub) c == ["7-34","7-35","8-28"] $ 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 > ;e = filter (not . is_superset [0,2,4,5,7,9,11]) d} > in e == [[0,2,5,7,9,10]] $ echo 156 | sro T0I | sro T4 3BA > 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] $ echo 156 | sro T4 | sro T0I 732 > let {i = SRO 0 False 0 False True > ;t4 = SRO 0 False 4 False False} > in (sro i . sro t4) [1,5,6] == [7,3,2] Note that 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] I = MB; TnI = TnMB, > mn 11 [0,1,4,9] == tni 0 [0,1,4,9] MI = IM = M7 = MBM5; TnMI = TnM7 > sro (rnrtnmi "T0MI") [0,1,4,9] == mn 7 [0,1,4,9] T0 = T0M1; Tn = TnM1 M = M5; TnM = TnM5, $ se -c5 123 12333 12233 12223 11233 11223 11123 > expand_set 5 [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 = expand_set 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 [3,4] [0,2,4,5,7,9] $ 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 > map sc_name (sb [sc "6-32",sc "6-8"]) > let f p = let xs = cf [3] (sb [p]) > in (sc_name p,length xs) > in map f (cf [6] scs) hmt-0.15/Music/0000755000000000000000000000000012416136065011501 5ustar0000000000000000hmt-0.15/Music/Theory/0000755000000000000000000000000012416136065012753 5ustar0000000000000000hmt-0.15/Music/Theory/Function.hs0000644000000000000000000000332012416136065015072 0ustar0000000000000000-- | "Data.Function" related functions. module Music.Theory.Function where -- * Predicate composition. -- | '&&' of predicates. predicate_and :: (t -> Bool) -> (t -> Bool) -> t -> Bool predicate_and f g x = f x && g x -- | 'all' of predicates. -- -- > let r = [False,False,True,False,True,False] -- > in map (predicate_all [(> 0),(< 5),even]) [0..5] == r predicate_all :: [t -> Bool] -> t -> Bool predicate_all p x = all id (map ($ x) p) -- | '||' of predicates. predicate_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool predicate_or f g x = f x || g x -- | 'any' of predicates. -- -- > let r = [True,False,True,False,True,True] -- > in map (predicate_any [(== 0),(== 5),even]) [0..5] == r predicate_any :: [t -> Bool] -> t -> Bool predicate_any p x = any id (map ($ x) p) -- * Function composition. -- . is infixr 9, this allows f . g .: h infixr 8 .:, .::, .:::, .::::, .::::: -- | 'fmap' '.' 'fmap', ie. @(t -> c) -> (a -> b -> t) -> a -> b -> c@. (.:) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) (.:) = fmap . fmap -- | 'fmap' '.' '.:', ie. @(t -> d) -> (a -> b -> c -> t) -> a -> b -> c -> d@. (.::) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b)) (.::) = fmap . (.:) -- | 'fmap' '.' '.::'. (.:::) :: (Functor f, Functor g, Functor h,Functor i) => (a -> b) -> f (g (h (i a))) -> f (g (h (i b))) (.:::) = fmap . (.::) -- | 'fmap' '.' '.:::'. (.::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j) => (a -> b) -> f (g (h (i (j a)))) -> f (g (h (i (j b)))) (.::::) = fmap . (.:::) -- | 'fmap' '.' '.::::'. (.:::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j,Functor k) => (a -> b) -> f (g (h (i (j (k a))))) -> f (g (h (i (j (k b))))) (.:::::) = fmap . (.::::) hmt-0.15/Music/Theory/Clef.hs0000644000000000000000000000275712416136065014173 0ustar0000000000000000-- | Common music notation clefs. module Music.Theory.Clef where import Music.Theory.Pitch import Music.Theory.Pitch.Name -- | Clef enumeration type. data Clef_T = Bass | Tenor | Alto | Treble | Percussion deriving (Eq,Ord,Show) -- | Clef with octave offset. data Clef i = Clef {clef_t :: Clef_T ,clef_octave :: i} deriving (Eq,Ord,Show) -- | Give clef range as a 'Pitch' pair indicating the notes below and -- above the staff. -- -- > map clef_range [Treble,Bass] == [Just (d4,g5),Just (f2,b3)] -- > clef_range Percussion == Nothing clef_range :: Clef_T -> Maybe (Pitch,Pitch) clef_range c = case c of Bass -> Just (f2,b3) Tenor -> Just (c3,f4) Alto -> Just (e3,a4) Treble -> Just (d4,g5) Percussion -> Nothing -- | Suggest a 'Clef' given a 'Pitch'. -- -- > map clef_suggest [c2,c4] == [Clef Bass (-1),Clef Treble 0] clef_suggest :: Integral i => Pitch -> Clef i clef_suggest p | p < f1 = Clef Bass (-2) | p < f2 = Clef Bass (-1) | p < b3 = Clef Bass 0 | p < g5 = Clef Treble 0 | p < g6 = Clef Treble 1 | otherwise = Clef Treble 2 -- | Set 'clef_octave' to @0@. clef_zero :: Integral i => Clef i -> Clef i clef_zero (Clef c_t _) = Clef c_t 0 -- | Set 'clef_octave' to be no further than /r/ from @0@. clef_restrict :: Integral i => i -> Clef i -> Clef i clef_restrict r (Clef c_t n) = let n' = if abs n > r then signum n * r else n in Clef c_t n' hmt-0.15/Music/Theory/Tuple.hs0000644000000000000000000001177412416136065014412 0ustar0000000000000000-- | Tuple functions. -- -- Uniform tuples have types 'T2', 'T3' etc. and functions names are -- prefixed @t2_@ etc. -- -- Heterogenous tuples (products) are prefixed @p2_@ etc. module Music.Theory.Tuple where import Data.Monoid {- base -} -- * P2 (2 product) p2_swap :: (s,t) -> (t,s) p2_swap (i,j) = (j,i) -- * T2 (2-tuple, regular) -- | Uniform two-tuple. type T2 a = (a,a) t2 :: [t] -> T2 t t2 l = case l of {[p,q] -> (p,q);_ -> error "t2"} t2_list :: T2 a -> [a] t2_list (i,j) = [i,j] t2_swap :: T2 t -> T2 t t2_swap = p2_swap t2_map :: (p -> q) -> T2 p -> T2 q t2_map f (p,q) = (f p,f q) t2_zipWith :: (p -> q -> r) -> T2 p -> T2 q -> T2 r t2_zipWith f (p,q) (p',q') = (f p p',f q q') t2_infix :: (a -> a -> b) -> T2 a -> b t2_infix f (i,j) = i `f` j -- | Infix 'mappend'. -- -- > t2_join ([1,2],[3,4]) == [1,2,3,4] t2_join :: Monoid m => T2 m -> m t2_join = t2_infix mappend t2_concat :: [T2 [a]] -> T2 [a] t2_concat = t2_map mconcat . unzip t2_sort :: Ord t => (t,t) -> (t,t) t2_sort (p,q) = (min p q,max p q) -- * P3 (3 product) -- | Left rotation. -- -- > p3_rotate_left (1,2,3) == (2,3,1) p3_rotate_left :: (s,t,u) -> (t,u,s) p3_rotate_left (i,j,k) = (j,k,i) p3_fst :: (a,b,c) -> a p3_fst (a,_,_) = a p3_snd :: (a,b,c) -> b p3_snd (_,b,_) = b p3_third :: (a,b,c) -> c p3_third (_,_,c) = c -- * T3 (3 triple, regular) type T3 a = (a,a,a) t3 :: [t] -> T3 t t3 l = case l of {[p,q,r] -> (p,q,r);_ -> error "t3"} t3_rotate_left :: T3 t -> T3 t t3_rotate_left = p3_rotate_left t3_fst :: T3 t -> t t3_fst = p3_fst t3_snd :: T3 t -> t t3_snd = p3_snd t3_third :: T3 t -> t t3_third = p3_third t3_map :: (p -> q) -> T3 p -> T3 q t3_map f (p,q,r) = (f p,f q,f r) t3_zipWith :: (p -> q -> r) -> T3 p -> T3 q -> T3 r t3_zipWith f (p,q,r) (p',q',r') = (f p p',f q q',f r r') t3_list :: T3 a -> [a] t3_list (i,j,k) = [i,j,k] t3_infix :: (a -> a -> a) -> T3 a -> a t3_infix f (i,j,k) = (i `f` j) `f` k t3_join :: T3 [a] -> [a] t3_join = t3_infix (++) -- * P4 (4 product) p4_fst :: (a,b,c,d) -> a p4_fst (a,_,_,_) = a p4_snd :: (a,b,c,d) -> b p4_snd (_,b,_,_) = b p4_third :: (a,b,c,d) -> c p4_third (_,_,c,_) = c p4_fourth :: (a,b,c,d) -> d p4_fourth (_,_,_,d) = d -- * T4 (4-tuple, regular) type T4 a = (a,a,a,a) t4 :: [t] -> T4 t t4 l = case l of {[p,q,r,s] -> (p,q,r,s); _ -> error "t4"} t4_list :: T4 t -> [t] t4_list (p,q,r,s) = [p,q,r,s] t4_fst :: T4 t -> t t4_fst = p4_fst t4_snd :: T4 t -> t t4_snd = p4_snd t4_third :: T4 t -> t t4_third = p4_third t4_fourth :: T4 t -> t t4_fourth = p4_fourth t4_map :: (p -> q) -> T4 p -> T4 q t4_map f (p,q,r,s) = (f p,f q,f r,f s) t4_zipWith :: (p -> q -> r) -> T4 p -> T4 q -> T4 r t4_zipWith f (p,q,r,s) (p',q',r',s') = (f p p',f q q',f r r',f s s') t4_infix :: (a -> a -> a) -> T4 a -> a t4_infix f (i,j,k,l) = ((i `f` j) `f` k) `f` l t4_join :: T4 [a] -> [a] t4_join = t4_infix (++) -- * P5 (5 product) p5_fst :: (a,b,c,d,e) -> a p5_fst (a,_,_,_,_) = a p5_snd :: (a,b,c,d,e) -> b p5_snd (_,b,_,_,_) = b p5_third :: (a,b,c,d,e) -> c p5_third (_,_,c,_,_) = c p5_fourth :: (a,b,c,d,e) -> d p5_fourth (_,_,_,d,_) = d p5_fifth :: (a,b,c,d,e) -> e p5_fifth (_,_,_,_,e) = e -- * T5 (5-tuple, regular) type T5 a = (a,a,a,a,a) t5 :: [t] -> T5 t t5 l = case l of {[p,q,r,s,t] -> (p,q,r,s,t); _ -> error "t5"} t5_list :: T5 t -> [t] t5_list (p,q,r,s,t) = [p,q,r,s,t] t5_map :: (p -> q) -> T5 p -> T5 q t5_map f (p,q,r,s,t) = (f p,f q,f r,f s,f t) t5_fst :: T5 t -> t t5_fst (p,_,_,_,_) = p t5_snd :: T5 t -> t t5_snd (_,q,_,_,_) = q t5_fourth :: T5 t -> t t5_fourth (_,_,_,t,_) = t t5_fifth :: T5 t -> t t5_fifth (_,_,_,_,u) = u t5_infix :: (a -> a -> a) -> T5 a -> a t5_infix f (i,j,k,l,m) = (((i `f` j) `f` k) `f` l) `f` m t5_join :: T5 [a] -> [a] t5_join = t5_infix (++) -- * P6 (6 product) p6_fst :: (a,b,c,d,e,f) -> a p6_fst (a,_,_,_,_,_) = a p6_snd :: (a,b,c,d,e,f) -> b p6_snd (_,b,_,_,_,_) = b p6_third :: (a,b,c,d,e,f) -> c p6_third (_,_,c,_,_,_) = c p6_fourth :: (a,b,c,d,e,f) -> d p6_fourth (_,_,_,d,_,_) = d p6_fifth :: (a,b,c,d,e,f) -> e p6_fifth (_,_,_,_,e,_) = e p6_sixth :: (a,b,c,d,e,f) -> f p6_sixth (_,_,_,_,_,f) = f -- * T6 (6-tuple, regular) type T6 a = (a,a,a,a,a,a) t6 :: [t] -> T6 t t6 l = case l of {[p,q,r,s,t,u] -> (p,q,r,s,t,u);_ -> error "t6"} t6_list :: T6 t -> [t] t6_list (p,q,r,s,t,u) = [p,q,r,s,t,u] t6_map :: (p -> q) -> T6 p -> T6 q t6_map f (p,q,r,s,t,u) = (f p,f q,f r,f s,f t,f u) -- * T7 (7-tuple, regular) type T7 a = (a,a,a,a,a,a,a) t7_list :: T7 t -> [t] t7_list (p,q,r,s,t,u,v) = [p,q,r,s,t,u,v] t7_map :: (p -> q) -> T7 p -> T7 q t7_map f (p,q,r,s,t,u,v) = (f p,f q,f r,f s,f t,f u,f v) -- * T8 (8-tuple, regular) type T8 a = (a,a,a,a,a,a,a,a) t8_list :: T8 t -> [t] t8_list (p,q,r,s,t,u,v,w) = [p,q,r,s,t,u,v,w] t8_map :: (p -> q) -> T8 p -> T8 q t8_map f (p,q,r,s,t,u,v,w) = (f p,f q,f r,f s,f t,f u,f v,f w) -- * T9 (9-tuple, regular) type T9 a = (a,a,a,a,a,a,a,a,a) t9_list :: T9 t -> [t] t9_list (p,q,r,s,t,u,v,w,x) = [p,q,r,s,t,u,v,w,x] t9_map :: (p -> q) -> T9 p -> T9 q t9_map f (p,q,r,s,t,u,v,w,x) = (f p,f q,f r,f s,f t,f u,f v,f w,f x) hmt-0.15/Music/Theory/Unicode.hs0000644000000000000000000000400412416136065014673 0ustar0000000000000000-- | module Music.Theory.Unicode where type Unicode_Table = [(Int,String)] -- > putStrLn (map (toEnum . fst) (concat unicode)) unicode :: [Unicode_Table] unicode = [accidentals,notes,rests,clefs] accidentals :: Unicode_Table accidentals = [(0x1D12A,"MUSICAL SYMBOL DOUBLE SHARP") ,(0x1D12B,"MUSICAL SYMBOL DOUBLE FLAT") ,(0x1D12C,"MUSICAL SYMBOL FLAT UP") ,(0x1D12D,"MUSICAL SYMBOL FLAT DOWN") ,(0x1D12E,"MUSICAL SYMBOL NATURAL UP") ,(0x1D12F,"MUSICAL SYMBOL NATURAL DOWN") ,(0x1D130,"MUSICAL SYMBOL SHARP UP") ,(0x1D131,"MUSICAL SYMBOL SHARP DOWN") ,(0x1D132,"MUSICAL SYMBOL QUARTER TONE SHARP") ,(0x1D133,"MUSICAL SYMBOL QUARTER TONE FLAT")] notes :: Unicode_Table notes = [(0x1D15C,"MUSICAL SYMBOL BREVE") ,(0x1D15D,"MUSICAL SYMBOL WHOLE NOTE") ,(0x1D15E,"MUSICAL SYMBOL HALF NOTE") ,(0x1D15F,"MUSICAL SYMBOL QUARTER NOTE") ,(0x1D160,"MUSICAL SYMBOL EIGHTH NOTE") ,(0x1D161,"MUSICAL SYMBOL SIXTEENTH NOTE") ,(0x1D162,"MUSICAL SYMBOL THIRTY-SECOND NOTE") ,(0x1D163,"MUSICAL SYMBOL SIXTY-FOURTH NOTE") ,(0x1D164,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE")] rests :: Unicode_Table rests = [(0x1D13B,"MUSICAL SYMBOL WHOLE REST") ,(0x1D13C,"MUSICAL SYMBOL HALF REST") ,(0x1D13D,"MUSICAL SYMBOL QUARTER REST") ,(0x1D13E,"MUSICAL SYMBOL EIGHTH REST") ,(0x1D13F,"MUSICAL SYMBOL SIXTEENTH REST") ,(0x1D140,"MUSICAL SYMBOL THIRTY-SECOND REST") ,(0x1D141,"MUSICAL SYMBOL SIXTY-FOURTH REST") ,(0x1D142,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH REST")] clefs :: Unicode_Table clefs = [(0x1D11E,"MUSICAL SYMBOL G CLEF") ,(0x1D11F,"MUSICAL SYMBOL G CLEF OTTAVA ALTA") ,(0x1D120,"MUSICAL SYMBOL G CLEF OTTAVA BASSA") ,(0x1D121,"MUSICAL SYMBOL C CLEF") ,(0x1D122,"MUSICAL SYMBOL F CLEF") ,(0x1D123,"MUSICAL SYMBOL F CLEF OTTAVA ALTA") ,(0x1D124,"MUSICAL SYMBOL F CLEF OTTAVA BASSA") ,(0x1D125,"MUSICAL SYMBOL DRUM CLEF-1") ,(0x1D126,"MUSICAL SYMBOL DRUM CLEF-2")] hmt-0.15/Music/Theory/Maybe.hs0000644000000000000000000000472612416136065014355 0ustar0000000000000000-- | Extensions to "Data.Maybe". module Music.Theory.Maybe where -- import Data.Maybe {- base -} -- | Variant of unzip. -- -- > let r = ([Just 1,Nothing,Just 3],[Just 'a',Nothing,Just 'c']) -- > in maybe_unzip [Just (1,'a'),Nothing,Just (3,'c')] == r maybe_unzip :: [Maybe (a,b)] -> ([Maybe a],[Maybe b]) maybe_unzip = let f x = case x of Nothing -> (Nothing,Nothing) Just (i,j) -> (Just i,Just j) in unzip . map f -- | Replace 'Nothing' elements with last 'Just' value. This does not -- alter the length of the list. -- -- > maybe_latch 1 [Nothing,Just 2,Nothing,Just 4] == [1,2,2,4] maybe_latch :: a -> [Maybe a] -> [a] maybe_latch i x = case x of [] -> [] Just e:x' -> e : maybe_latch e x' Nothing:x' -> i : maybe_latch i x' -- | Variant requiring initial value is not 'Nothing'. -- -- > maybe_latch1 [Just 1,Nothing,Nothing,Just 4] == [1,1,1,4] maybe_latch1 :: [Maybe a] -> [a] maybe_latch1 = maybe_latch (error "maybe_latch1") -- | 'map' of 'fmap'. -- -- > maybe_map negate [Nothing,Just 2] == [Nothing,Just (-2)] maybe_map :: (a -> b) -> [Maybe a] -> [Maybe b] maybe_map = map . fmap -- | If either is 'Nothing' then 'False', else /eq/ of values. maybe_eq_by :: (t -> u -> Bool) -> Maybe t -> Maybe u -> Bool maybe_eq_by eq_fn p q = case (p,q) of (Just p',Just q') -> eq_fn p' q' _ -> False -- | Join two values, either of which may be missing. maybe_join' :: (s -> t) -> (s -> s -> t) -> Maybe s -> Maybe s -> Maybe t maybe_join' f g p q = case (p,q) of (Nothing,_) -> fmap f q (_,Nothing) -> fmap f p (Just p',Just q') -> Just (p' `g` q') -- | 'maybe_join'' of 'id' maybe_join :: (t -> t -> t) -> Maybe t -> Maybe t -> Maybe t maybe_join = maybe_join' id -- | Apply predicate inside 'Maybe'. -- -- > maybe_predicate even (Just 3) == Nothing maybe_predicate :: (a -> Bool) -> Maybe a -> Maybe a maybe_predicate f i = case i of Nothing -> Nothing Just j -> if f j then Just j else Nothing -- | 'map' of 'maybe_predicate'. -- -- > let r = [Nothing,Nothing,Nothing,Just 4] -- > in maybe_filter even [Just 1,Nothing,Nothing,Just 4] == r maybe_filter :: (a -> Bool) -> [Maybe a] -> [Maybe a] maybe_filter = map . maybe_predicate -- | Variant of 'Data.List.filter' that retains 'Nothing' as a -- placeholder for removed elements. -- -- > filter_maybe even [1..4] == [Nothing,Just 2,Nothing,Just 4] filter_maybe :: (a -> Bool) -> [a] -> [Maybe a] filter_maybe f = maybe_filter f . map Just hmt-0.15/Music/Theory/List.hs0000644000000000000000000003241212416136065014224 0ustar0000000000000000-- | List functions. module Music.Theory.List where import Data.Function {- base -} import Data.List {- base -} import qualified Data.List.Ordered as O {- data-ordlist -} import Data.List.Split {- split -} import Data.Maybe {- base -} -- | Bracket sequence with left and right values. -- -- > bracket ('<','>') "1,2,3" == "<1,2,3>" bracket :: (a,a) -> [a] -> [a] bracket (l,r) x = l : x ++ [r] -- | Variant where brackets are sequences. -- -- > bracket_l ("<:",":>") "1,2,3" == "<:1,2,3:>" bracket_l :: ([a],[a]) -> [a] -> [a] bracket_l (l,r) s = l ++ s ++ r -- | Generic form of 'rotate_left'. genericRotate_left :: Integral i => i -> [a] -> [a] genericRotate_left n = let f (p,q) = q ++ p in f . genericSplitAt n -- | Left rotation. -- -- > rotate_left 1 [1..3] == [2,3,1] -- > rotate_left 3 [1..5] == [4,5,1,2,3] rotate_left :: Int -> [a] -> [a] rotate_left = genericRotate_left -- | Generic form of 'rotate_right'. genericRotate_right :: Integral n => n -> [a] -> [a] genericRotate_right n = reverse . genericRotate_left n . reverse -- | Right rotation. -- -- > rotate_right 1 [1..3] == [3,1,2] rotate_right :: Int -> [a] -> [a] rotate_right = genericRotate_right -- | Rotate left by /n/ 'mod' /#p/ places. -- -- > rotate 1 [1..3] == [2,3,1] -- > rotate 8 [1..5] == [4,5,1,2,3] rotate :: (Integral n) => n -> [a] -> [a] rotate n p = let m = n `mod` genericLength p in genericRotate_left m p -- | Rotate right by /n/ places. -- -- > rotate_r 8 [1..5] == [3,4,5,1,2] rotate_r :: (Integral n) => n -> [a] -> [a] rotate_r = rotate . negate -- | All rotations. -- -- > rotations [0,1,3] == [[0,1,3],[1,3,0],[3,0,1]] rotations :: [a] -> [[a]] rotations p = map (`rotate_left` p) [0 .. length p - 1] -- | Generic form of 'adj2'. genericAdj2 :: (Integral n) => n -> [t] -> [(t,t)] genericAdj2 n l = case l of p:q:_ -> (p,q) : genericAdj2 n (genericDrop n l) _ -> [] -- | Adjacent elements of list, at indicated distance, as pairs. -- -- > adj2 1 [1..5] == [(1,2),(2,3),(3,4),(4,5)] -- > adj2 2 [1..4] == [(1,2),(3,4)] -- > adj2 3 [1..5] == [(1,2),(4,5)] adj2 :: Int -> [t] -> [(t,t)] adj2 = genericAdj2 -- | Append first element to end of list. -- -- > close [1..3] == [1,2,3,1] close :: [a] -> [a] close x = case x of [] -> [] e:_ -> x ++ [e] -- | 'adj2' '.' 'close'. -- -- > adj2_cyclic 1 [1..3] == [(1,2),(2,3),(3,1)] adj2_cyclic :: Int -> [t] -> [(t,t)] adj2_cyclic n = adj2 n . close -- | Interleave elements of /p/ and /q/. -- -- > interleave [1..3] [4..6] == [1,4,2,5,3,6] -- > interleave ".+-" "abc" == ".a+b-c" -- > interleave [1..3] [] == [] interleave :: [b] -> [b] -> [b] interleave p q = let u (i,j) = [i,j] in concatMap u (zip p q) -- | Variant that continues with the longer input. -- -- > interleave_continue ".+-" "abc" == ".a+b-c" -- > interleave_continue [1..3] [] == [1..3] -- > interleave_continue [] [1..3] == [1..3] interleave_continue :: [a] -> [a] -> [a] interleave_continue p q = case (p,q) of ([],_) -> q (_,[]) -> p (i:p',j:q') -> i : j : interleave_continue p' q' -- | 'interleave' of 'rotate_left' by /i/ and /j/. -- -- > interleave_rotations 9 3 [1..13] == [10,4,11,5,12,6,13,7,1,8,2,9,3,10,4,11,5,12,6,13,7,1,8,2,9,3] interleave_rotations :: Int -> Int -> [b] -> [b] interleave_rotations i j s = interleave (rotate_left i s) (rotate_left j s) -- | Count occurences of elements in list. -- -- > histogram "hohoh" == [('h',3),('o',2)] histogram :: (Ord a,Integral i) => [a] -> [(a,i)] histogram x = let g = group (sort x) n = map genericLength g in zip (map head g) n -- | List segments of length /i/ at distance /j/. -- -- > segments 2 1 [1..5] == [[1,2],[2,3],[3,4],[4,5]] -- > segments 2 2 [1..5] == [[1,2],[3,4]] segments :: Int -> Int -> [a] -> [[a]] segments i j p = let q = take i p p' = drop j p in if length q /= i then [] else q : segments i j p' -- | 'foldl1' 'intersect'. -- -- > intersect_l [[1,2],[1,2,3],[1,2,3,4]] == [1,2] intersect_l :: Eq a => [[a]] -> [a] intersect_l = foldl1 intersect -- | 'foldl1' 'union'. -- -- > sort (union_l [[1,3],[2,3],[3]]) == [1,2,3] union_l :: Eq a => [[a]] -> [a] union_l = foldl1 union -- | Intersection of adjacent elements of list at distance /n/. -- -- > adj_intersect 1 [[1,2],[1,2,3],[1,2,3,4]] == [[1,2],[1,2,3]] adj_intersect :: Eq a => Int -> [[a]] -> [[a]] adj_intersect n = map intersect_l . segments 2 n -- | List of cycles at distance /n/. -- -- > cycles 2 [1..6] == [[1,3,5],[2,4,6]] -- > cycles 3 [1..9] == [[1,4,7],[2,5,8],[3,6,9]] -- > cycles 4 [1..8] == [[1,5],[2,6],[3,7],[4,8]] cycles :: Int -> [a] -> [[a]] cycles n = transpose . chunksOf n -- * Association lists -- | Given accesors for /key/ and /value/ collate input. -- -- > let r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")] -- > in collate_on fst snd (zip "ABCBCD" "abcdef") collate_on :: (Eq k,Ord k) => (a -> k) -> (a -> v) -> [a] -> [(k,[v])] collate_on f g = let h l = case l of [] -> error "collate_on" l0:_ -> (f l0,map g l) in map h . groupBy ((==) `on` f) . sortBy (compare `on` f) -- | 'collate_on' of 'fst' and 'snd'. -- -- > collate (zip [1,2,1] "abc") == [(1,"ac"),(2,"b")] collate :: Ord a => [(a,b)] -> [(a,[b])] collate = collate_on fst snd -- | Make /assoc/ list with given /key/. -- -- > with_key 'a' [1..3] == [('a',1),('a',2),('a',3)] with_key :: k -> [v] -> [(k,v)] with_key h = zip (repeat h) -- | Intervals to values, zero is /n/. -- -- > dx_d 5 [1,2,3] == [5,6,8,11] dx_d :: (Num a) => a -> [a] -> [a] dx_d = scanl (+) -- | Variant that takes initial value and separates final value. This -- is an appropriate function for 'mapAccumL'. -- -- > dx_d' 5 [1,2,3] == (11,[5,6,8]) -- > dx_d' 0 [1,1,1] == (3,[0,1,2]) dx_d' :: Num t => t -> [t] -> (t,[t]) dx_d' n l = case reverse (scanl (+) n l) of e:r -> (e,reverse r) _ -> error "dx_d'" -- | Integrate, ie. pitch class segment to interval sequence. -- -- > d_dx [5,6,8,11] == [1,2,3] -- > d_dx [] == [] d_dx :: (Num a) => [a] -> [a] d_dx l = if null l then [] else zipWith (-) (tail l) l -- | Elements of /p/ not in /q/. -- -- > [1,2,3] `difference` [1,2] == [3] difference :: (Eq a) => [a] -> [a] -> [a] difference p q = let f e = e `notElem` q in filter f p -- | Is /p/ a subset of /q/, ie. is 'intersect' of /p/ and /q/ '==' /p/. -- -- > is_subset [1,2] [1,2,3] == True is_subset :: Eq a => [a] -> [a] -> Bool is_subset p q = p `intersect` q == p -- | Is /p/ a superset of /q/, ie. 'flip' 'is_subset'. -- -- > is_superset [1,2,3] [1,2] == True is_superset :: Eq a => [a] -> [a] -> Bool is_superset = flip is_subset -- | Is /p/ a subsequence of /q/, ie. synonym for 'isInfixOf'. -- -- > subsequence [1,2] [1,2,3] == True subsequence :: (Eq a) => [a] -> [a] -> Bool subsequence = isInfixOf -- | Variant of 'elemIndices' that requires /e/ to be unique in /p/. -- -- > elem_index_unique 'a' "abcda" == undefined elem_index_unique :: (Eq a) => a -> [a] -> Int elem_index_unique e p = case elemIndices e p of [i] -> i _ -> error "elem_index_unique" -- | Basis of 'find_bounds'. There is an option to consider the last -- element specially, and if equal to the last span is given. find_bounds' :: Bool -> (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t) find_bounds' scl f l x = let g (p,q) = f p x /= GT && f q x == GT h (p,q) = f p x /= GT && f q x /= LT h' = if scl then h else g in case l of [] -> Nothing [e] -> if h' e then Just e else Nothing e:l' -> if g e then Just e else find_bounds' scl f l' x -- | Find adjacent elements of list that bound element under given -- comparator. -- -- > let {f = find_bounds True compare [1..5] -- > ;r = [Nothing,Just (1,2),Just (3,4),Just (4,5)]} -- > in map f [0,1,3.5,5] == r find_bounds :: Bool -> (t -> s -> Ordering) -> [t] -> s -> Maybe (t,t) find_bounds scl f l = find_bounds' scl f (adj2 1 l) -- | Variant of 'drop' from right of list. -- -- > dropRight 1 [1..9] == [1..8] dropRight :: Int -> [a] -> [a] dropRight n = reverse . drop n . reverse -- | Variant of 'dropWhile' from right of list. -- -- > dropWhileRight Data.Char.isDigit "A440" == "A" dropWhileRight :: (a -> Bool) -> [a] -> [a] dropWhileRight p = reverse . dropWhile p . reverse -- | Apply /f/ at first element, and /g/ at all other elements. -- -- > at_head negate id [1..5] == [-1,2,3,4,5] at_head :: (a -> b) -> (a -> b) -> [a] -> [b] at_head f g x = case x of [] -> [] e:x' -> f e : map g x' -- | Apply /f/ at all but last element, and /g/ at last element. -- -- > at_last (* 2) negate [1..4] == [2,4,6,-4] at_last :: (a -> b) -> (a -> b) -> [a] -> [b] at_last f g x = case x of [] -> [] [i] -> [g i] i:x' -> f i : at_last f g x' -- | Separate list into an initial list and a last element tuple. -- -- > separate_last [1..5] == ([1..4],5) separate_last :: [a] -> ([a],a) separate_last x = let e:x' = reverse x in (reverse x',e) -- | Replace directly repeated elements with 'Nothing'. -- -- > indicate_repetitions "abba" == [Just 'a',Just 'b',Nothing,Just 'a'] indicate_repetitions :: Eq a => [a] -> [Maybe a] indicate_repetitions = let f l = case l of [] -> [] e:l' -> Just e : map (const Nothing) l' in concatMap f . group -- | 'Data.List.groupBy' does not make adjacent comparisons, it -- compares each new element to the start of the group. This function -- is the adjacent variant. -- -- > groupBy (<) [1,2,3,2,4,1,5,9] == [[1,2,3,2,4],[1,5,9]] -- > adjacent_groupBy (<) [1,2,3,2,4,1,5,9] == [[1,2,3],[2,4],[1,5,9]] adjacent_groupBy :: (a -> a -> Bool) -> [a] -> [[a]] adjacent_groupBy f p = case p of [] -> [] [x] -> [[x]] x:y:p' -> let r = adjacent_groupBy f (y:p') r0:r' = r in if f x y then (x:r0) : r' else [x] : r -- | 'groupBy' on /structure/ of 'Maybe', ie. all 'Just' compare equal. -- -- > let r = [[Just 1],[Nothing,Nothing],[Just 4,Just 5]] -- > in group_just [Just 1,Nothing,Nothing,Just 4,Just 5] == r group_just :: [Maybe a] -> [[Maybe a]] group_just = groupBy ((==) `on` isJust) -- | Predicate to determine if all elements of the list are '=='. all_eq :: Eq n => [n] -> Bool all_eq = (== 1) . length . nub -- | 'groupBy' of 'sortBy'. -- -- > let r = [[('1','a'),('1','c')],[('2','d')],[('3','b'),('3','e')]] -- > in sort_group_on fst (zip "13123" "abcde") == r sort_group_on :: Ord b => (a -> b) -> [a] -> [[a]] sort_group_on f = groupBy ((==) `on` f) . sortBy (compare `on` f) -- | Maybe cons element onto list. -- -- > Nothing `mcons` "something" == "something" -- > Just 's' `mcons` "omething" == "something" mcons :: Maybe a -> [a] -> [a] mcons e l = maybe l (:l) e -- * Ordering -- | Comparison function type. type Compare_F a = a -> a -> Ordering -- | If /f/ compares 'EQ', defer to /g/. two_stage_compare :: Compare_F a -> Compare_F a -> Compare_F a two_stage_compare f g p q = case f p q of EQ -> g p q r -> r -- | Invert 'Ordering'. ordering_invert :: Ordering -> Ordering ordering_invert o = case o of LT -> GT EQ -> EQ GT -> LT -- | Sort sequence /a/ based on ordering of sequence /b/. -- -- > sort_to "abc" [1,3,2] == "acb" -- > sort_to "adbce" [1,4,2,3,5] == "abcde" sort_to :: Ord i => [e] -> [i] -> [e] sort_to e = map fst . sortBy (compare `on` snd) . zip e -- | 'flip' of 'sort_to'. -- -- > sort_on [1,4,2,3,5] "adbce" == "abcde" sort_on :: Ord i => [i] -> [e] -> [e] sort_on = flip sort_to -- | 'sortBy' of 'two_stage_compare'. sort_by_two_stage :: (Ord b,Ord c) => (a -> b) -> (a -> c) -> [a] -> [a] sort_by_two_stage f g = sortBy (two_stage_compare (compare `on` f) (compare `on` g)) -- | Given a comparison function, merge two ascending lists. -- -- > mergeBy compare [1,3,5] [2,4] == [1..5] merge_by :: Compare_F a -> [a] -> [a] -> [a] merge_by = O.mergeBy -- | 'O.mergeBy' of 'two_stage_compare'. merge_by_two_stage :: Ord b => (a -> b) -> Compare_F c -> (a -> c) -> [a] -> [a] -> [a] merge_by_two_stage f cmp g = O.mergeBy (two_stage_compare (compare `on` f) (cmp `on` g)) -- | 'mergeBy' 'compare'. merge :: Ord a => [a] -> [a] -> [a] merge = O.merge -- | Merge list of sorted lists given comparison function. Note that -- this is not equal to 'O.mergeAll'. merge_set_by :: (a -> a -> Ordering) -> [[a]] -> [a] merge_set_by f = foldr (merge_by f) [] -- | 'merge_set_by' of 'compare'. -- -- > merge_set [[1,3,5,7,9],[2,4,6,8],[10]] == [1..10] merge_set :: Ord a => [[a]] -> [a] merge_set = merge_set_by compare {-| 'merge_by' variant that joins (resolves) equal elements. > let {left p _ = p > ;right _ q = q > ;cmp = compare `on` fst > ;p = zip [1,3,5] "abc" > ;q = zip [1,2,3] "ABC" > ;left_r = [(1,'a'),(2,'B'),(3,'b'),(5,'c')] > ;right_r = [(1,'A'),(2,'B'),(3,'C'),(5,'c')]} > in merge_by_resolve left cmp p q == left_r && > merge_by_resolve right cmp p q == right_r -} merge_by_resolve :: (a -> a -> a) -> Compare_F a -> [a] -> [a] -> [a] merge_by_resolve jn cmp = let recur p q = case (p,q) of ([],_) -> q (_,[]) -> p (l:p',r:q') -> case cmp l r of LT -> l : recur p' q EQ -> jn l r : recur p' q' GT -> r : recur p q' in recur -- * Bimap -- | Apply /f/ to both elements of a two-tuple, ie. 'bimap' /f/ /f/. bimap1 :: (t -> u) -> (t,t) -> (u,u) bimap1 f (p,q) = (f p,f q) hmt-0.15/Music/Theory/Z12.hs0000644000000000000000000000536712416136065013676 0ustar0000000000000000{-# Language GeneralizedNewtypeDeriving #-} module Music.Theory.Z12 where import Data.List {- base -} -- | Z12 are modulo 12 integers. -- -- > map signum [-1,0::Z12,1] == [1,0,1] -- > map abs [-1,0::Z12,1] == [11,0,1] newtype Z12 = Z12 Int deriving (Eq,Ord,Integral,Real) -- | Cyclic 'Enum' instance for Z12. -- -- > pred (0::Z12) == 11 -- > succ (11::Z12) == 0 -- > [9::Z12 .. 3] == [9,10,11,0,1,2,3] -- > [9::Z12,11 .. 3] == [9,11,1,3] instance Enum Z12 where pred = subtract 1 succ = (+) 1 toEnum = fromIntegral fromEnum = fromIntegral enumFromThenTo n m o = let m' = m + (m - n) in if m' == o then [n,m,o] else n : enumFromThenTo m m' o enumFromTo n m = let n' = succ n in if n' == m then [n,m] else n : enumFromTo n' m -- | 'Bounded' instance for Z12. -- -- > [minBound::Z12 .. maxBound] == [0::Z12 .. 11] instance Bounded Z12 where minBound = Z12 0 maxBound = Z12 11 -- | The Z12 modulo (ie. @12@) as a 'Z12' value. This is required -- when lifting generalised @Z@ functions to 'Z12'. It is /not/ the -- same as writing @12::Z12@. -- -- > z12_modulo == Z12 12 -- > z12_modulo /= 12 -- > (12::Z12) == 0 -- > show z12_modulo == "(Z12 12)" z12_modulo :: Z12 z12_modulo = Z12 12 -- | Basis for Z12 show instance. -- -- > map show [-1,0::Z12,1,z12_modulo] == ["11","0","1","(Z12 12)"] z12_showsPrec :: Int -> Z12 -> ShowS z12_showsPrec p (Z12 i) = let x = showsPrec p i in if i < 0 || i > 11 then showString "(Z12 " . x . showString ")" else x instance Show Z12 where showsPrec = z12_showsPrec -- | Lift unary function over integers to Z12. -- -- > lift_unary_Z12 (negate) 7 == 5 lift_unary_Z12 :: (Int -> Int) -> Z12 -> Z12 lift_unary_Z12 f (Z12 a) = Z12 (f a `mod` 12) -- | Lift unary function over integers to Z12. -- -- > map (lift_binary_Z12 (+) 4) [1,5,6] == [5,9,10] lift_binary_Z12 :: (Int -> Int -> Int) -> Z12 -> Z12 -> Z12 lift_binary_Z12 f (Z12 a) (Z12 b) = Z12 (mod (a `f` b) 12) -- | Raise an error if the internal 'Z12' value is negative. check_negative :: (Int -> Int) -> Z12 -> Z12 check_negative f (Z12 n) = if n < 0 then error "check_negative: negative Z12" else Z12 (f n) instance Num Z12 where (+) = lift_binary_Z12 (+) (-) = lift_binary_Z12 (-) (*) = lift_binary_Z12 (*) negate = lift_unary_Z12 negate fromInteger n = Z12 (fromInteger n `mod` 12) signum = check_negative signum abs = check_negative abs -- | Convert integral to 'Z12'. -- -- > map to_Z12 [-9,-3,0,13] == [3,9,0,1] to_Z12 :: Integral i => i -> Z12 to_Z12 = fromIntegral -- | Convert 'Z12' to integral. from_Z12 :: Integral i => Z12 -> i from_Z12 = fromIntegral -- | Z12 not in set. -- -- > complement [0,2,4,5,7,9,11] == [1,3,6,8,10] complement :: [Z12] -> [Z12] complement = (\\) [0 .. 11] hmt-0.15/Music/Theory/Either.hs0000644000000000000000000000047712416136065014537 0ustar0000000000000000-- | Either module Music.Theory.Either where -- | Maybe 'Left' of 'Either'. fromLeft :: Either a b -> Maybe a fromLeft e = case e of Left x -> Just x _ -> Nothing -- | Maybe 'Right' of 'Either'. fromRight :: Either a b -> Maybe b fromRight e = case e of Right x -> Just x _ -> Nothing hmt-0.15/Music/Theory/Dynamic_Mark.hs0000644000000000000000000001500012416136065015641 0ustar0000000000000000-- | Common music notation dynamic marks. module Music.Theory.Dynamic_Mark where import Data.Char {- base -} import Data.List {- base -} import Data.Maybe {- base -} import qualified Music.Theory.List as T -- | Enumeration of dynamic mark symbols. data Dynamic_Mark_T = Niente | PPPPP | PPPP | PPP | PP | P | MP | MF | F | FF | FFF | FFFF | FFFFF | FP | SF | SFP | SFPP | SFZ | SFFZ deriving (Eq,Ord,Enum,Bounded,Show) -- | Lookup MIDI velocity for 'Dynamic_Mark_T'. The range is linear -- in @0-127@. -- -- > let r = [0,6,17,28,39,50,61,72,83,94,105,116,127] -- > in mapMaybe dynamic_mark_midi [Niente .. FFFFF] == r -- -- > map dynamic_mark_midi [FP,SF,SFP,SFPP,SFZ,SFFZ] == replicate 6 Nothing dynamic_mark_midi :: (Num n,Enum n) => Dynamic_Mark_T -> Maybe n dynamic_mark_midi m = let r = zip [0..] (0 : reverse [127, 127-11 .. 0]) in lookup (fromEnum m) r -- | Error variant. dynamic_mark_midi_err :: Integral n => Dynamic_Mark_T -> n dynamic_mark_midi_err = fromMaybe (error "dynamic_mark_midi") . dynamic_mark_midi -- | Map midi velocity (0-127) to dynamic mark. -- -- > histogram (mapMaybe midi_dynamic_mark [0 .. 127]) midi_dynamic_mark :: (Ord n,Eq n,Num n,Enum n) => n -> Maybe Dynamic_Mark_T midi_dynamic_mark m = let r = zip (0 : [12,24 .. 132]) [0..] in fmap (toEnum . snd) (find ((>= m) . fst) r) -- | Translate /fixed/ 'Dynamic_Mark_T's to /db/ amplitude over given -- /range/. -- -- > mapMaybe (dynamic_mark_db 120) [Niente,P,F,FFFFF] == [-120,-70,-40,0] -- > mapMaybe (dynamic_mark_db 60) [Niente,P,F,FFFFF] == [-60,-35,-20,0] dynamic_mark_db :: Fractional n => n -> Dynamic_Mark_T -> Maybe n dynamic_mark_db r m = let u = [Niente .. FFFFF] n = length u - 1 k = r / fromIntegral n f i = negate r + (fromIntegral i * k) in fmap f (elemIndex m u) -- | -- -- > import Sound.SC3.Plot -- > plotTable [map (ampmidid 20) [0 .. 127],map (ampmidid 60) [0 .. 127]] ampmidid :: Floating a => a -> a -> a ampmidid db v = let r = 10 ** (db / 20) b = 127 / (126 * sqrt r) - 1 / 126 m = (1 - b) / 127 in (m * v + b) ** 2 -- | JMcC (SC3) equation. -- -- > plotTable1 (map amp_db [0,0.005 .. 1]) amp_db :: Floating a => a -> a amp_db a = logBase 10 a * 20 -- | JMcC (SC3) equation. -- -- > plotTable1 (map db_amp [-60,-59 .. 0]) db_amp :: Floating a => a -> a db_amp a = 10 ** (a * 0.05) -- | Enumeration of hairpin indicators. data Hairpin_T = Crescendo | Diminuendo | End_Hairpin deriving (Eq,Ord,Enum,Bounded,Show) -- | The 'Hairpin_T' implied by a ordered pair of 'Dynamic_Mark_T's. -- -- > map (implied_hairpin MF) [MP,F] == [Just Diminuendo,Just Crescendo] implied_hairpin :: Dynamic_Mark_T -> Dynamic_Mark_T -> Maybe Hairpin_T implied_hairpin p q = case compare p q of LT -> Just Crescendo EQ -> Nothing GT -> Just Diminuendo -- | A node in a dynamic sequence. type Dynamic_Node = (Maybe Dynamic_Mark_T,Maybe Hairpin_T) -- | The empty 'Dynamic_Node'. empty_dynamic_node :: Dynamic_Node empty_dynamic_node = (Nothing,Nothing) -- | Calculate a 'Dynamic_Node' sequence from a sequence of -- 'Dynamic_Mark_T's. -- -- > dynamic_sequence [PP,MP,MP,PP] == [(Just PP,Just Crescendo) -- > ,(Just MP,Just End_Hairpin) -- > ,(Nothing,Just Diminuendo) -- > ,(Just PP,Just End_Hairpin)] dynamic_sequence :: [Dynamic_Mark_T] -> [Dynamic_Node] dynamic_sequence d = let h = zipWith implied_hairpin d (tail d) ++ [Nothing] e = Just End_Hairpin rec i p = case p of [] -> [] [(j,_)] -> if i then [(j,e)] else [(j,Nothing)] (j,k):p' -> case k of Nothing -> if i then (j,e) : rec False p' else (j,k) : rec False p' Just _ -> (j,k) : rec True p' in rec False (zip (T.indicate_repetitions d) h) -- | Delete redundant (unaltered) dynamic marks. -- -- > let s = [Just P,Nothing,Just P,Just P,Just F] -- > in delete_redundant_marks s == [Just P,Nothing,Nothing,Nothing,Just F] delete_redundant_marks :: [Maybe Dynamic_Mark_T] -> [Maybe Dynamic_Mark_T] delete_redundant_marks = let f i j = case (i,j) of (Just a,Just b) -> if a == b then (j,Nothing) else (j,j) (Just _,Nothing) -> (i,Nothing) (Nothing,_) -> (j,j) in snd . mapAccumL f Nothing -- | Variant of 'dynamic_sequence' for sequences of 'Dynamic_Mark_T' -- with holes (ie. rests). Runs 'delete_redundant_marks'. -- -- > let r = [Just (Just P,Just Crescendo),Just (Just F,Just End_Hairpin) -- > ,Nothing,Just (Just P,Nothing)] -- > in dynamic_sequence_sets [Just P,Just F,Nothing,Just P] == r -- -- > let s = [Just P,Nothing,Just P] -- > in dynamic_sequence_sets s = [Just (Just P,Nothing),Nothing,Nothing] dynamic_sequence_sets :: [Maybe Dynamic_Mark_T] -> [Maybe Dynamic_Node] dynamic_sequence_sets = let f l = case l of Nothing:_ -> map (const Nothing) l _ -> map Just (dynamic_sequence (catMaybes l)) in concatMap f . T.group_just . delete_redundant_marks -- | Apply 'Hairpin_T' and 'Dynamic_Mark_T' functions in that order as -- required by 'Dynamic_Node'. -- -- > let f _ x = show x -- > in apply_dynamic_node f f (Nothing,Just Crescendo) undefined apply_dynamic_node :: (a -> Dynamic_Mark_T -> a) -> (a -> Hairpin_T -> a) -> Dynamic_Node -> a -> a apply_dynamic_node f g (i,j) m = let n = maybe m (g m) j in maybe n (f n) i -- * ASCII -- | ASCII pretty printer for 'Dynamic_Mark_T'. dynamic_mark_ascii :: Dynamic_Mark_T -> String dynamic_mark_ascii = map toLower . show -- | ASCII pretty printer for 'Hairpin_T'. hairpin_ascii :: Hairpin_T -> String hairpin_ascii hp = case hp of Crescendo -> "<" Diminuendo -> ">" End_Hairpin -> "" -- | ASCII pretty printer for 'Dynamic_Node'. dynamic_node_ascii :: Dynamic_Node -> String dynamic_node_ascii (mk,hp) = let mk' = maybe "" dynamic_mark_ascii mk hp' = maybe "" hairpin_ascii hp in case (mk',hp') of ([],[]) -> [] ([],_) -> hp' (_,[]) -> mk' _ -> mk' ++ " " ++ hp' -- | ASCII pretty printer for 'Dynamic_Node' sequence. dynamic_sequence_ascii :: [Dynamic_Node] -> String dynamic_sequence_ascii = intercalate " " . filter (not . null) . map dynamic_node_ascii hmt-0.15/Music/Theory/Pitch.hs0000644000000000000000000003120712416136065014361 0ustar0000000000000000-- | Common music notation pitch values. module Music.Theory.Pitch where import Data.Char {- base -} import Data.Function {- base -} import Data.List {- base -} import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Math as T {- hmt -} import Music.Theory.Pitch.Note {- hmt -} import Music.Theory.Pitch.Spelling {- hmt -} -- | Pitch classes are modulo twelve integers. type PitchClass = Int -- | Octaves are integers, the octave of middle C is @4@. type Octave = Int -- | 'Octave' and 'PitchClass' duple. type Octave_PitchClass i = (i,i) type OctPC = (Octave,PitchClass) -- | 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 -- | Generalised pitch, given by a generalised alteration. data Pitch' = Pitch' Note_T Alteration_T' Octave deriving (Eq,Show) -- | Pretty printer for 'Pitch''. pitch'_pp :: Pitch' -> String pitch'_pp (Pitch' n (_,a) o) = show n ++ a ++ show o -- | 'Pitch'' printed without octave. pitch'_class_pp :: Pitch' -> String pitch'_class_pp = T.dropWhileRight isDigit . pitch'_pp -- | Simplify 'Pitch' to standard 12ET by deleting quarter tones. -- -- > let p = Pitch A QuarterToneSharp 4 -- > in alteration (pitch_clear_quarter_tone p) == Sharp pitch_clear_quarter_tone :: Pitch -> Pitch pitch_clear_quarter_tone p = let Pitch n a o = p in Pitch n (alteration_clear_quarter_tone a) o -- | 'Pitch' to 'Octave' and 'PitchClass' notation. -- -- > pitch_to_octpc (Pitch F Sharp 4) == (4,6) pitch_to_octpc :: Integral i => Pitch -> Octave_PitchClass i pitch_to_octpc = midi_to_octpc . pitch_to_midi -- | Is 'Pitch' 12-ET. pitch_is_12et :: Pitch -> Bool pitch_is_12et = alteration_is_12et . alteration -- | 'Pitch' to midi note number notation. -- -- > pitch_to_midi (Pitch A Natural 4) == 69 pitch_to_midi :: Integral i => Pitch -> i pitch_to_midi (Pitch n a o) = let a' = alteration_to_diff_err a n' = note_to_pc n o' = fromIntegral o 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 :: Fractional n => Pitch -> n pitch_to_fmidi (Pitch n a o) = let a' = alteration_to_fdiff a o' = fromIntegral o n' = fromInteger (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 (Pitch n a _) = note_to_pc n + alteration_to_diff_err 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 = let f = pitch_to_fmidi :: Pitch -> Double in compare `on` f -- | Given 'Spelling' function translate from 'OctPC' notation to -- 'Pitch'. octpc_to_pitch :: Integral i => Spelling i -> Octave_PitchClass i -> Pitch octpc_to_pitch sp (o,pc) = let (n,a) = sp pc in Pitch n a (fromIntegral o) -- | Normalise 'OctPC' value, ie. ensure 'PitchClass' is in (0,11). -- -- > octpc_nrm (4,16) == (5,4) octpc_nrm :: Integral i => Octave_PitchClass i -> Octave_PitchClass i octpc_nrm (o,pc) = if pc > 11 then octpc_nrm (o+1,pc-12) else if pc < 0 then octpc_nrm (o-1,pc+12) else (o,pc) -- | Transpose 'OctPC' value. -- -- > octpc_trs 7 (4,9) == (5,4) -- > octpc_trs (-11) (4,9) == (3,10) octpc_trs :: Integral i => i -> Octave_PitchClass i -> Octave_PitchClass i octpc_trs n (o,pc) = let pc' = fromIntegral pc k = pc' + n (i,j) = k `divMod` 12 in (fromIntegral o + fromIntegral i,fromIntegral j) -- | 'OctPC' value to integral /midi/ note number. -- -- > octpc_to_midi (4,9) == 69 octpc_to_midi :: Integral i => Octave_PitchClass i -> i octpc_to_midi (o,pc) = 60 + ((fromIntegral o - 4) * 12) + pc -- | 'fromIntegral' of 'octpc_to_midi'. octpc_to_fmidi :: (Integral i,Num n) => Octave_PitchClass i -> n octpc_to_fmidi = fromIntegral . octpc_to_midi -- | Inverse of 'octpc_to_midi'. -- -- > midi_to_octpc 69 == (4,9) midi_to_octpc :: Integral i => i -> Octave_PitchClass i midi_to_octpc n = (n - 12) `divMod` 12 -- | Enumerate range, inclusive. -- -- > octpc_range ((3,8),(4,1)) == [(3,8),(3,9),(3,10),(3,11),(4,0),(4,1)] octpc_range :: (OctPC,OctPC) -> [OctPC] octpc_range (l,r) = let (l',r') = (octpc_to_midi l,octpc_to_midi r) in map midi_to_octpc [l' .. r'] -- | Midi note number to 'Pitch'. -- -- > let r = ["C4","E♭4","F♯4"] -- > in map (pitch_pp . midi_to_pitch pc_spell_ks) [60,63,66] == r midi_to_pitch :: Integral i => Spelling i -> i -> Pitch midi_to_pitch sp = octpc_to_pitch sp . midi_to_octpc -- | Fractional midi note number to 'Pitch'. -- -- > import Music.Theory.Pitch.Spelling -- > pitch_pp (fmidi_to_pitch pc_spell_ks 65.5) == "F𝄲4" -- > pitch_pp (fmidi_to_pitch pc_spell_ks 66.5) == "F𝄰4" -- > pitch_pp (fmidi_to_pitch pc_spell_ks 67.5) == "A𝄭4" -- > pitch_pp (fmidi_to_pitch pc_spell_ks 69.5) == "B𝄭4" fmidi_to_pitch :: RealFrac n => Spelling Int -> n -> Pitch fmidi_to_pitch sp m = let m' = round m (Pitch n a o) = midi_to_pitch sp m' q = m - fromIntegral m' in case alteration_edit_quarter_tone q a of Nothing -> error "fmidi_to_pitch" Just a' -> Pitch n a' o -- | Composition of 'pitch_to_fmidi' and then 'fmidi_to_pitch'. -- -- > import Music.Theory.Pitch.Name as T -- > import Music.Theory.Pitch.Spelling as T -- -- > pitch_tranpose T.pc_spell_ks 2 T.ees5 == T.f5 pitch_tranpose :: RealFrac n => Spelling Int -> n -> Pitch -> Pitch pitch_tranpose sp n p = let m = pitch_to_fmidi p in fmidi_to_pitch sp (m + n) -- | Set octave of /p2/ so that it nearest to /p1/. -- -- > import Music.Theory.Pitch.Name as T -- -- > let {r = ["B1","C2","C#2"];f = pitch_in_octave_nearest T.cis2} -- > in map (pitch_pp_iso . f) [T.b4,T.c4,T.cis4] == r pitch_in_octave_nearest :: Pitch -> Pitch -> Pitch pitch_in_octave_nearest p1 p2 = let o1 = octave p1 p2' = map (\n -> p2 {octave = n}) [o1 - 1,o1,o1 + 1] m1 = pitch_to_fmidi p1 :: Double m2 = map (pitch_to_fmidi) p2' d = map (abs . (m1 -)) m2 z = sortBy (compare `on` snd) (zip p2' d) in fst (head z) -- | Raise 'Note_T' of 'Pitch', account for octave transposition. -- -- > pitch_note_raise (Pitch B Natural 3) == Pitch C Natural 4 pitch_note_raise :: Pitch -> Pitch pitch_note_raise (Pitch n a o) = if n == maxBound then Pitch minBound a (o + 1) else Pitch (succ n) a o -- | Lower 'Note_T' of 'Pitch', account for octave transposition. -- -- > pitch_note_lower (Pitch C Flat 4) == Pitch B Flat 3 pitch_note_lower :: Pitch -> Pitch pitch_note_lower (Pitch n a o) = if n == minBound then Pitch maxBound a (o - 1) else Pitch (pred n) a o -- | Rewrite 'Pitch' to not use @3/4@ tone alterations, ie. re-spell -- to @1/4@ alteration. -- -- > let {p = Pitch A ThreeQuarterToneFlat 4 -- > ;q = Pitch G QuarterToneSharp 4} -- > in pitch_rewrite_threequarter_alteration p == q pitch_rewrite_threequarter_alteration :: Pitch -> Pitch pitch_rewrite_threequarter_alteration (Pitch n a o) = case a of ThreeQuarterToneFlat -> pitch_note_lower (Pitch n QuarterToneSharp o) ThreeQuarterToneSharp -> pitch_note_raise (Pitch n QuarterToneFlat o) _ -> Pitch n a o -- | Apply function to 'octave' of 'PitchClass'. -- -- > pitch_edit_octave (+ 1) (Pitch A Natural 4) == Pitch A Natural 5 pitch_edit_octave :: (Octave -> Octave) -> Pitch -> Pitch pitch_edit_octave f (Pitch n a o) = Pitch n a (f o) -- * Frequency (CPS) -- | /Midi/ note number to cycles per second. -- -- > map midi_to_cps [60,69] == [261.6255653005986,440.0] midi_to_cps :: (Integral i,Floating f) => i -> f midi_to_cps = fmidi_to_cps . fromIntegral -- | Fractional /midi/ note number to cycles per second. -- -- > map fmidi_to_cps [69,69.1] == [440.0,442.5488940698553] fmidi_to_cps :: Floating a => a -> a fmidi_to_cps i = 440 * (2 ** ((i - 69) * (1 / 12))) -- | 'fmidi_to_cps' of 'pitch_to_fmidi'. pitch_to_cps :: Floating n => Pitch -> n pitch_to_cps = fmidi_to_cps . pitch_to_fmidi -- | Frequency (cycles per second) to /midi/ note number, ie. 'round' -- of 'cps_to_fmidi'. -- -- > map cps_to_midi [261.6,440] == [60,69] cps_to_midi :: (Integral i,Floating f,RealFrac f) => f -> i cps_to_midi = round . cps_to_fmidi -- | Frequency (cycles per second) to fractional /midi/ note number. -- -- > cps_to_fmidi 440 == 69 -- > cps_to_fmidi (fmidi_to_cps 60.25) == 60.25 cps_to_fmidi :: Floating a => a -> a cps_to_fmidi a = (logBase 2 (a * (1 / 440)) * 12) + 69 -- | Midi note number with cents detune. type Midi_Detune = (Int,Double) -- | Frequency (in hertz) to 'Midi_Detune'. -- -- > map (fmap round . cps_to_midi_detune) [440.00,508.35] == [(69,0),(71,50)] cps_to_midi_detune :: Double -> Midi_Detune cps_to_midi_detune f = let (n,c) = T.integral_and_fractional_parts (cps_to_fmidi f) in (n,c * 100) -- | Inverse of 'cps_to_midi_detune'. midi_detune_to_cps :: Midi_Detune -> Double midi_detune_to_cps (m,c) = fmidi_to_cps (fromIntegral m + (c / 100)) -- | 'midi_to_cps' of 'octpc_to_midi'. -- -- > octpc_to_cps (4,9) == 440 octpc_to_cps :: (Integral i,Floating n) => Octave_PitchClass i -> n octpc_to_cps = midi_to_cps . octpc_to_midi -- | 'midi_to_octpc' of 'cps_to_midi'. cps_to_octpc :: (Floating f,RealFrac f,Integral i) => f -> Octave_PitchClass i cps_to_octpc = midi_to_octpc . cps_to_midi -- * Parsers -- | Slight generalisation of ISO pitch representation. Allows octave -- to be elided, pitch names to be lower case, and double sharps -- written as @##@. -- -- See -- -- > let r = [Pitch C Natural 4,Pitch A Flat 5,Pitch F DoubleSharp 6] -- > in mapMaybe (parse_iso_pitch_oct 4) ["C","Ab5","f##6",""] == r parse_iso_pitch_oct :: Octave -> String -> Maybe Pitch parse_iso_pitch_oct def_o s = let nte n = let tb = zip "cdefgab" [C,D,E,F,G,A,B] in lookup (toLower n) tb oct o = case o of [] -> Just def_o [n] -> if isDigit n then Just (fromIntegral (digitToInt n)) else Nothing _ -> Nothing mk n a o = case nte n of Nothing -> Nothing Just n' -> fmap (Pitch n' a) (oct o) in case s of [] -> Nothing n:'b':'b':o -> mk n DoubleFlat o n:'#':'#':o -> mk n DoubleSharp o n:'x':o -> mk n DoubleSharp o n:'b':o -> mk n Flat o n:'#':o -> mk n Sharp o n:o -> mk n Natural o -- | Variant of 'parse_iso_pitch_oct' requiring octave. parse_iso_pitch :: String -> Maybe Pitch parse_iso_pitch = parse_iso_pitch_oct (error "parse_iso_pitch: no octave") -- * Pretty printers -- | Pretty printer for 'Pitch' (unicode, see 'alteration_symbol'). -- -- > pitch_pp (Pitch E Flat 4) == "E♭4" -- > pitch_pp (Pitch F QuarterToneSharp 3) == "F𝄲3" pitch_pp :: Pitch -> String pitch_pp (Pitch n a o) = let a' = if a == Natural then "" else [alteration_symbol a] in show n ++ a' ++ show o -- | 'Pitch' printed without octave. pitch_class_pp :: Pitch -> String pitch_class_pp = T.dropWhileRight isDigit . pitch_pp -- | Sequential list of /n/ pitch class names starting from /k/. -- -- > pitch_class_names_12et 11 2 == ["B","C"] pitch_class_names_12et :: Integral n => n -> n -> [String] pitch_class_names_12et k n = let f = pitch_class_pp . midi_to_pitch pc_spell_ks in map f [60 + k .. 60 + k + n - 1] -- | Pretty printer for 'Pitch' (ISO, ASCII, see 'alteration_iso'). -- -- > pitch_pp_iso (Pitch E Flat 4) == "Eb4" -- > pitch_pp_iso (Pitch F DoubleSharp 3) == "Fx3" pitch_pp_iso :: Pitch -> String pitch_pp_iso (Pitch n a o) = show n ++ alteration_iso a ++ show o -- | Pretty printer for 'Pitch' (ASCII, see 'alteration_tonh'). -- -- > pitch_pp_hly (Pitch E Flat 4) == "ees4" -- > pitch_pp_hly (Pitch F QuarterToneSharp 3) == "fih3" -- > pitch_pp_hly (Pitch B Natural 6) == "b6" pitch_pp_hly :: Pitch -> String pitch_pp_hly (Pitch n a o) = let n' = map toLower (show n) in n' ++ alteration_tonh a ++ show o -- | Pretty printer for 'Pitch' (Tonhöhe, see 'alteration_tonh'). -- -- > pitch_pp_tonh (Pitch E Flat 4) == "Es4" -- > pitch_pp_tonh (Pitch F QuarterToneSharp 3) == "Fih3" -- > pitch_pp_tonh (Pitch B Natural 6) == "H6" pitch_pp_tonh :: Pitch -> String pitch_pp_tonh (Pitch n a o) = let o' = show o in case (n,a) of (B,Natural) -> "H" ++ o' (B,Flat) -> "B" ++ o' (B,DoubleFlat) -> "Heses" ++ o' (A,Flat) -> "As" ++ o' (E,Flat) -> "Es" ++ o' _ -> show n ++ alteration_tonh a ++ o' hmt-0.15/Music/Theory/Bjorklund.hs0000644000000000000000000000754512416136065015254 0ustar0000000000000000-- | 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 import Data.List.Split {- split -} 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'')) right :: STEP a -> STEP a right ((i,j),(xs,ys)) = let (ys',ys'') = splitAt i ys in ((i,j-i),(zipWith (++) xs ys',ys'')) bjorklund' :: STEP a -> STEP a bjorklund' (n,x) = let (i,j) = n in if min i j <= 1 then (n,x) else bjorklund' (if i > j then left (n,x) else right (n,x)) -- | 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] y = replicate j [False] (_,(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' 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 hmt-0.15/Music/Theory/Z.hs0000644000000000000000000000457612416136065013534 0ustar0000000000000000-- | Generalised Z-/n/ functions. module Music.Theory.Z where {- From GHC 7.6 onwards there is the modular-arithmetic package, which subsumes this work. {-# Language DataKinds #-} import Data.Modular {- modular-arithmetic -} import GHC.TypeLits {- base -} type Z n = Mod Integer n -- > map negate [0::Z12 .. 11] == [0,11,10,9,8,7,6,5,4,3,2,1] -- > map (+ 5) [0::Z12 .. 11] == [5,6,7,8,9,10,11,0,1,2,3,4] type Z12 = Mod Integer 12 -- > map invert [0::Z12 .. 11] == [0,11,10,9,8,7,6,5,4,3,2,1] invert :: KnownNat n => Z n -> Z n invert = negate -} import Data.List {- base -} lift_unary_Z :: Integral a => a -> (t -> a) -> t -> a lift_unary_Z z f n = mod (f n) z lift_binary_Z :: Integral a => a -> (s -> t -> a) -> s -> t -> a lift_binary_Z z f n1 n2 = mod (n1 `f` n2) z -- > import Music.Theory.Z -- > import qualified Music.Theory.Z12 as Z12 -- > z_mod 12 (6::Z12.Z12) 12 -- > z_add 12 (1::Z12.Z12) 5 -- > (1::Z12.Z12) + 5 -- > map (z_add 12 4) [1,5,6] == [5,9,10] z_add :: Integral a => a -> a -> a -> a z_add z = lift_binary_Z z (+) z_sub :: Integral a => a -> a -> a -> a z_sub z = lift_binary_Z z (-) z_mul :: Integral a => a -> a -> a -> a z_mul z = lift_binary_Z z (*) z_negate :: Integral a => a -> a -> a z_negate z = lift_unary_Z z negate z_fromInteger :: Integral a => a -> Integer -> a z_fromInteger z i = fromInteger i `mod` z z_signum :: t -> t1 -> t2 z_signum _ _ = error "Z numbers are not signed" z_abs :: t -> t1 -> t2 z_abs _ _ = error "Z numbers are not signed" -- > map (to_Z 12) [-9,-3,0] == [3,9,0] to_Z :: Integral i => i -> i -> i to_Z z = z_fromInteger z . fromIntegral from_Z :: (Integral i,Num n) => i -> n from_Z = fromIntegral -- | Z not in set. -- -- > z_complement 5 [0,2,3] == [1,4] -- > z_complement 12 [0,2,4,5,7,9,11] == [1,3,6,8,10] z_complement :: (Enum a, Eq a, Num a) => a -> [a] -> [a] z_complement z = (\\) [0 .. z - 1] z_quot :: Integral i => i -> i -> i -> i z_quot z p = to_Z z . quot p z_rem :: Integral c => c -> c -> c -> c z_rem z p = to_Z z . rem p z_div :: Integral c => c -> c -> c -> c z_div z p = to_Z z . div p -- > z_mod 12 6 12 z_mod :: Integral c => c -> c -> c -> c z_mod z p = to_Z z . mod p z_quotRem :: Integral t => t -> t -> t -> (t, t) z_quotRem z p q = (z_quot z p q,z_quot z p q) z_divMod :: Integral t => t -> t -> t -> (t, t) z_divMod z p q = (z_div z p q,z_mod z p q) z_toInteger :: Integral i => i -> i -> i z_toInteger z = to_Z z hmt-0.15/Music/Theory/Duration.hs0000644000000000000000000001572112416136065015102 0ustar0000000000000000-- | Common music notation duration model. module Music.Theory.Duration where import Control.Monad {- base -} import Data.List {- base -} import Data.Maybe {- base -} import Data.Ratio {- base -} -- | Common 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) -- | Are multipliers equal? duration_meq :: Duration -> Duration -> Bool duration_meq p q = multiplier p == multiplier q -- | Compare durations with equal multipliers. duration_compare_meq :: Duration -> Duration -> Maybe Ordering duration_compare_meq y0 y1 = let (Duration x0 n0 m0) = y0 (Duration x1 n1 m1) = y1 in if y0 == y1 then Just EQ else if m0 /= m1 then Nothing else Just (if x0 == x1 then compare n0 n1 else compare x1 x0) -- | Erroring variant of 'duration_compare_meq'. duration_compare_meq_err :: Duration -> Duration -> Ordering duration_compare_meq_err p = let err = error "duration_compare_meq_err: non-equal multipliers" in fromMaybe err . duration_compare_meq p -- | 'Ord' instance in terms of 'duration_compare_meq_err'. instance Ord Duration where compare = duration_compare_meq_err order_pair :: Ordering -> (t,t) -> (t,t) order_pair o (x,y) = case o of LT -> (x,y) EQ -> (x,y) GT -> (y,x) -- | Sort a pair of equal type values using given comparison function. -- -- > sort_pair compare ('b','a') == ('a','b') sort_pair :: (t -> t -> Ordering) -> (t,t) -> (t,t) sort_pair fn (x,y) = order_pair (fn x y) (x,y) sort_pair_m :: (t -> t -> Maybe Ordering) -> (t,t) -> Maybe (t,t) sort_pair_m fn (x,y) = fmap (`order_pair` (x,y)) (fn x y) -- | True if neither duration is dotted. no_dots :: (Duration, Duration) -> Bool no_dots (x0,x1) = dots x0 == 0 && dots x1 == 0 -- | Sum undotted divisions, input is required to be sorted. sum_dur_undotted :: (Integer, Integer) -> Maybe Duration sum_dur_undotted (x0, x1) | x0 == x1 = Just (Duration (x0 `div` 2) 0 1) | x0 == x1 * 2 = Just (Duration x1 1 1) | otherwise = Nothing -- | Sum dotted divisions, input is required to be sorted. -- -- > sum_dur_dotted (4,1,4,1) == Just (Duration 2 1 1) -- > sum_dur_dotted (4,0,2,1) == Just (Duration 1 0 1) -- > sum_dur_dotted (8,1,4,0) == Just (Duration 4 2 1) -- > sum_dur_dotted (16,0,4,2) == Just (Duration 2 0 1) sum_dur_dotted :: (Integer,Integer,Integer,Integer) -> Maybe Duration sum_dur_dotted (x0, n0, x1, n1) | x0 == x1 && n0 == 1 && n1 == 1 = Just (Duration (x1 `div` 2) 1 1) | x0 == x1 * 2 && n0 == 0 && n1 == 1 = Just (Duration (x1 `div` 2) 0 1) | x0 == x1 * 4 && n0 == 0 && n1 == 2 = Just (Duration (x1 `div` 2) 0 1) | x0 == x1 * 2 && n0 == 1 && n1 == 0 = Just (Duration x1 2 1) | otherwise = Nothing -- | Sum durations. Not all durations can be summed, and the present -- algorithm is not exhaustive. -- -- > import Music.Theory.Duration.Name -- > sum_dur quarter_note eighth_note == Just dotted_quarter_note -- > sum_dur dotted_quarter_note eighth_note == Just half_note -- > sum_dur quarter_note dotted_eighth_note == Just double_dotted_quarter_note sum_dur :: Duration -> Duration -> Maybe Duration sum_dur y0 y1 = let f (x0,x1) = if no_dots (x0,x1) then sum_dur_undotted (division x0, division x1) else sum_dur_dotted (division x0, dots x0 ,division x1, dots x1) in join (fmap f (sort_pair_m duration_compare_meq (y0,y1))) -- | Erroring variant of 'sum_dur'. sum_dur' :: Duration -> Duration -> Duration sum_dur' y0 y1 = let y2 = sum_dur y0 y1 err = error ("sum_dur': " ++ show (y0,y1)) in fromMaybe err y2 -- | Give @MusicXML@ type for division. -- -- > map whole_note_division_to_musicxml_type [2,4] == ["half","quarter"] whole_note_division_to_musicxml_type :: Integer -> String whole_note_division_to_musicxml_type x = case x of 256 -> "256th" 128 -> "128th" 64 -> "64th" 32 -> "32nd" 16 -> "16th" 8 -> "eighth" 4 -> "quarter" 2 -> "half" 1 -> "whole" 0 -> "breve" -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 -- | Give /Lilypond/ notation for 'Duration'. Note that the duration -- multiplier is /not/ written. -- -- > import Music.Theory.Duration.Name -- > map duration_to_lilypond_type [half_note,dotted_quarter_note] == ["2","4."] duration_to_lilypond_type :: Duration -> String duration_to_lilypond_type (Duration dv d _) = 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 _ _) = let err = error "duration_beam_count" bc = whole_note_division_to_beam_count x in fromMaybe err bc whole_note_division_pp :: Integer -> Maybe Char whole_note_division_pp x = let t = [(16,'s'),(8,'e'),(4,'q'),(2,'h'),(1,'w')] in lookup x t -- > import Music.Theory.Duration.Name.Abbreviation -- > map duration_pp [q,h',e''] == [Just "q",Just "h'",Just "e''"] duration_pp :: Duration -> Maybe String duration_pp (Duration x d m) = let d' = genericReplicate d '\'' m' = case (numerator m,denominator m) of (1,1) -> "" (1,i) -> '/' : show i (i,j) -> '*' : show i ++ "/" ++ show j in case whole_note_division_pp x of Just x' -> Just (x' : d' ++ m') _ -> Nothing -- | Duration to @**recip@ notation. -- -- http://humdrum.org/Humdrum/representations/recip.rep.html -- -- > let d = map (\z -> Duration z 0 1) [0,1,2,4,8,16,32] -- > in map duration_recip_pp d == ["0","1","2","4","8","16","32"] -- -- > let d = [Duration 1 1 (1/3),Duration 4 1 1,Duration 4 1 (2/3)] -- > in map duration_recip_pp d == ["3.","4.","6."] duration_recip_pp :: Duration -> String duration_recip_pp (Duration x d m) = let (mn,md) = (numerator m,denominator m) r = (x % mn) * (md % 1) in if denominator r == 1 then show (numerator r) ++ genericReplicate d '.' else error (show ("duration_recip_pp",x,d,m,r)) hmt-0.15/Music/Theory/Tuning.hs0000644000000000000000000003140712416136065014560 0ustar0000000000000000-- | Tuning theory module Music.Theory.Tuning where import Data.Fixed {- base -} import Data.List {- base -} import Data.Maybe {- base -} import Data.Ratio {- base -} import Safe {- safe -} import qualified Music.Theory.Either as T {- hmt -} import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Pitch as T {- hmt -} -- * Types -- | An approximation of a ratio. type Approximate_Ratio = Double -- | A real valued division of a semi-tone into one hundred parts, and -- hence of the octave into @1200@ parts. type Cents = Double -- | A tuning specified 'Either' as a sequence of exact ratios, or as -- a sequence of possibly inexact 'Cents'. data Tuning = Tuning {ratios_or_cents :: Either [Rational] [Cents] ,octave_ratio :: Rational} deriving (Eq,Show) -- | Divisions of octave. -- -- > divisions ditone == 12 divisions :: Tuning -> Int divisions = either length length . ratios_or_cents -- | 'Maybe' exact ratios of 'Tuning'. ratios :: Tuning -> Maybe [Rational] ratios = T.fromLeft . ratios_or_cents -- | 'error'ing variant. ratios_err :: Tuning -> [Rational] ratios_err = fromMaybe (error "ratios") . ratios -- | Possibly inexact 'Cents' of tuning. cents :: Tuning -> [Cents] cents = either (map ratio_to_cents) id . ratios_or_cents -- | 'map' 'round' '.' 'cents'. cents_i :: Integral i => Tuning -> [i] cents_i = map round . cents -- | Variant of 'cents' that includes octave at right. cents_octave :: Tuning -> [Cents] cents_octave t = cents t ++ [ratio_to_cents (octave_ratio t)] -- | Convert from interval in cents to frequency ratio. -- -- > map cents_to_ratio [0,701.9550008653874,1200] == [1,3/2,2] cents_to_ratio :: Floating a => a -> a cents_to_ratio n = 2 ** (n / 1200) -- | Possibly inexact 'Approximate_Ratio's of tuning. approximate_ratios :: Tuning -> [Approximate_Ratio] approximate_ratios = either (map approximate_ratio) (map cents_to_ratio) . ratios_or_cents -- | Cyclic form, taking into consideration 'octave_ratio'. approximate_ratios_cyclic :: Tuning -> [Approximate_Ratio] approximate_ratios_cyclic t = let r = approximate_ratios t m = realToFrac (octave_ratio t) g = iterate (* m) 1 f n = map (* n) r in concatMap f g -- | 'Maybe' exact ratios reconstructed from possibly inexact 'Cents' -- of 'Tuning'. -- -- > let r = [1,17/16,9/8,13/11,5/4,4/3,7/5,3/2,11/7,5/3,16/9,15/8] -- > in reconstructed_ratios 1e-2 werckmeister_iii == Just r reconstructed_ratios :: Double -> Tuning -> Maybe [Rational] reconstructed_ratios epsilon = fmap (map (reconstructed_ratio epsilon)) . T.fromRight . ratios_or_cents -- | Convert from a 'Floating' ratio to /cents/. -- -- > let r = [0,498,702,1200] -- > in map (round . fratio_to_cents) [1,4/3,3/2,2] == r fratio_to_cents :: (Real r,Floating n) => r -> n fratio_to_cents = (1200 *) . logBase 2 . realToFrac -- | Type specialised 'fratio_to_cents'. approximate_ratio_to_cents :: Approximate_Ratio -> Cents approximate_ratio_to_cents = fratio_to_cents -- | Type specialised 'fromRational'. approximate_ratio :: Rational -> Approximate_Ratio approximate_ratio = fromRational -- | 'approximate_ratio_to_cents' '.' 'approximate_ratio'. ratio_to_cents :: Rational -> Cents ratio_to_cents = approximate_ratio_to_cents . approximate_ratio -- | Construct an exact 'Rational' that approximates 'Cents' to within -- /epsilon/. -- -- > map (reconstructed_ratio 1e-5) [0,700,1200] == [1,442/295,2] -- -- > ratio_to_cents (442/295) == 699.9976981706734 reconstructed_ratio :: Double -> Cents -> Rational reconstructed_ratio epsilon c = approxRational (cents_to_ratio c) epsilon -- | Frequency /n/ cents from /f/. -- -- > import Music.Theory.Pitch -- > map (cps_shift_cents 440) [-100,100] == map octpc_to_cps [(4,8),(4,10)] cps_shift_cents :: Floating a => a -> a -> a cps_shift_cents f = (* f) . cents_to_ratio -- | Interval in /cents/ from /p/ to /q/, ie. 'ratio_to_cents' of /p/ -- '/' /q/. -- -- > cps_difference_cents 440 (octpc_to_cps (5,2)) == 500 -- -- > let abs_dif i j = abs (i - j) -- > in cps_difference_cents 440 (fmidi_to_cps 69.1) `abs_dif` 10 < 1e9 cps_difference_cents :: (Real r,Fractional r,Floating n) => r -> r -> n cps_difference_cents p q = fratio_to_cents (q / p) -- * Commas -- | The Syntonic comma. -- -- > syntonic_comma == 81/80 syntonic_comma :: Rational syntonic_comma = 81 % 80 -- | The Pythagorean comma. -- -- > pythagorean_comma == 3^12 / 2^19 pythagorean_comma :: Rational pythagorean_comma = 531441 / 524288 -- | Mercators comma. -- -- > mercators_comma == 3^53 / 2^84 mercators_comma :: Rational mercators_comma = 19383245667680019896796723 / 19342813113834066795298816 -- | Calculate /n/th root of /x/. -- -- > 12 `nth_root` 2 == twelve_tone_equal_temperament_comma nth_root :: (Floating a,Eq a) => a -> a -> a nth_root n x = let f (_,x0) = (x0, ((n-1)*x0+x/x0**(n-1))/n) e = uncurry (==) in fst (until e f (x, x/n)) -- | 12-tone equal temperament comma (ie. 12th root of 2). -- -- > twelve_tone_equal_temperament_comma == 1.0594630943592953 twelve_tone_equal_temperament_comma :: (Floating a,Eq a) => a twelve_tone_equal_temperament_comma = 12 `nth_root` 2 -- * Equal temperaments -- | Make /n/ division equal temperament. equal_temperament :: Integral n => n -> Tuning equal_temperament n = let c = genericTake n [0,1200 / fromIntegral n ..] in Tuning (Right c) 2 -- | 12-tone equal temperament. -- -- > cents equal_temperament_12 == [0,100..1100] equal_temperament_12 :: Tuning equal_temperament_12 = equal_temperament (12::Int) -- | 19-tone equal temperament. equal_temperament_19 :: Tuning equal_temperament_19 = equal_temperament (19::Int) -- | 31-tone equal temperament. equal_temperament_31 :: Tuning equal_temperament_31 = equal_temperament (31::Int) -- | 53-tone equal temperament. equal_temperament_53 :: Tuning equal_temperament_53 = equal_temperament (53::Int) -- | 72-tone equal temperament. -- -- > let r = [0,17,33,50,67,83,100] -- > in take 7 (map round (cents equal_temperament_72)) == r equal_temperament_72 :: Tuning equal_temperament_72 = equal_temperament (72::Int) -- * Harmonic series -- | Raise or lower the frequency /q/ by octaves until it is in the -- octave starting at /p/. -- -- > fold_cps_to_octave_of 55 392 == 98 fold_cps_to_octave_of :: (Ord a, Fractional a) => a -> a -> a fold_cps_to_octave_of p = let f q = if q > p * 2 then f (q / 2) else if q < p then f (q * 2) else q in f -- | Harmonic series on /n/. harmonic_series_cps :: (Num t, Enum t) => t -> [t] harmonic_series_cps n = [n,n * 2 ..] -- | /n/ elements of 'harmonic_series_cps'. -- -- > let r = [55,110,165,220,275,330,385,440,495,550,605,660,715,770,825,880,935] -- > in harmonic_series_cps_n 17 55 == r harmonic_series_cps_n :: (Num a, Enum a) => Int -> a -> [a] harmonic_series_cps_n n = take n . harmonic_series_cps -- | Sub-harmonic series on /n/. subharmonic_series_cps :: (Fractional t,Enum t) => t -> [t] subharmonic_series_cps n = map (* n) (map recip [1..]) -- | /n/ elements of 'harmonic_series_cps'. -- -- > let r = [1760,880,587,440,352,293,251,220,196,176,160,147,135,126,117,110,104] -- > in map round (subharmonic_series_cps_n 17 1760) == r subharmonic_series_cps_n :: (Fractional t,Enum t) => Int -> t -> [t] subharmonic_series_cps_n n = take n . subharmonic_series_cps -- | /n/th partial of /f1/, ie. one indexed. -- -- > map (partial 55) [1,5,3] == [55,275,165] partial :: (Num a, Enum a) => a -> Int -> a partial f1 k = harmonic_series_cps f1 `at` (k - 1) -- | Fold ratio until within an octave, ie. @1@ '<' /n/ '<=' @2@. -- -- > map fold_ratio_to_octave [2/3,3/4] == [4/3,3/2] fold_ratio_to_octave :: Integral i => Ratio i -> Ratio i fold_ratio_to_octave n = if n >= 2 then fold_ratio_to_octave (n / 2) else if n < 1 then fold_ratio_to_octave (n * 2) else n -- | The interval between two pitches /p/ and /q/ given as ratio -- multipliers of a fundamental is /q/ '/' /p/. The classes over such -- intervals consider the 'fold_ratio_to_octave' of both /p/ to /q/ -- and /q/ to /p/. -- -- > map ratio_interval_class [2/3,3/2,3/4,4/3] == [3/2,3/2,3/2,3/2] ratio_interval_class :: Integral i => Ratio i -> Ratio i ratio_interval_class i = let f = fold_ratio_to_octave in max (f i) (f (recip i)) -- | Derivative harmonic series, based on /k/th partial of /f1/. -- -- > import Music.Theory.Pitch -- -- > let {r = [52,103,155,206,258,309,361,412,464,515,567,618,670,721,773] -- > ;d = harmonic_series_cps_derived 5 (octpc_to_cps (1,4))} -- > in map round (take 15 d) == r harmonic_series_cps_derived :: (Ord a, Fractional a, Enum a) => Int -> a -> [a] harmonic_series_cps_derived k f1 = let f0 = fold_cps_to_octave_of f1 (partial f1 k) in harmonic_series_cps f0 -- | Harmonic series to /n/th harmonic (folded). -- -- > harmonic_series_folded 17 == [1,17/16,9/8,5/4,11/8,3/2,13/8,7/4,15/8] -- -- > let r = [0,105,204,386,551,702,841,969,1088] -- > in map (round . ratio_to_cents) (harmonic_series_folded 17) == r harmonic_series_folded :: Integer -> [Rational] harmonic_series_folded n = nub (sort (map fold_ratio_to_octave [1 .. n%1])) -- | 'ratio_to_cents' variant of 'harmonic_series_folded'. -- -- > map round (harmonic_series_folded_c 21) == [0,105,204,298,386,471,551,702,841,969,1088] harmonic_series_folded_c :: Integer -> [Cents] harmonic_series_folded_c = map ratio_to_cents . harmonic_series_folded -- | @12@-tone tuning of first @21@ elements of the harmonic series. -- -- > cents_i harmonic_series_folded_21 == [0,105,204,298,386,471,551,702,841,969,1088] -- > divisions harmonic_series_folded_21 == 11 harmonic_series_folded_21 :: Tuning harmonic_series_folded_21 = Tuning (Left (harmonic_series_folded 21)) 2 -- * Cents -- | Give cents difference from nearest 12ET tone. -- -- > let r = [50,-49,-2,0,2,49,50] -- > in map cents_et12_diff [650,651,698,700,702,749,750] == r cents_et12_diff :: Integral n => n -> n cents_et12_diff n = let m = n `mod` 100 in if m > 50 then m - 100 else m -- | Fractional form of 'cents_et12_diff'. fcents_et12_diff :: Real n => n -> n fcents_et12_diff n = let m = n `mod'` 100 in if m > 50 then m - 100 else m -- | The class of cents intervals has range @(0,600)@. -- -- > map cents_interval_class [50,1150,1250] == [50,50,50] -- -- > let r = concat [[0,50 .. 550],[600],[550,500 .. 0]] -- > in map cents_interval_class [1200,1250 .. 2400] == r cents_interval_class :: Integral a => a -> a cents_interval_class n = let n' = n `mod` 1200 in if n' > 600 then 1200 - n' else n' -- | Fractional form of 'cents_interval_class'. fcents_interval_class :: Real a => a -> a fcents_interval_class n = let n' = n `mod'` 1200 in if n' > 600 then 1200 - n' else n' -- | Always include the sign, elide @0@. cents_diff_pp :: (Num a, Ord a, Show a) => a -> String cents_diff_pp n = case compare n 0 of LT -> show n EQ -> "" GT -> '+' : show n -- | Given brackets, print cents difference. cents_diff_br :: (Num a, Ord a, Show a) => (String,String) -> a -> String cents_diff_br br = let f s = if null s then s else T.bracket_l br s in f . cents_diff_pp -- | 'cents_diff_br' with parentheses. -- -- > map cents_diff_text [-1,0,1] == ["(-1)","","(+1)"] cents_diff_text :: (Num a, Ord a, Show a) => a -> String cents_diff_text = cents_diff_br ("(",")") -- | 'cents_diff_br' with markdown superscript (@^@). cents_diff_md :: (Num a, Ord a, Show a) => a -> String cents_diff_md = cents_diff_br ("^","^") -- | 'cents_diff_br' with HTML superscript (@@). cents_diff_html :: (Num a, Ord a, Show a) => a -> String cents_diff_html = cents_diff_br ("","") -- * Midi -- | (/n/ -> /dt/). Function from midi note number /n/ to -- 'Midi_Detune' /dt/. The incoming note number is the key pressed, -- which may be distant from the note sounded. type Midi_Tuning_F = Int -> T.Midi_Detune -- | (t,c,k) where t=tuning (must have 12 divisions of octave), -- c=cents deviation (ie. constant detune offset), k=midi offset -- (ie. value to be added to incoming midi note number). type D12_Midi_Tuning = (Tuning,Cents,Int) -- | 'Midi_Tuning_F' for 'D12_Midi_Tuning'. -- -- > import Music.Theory.Tuning.Gann -- > let f = d12_midi_tuning_f (la_monte_young,-74.7,-3) -- > octpc_to_midi (-1,11) == 11 -- > map (round . midi_detune_to_cps . f) [62,63,69] == [293,298,440] d12_midi_tuning_f :: D12_Midi_Tuning -> Midi_Tuning_F d12_midi_tuning_f (t,c_diff,k) n = let (_,pc) = T.midi_to_octpc (n + k) dt = zipWith (-) (cents t) [0,100 .. 1200] in (n,(dt `at` pc) + c_diff) -- | (t,f0,k) where t=tuning, f0=fundamental frequency, k=midi note -- number for f0, n=gamut type CPS_Midi_Tuning = (Tuning,Double,Int,Int) -- | 'Midi_Tuning_F' for 'CPS_Midi_Tuning'. cps_midi_tuning_f :: CPS_Midi_Tuning -> Midi_Tuning_F cps_midi_tuning_f (t,f0,k,g) n = let r = approximate_ratios_cyclic t m = take g (map (T.cps_to_midi_detune . (* f0)) r) in m `at` (n - k) -- Local Variables: -- truncate-lines:t -- End: hmt-0.15/Music/Theory/Permutations.hs0000644000000000000000000001205112416136065016000 0ustar0000000000000000-- | Permutation functions. module Music.Theory.Permutations where import qualified Data.Permute as P {- permutation -} import Numeric (showHex) {- base -} import qualified Music.Theory.List as L -- | Factorial function. -- -- > (factorial 13,maxBound::Int) factorial :: (Ord a, Num a) => a -> a factorial n = if n <= 1 then 1 else n * factorial (n - 1) -- | Number of /k/ element permutations of a set of /n/ elements. -- -- > (nk_permutations 4 3,nk_permutations 13 3) == (24,1716) nk_permutations :: Integral a => a -> a -> a nk_permutations n k = factorial n `div` factorial (n - k) -- | Number of /nk/ permutations where /n/ '==' /k/. -- -- > map n_permutations [1..8] == [1,2,6,24,120,720,5040,40320] -- > n_permutations 16 `div` 1000000 == 20922789 n_permutations :: (Integral a) => a -> a n_permutations n = nk_permutations n n -- | 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 = L.elem_index_unique x p in P.listPermute n (map f q) -- | Apply permutation /f/ to /p/. -- -- > let p = permutation [1..4] [4,3,2,1] -- > in apply_permutation p [1..4] == [4,3,2,1] apply_permutation :: (Eq a) => P.Permute -> [a] -> [a] apply_permutation f p = map (p !!) (P.elems f) -- | 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 -- -- > let p = permutation [1..4] [4,3,2,1] -- > in non_invertible p == True && P.cycles p == [[0,3],[1,2]] non_invertible :: P.Permute -> Bool non_invertible p = p == P.inverse p -- | 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) -- | 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 q = permutation [1..4] [2,3,4,1] -- [[0,1,2,3]] (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)) -} hmt-0.15/Music/Theory/Key.hs0000644000000000000000000000207612416136065014044 0ustar0000000000000000-- | Common music keys. module Music.Theory.Key where import Data.List {- base -} import Music.Theory.Pitch import Music.Theory.Pitch.Name import Music.Theory.Pitch.Note import Music.Theory.Interval -- | Enumeration of common music notation modes. data Mode_T = Minor_Mode | Major_Mode deriving (Eq,Ord,Show) -- | 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' (Just ix) = case m of Major_Mode -> findIndex eq (cf c4) Minor_Mode -> findIndex eq (cf a4) in if ix < 13 then negate ix else ix - 12 hmt-0.15/Music/Theory/Interval.hs0000644000000000000000000002523712416136065015104 0ustar0000000000000000-- | Common music notation intervals. module Music.Theory.Interval where import Data.List {- base -} import Data.Maybe {- base -} import Music.Theory.Pitch import Music.Theory.Pitch.Note -- | Interval type or degree. data Interval_T = Unison | Second | Third | Fourth | Fifth | Sixth | Seventh deriving (Eq,Enum,Bounded,Ord,Show) -- | Interval quality. data Interval_Q = Diminished | Minor | Perfect | Major | Augmented deriving (Eq,Enum,Bounded,Ord,Show) -- | Common music notation interval. An 'Ordering' of 'LT' indicates -- an ascending interval, 'GT' a descending interval, and 'EQ' a -- unison. data Interval = Interval {interval_type :: Interval_T ,interval_quality :: Interval_Q ,interval_direction :: Ordering ,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) -- | Table of interval qualities. For each 'Interval_T' gives -- directed semitone interval counts for each allowable 'Interval_Q'. -- For lookup function see 'interval_q', for reverse lookup see -- 'interval_q_reverse'. interval_q_tbl :: Integral n => [(Interval_T, [(n,Interval_Q)])] interval_q_tbl = [(Unison,[(11,Diminished) ,(0,Perfect) ,(1,Augmented)]) ,(Second,[(0,Diminished) ,(1,Minor) ,(2,Major) ,(3,Augmented)]) ,(Third,[(2,Diminished) ,(3,Minor) ,(4,Major) ,(5,Augmented)]) ,(Fourth,[(4,Diminished) ,(5,Perfect) ,(6,Augmented)]) ,(Fifth,[(6,Diminished) ,(7,Perfect) ,(8,Augmented)]) ,(Sixth,[(7,Diminished) ,(8,Minor) ,(9,Major) ,(10,Augmented)]) ,(Seventh,[(9,Diminished) ,(10,Minor) ,(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 = lookup i interval_q_tbl >>= lookup n -- | Lookup semitone difference of 'Interval_T' with 'Interval_Q'. -- -- > interval_q_reverse Third Minor == Just 3 -- > interval_q_reverse Unison Diminished == Just 11 interval_q_reverse :: Interval_T -> Interval_Q -> Maybe Int interval_q_reverse ty qu = case lookup ty interval_q_tbl of Nothing -> Nothing Just tbl -> fmap fst (find ((== qu) . snd) tbl) -- | Semitone difference of 'Interval'. -- -- > interval_semitones (interval (Pitch C Sharp 4) (Pitch E Sharp 5)) == 16 -- > interval_semitones (interval (Pitch C Natural 4) (Pitch D Sharp 3)) == -9 interval_semitones :: Interval -> Int interval_semitones (Interval ty qu dir oct) = case interval_q_reverse ty qu of Just n -> let o = 12 * oct in if dir == GT then negate n - o else n + o Nothing -> error "interval_semitones" -- | Inclusive set of 'Note_T' within indicated interval. This is not -- equal to 'enumFromTo' which is not circular. -- -- > 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) n1' = fromEnum n1 n2' = fromEnum n2 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 LT -> GT EQ -> EQ GT -> LT -- | 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 (Pitch n1 _ o1) = p1 (Pitch n2 _ o2) = p2 p1' = pitch_to_pc p1 p2' = pitch_to_pc p2 st = (p2' - p1') `mod` 12 ty = interval_ty n1 n2 (Just qu) = interval_q ty (fromIntegral st) o_a = if n1 > n2 then -1 else 0 in case c of 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 -- | 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 else case (x,y) of (Diminished,Minor) -> Just 1 (Diminished,Major) -> Just 2 (Diminished,Augmented) -> Just 3 (Minor,Major) -> Just 1 (Minor,Augmented) -> Just 2 (Major,Augmented) -> Just 1 (Diminished,Perfect) -> Just 1 (Perfect,Augmented) -> Just 1 _ -> Nothing fwd = rule (a,b) rvs = rule (b,a) in case fwd of Just n -> Just n Nothing -> case rvs of 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 pitch_transpose :: Interval -> Pitch -> Pitch pitch_transpose i ip = let (Pitch p_n p_a p_o) = ip (Interval i_t i_q i_d i_o) = i i_d' = if i_d == GT then -1 else 1 p_n' = toEnum ((fromEnum p_n + (fromEnum i_t * i_d')) `mod` 7) -- oa = octave alteration oa = if p_n' > p_n && i_d == GT then -1 else if p_n' < p_n && i_d == LT then 1 else 0 ip' = Pitch p_n' p_a (p_o + i_o + oa) st = if i_d == GT then (pitch_to_pc ip - pitch_to_pc ip') `mod` 12 else (pitch_to_pc ip' - pitch_to_pc ip) `mod` 12 ty = if i_d == GT then interval_ty p_n' p_n else interval_ty p_n p_n' 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 p5 = Interval Fifth Perfect LT 0 mk y = take 12 (iterate (pitch_transpose y) x) in (mk p4,mk p5) -- | Parse a positive integer into interval type and octave -- displacement. -- -- > mapMaybe parse_interval_type (map show [1 .. 15]) parse_interval_type :: String -> Maybe (Interval_T,Octave) parse_interval_type n = case reads n of [(n',[])] -> if n' == 0 then Nothing else let (o,t) = (n' - 1) `divMod` 7 in Just (toEnum t,fromIntegral o) _ -> Nothing -- | Parse interval quality notation. -- -- > mapMaybe parse_interval_quality "dmPMA" == [minBound .. maxBound] parse_interval_quality :: Char -> Maybe Interval_Q parse_interval_quality q = let c = zip "dmPMA" [0..] in fmap toEnum (lookup q c) -- | Degree of interval type and octave displacement. Inverse of -- 'parse_interval_type'. -- -- > map interval_type_degree [(Third,0),(Second,1),(Unison,2)] == [3,9,15] interval_type_degree :: (Interval_T,Octave) -> Int interval_type_degree (t,o) = fromEnum t + 1 + (fromIntegral o * 7) -- | Inverse of 'parse_interval_quality. interval_quality_pp :: Interval_Q -> Char interval_quality_pp q = "dmPMA" !! fromEnum q -- | Parse standard common music interval notation. -- -- > let i = mapMaybe parse_interval (words "P1 d2 m2 M2 A3 P8 +M9 -M2") -- > in unwords (map interval_pp i) == "P1 d2 m2 M2 A3 P8 M9 -M2" -- -- > mapMaybe (fmap interval_octave . parse_interval) (words "d1 d8 d15") == [-1,0,1] parse_interval :: String -> Maybe Interval parse_interval i = let unisons = [(Perfect,Unison) ,(Diminished,Second) ,(Augmented,Seventh)] f q n = case (parse_interval_quality q,parse_interval_type n) of (Just q',Just (n',o)) -> let o' = if (q',n') == (Diminished,Unison) then o - 1 else o d = if o' == 0 && (q',n') `elem` unisons then EQ else LT in Just (Interval n' q' d o') _ -> Nothing in case i of '-':q:n -> fmap invert_interval (f q n) '+':q:n -> f q n q:n -> f q n _ -> Nothing -- | Pretty printer for intervals, inverse of 'parse_interval'. interval_pp :: Interval -> String interval_pp (Interval n q d o) = let d' = if d == GT then ('-' :) else id in d' (interval_quality_pp q : show (interval_type_degree (n,o))) -- | Standard names for the intervals within the octave, divided into -- perfect, major and minor at the left, and diminished and augmented -- at the right. -- -- > let {bimap f (p,q) = (f p,f q) -- > ;f = mapMaybe (fmap interval_semitones . parse_interval)} -- > in bimap f std_interval_names std_interval_names :: ([String],[String]) std_interval_names = let pmM = "P1 m2 M2 m3 M3 P4 P5 m6 M6 m7 M7 P8" dA = "d2 A1 d3 A2 d4 A3 d5 A4 d6 A5 d7 A6 d8 A7" in (words pmM,words dA) hmt-0.15/Music/Theory/Math.hs0000644000000000000000000000622512416136065014205 0ustar0000000000000000-- | Math functions. module Music.Theory.Math where import Data.Maybe {- base -} import Data.Ratio {- base -} import Numeric {- base -} -- | Real (alias for 'Double'). type R = Double -- | integral_and_fractional_parts :: (Integral i, RealFrac t) => t -> (i,t) integral_and_fractional_parts n = if n >= 0 then let n' = floor n in (n',n - fromIntegral n') else let n' = ceiling n in (n',n - fromIntegral n') -- | Type specialised. integer_and_fractional_parts :: RealFrac t => t -> (Integer,t) integer_and_fractional_parts = integral_and_fractional_parts -- | -- -- > import Sound.SC3.Plot {- hsc3-plot -} -- > plotTable1 (map fractional_part [-2.0,-1.99 .. 2.0]) fractional_part :: RealFrac a => a -> a fractional_part = snd . integer_and_fractional_parts -- | -- -- > plotTable1 (map sawtooth_wave [-2.0,-1.99 .. 2.0]) sawtooth_wave :: RealFrac a => a -> a sawtooth_wave n = n - fromInteger (floor n) -- | Pretty printer for 'Rational' that elides denominators of @1@. -- -- > map rational_pp [1,3/2,2] == ["1","3/2","2"] rational_pp :: (Show a,Integral a) => Ratio a -> String rational_pp r = let n = numerator r d = denominator r in if d == 1 then show n else concat [show n,"/",show d] -- | Pretty print ratio as @:@ separated integers. -- -- > map ratio_pp [1,3/2,2] == ["1:1","3:2","2:1"] ratio_pp :: Rational -> String ratio_pp r = let (n,d) = rational_nd r in concat [show n,":",show d] -- | Predicate that is true if @n/d@ can be simplified, ie. where -- 'gcd' of @n@ and @d@ is not @1@. -- -- > let r = [False,True,False] -- > in map rational_simplifies [(2,3),(4,6),(5,7)] == r rational_simplifies :: Integral a => (a,a) -> Bool rational_simplifies (n,d) = gcd n d /= 1 -- | 'numerator' and 'denominator' of rational. rational_nd :: Integral t => Ratio t -> (t,t) rational_nd r = (numerator r,denominator r) -- | Rational as a whole number, or 'Nothing'. rational_whole :: Integral a => Ratio a -> Maybe a rational_whole r = if denominator r == 1 then Just (numerator r) else Nothing -- | Erroring variant. rational_whole_err :: Integral a => Ratio a -> a rational_whole_err = fromMaybe (error "rational_whole") . rational_whole -- | Variant of 'showFFloat'. The 'Show' instance for floats resorts -- to exponential notation very readily. -- -- > [show 0.01,realfloat_pp 2 0.01] == ["1.0e-2","0.01"] realfloat_pp :: RealFloat a => Int -> a -> String realfloat_pp k n = showFFloat (Just k) n "" -- | Type specialised 'realfloat_pp'. float_pp :: Int -> Float -> String float_pp = realfloat_pp -- | Type specialised 'realfloat_pp'. double_pp :: Int -> Double -> String double_pp = realfloat_pp -- | Show /only/ positive and negative values, always with sign. -- -- > map num_diff_str [-2,-1,0,1,2] == ["-2","-1","","+1","+2"] -- > map show [-2,-1,0,1,2] == ["-2","-1","0","1","2"] num_diff_str :: (Num a, Ord a, Show a) => a -> String num_diff_str n = case compare n 0 of LT -> '-' : show (abs n) EQ -> "" GT -> '+' : show n hmt-0.15/Music/Theory/Tempo_Marking.hs0000644000000000000000000000517512416136065016053 0ustar0000000000000000-- | Common music notation tempo indications. module Music.Theory.Tempo_Marking where import Data.List {- base -} import Music.Theory.Duration import Music.Theory.Duration.RQ import Music.Theory.Time_Signature -- | A tempo marking is in terms of a common music notation 'Duration'. type Tempo_Marking = (Duration,Rational) -- | Duration of a RQ value, in seconds, given indicated tempo. -- -- > rq_to_seconds (quarter_note,90) 1 == 60/90 rq_to_seconds :: Tempo_Marking -> RQ -> Rational rq_to_seconds (d,n) x = let d' = duration_to_rq d s = 60 / n in (x * s) / d' -- | The duration, in seconds, of a pulse at the indicated time -- signature and tempo marking. -- -- > import Music.Theory.Duration.Name -- > pulse_duration (6,8) (quarter_note,60) == 1/2 pulse_duration :: Time_Signature -> Tempo_Marking -> Rational pulse_duration t (x,i) = let j = recip (ts_duration_pulses t x) s = 60 / i in j * s -- | The duration, in seconds, of a measure at the indicated time -- signaure and tempo marking. -- -- > measure_duration (3,4) (quarter_note,90) == 2 -- > measure_duration (6,8) (quarter_note,120) == 3/2 measure_duration :: Time_Signature -> Tempo_Marking -> Rational measure_duration (n,d) t = pulse_duration (n,d) t * fromIntegral n -- | 'Fractional' variant of 'measure_duration'. measure_duration_f :: Fractional c => Time_Signature -> Tempo_Marking -> c measure_duration_f ts = fromRational . measure_duration ts -- | Italian terms and markings from Wittner metronome (W.-Germany). -- metronome_table_wittner :: Num n => [(String,(n,n))] metronome_table_wittner = [("Largo",(40,60)) ,("Larghetto",(60,66)) ,("Adagio",(66,76)) ,("Andante",(76,108)) ,("Moderato",(108,120)) ,("Allegro",(120,168)) ,("Presto",(168,208))] -- | Italian terms and markings from Nikko Seiki metronome (Japan). -- metronome_table_nikko :: Num n => [(String,(n,n))] metronome_table_nikko = [("Grave",(40,46)) ,("Largo",(46,52)) ,("Lento",(52,56)) ,("Adagio",(56,60)) ,("Larghetto",(60,66)) ,("Adagietto",(66,72)) ,("Andante",(72,80)) ,("Andantino",(80,88)) ,("Maestoso",(88,96)) ,("Moderato",(96,108)) ,("Allegretto",(108,120)) ,("Animato",(120,132)) ,("Allegro",(132,144)) ,("Assai",(144,160)) ,("Vivace",(160,184)) ,("Presto",(184,208)) ,("Prestissimo",(208,240))] -- | Lookup metronome mark in table. -- -- > mm_name metronome_table_nikko 72 == Just "Andante" mm_name :: (Num a, Ord a) => [(String,(a,a))] -> a -> Maybe String mm_name tbl x = let f (_,(p,q)) = x >= p && x < q in fmap fst (find f tbl) hmt-0.15/Music/Theory/Time_Signature.hs0000644000000000000000000001415212416136065016231 0ustar0000000000000000-- | Time Signatures. module Music.Theory.Time_Signature where import Data.Ratio {- base -} import Music.Theory.Duration import Music.Theory.Duration.Name import Music.Theory.Duration.RQ import Music.Theory.Math -- | A Time Signature is a /(numerator,denominator)/ pair. type Time_Signature = (Integer,Integer) -- | Tied, non-multiplied durations to fill a whole measure. -- -- > ts_whole_note (3,8) == [dotted_quarter_note] -- > ts_whole_note (2,2) == [whole_note] ts_whole_note :: Time_Signature -> [Duration] ts_whole_note t = case t of (1,8) -> [eighth_note] (2,16) -> [eighth_note] (3,16) -> [dotted_eighth_note] (1,4) -> [quarter_note] (2,8) -> [quarter_note] (4,16) -> [quarter_note] (5,16) -> [quarter_note,sixteenth_note] (3,8) -> [dotted_quarter_note] (6,16) -> [dotted_quarter_note] (7,16) -> [quarter_note,dotted_eighth_note] (1,2) -> [half_note] (2,4) -> [half_note] (4,8) -> [half_note] (5,8) -> [half_note,eighth_note] (3,4) -> [dotted_half_note] (6,8) -> [dotted_half_note] (1,1) -> [whole_note] (2,2) -> [whole_note] (4,4) -> [whole_note] (5,4) -> [whole_note,quarter_note] (3,2) -> [dotted_whole_note] (6,4) -> [dotted_whole_note] (7,4) -> [whole_note,dotted_half_note] (2,1) -> [breve] (4,2) -> [breve] (3,1) -> [dotted_breve] (6,2) -> [dotted_breve] _ -> error ("ts_whole_note: " ++ show t) -- | Duration of measure in 'RQ'. -- -- > map ts_whole_note_rq [(3,8),(2,2)] == [3/2,4] ts_whole_note_rq :: Time_Signature -> RQ ts_whole_note_rq = sum . map duration_to_rq . ts_whole_note -- | Duration, in 'RQ', of a measure of indicated 'Time_Signature'. -- -- > map ts_rq [(3,4),(5,8)] == [3,5/2] ts_rq :: Time_Signature -> RQ ts_rq (n,d) = (4 * n) % d -- | 'Time_Signature' derived from whole note duration in 'RQ' form. -- -- > map rq_to_ts [4,3/2,7/4,6] == [(4,4),(3,8),(7,16),(6,4)] rq_to_ts :: Rational -> Time_Signature rq_to_ts rq = let n = numerator rq d = denominator rq * 4 in (n,d) -- | Uniform division of time signature. -- -- > ts_divisions (3,4) == [1,1,1] -- > ts_divisions (3,8) == [1/2,1/2,1/2] -- > ts_divisions (2,2) == [2,2] -- > ts_divisions (1,1) == [4] ts_divisions :: Time_Signature -> [RQ] ts_divisions (i,j) = let k = fromIntegral i in replicate k (recip (j % 4)) -- | Convert a duration to a pulse count in relation to the indicated -- time signature. -- -- > ts_duration_pulses (3,8) quarter_note == 2 ts_duration_pulses :: Time_Signature -> Duration -> Rational ts_duration_pulses (_, b) (Duration dv dt ml) = let n = b % dv in rq_apply_dots n dt * ml -- | Rewrite time signature to indicated denominator. -- -- > ts_rewrite 8 (3,4) == (6,8) ts_rewrite :: Integer -> Time_Signature -> Time_Signature ts_rewrite d' = let dv i j = let (x,y) = i `divMod` j in if y == 0 then x else error "ts_rewrite" go (n,d) = case compare d d' of EQ -> (n,d) GT -> go (n `dv` 2, d `dv` 2) LT -> go (n * 2, d * 2) in go -- | Sum time signatures. -- -- > ts_sum [(3,16),(1,2)] == (11,16) ts_sum :: [Time_Signature] -> Time_Signature ts_sum t = let i = maximum (map snd t) t' = map (ts_rewrite i) t j = sum (map fst t') in (j,i) -- * Composite Time Signatures -- | A composite time signature is a sequence of 'Time_Signature's. type Composite_Time_Signature = [Time_Signature] -- | The 'RQ' is the 'sum' of 'ts_rq' of the elements. -- -- > cts_rq [(3,4),(1,8)] == 3 + 1/2 cts_rq :: Composite_Time_Signature -> RQ cts_rq = sum . map ts_rq -- | The divisions are the 'concat' of the 'ts_divisions' of the -- elements. -- -- > cts_divisions [(3,4),(1,8)] == [1,1,1,1/2] cts_divisions :: Composite_Time_Signature -> [RQ] cts_divisions = concatMap ts_divisions -- | Pulses are 1-indexed, RQ locations are 0-indexed. -- -- > map (cts_pulse_to_rq [(2,4),(1,8),(1,4)]) [1 .. 4] == [0,1,2,2 + 1/2] cts_pulse_to_rq :: Composite_Time_Signature -> Int -> RQ cts_pulse_to_rq cts p = let dv = cts_divisions cts in sum (take (p - 1) dv) -- | Variant that gives the /window/ of the pulse (ie. the start -- location and the duration). -- -- > let r = [(0,1),(1,1),(2,1/2),(2 + 1/2,1)] -- > in map (cts_pulse_to_rqw [(2,4),(1,8),(1,4)]) [1 .. 4] == r cts_pulse_to_rqw :: Composite_Time_Signature -> Int -> (RQ,RQ) cts_pulse_to_rqw cts p = (cts_pulse_to_rq cts p,cts_divisions cts !! (p - 1)) -- * Rational Time Signatures -- | A rational time signature is a 'Composite_Time_Signature' where -- the parts are 'Rational'. type Rational_Time_Signature = [(Rational,Rational)] -- | The 'sum' of the RQ of the elements. -- -- > rts_rq [(3,4),(1,8)] == 3 + 1/2 -- > rts_rq [(3/2,4),(1/2,8)] == 3/2 + 1/4 rts_rq :: Rational_Time_Signature -> RQ rts_rq = let f (n,d) = (4 * n) / d in sum . map f -- | The /divisions/ of the elements. -- -- > rts_divisions [(3,4),(1,8)] == [1,1,1,1/2] -- > rts_divisions [(3/2,4),(1/2,8)] == [1,1/2,1/4] rts_divisions :: Rational_Time_Signature -> [[RQ]] rts_divisions = let f (n,d) = let (ni,nf) = integral_and_fractional_parts n rq = recip (d / 4) ip = replicate ni rq in if nf == 0 then ip else ip ++ [nf * rq] in map f -- > rts_derive [1,1,1,1/2] -- > rts_derive [1,1/2,1/4] rts_derive :: [RQ] -> Rational_Time_Signature rts_derive = let f rq = (rq,4) in map f -- | Pulses are 1-indexed, RQ locations are 0-indexed. -- -- > map (rts_pulse_to_rq [(2,4),(1,8),(1,4)]) [1 .. 4] == [0,1,2,2 + 1/2] -- > map (rts_pulse_to_rq [(3/2,4),(1/2,8),(1/4,4)]) [1 .. 4] == [0,1,3/2,7/4] rts_pulse_to_rq :: Rational_Time_Signature -> Int -> RQ rts_pulse_to_rq rts p = let dv = concat (rts_divisions rts) in sum (take (p - 1) dv) -- | Variant that gives the /window/ of the pulse (ie. the start -- location and the duration). -- -- > let r = [(0,1),(1,1),(2,1/2),(2 + 1/2,1)] -- > in map (rts_pulse_to_rqw [(2,4),(1,8),(1,4)]) [1 .. 4] == r rts_pulse_to_rqw :: Rational_Time_Signature -> Int -> (RQ,RQ) rts_pulse_to_rqw ts p = (rts_pulse_to_rq ts p,concat (rts_divisions ts) !! (p - 1)) hmt-0.15/Music/Theory/Combinations.hs0000644000000000000000000000126712416136065015742 0ustar0000000000000000-- | Combination functions. module Music.Theory.Combinations where import Music.Theory.Permutations -- | Number of /k/ element combinations of a set of /n/ elements. -- -- > (nk_combinations 6 3,nk_combinations 13 3) == (20,286) nk_combinations :: Integral a => a -> a -> a nk_combinations n k = nk_permutations n k `div` factorial k -- | /k/ element subsets of /s/. -- -- > combinations 3 [1..4] == [[1,2,3],[1,2,4],[1,3,4],[2,3,4]] -- > length (combinations 3 [1..5]) == nk_combinations 5 3 combinations :: Integral t => t -> [a] -> [[a]] combinations k s = case (k,s) of (0,_) -> [[]] (_,[]) -> [] (_,e:s') -> map (e :) (combinations (k - 1) s') ++ combinations k s' hmt-0.15/Music/Theory/Instrument/0000755000000000000000000000000012416136065015123 5ustar0000000000000000hmt-0.15/Music/Theory/Instrument/Choir.hs0000644000000000000000000000755012416136065016532 0ustar0000000000000000module Music.Theory.Instrument.Choir where import Data.List.Split {- split -} import Data.Maybe {- base -} import qualified Music.Theory.Clef as T {- hmt -} import qualified Music.Theory.Pitch as T {- hmt -} import qualified Music.Theory.Pitch.Name as T {- hmt -} -- | Voice types. data Voice = Bass | Tenor | Alto | Soprano deriving (Eq,Ord,Enum,Bounded,Show) -- | Single character abbreviation for 'Voice'. voice_abbrev :: Voice -> Char voice_abbrev = head . show -- | Standard 'Clef' for 'Voice'. voice_clef :: Integral i => Voice -> T.Clef i voice_clef v = case v of Bass -> T.Clef T.Bass 0 Tenor -> T.Clef T.Treble (-1) Alto -> T.Clef T.Treble 0 Soprano -> T.Clef T.Treble 0 -- | Table giving ranges for 'Voice's. type Voice_Rng_Tbl = [(Voice,(T.Pitch,T.Pitch))] -- | More or less standard choir ranges, /inclusive/. voice_rng_tbl_std :: Voice_Rng_Tbl voice_rng_tbl_std = [(Bass,(T.d2,T.c4)) ,(Tenor,(T.c3,T.a4)) ,(Alto,(T.f3,T.f5)) ,(Soprano,(T.c4,T.a5))] -- | More conservative ranges, /inclusive/. voice_rng_tbl_safe :: Voice_Rng_Tbl voice_rng_tbl_safe = [(Bass,(T.g2,T.c4)) ,(Tenor,(T.c3,T.f4)) ,(Alto,(T.g3,T.c5)) ,(Soprano,(T.c4,T.f5))] -- | Erroring variant. lookup_err :: Eq a => a -> [(a,b)] -> b lookup_err e = fromMaybe (error "lookup_err") . lookup e -- | Lookup voice range table. voice_rng :: Voice_Rng_Tbl -> Voice -> (T.Pitch,T.Pitch) voice_rng tbl v = lookup_err v tbl -- | Lookup 'voice_rng_tbl_std'. voice_rng_std :: Voice -> (T.Pitch,T.Pitch) voice_rng_std = voice_rng voice_rng_tbl_std -- | Lookup 'voice_rng_tbl_safe'. voice_rng_safe :: Voice -> (T.Pitch,T.Pitch) voice_rng_safe = voice_rng voice_rng_tbl_safe -- | Is /p/ '>=' /l/ and '<=' /r/. in_range_inclusive :: Ord a => a -> (a,a) -> Bool in_range_inclusive p (l,r) = p >= l && p <= r -- | Is /p/ in range for /v/, (/std/ & /safe/). -- -- > map (in_voice_rng T.c4) [Bass .. Soprano] in_voice_rng :: T.Pitch -> Voice -> (Bool,Bool) in_voice_rng p v = (in_range_inclusive p (voice_rng_std v) ,in_range_inclusive p (voice_rng_safe v)) -- | Given /tbl/ list 'Voice's that can sing 'T.Pitch'. possible_voices :: Voice_Rng_Tbl -> T.Pitch -> [Voice] possible_voices tbl p = let f = in_range_inclusive p . voice_rng tbl in filter f [Bass .. Soprano] -- | /std/ variant. possible_voices_std :: T.Pitch -> [Voice] possible_voices_std = possible_voices voice_rng_tbl_std -- | /safe/ variant. possible_voices_safe :: T.Pitch -> [Voice] possible_voices_safe = possible_voices voice_rng_tbl_safe -- | Enumeration of SATB voices. satb :: [Voice] satb = [Soprano,Alto,Tenor,Bass] -- | Names of 'satb'. satb_name :: [String] satb_name = map show satb -- | 'voice_abbrev' of 'satb' as 'String's. satb_abbrev :: [String] satb_abbrev = map (return . voice_abbrev) satb -- | Voice & part number. type Part = (Voice,Int) -- | /k/ part choir, ordered by voice. ch_satb_seq :: Int -> [Part] ch_satb_seq k = [(vc,n) | vc <- satb, n <- [1..k]] -- | 'ch_satb_seq' grouped in parts. -- -- > map (map part_nm) (ch_parts 8) ch_parts :: Int -> [[Part]] ch_parts k = chunksOf k (ch_satb_seq k) -- | Abreviated name for part. -- -- > part_nm (Soprano,1) == "S1" part_nm :: Part -> String part_nm (v,n) = voice_abbrev v : show n -- | /k/ SATB choirs, grouped by choir. -- -- > k_ch_groups 2 k_ch_groups :: Int -> [[Part]] k_ch_groups k = let f n = map (\p -> (p,n)) satb in map f [1 .. k] -- | 'concat' of 'k_ch_groups'. k_ch_groups' :: Int -> [Part] k_ch_groups' = concat . k_ch_groups -- | Two /k/ part SATB choirs in score order. -- -- > map part_nm (concat (dbl_ch_parts 8)) dbl_ch_parts :: Int -> [[Part]] dbl_ch_parts k = let v = satb f p = map (\n -> (p,n)) g = zipWith f v . replicate 4 in concatMap g (chunksOf (k `div` 2) [1 .. k]) -- | 'voice_clef' for 'Part's. mk_clef_seq :: [Part] -> [T.Clef Int] mk_clef_seq = map (voice_clef . fst) hmt-0.15/Music/Theory/Contour/0000755000000000000000000000000012416136065014404 5ustar0000000000000000hmt-0.15/Music/Theory/Contour/Polansky_1992.hs0000644000000000000000000004200612416136065017226 0ustar0000000000000000-- | 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 import Data.List {- base -} import Data.List.Split {- split -} import qualified Data.Map as M {- containers -} import Data.Maybe {- base -} import Data.Ratio {- base -} import qualified Music.Theory.Set.List as T import qualified Music.Theory.Permutations.List as T -- * List functions -- | Replace the /i/th value at /ns/ with /x/. -- -- > replace "test" 2 'n' == "tent" replace :: Integral i => [a] -> i -> a -> [a] replace ns i x = let f j y = if i == j then x else y in zipWith f [0..] ns -- | Are all elements equal. -- -- > all_equal "aaa" == True all_equal :: Eq a => [a] -> Bool all_equal xs = all id (zipWith (==) xs (tail xs)) -- * Indices -- | Compare adjacent elements (p.262) left to right. -- -- > compare_adjacent [0,1,3,2] == [LT,LT,GT] compare_adjacent :: Ord a => [a] -> [Ordering] compare_adjacent xs = zipWith compare xs (tail xs) -- | Construct set of /n/ '-' @1@ adjacent indices, left right order. -- -- > adjacent_indices 5 == [(0,1),(1,2),(2,3),(3,4)] adjacent_indices :: Integral i => i -> [(i,i)] adjacent_indices n = zip [0..n-2] [1..n-1] -- | All /(i,j)/ indices, in half matrix order. -- -- > all_indices 4 == [(0,1),(0,2),(0,3),(1,2),(1,3),(2,3)] all_indices :: Integral i => i -> [(i,i)] all_indices n = let n' = n - 1 in [(i,j) | i <- [0 .. n'], j <- [i + 1 .. n']] -- * 'Enum' functions -- | Generic variant of 'fromEnum' (p.263). genericFromEnum :: (Integral i,Enum e) => e -> i genericFromEnum = fromIntegral . fromEnum -- | Generic variant of 'toEnum' (p.263). genericToEnum :: (Integral i,Enum e) => i -> e genericToEnum = toEnum . fromIntegral -- * 'Ordering' functions -- | Specialised 'genericFromEnum'. ord_to_int :: Integral a => Ordering -> a ord_to_int = genericFromEnum -- | Specialised 'genericToEnum'. int_to_ord :: Integral a => a -> Ordering int_to_ord = genericToEnum -- | Invert 'Ordering'. -- -- > map ord_invert [LT,EQ,GT] == [GT,EQ,LT] ord_invert :: Ordering -> Ordering ord_invert x = case x of LT -> GT EQ -> EQ GT -> LT -- * Matrix -- | A list notation for matrices. type Matrix a = [[a]] -- | 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 (f x) xs h xs = map (\x -> (x,xs)) xs in map g . h -- | 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 -- * Half matrix -- | 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' 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 zipWith drop [1..] m -- | 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 unwords hm' instance Show Contour_Half_Matrix where show = contour_half_matrix_str -- * Contour description -- | /Description/ notation of contour. data Contour_Description = Contour_Description {contour_description_n :: Int ,contour_description_m :: M.Map (Int,Int) Ordering} deriving (Eq) -- | Construct 'Contour_Description' of contour (p.264). -- -- > let c = [[3,2,4,1],[3,2,1,4]] -- > in map (show.contour_description) c == ["202 02 2","220 20 0"] contour_description :: Ord a => [a] -> Contour_Description contour_description x = let n = length x ix = all_indices n o = zip ix (map (\(i,j) -> compare (x !! i) (x !! j)) ix) in Contour_Description n (M.fromList o) -- | '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 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/. -- -- > 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 -- | 'True' if contour is all descending, equal or ascending. -- -- > let c = ["abc","bbb","cba"] -- > in map (uniform.contour_description) c == [True,True,True] uniform :: Contour_Description -> Bool uniform (Contour_Description _ m) = all_equal (M.elems m) -- | 'True' if contour does not containt any 'EQ' elements. -- -- > let c = ["abc","bbb","cba"] -- > map (no_equalities.contour_description) c == [True,False,True] no_equalities :: Contour_Description -> Bool no_equalities (Contour_Description _ m) = EQ `notElem` M.elems m -- | 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 ix = all_indices n cs = filter (not.null) (T.powerset [LT,EQ,GT]) pf = concatMap T.multiset_permutations . T.expand_set n' mk p = Contour_Description n (M.fromList (zip ix p)) in map mk (concatMap pf cs) -- | A sequence of orderings /(i,j)/ and /(j,k)/ may imply ordering -- for /(i,k)/. -- -- > map implication [(LT,EQ),(EQ,EQ),(EQ,GT)] == [Just LT,Just EQ,Just GT] implication :: (Ordering,Ordering) -> Maybe Ordering implication (i,j) = case (min i j,max i j) of (LT,LT) -> Just LT (LT,EQ) -> Just LT (LT,GT) -> Nothing (EQ,EQ) -> Just EQ (EQ,GT) -> Just GT (GT,GT) -> Just GT _ -> error "implication" -- | List of all violations at a 'Contour_Description' (p.266). violations :: Contour_Description -> [(Int,Int,Int,Ordering)] violations d = let n = contour_description_n d - 1 ms = [(i,j,k) | i <- [0..n], j <- [i + 1 .. n], k <- [j + 1 .. n]] ix = contour_description_ix d complies (i,j,k) = let l = ix (i,j) r = ix (j,k) b = ix (i,k) in case implication (l,r) of Nothing -> Nothing Just x -> if x == b then Nothing else Just (i,j,k,x) in mapMaybe complies ms -- | Is the number of 'violations' zero. is_possible :: Contour_Description -> Bool is_possible = null . violations -- | 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 -- -- > map (length.impossible_contours) [3,4,5] == [14,654,58508] impossible_contours :: Int -> [Contour_Description] impossible_contours = filter (not.is_possible) . all_contours -- | Calculate number of contours of indicated degree (p.263). -- -- > map contour_description_lm [2..7] == [1,3,6,10,15,21] -- -- > let r = [3,27,729,59049,14348907] -- > in map (\n -> 3 ^ n) (map contour_description_lm [2..6]) == r contour_description_lm :: Integral a => a -> a contour_description_lm l = (l * l - l) `div` 2 -- | Truncate a 'Contour_Description' to have at most /n/ elements. -- -- > let c = contour_description [3,2,4,1] -- > in contour_truncate c 3 == contour_description [3,2,4] contour_truncate :: Contour_Description -> Int -> Contour_Description contour_truncate (Contour_Description n m) z = let n' = min n z f (i,j) _ = i < n' && j < n' in Contour_Description n' (M.filterWithKey f m) -- | Is 'Contour_Description' /p/ a prefix of /q/. -- -- > let {c = contour_description [3,2,4,1] -- > ;d = contour_description [3,2,4]} -- > in d `contour_is_prefix_of` c == True contour_is_prefix_of :: Contour_Description -> Contour_Description -> Bool contour_is_prefix_of p q = p == contour_truncate q (contour_description_n p) -- | Are 'Contour_Description's /p/ and /q/ equal at column /n/. -- -- > let {c = contour_description [3,2,4,1,5] -- > ;d = contour_description [3,2,4,1]} -- > in map (contour_eq_at c d) [0..4] == [True,True,True,True,False] contour_eq_at :: Contour_Description -> Contour_Description -> Int -> Bool contour_eq_at p q n = let a = contour_description_m p b = contour_description_m q f (_,j) _ = j == n g = M.toAscList . M.filterWithKey f in g a == g b -- * Contour drawing -- | Derive an 'Integral' contour that would be described by -- 'Contour_Description'. Diverges for impossible contours. -- -- > 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 ix = all_indices n normalise :: Integral i => [Rational] -> [i] normalise xs = let xs' = nub (sort xs) in map (\i -> fromIntegral (fromJust (elemIndex i xs'))) xs adjustment x = if x == 0 then 1 else 1 % (denominator x * 2) step (i,j) ns = let c = contour_description_ix d (i,j) i' = ns !! i j' = ns !! j c' = compare i' j' -- traceShow (i,j,ns) $ in if c == c' then Nothing else let j'' = case c of LT -> i' + adjustment j' EQ -> i' GT -> i' - adjustment j' in Just (replace ns j j'') refine [] ns = ns refine (i:is) ns = case step i ns of Nothing -> refine is ns Just ns' -> refine ix ns' in normalise (refine ix (replicate n 0)) -- | Invert 'Contour_Description'. -- -- > let c = contour_description "abdc" -- > in draw_contour (contour_description_invert c) == [3,2,0,1] contour_description_invert :: Contour_Description -> Contour_Description contour_description_invert (Contour_Description n m) = Contour_Description n (M.map ord_invert m) -- * Construction -- | Function to perhaps generate an element and a new state from an -- initial state. This is the function provided to 'unfoldr'. type Build_f st e = st -> Maybe (e,st) -- | Function to test is a partial sequence conforms to the target -- sequence. type Conforms_f e = Int -> [e] -> Bool -- | Transform a 'Build_f' to produce at most /n/ elements. -- -- > let f i = Just (i,succ i) -- > in unfoldr (build_f_n f) (5,'a') == "abcde" build_f_n :: Build_f st e -> Build_f (Int,st) e build_f_n f = let g g_st = let (i,f_st) = g_st in if i == 0 then Nothing else case f f_st of Nothing -> Nothing Just (e,f_st') -> Just (e,(i - 1,f_st')) in g -- | Attempt to construct a sequence of /n/ elements given a 'Build_f' -- to generate possible elements, a 'Conforms_f' that the result -- sequence must conform to at each step, an 'Int' to specify the -- maximum number of elements to generate when searching for a -- solution, and an initial state. -- -- > let {b_f i = Just (i,i+1) -- > ;c_f i x = odd (sum x `div` i)} -- > in build_sequence 6 b_f c_f 20 0 == (Just [1,2,6,11,15,19],20) build_sequence :: Int -> Build_f st e -> Conforms_f e -> Int -> st -> (Maybe [e],st) build_sequence n f g z = let go i j r st = if i == n then (Just r,st) else if j == z then (Nothing,st) else case f st of Nothing -> (Nothing,st) Just (e,st') -> let i' = i + 1 j' = j + 1 r' = r ++ [e] in if g i' r' then go i' j' r' st' else go i j' r st' in go 0 0 [] -- | Attempt to construct a sequence that has a specified contour. -- The arguments are a 'Build_f' to generate possible elements, a -- 'Contour_Description' that the result sequence must conform to, an -- 'Int' to specify the maximum number of elements to generate when -- searching for a solution, and an initial state. -- -- > import System.Random -- -- > let {f = Just . randomR ('a','z') -- > ;c = contour_description "atdez" -- > ;st = mkStdGen 2347} -- > in fst (build_contour f c 1024 st) == Just "nvruy" build_contour :: (Ord e) => Build_f st e -> Contour_Description -> Int -> st -> (Maybe [e],st) build_contour f c z = let n = contour_description_n c g i r = let d = contour_description r -- traceShow r in contour_eq_at c d (i - 1) in build_sequence n f g z -- | A variant on 'build_contour' that retries a specified number of -- times using the final state of the failed attempt as the state for -- the next try. -- -- > let {f = Just . randomR ('a','z') -- > ;c = contour_description "atdezjh" -- > ;st = mkStdGen 2347} -- > in fst (build_contour_retry f c 64 8 st) == Just "nystzvu" build_contour_retry :: (Ord e) => Build_f st e -> Contour_Description -> Int -> Int -> st -> (Maybe [e], st) build_contour_retry f c z n st = if n == 0 then (Nothing,st) else case build_contour f c z st of (Nothing,st') -> build_contour_retry f c z (n - 1) st' r -> r -- | A variant on 'build_contour_retry' that returns the set of all -- sequences constructed. -- -- > let {f = Just . randomR ('a','z') -- > ;c = contour_description "atdezjh" -- > ;st = mkStdGen 2347} -- > in length (build_contour_set f c 64 64 st) == 60 build_contour_set :: (Ord e) => Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]] build_contour_set f c z n st = case build_contour_retry f c z n st of (Nothing,_) -> [] (Just r,st') -> r : build_contour_set f c z n st' -- | Variant of 'build_contour_set' that halts when an generated -- sequence is a duplicate of an already generated sequence. -- -- > let {f = randomR ('a','f') -- > ;c = contour_description "cafe" -- > ;st = mkStdGen 2346836 -- > ;r = build_contour_set_nodup f c 64 64 st} -- > in filter ("c" `isPrefixOf`) r == ["cafe","cbed","caed"] build_contour_set_nodup :: Ord e => Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]] build_contour_set_nodup f c z n = let go r st = case build_contour_retry f c z n st of (Nothing,_) -> [] (Just r',st') -> if r' `elem` r then r else go (r' : r) st' in go [] -- * Examples -- | Example from p.262 (quarter-note durations) -- -- > 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] -- | 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] -- | 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] -- | 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]] ns = [[2,2,2,1],[2,2,0],[0,0],[1]] ns' = map (map int_to_ord) ns in half_matrix_to_description (Contour_Half_Matrix 5 ns') hmt-0.15/Music/Theory/Array/0000755000000000000000000000000012416136065014031 5ustar0000000000000000hmt-0.15/Music/Theory/Array/MD.hs0000644000000000000000000000735512416136065014677 0ustar0000000000000000-- | Regular array data as markdown (MD) tables. module Music.Theory.Array.MD where import Data.Char {- base -} import Data.List {- base -} import qualified Music.Theory.List as T {- hmt -} -- | Append /k/ to the right of /l/ until result has /n/ places. pad_right :: a -> Int -> [a] -> [a] pad_right k n l = take n (l ++ repeat k) -- | Append /k/ to each row of /tbl/ as required to be regular (all -- rows equal length). make_regular :: a -> [[a]] -> [[a]] make_regular k tbl = let z = maximum (map length tbl) in map (pad_right k z) tbl -- | Delete trailing 'Char' where 'isSpace' holds. delete_trailing_whitespace :: [Char] -> [Char] delete_trailing_whitespace = reverse . dropWhile isSpace . reverse -- | Optional header row then data rows. type MD_Table t = (Maybe [String],[[t]]) -- | Join second table to right of initial table. md_table_join :: MD_Table a -> MD_Table a -> MD_Table a md_table_join (nm,c) (hdr,tbl) = let hdr' = fmap (\h -> maybe h (++ h) nm) hdr tbl' = map (\(i,r) -> i ++ r) (zip c tbl) in (hdr',tbl') -- | Add a row number column at the front of the table. md_number_rows :: MD_Table String -> MD_Table String md_number_rows (hdr,tbl) = let hdr' = fmap ("#" :) hdr tbl' = map (\(i,r) -> show i : r) (zip [1::Int ..] tbl) in (hdr',tbl') -- | Markdown table, perhaps with header. Table is in row order. -- Options are: /pad_left/. -- -- > md_table_opt False (Nothing,[["a","bc","def"],["ghij","klm","no","p"]]) md_table_opt :: Bool -> MD_Table String -> [String] md_table_opt pleft (hdr,t) = let t' = maybe t (:t) hdr c = transpose (make_regular "" t') n = map (maximum . map length) c ext k s = let pd = replicate (k - length s) ' ' in if pleft then pd ++ s else s ++ pd m = unwords (map (flip replicate '-') n) w = map unwords (transpose (zipWith (map . ext) n c)) d = map delete_trailing_whitespace w in case hdr of Nothing -> T.bracket (m,m) d Just _ -> case d of [] -> error "md_table" d0:d' -> d0 : T.bracket (m,m) d' md_table' :: MD_Table String -> [String] md_table' = md_table_opt True -- | 'curry' of 'md_table''. md_table :: Maybe [String] -> [[String]] -> [String] md_table = curry md_table' -- | Variant relying on 'Show' instances. -- -- > md_table_show Nothing [[1..4],[5..8],[9..12]] md_table_show :: Show t => Maybe [String] -> [[t]] -> [String] md_table_show hdr = md_table hdr . map (map show) -- | Variant in column order (ie. 'transpose'). -- -- > md_table_column_order [["a","bc","def"],["ghij","klm","no"]] md_table_column_order :: Maybe [String] -> [[String]] -> [String] md_table_column_order hdr = md_table hdr . transpose -- | Two-tuple 'show' variant. md_table_p2 :: (Show a,Show b) => Maybe [String] -> ([a],[b]) -> [String] md_table_p2 hdr (p,q) = md_table hdr [map show p,map show q] -- | Three-tuple 'show' variant. md_table_p3 :: (Show a,Show b,Show c) => Maybe [String] -> ([a],[b],[c]) -> [String] md_table_p3 hdr (p,q,r) = md_table hdr [map show p,map show q,map show r] {- | Matrix form, ie. header in both first row and first column, in each case displaced by one location which is empty. > let t = md_matrix "" (map return "abc") (map (map show) [[1,2,3],[2,3,1],[3,1,2]]) >>> putStrLn $ unlines $ md_table' t - - - - a b c a 1 2 3 b 2 3 1 c 3 1 2 - - - - -} md_matrix :: a -> [a] -> [[a]] -> MD_Table a md_matrix nil nm t = md_table_join (Nothing,[nil] : map return nm) (Nothing,nm : t) -- | Variant for 'String' tables where /nil/ is the empty string and -- the header cells are in bold. md_matrix_bold :: [String] -> [[String]] -> MD_Table String md_matrix_bold nm t = let bold x = "__" ++ x ++ "__" nm' = map bold nm in md_matrix "" nm' t hmt-0.15/Music/Theory/Array/CSV.hs0000644000000000000000000002601412416136065015023 0ustar0000000000000000-- | Regular matrix array data, CSV, column & row indexing. module Music.Theory.Array.CSV where import Data.Array {- array -} import Data.Char {- base -} import Data.Function {- base -} import Data.List {- base -} import Data.String {- base -} import qualified Text.CSV.Lazy.String as C {- lazy-csv -} import qualified Music.Theory.List as T {- hmt -} -- * Indexing -- | @A@ indexed case-insensitive column references. The column -- following @Z@ is @AA@. data Column_Ref = Column_Ref {column_ref_string :: String} instance IsString Column_Ref where fromString = Column_Ref instance Read Column_Ref where readsPrec _ s = [(Column_Ref s,[])] instance Show Column_Ref where show = column_ref_string instance Eq Column_Ref where (==) = (==) `on` column_index instance Ord Column_Ref where compare = compare `on` column_index instance Enum Column_Ref where fromEnum = column_index toEnum = column_ref instance Ix Column_Ref where range = column_range index = interior_column_index inRange = column_in_range rangeSize = column_range_size -- | Inclusive range of column references. type Column_Range = (Column_Ref,Column_Ref) -- | @1@-indexed row reference. type Row_Ref = Int -- | Zero index of 'Row_Ref'. row_index :: Row_Ref -> Int row_index r = r - 1 -- | Inclusive range of row references. type Row_Range = (Row_Ref,Row_Ref) -- | Cell reference, column then row. type Cell_Ref = (Column_Ref,Row_Ref) -- | Inclusive range of cell references. type Cell_Range = (Cell_Ref,Cell_Ref) -- | Case folding letter to index function. Only valid for ASCII letters. -- -- > map letter_index ['A' .. 'Z'] == [0 .. 25] -- > map letter_index ['a','d' .. 'm'] == [0,3 .. 12] letter_index :: Char -> Int letter_index c = fromEnum (toUpper c) - fromEnum 'A' -- | Inverse of 'letter_index'. -- -- > map index_letter [0,3 .. 12] == ['A','D' .. 'M'] index_letter :: Int -> Char index_letter i = toEnum (i + fromEnum 'A') -- | Translate column reference to @0@-index. -- -- > :set -XOverloadedStrings -- > map column_index ["A","c","z","ac","XYZ"] == [0,2,25,28,17575] column_index :: Column_Ref -> Int column_index (Column_Ref c) = let m = iterate (* 26) 1 i = reverse (map letter_index c) in sum (zipWith (*) m (zipWith (+) [0..] i)) -- | Column reference to interior index within specified range. Type -- specialised 'Data.Ix.index'. -- -- > map (Data.Ix.index ('A','Z')) ['A','C','Z'] == [0,2,25] -- > map (interior_column_index ("A","Z")) ["A","C","Z"] == [0,2,25] -- -- > map (Data.Ix.index ('B','C')) ['B','C'] == [0,1] -- > map (interior_column_index ("B","C")) ["B","C"] == [0,1] interior_column_index :: Column_Range -> Column_Ref -> Int interior_column_index (l,r) c = let n = column_index c l' = column_index l r' = column_index r in if n > r' then error (show ("interior_column_index",l,r,c)) else n - l' -- | Inverse of 'column_index'. -- -- > let c = ["A","Z","AA","AZ","BA","BZ","CA"] -- > in map column_ref [0,25,26,51,52,77,78] == c -- -- > column_ref (0+25+1+25+1+25+1) == "CA" column_ref :: Int -> Column_Ref column_ref = let rec n = case n `quotRem` 26 of (0,r) -> [index_letter r] (q,r) -> index_letter (q - 1) : rec r in Column_Ref . rec -- | Type specialised 'pred'. -- -- > column_ref_pred "DF" == "DE" column_ref_pred :: Column_Ref -> Column_Ref column_ref_pred = pred -- | Type specialised 'succ'. -- -- > column_ref_succ "DE" == "DF" column_ref_succ :: Column_Ref -> Column_Ref column_ref_succ = succ -- | Bimap of 'column_index'. -- -- > column_indices ("b","p") == (1,15) -- > column_indices ("B","IT") == (1,253) column_indices :: Column_Range -> (Int,Int) column_indices = let bimap f (i,j) = (f i,f j) in bimap column_index -- | Type specialised 'Data.Ix.range'. -- -- > column_range ("L","R") == ["L","M","N","O","P","Q","R"] -- > Data.Ix.range ('L','R') == "LMNOPQR" column_range :: Column_Range -> [Column_Ref] column_range rng = let (l,r) = column_indices rng in map column_ref [l .. r] -- | Type specialised 'Data.Ix.inRange'. -- -- > map (column_in_range ("L","R")) ["A","N","Z"] == [False,True,False] -- > map (column_in_range ("L","R")) ["L","N","R"] == [True,True,True] -- -- > map (Data.Ix.inRange ('L','R')) ['A','N','Z'] == [False,True,False] -- > map (Data.Ix.inRange ('L','R')) ['L','N','R'] == [True,True,True] column_in_range :: Column_Range -> Column_Ref -> Bool column_in_range rng c = let (l,r) = column_indices rng k = column_index c in k >= l && k <= r -- | Type specialised 'Data.Ix.rangeSize'. -- -- > map column_range_size [("A","Z"),("AA","ZZ")] == [26,26 * 26] -- > Data.Ix.rangeSize ('A','Z') == 26 column_range_size :: Column_Range -> Int column_range_size = (+ 1) . negate . uncurry (-) . column_indices -- | Type specialised 'Data.Ix.range'. row_range :: Row_Range -> [Row_Ref] row_range = range -- | The standard uppermost leftmost cell reference, @A1@. -- -- > Just cell_ref_minima == parse_cell_ref "A1" cell_ref_minima :: Cell_Ref cell_ref_minima = (Column_Ref "A",1) -- | Cell reference parser for standard notation of (column,row). -- -- > parse_cell_ref "CC348" == Just ("CC",348) parse_cell_ref :: String -> Maybe Cell_Ref parse_cell_ref s = case span isUpper s of ([],_) -> Nothing (c,r) -> case span isDigit r of (n,[]) -> Just (Column_Ref c,read n) _ -> Nothing -- | Cell reference pretty printer. -- -- > cell_ref_pp ("CC",348) == "CC348" cell_ref_pp :: Cell_Ref -> String cell_ref_pp (Column_Ref c,r) = c ++ show r -- | Translate cell reference to @0@-indexed pair. -- -- > cell_index ("CC",348) == (80,347) -- > Data.Ix.index (("AA",1),("ZZ",999)) ("CC",348) == 54293 cell_index :: Cell_Ref -> (Int,Int) cell_index (c,r) = (column_index c,row_index r) -- | Type specialised 'Data.Ix.range', cells are in column-order. -- -- > cell_range (("AA",1),("AC",1)) == [("AA",1),("AB",1),("AC",1)] -- -- > let r = [("AA",1),("AA",2),("AB",1),("AB",2),("AC",1),("AC",2)] -- > in cell_range (("AA",1),("AC",2)) == r -- -- > Data.Ix.range (('A',1),('C',1)) == [('A',1),('B',1),('C',1)] -- -- > let r = [('A',1),('A',2),('B',1),('B',2),('C',1),('C',2)] -- > in Data.Ix.range (('A',1),('C',2)) == r cell_range :: Cell_Range -> [Cell_Ref] cell_range ((c1,r1),(c2,r2)) = [(c,r) | c <- column_range (c1,c2) ,r <- row_range (r1,r2)] -- | Variant of 'cell_range' in row-order. -- -- > let r = [(AA,1),(AB,1),(AC,1),(AA,2),(AB,2),(AC,2)] -- > in cell_range_row_order (("AA",1),("AC",2)) == r cell_range_row_order :: Cell_Range -> [Cell_Ref] cell_range_row_order ((c1,r1),(c2,r2)) = [(c,r) | r <- row_range (r1,r2) ,c <- column_range (c1,c2)] -- * TABLE -- | When reading a CSV file is the first row a header? type CSV_Has_Header = Bool type CSV_Delimiter = Char type CSV_Allow_Linebreaks = Bool -- | When writing a CSV file should the delimiters be aligned, -- ie. should columns be padded with spaces, and if so at which side -- of the data? data CSV_Align_Columns = CSV_No_Align | CSV_Align_Left | CSV_Align_Right -- | CSV options. type CSV_Opt = (CSV_Has_Header,CSV_Delimiter,CSV_Allow_Linebreaks,CSV_Align_Columns) -- | Default CSV options, no header, comma delimiter, no linebreaks, no alignment. def_csv_opt :: CSV_Opt def_csv_opt = (False,',',False,CSV_No_Align) -- | Plain list representation of a two-dimensional table of /a/ in -- row-order. Tables are regular, ie. all rows have equal numbers of -- columns. type Table a = [[a]] -- | CSV table, ie. a table with perhaps a header. type CSV_Table a = (Maybe [String],Table a) -- | Read 'Table' from @CSV@ file. csv_table_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (CSV_Table a) csv_table_read (hdr,delim,brk,_) f fn = do s <- readFile fn let t = C.csvTable (C.parseDSV brk delim s) p = C.fromCSVTable t (h,d) = if hdr then (Just (head p),tail p) else (Nothing,p) return (h,map (map f) d) -- | Read 'Table' only with 'def_csv_opt'. csv_table_read' :: (String -> a) -> FilePath -> IO (Table a) csv_table_read' f = fmap snd . csv_table_read def_csv_opt f -- | Read and process @CSV@ 'Table'. csv_table_with :: CSV_Opt -> (String -> a) -> FilePath -> (CSV_Table a -> b) -> IO b csv_table_with opt f fn g = fmap g (csv_table_read opt f fn) -- > csv_table_align CSV_No_Align [["a","row","and"],["then","another","one"]] csv_table_align :: CSV_Align_Columns -> Table String -> Table String csv_table_align align tbl = let c = transpose tbl n = map (maximum . map length) c ext k s = let pd = replicate (k - length s) ' ' in case align of CSV_No_Align -> s CSV_Align_Left -> pd ++ s CSV_Align_Right -> s ++ pd in transpose (zipWith (map . ext) n c) -- | Write 'Table' to @CSV@ file. csv_table_write :: (a -> String) -> CSV_Opt -> FilePath -> CSV_Table a -> IO () csv_table_write f (_,delim,brk,align) fn (hdr,tbl) = do let tbl' = csv_table_align align (map (map f) tbl) (_,t) = C.toCSVTable (T.mcons hdr tbl') s = C.ppDSVTable brk delim t writeFile fn s -- | Write 'Table' only (no header). csv_table_write' :: (a -> String) -> CSV_Opt -> FilePath -> Table a -> IO () csv_table_write' f opt fn tbl = csv_table_write f opt fn (Nothing,tbl) -- | @0@-indexed (row,column) cell lookup. table_lookup :: Table a -> (Int,Int) -> a table_lookup t (r,c) = (t !! r) !! c -- | Row data. table_row :: Table a -> Row_Ref -> [a] table_row t r = t !! row_index r -- | Column data. table_column :: Table a -> Column_Ref -> [a] table_column t c = transpose t !! column_index c -- | Lookup value across columns. table_column_lookup :: Eq a => Table a -> (Column_Ref,Column_Ref) -> a -> Maybe a table_column_lookup t (c1,c2) e = let a = zip (table_column t c1) (table_column t c2) in lookup e a -- | Table cell lookup. table_cell :: Table a -> Cell_Ref -> a table_cell t (c,r) = let (r',c') = (row_index r,column_index c) in table_lookup t (r',c') -- | @0@-indexed (row,column) cell lookup over column range. table_lookup_row_segment :: Table a -> (Int,(Int,Int)) -> [a] table_lookup_row_segment t (r,(c0,c1)) = let r' = t !! r in take (c1 - c0 + 1) (drop c0 r') -- | Range of cells from row. table_row_segment :: Table a -> (Row_Ref,Column_Range) -> [a] table_row_segment t (r,c) = let (r',c') = (row_index r,column_indices c) in table_lookup_row_segment t (r',c') -- * Array -- | Translate 'Table' to 'Array'. It is assumed that the 'Table' is -- regular, ie. all rows have an equal number of columns. -- -- > let a = table_to_array [[0,1,3],[2,4,5]] -- > in (bounds a,indices a,elems a) -- -- > > (((A,1),(C,2)) -- > > ,[(A,1),(A,2),(B,1),(B,2),(C,1),(C,2)] -- > > ,[0,2,1,4,3,5]) table_to_array :: Table a -> Array Cell_Ref a table_to_array t = let nr = length t nc = length (t !! 0) bnd = (cell_ref_minima,(toEnum (nc - 1),nr)) asc = zip (cell_range_row_order bnd) (concat t) in array bnd asc -- | 'table_to_array' of 'csv_table_read'. csv_array_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (Array Cell_Ref a) csv_array_read opt f fn = fmap (table_to_array . snd) (csv_table_read opt f fn) hmt-0.15/Music/Theory/Array/CSV/0000755000000000000000000000000012416136065014464 5ustar0000000000000000hmt-0.15/Music/Theory/Array/CSV/Midi.hs0000644000000000000000000000731112416136065015704 0ustar0000000000000000-- | Functions for reading midi note data from CSV files. module Music.Theory.Array.CSV.Midi where import Data.Function {- base -} import Data.Maybe {- base -} import qualified Music.Theory.Array.CSV as T {- hmt -} import qualified Music.Theory.Time.Seq as T {- hmt -} -- | Variant of 'reads' requiring exact match. reads_exact :: Read a => String -> Maybe a reads_exact s = case reads s of [(r,"")] -> Just r _ -> Nothing -- | Variant of 'reads_exact' that errors on failure. reads_err :: Read a => String -> a reads_err str = fromMaybe (error ("could not read: " ++ str)) (reads_exact str) -- | The required header field. csv_midi_note_data_hdr :: [String] csv_midi_note_data_hdr = ["time","on/off","note","velocity"] -- | Midi note data, header is @time,on/off,note,velocity@. -- Translation values for on/off are consulted. -- -- > let fn = "/home/rohan/cvs/uc/uc-26/daily-practice/2014-08-13.1.csv" -- > csv_midi_note_data_read' ("ON","OFF") fn :: IO [(Double,Either String String,Double,Double)] csv_midi_note_data_read' :: (Read t,Real t,Read n,Real n) => (m,m) -> FilePath -> IO [(t,Either m String,n,n)] csv_midi_note_data_read' (m_on,m_off) = let err x = error ("csv_midi_note_data_read: " ++ x) read_md x = case x of "on" -> Left m_on "off" -> Left m_off _ -> Right x f m = case m of [st,md,mnn,amp] -> (reads_err st,read_md md,reads_err mnn,reads_err amp) _ -> err "entry?" g (hdr,dat) = case hdr of Just hdr' -> if hdr' == csv_midi_note_data_hdr then dat else err "header?" Nothing -> err "no header?" in fmap (map f . g) . T.csv_table_read (True,',',False,T.CSV_No_Align) id -- | Variant of 'csv_midi_note_data_read'' that errors on non on/off data. csv_midi_note_data_read :: (Read t,Real t,Read n,Real n) => (m,m) -> FilePath -> IO [(t,m,n,n)] csv_midi_note_data_read m = let f (t,p,q,r) = (t,either id (error "not on/off") p,q,r) in fmap (map f) . csv_midi_note_data_read' m -- | 'Tseq' form of 'csv_read_midi_note_data'. midi_tseq_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Tseq t (T.On_Off (n,n))) midi_tseq_read = let mk_node (st,md,mnn,amp) = if md then (st,T.On (mnn,amp)) else (st,T.Off (mnn,0)) in fmap (map mk_node) . csv_midi_note_data_read (True,False) -- | Translate from 'Tseq' form to 'Wseq' form. midi_tseq_to_midi_wseq :: (Num t,Eq n) => T.Tseq t (T.On_Off (n,n)) -> T.Wseq t (n,n) midi_tseq_to_midi_wseq = T.tseq_on_off_to_wseq ((==) `on` fst) -- | Off-velocity is zero. midi_wseq_to_midi_tseq :: (Num t,Ord t) => T.Wseq t (n,n) -> T.Tseq t (T.On_Off (n,n)) midi_wseq_to_midi_tseq = T.wseq_on_off -- | Writer. csv_midi_note_data_write :: (Eq m,Show t,Real t,Show n,Real n) => (m,m) -> FilePath -> [(t,m,n,n)] -> IO () csv_midi_note_data_write (m_on,m_off) nm = let show_md md = if md == m_on then "on" else if md == m_off then "off" else error "csv_midi_note_data_write" un_node (st,md,mnn,amp) = [show st,show_md md,show mnn,show amp] with_hdr dat = (Just csv_midi_note_data_hdr,dat) in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node -- | 'Tseq' form of 'csv_midi_note_data_write'. midi_tseq_write :: (Show t,Real t,Show n,Real n) => FilePath -> T.Tseq t (T.On_Off (n,n)) -> IO () midi_tseq_write nm sq = let f (t,e) = case e of T.On (n,v) -> (t,True,n,v) T.Off (n,v) -> (t,False,n,v) sq' = map f sq in csv_midi_note_data_write (True,False) nm sq' hmt-0.15/Music/Theory/Z12/0000755000000000000000000000000012416136065013327 5ustar0000000000000000hmt-0.15/Music/Theory/Z12/Morris_1974.hs0000644000000000000000000000231312416136065015621 0ustar0000000000000000-- | Robert Morris and D. Starr. \"The Structure of All-Interval Series\". -- /Journal of Music Theory/, 18:364-389, 1974. module Music.Theory.Z12.Morris_1974 where import Control.Monad.Logic {- logict -} -- | 'msum' '.' 'map' 'return'. -- -- > observeAll (fromList [1..7]) == [1..7] fromList :: MonadPlus m => [a] -> m a fromList = msum . map return -- | 'MonadPlus' all-interval series. -- -- > [0,1,3,2,9,5,10,4,7,11,8,6] `elem` observeAll (all_interval_m 12) -- > length (observeAll (all_interval_m 12)) == 3856 -- > map (length . observeAll . all_interval_m) [4,6,8,10] == [2,4,24,288] all_interval_m :: MonadPlus m => Int -> m [Int] all_interval_m n = let rec p q = if length p == n then return (reverse p) else do i <- fromList [1 .. n - 1] guard (i `notElem` p) let j:_ = p m = abs ((i - j) `mod` n) guard (m `notElem` q) rec (i:p) (m:q) in rec [0] [] -- | 'observeAll' of 'all_interval_m'. -- -- > let r = [[0,1,5,2,4,3],[0,2,1,4,5,3],[0,4,5,2,1,3],[0,5,1,4,2,3]] -- > in all_interval 6 == r all_interval :: Int -> [[Int]] all_interval = observeAll . all_interval_m hmt-0.15/Music/Theory/Z12/Castren_1994.hs0000644000000000000000000001170412416136065015753 0ustar0000000000000000-- | Marcus Castrén. /RECREL: A Similarity Measure for Set-Classes/. PhD -- thesis, Sibelius Academy, Helsinki, 1994. module Music.Theory.Z12.Castren_1994 where import Data.List {- base -} import Data.Maybe {- base -} import Data.Ratio {- base -} import qualified Music.Theory.List as T import Music.Theory.Z12 (Z12) import qualified Music.Theory.Z12.Forte_1973 as T import qualified Music.Theory.Z12.TTO as T -- | Is /p/ symmetrical under inversion. -- -- > import Music.Theory.Z12.Forte_1973 -- > map inv_sym (scs_n 2) == [True,True,True,True,True,True] -- > map (fromEnum.inv_sym) (scs_n 3) == [1,0,0,0,0,1,0,0,1,1,0,1] inv_sym :: [Z12] -> Bool inv_sym x = x `elem` map (\i -> sort (T.tn i (T.invert 0 x))) [0..11] -- | If /p/ is not 'inv_sym' then @(p,invert 0 p)@ else 'Nothing'. -- -- > sc_t_ti [0,2,4] == Nothing -- > sc_t_ti [0,1,3] == Just ([0,1,3],[0,2,3]) sc_t_ti :: [Z12] -> Maybe ([Z12], [Z12]) sc_t_ti p = if inv_sym p then Nothing else Just (p,T.t_prime (T.invert 0 p)) -- | Transpositional equivalence variant of Forte's 'sc_table'. The -- inversionally related classes are distinguished by labels @A@ and -- @B@; the class providing the /best normal order/ (Forte 1973) is -- always the @A@ class. If neither @A@ nor @B@ appears in the name of -- a set-class, it is inversionally symmetrical. -- -- > (length sc_table,length t_sc_table) == (224,352) -- > lookup "5-Z18B" t_sc_table == Just [0,2,3,6,7] t_sc_table :: [(T.SC_Name,[Z12])] t_sc_table = let f x = let nm = T.sc_name x in case sc_t_ti x of Nothing -> [(nm,x)] Just (p,q) -> [(nm++"A",p),(nm++"B",q)] in concatMap f T.scs -- | Lookup a set-class name. The input set is subject to -- 't_prime' before lookup. -- -- > t_sc_name [0,2,3,6,7] == "5-Z18B" -- > t_sc_name [0,1,4,6,7,8] == "6-Z17B" t_sc_name :: [Z12] -> T.SC_Name t_sc_name p = let n = find (\(_,q) -> T.t_prime p == q) t_sc_table in fst (fromJust n) -- | Lookup a set-class given a set-class name. -- -- > t_sc "6-Z17A" == [0,1,2,4,7,8] t_sc :: T.SC_Name -> [Z12] t_sc n = snd (fromJust (find (\(m,_) -> n == m) t_sc_table)) -- | List of set classes. t_scs :: [[Z12]] t_scs = map snd t_sc_table -- | Cardinality /n/ subset of 't_scs'. -- -- > map (length . t_scs_n) [2..10] == [6,19,43,66,80,66,43,19,6] t_scs_n :: Integral i => i -> [[Z12]] t_scs_n n = filter ((== n) . genericLength) t_scs -- | T-related /q/ that are subsets of /p/. -- -- > t_subsets [0,1,2,3,4] [0,1] == [[0,1],[1,2],[2,3],[3,4]] -- > t_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4]] -- > t_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6]] t_subsets :: [Z12] -> [Z12] -> [[Z12]] t_subsets x a = filter (`T.is_subset` x) (T.t_related a) -- | T\/I-related /q/ that are subsets of /p/. -- -- > ti_subsets [0,1,2,3,4] [0,1] == [[0,1],[1,2],[2,3],[3,4]] -- > ti_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4],[0,3,4]] -- > ti_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6],[3,6,7]] ti_subsets :: [Z12] -> [Z12] -> [[Z12]] ti_subsets x a = filter (`T.is_subset` x) (T.ti_related a) -- | Trivial run length encoder. -- -- > rle "abbcccdde" == [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')] rle :: (Eq a,Integral i) => [a] -> [(i,a)] rle = let f x = (genericLength x,head x) in map f . group -- | Inverse of 'rle'. -- -- > rle_decode [(5,'a'),(4,'b')] == "aaaaabbbb" rle_decode :: (Integral i) => [(i,a)] -> [a] rle_decode = let f (i,j) = genericReplicate i j in concatMap f -- | Length of /rle/ encoded sequence. -- -- > rle_length [(5,'a'),(4,'b')] == 9 rle_length :: (Integral i) => [(i,a)] -> i rle_length = sum . map fst -- | T-equivalence /n/-class vector (subset-class vector, nCV). -- -- > t_n_class_vector 2 [0..4] == [4,3,2,1,0,0] -- > rle (t_n_class_vector 3 [0..4]) == [(1,3),(2,2),(2,1),(4,0),(1,1),(9,0)] -- > rle (t_n_class_vector 4 [0..4]) == [(1,2),(3,1),(39,0)] t_n_class_vector :: (Num a, Integral i) => i -> [Z12] -> [a] t_n_class_vector n x = let a = t_scs_n n in map (genericLength . t_subsets x) a -- | T\/I-equivalence /n/-class vector (subset-class vector, nCV). -- -- > ti_n_class_vector 2 [0..4] == [4,3,2,1,0,0] -- > ti_n_class_vector 3 [0,1,2,3,4] == [3,4,2,0,0,1,0,0,0,0,0,0] -- > rle (ti_n_class_vector 4 [0,1,2,3,4]) == [(2,2),(1,1),(26,0)] ti_n_class_vector :: (Num b, Integral i) => i -> [Z12] -> [b] ti_n_class_vector n x = let a = T.scs_n n in map (genericLength . ti_subsets x) a -- | 'icv' scaled by sum of /icv/. -- -- > dyad_class_percentage_vector [0,1,2,3,4] == [40,30,20,10,0,0] -- > dyad_class_percentage_vector [0,1,4,5,7] == [20,10,20,20,20,10] dyad_class_percentage_vector :: Integral i => [Z12] -> [i] dyad_class_percentage_vector p = let p' = T.icv p in map (sum p' *) p' -- | /rel/ metric. -- -- > rel [0,1,2,3,4] [0,1,4,5,7] == 40 -- > rel [0,1,2,3,4] [0,2,4,6,8] == 60 -- > rel [0,1,4,5,7] [0,2,4,6,8] == 60 rel :: Integral i => [Z12] -> [Z12] -> Ratio i rel x y = let x' = dyad_class_percentage_vector x y' = dyad_class_percentage_vector y in sum (map abs (zipWith (-) x' y')) % 2 hmt-0.15/Music/Theory/Z12/Morris_1987.hs0000644000000000000000000000506012416136065015627 0ustar0000000000000000-- | Robert Morris. /Composition with Pitch-Classes: A Theory of -- Compositional Design/. Yale University Press, New Haven, 1987. module Music.Theory.Z12.Morris_1987 where import Data.List import Music.Theory.List import Music.Theory.Z12 import Music.Theory.Z12.SRO -- | @INT@ operator. -- -- > int [0,1,3,6,10] == [1,2,3,4] int :: [Z12] -> [Z12] int = d_dx -- * Serial operations -- | Serial Operator,of the form rRTMI. data SRO = SRO Z12 Bool Z12 Bool Bool deriving (Eq,Show) -- | Serial operation. -- -- >>> sro T4 156 -- 59A -- -- > sro (rnrtnmi "T4") (pco "156") == [5,9,10] -- -- >>> echo 024579 | sro RT4I -- 79B024 -- -- > sro (SRO 0 True 4 False True) [0,2,4,5,7,9] == [7,9,11,0,2,4] -- -- >>> sro T4I 156 -- 3BA -- -- > sro (rnrtnmi "T4I") (pco "156") == [3,11,10] -- > sro (SRO 0 False 4 False True) [1,5,6] == [3,11,10] -- -- >>> echo 156 | sro T4 | sro T0I -- 732 -- -- > (sro (rnrtnmi "T0I") . sro (rnrtnmi "T4")) (pco "156") == [7,3,2] -- -- >>> echo 024579 | sro RT4I -- 79B024 -- -- > sro (rnrtnmi "RT4I") (pco "024579") == [7,9,11,0,2,4] -- -- > sro (SRO 1 True 1 True False) [0,1,2,3] == [11,6,1,4] -- > sro (SRO 1 False 4 True True) [0,1,2,3] == [11,6,1,4] sro :: SRO -> [Z12] -> [Z12] sro (SRO r r' t m i) x = let x1 = if i then invert 0 x else x x2 = if m then m5 x1 else x1 x3 = tn t x2 x4 = if r' then reverse x3 else x3 in genericRotate_left r x4 -- | The total set of serial operations. sros :: [Z12] -> [(SRO,[Z12])] sros x = [let o = (SRO r r' t m i) in (o,sro o x) | r <- [0 .. genericLength x - 1], r' <- [False,True], t <- [0 .. 11], m <- [False,True], i <- [False,True]] -- | The set of transposition 'SRO's. sro_Tn ::[SRO] sro_Tn = [SRO 0 False n False False | n <- [0..11]] -- | The set of transposition and inversion 'SRO's. sro_TnI ::[SRO] sro_TnI = [SRO 0 False n False i | n <- [0..11], i <- [False,True]] -- | The set of retrograde and transposition and inversion 'SRO's. sro_RTnI ::[SRO] sro_RTnI = [SRO 0 r n False i | r <- [True,False], n <- [0..11], i <- [False,True]] -- | The set of transposition,@M5@ and inversion 'SRO's. sro_TnMI ::[SRO] sro_TnMI = [SRO 0 False n m i | n <- [0..11], m <- [True,False], i <- [True,False]] -- | The set of retrograde,transposition,@M5@ and inversion 'SRO's. sro_RTnMI ::[SRO] sro_RTnMI = [SRO 0 r n m i | r <- [True,False], n <- [0..11], m <- [True,False], i <- [True,False]] hmt-0.15/Music/Theory/Z12/SRO.hs0000644000000000000000000000500712416136065014330 0ustar0000000000000000-- | Serial (ordered) pitch-class operations on 'Z12'. module Music.Theory.Z12.SRO where import Data.List import qualified Music.Theory.List as T import qualified Music.Theory.Z.SRO as Z import Music.Theory.Z12 -- | Transpose /p/ by /n/. -- -- > tn 4 [1,5,6] == [5,9,10] tn :: Z12 -> [Z12] -> [Z12] tn = Z.tn z12_modulo -- | Invert /p/ about /n/. -- -- > invert 6 [4,5,6] == [8,7,6] -- > invert 0 [0,1,3] == [0,11,9] invert :: Z12 -> [Z12] -> [Z12] invert = Z.invert z12_modulo -- | Composition of 'invert' about @0@ and 'tn'. -- -- > tni 4 [1,5,6] == [3,11,10] -- > (invert 0 . tn 4) [1,5,6] == [7,3,2] tni :: Z12 -> [Z12] -> [Z12] tni = Z.tni z12_modulo -- | Modulo 12 multiplication -- -- > mn 11 [0,1,4,9] == tni 0 [0,1,4,9] mn :: Z12 -> [Z12] -> [Z12] mn = Z.mn z12_modulo -- | M5, ie. 'mn' @5@. -- -- > m5 [0,1,3] == [0,5,3] m5 :: [Z12] -> [Z12] m5 = mn 5 -- | T-related sequences of /p/. -- -- > length (t_related [0,3,6,9]) == 12 t_related :: [Z12] -> [[Z12]] t_related = Z.t_related z12_modulo -- | T\/I-related sequences of /p/. -- -- > length (ti_related [0,1,3]) == 24 -- > length (ti_related [0,3,6,9]) == 24 -- > ti_related [0] == map return [0..11] ti_related :: [Z12] -> [[Z12]] ti_related = Z.ti_related z12_modulo -- | R\/T\/I-related sequences of /p/. -- -- > length (rti_related [0,1,3]) == 48 -- > length (rti_related [0,3,6,9]) == 24 rti_related :: [Z12] -> [[Z12]] rti_related = Z.rti_related z12_modulo -- | T\/M\/I-related sequences of /p/. tmi_related :: [Z12] -> [[Z12]] tmi_related p = let q = ti_related p in nub (q ++ map m5 q) -- | R\/T\/M\/I-related sequences of /p/. rtmi_related :: [Z12] -> [[Z12]] rtmi_related p = let q = tmi_related p in nub (q ++ map reverse q) -- | r\/R\/T\/M\/I-related sequences of /p/. rrtmi_related :: [Z12] -> [[Z12]] rrtmi_related p = nub (concatMap rtmi_related (T.rotations p)) -- * Sequence operations -- | Variant of 'tn', transpose /p/ so first element is /n/. -- -- > tn_to 5 [0,1,3] == [5,6,8] -- > map (tn_to 0) [[0,1,3],[1,3,0],[3,0,1]] == [[0,1,3],[0,2,11],[0,9,10]] tn_to :: Z12 -> [Z12] -> [Z12] tn_to = Z.tn_to z12_modulo -- | Variant of 'invert', inverse about /n/th element. -- -- > map (invert_ix 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]] -- > map (invert_ix 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]] invert_ix :: Int -> [Z12] -> [Z12] invert_ix = Z.invert_ix z12_modulo -- | The standard t-matrix of /p/. -- -- > tmatrix [0,1,3] == [[0,1,3] -- > ,[11,0,2] -- > ,[9,10,0]] tmatrix :: [Z12] -> [[Z12]] tmatrix = Z.tmatrix z12_modulo hmt-0.15/Music/Theory/Z12/Forte_1973.hs0000644000000000000000000004035512416136065015434 0ustar0000000000000000-- | Allen Forte. /The Structure of Atonal Music/. Yale University -- Press, New Haven, 1973. module Music.Theory.Z12.Forte_1973 where import Data.List {- base -} import Data.Maybe {- base -} import qualified Music.Theory.Z.Forte_1973 as Z import Music.Theory.Z12 -- * Prime form -- | T-related rotations of /p/. -- -- > t_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]] t_rotations :: [Z12] -> [[Z12]] t_rotations = Z.t_rotations z12_modulo -- | T\/I-related rotations of /p/. -- -- > ti_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10] -- > ,[0,9,11],[0,2,3],[0,1,10]] ti_rotations :: [Z12] -> [[Z12]] ti_rotations = Z.ti_rotations z12_modulo -- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'. -- -- > forte_prime [0,1,3,6,8,9] == [0,1,3,6,8,9] forte_prime :: [Z12] -> [Z12] forte_prime = Z.forte_prime z12_modulo -- | Transpositional equivalence prime form, ie. 't_cmp_prime' of -- 'forte_cmp'. -- -- > (forte_prime [0,2,3],t_prime [0,2,3]) == ([0,1,3],[0,2,3]) t_prime :: [Z12] -> [Z12] t_prime = Z.t_prime z12_modulo -- * Set Class Table -- | Synonym for 'String'. type SC_Name = String -- | The set-class table (Forte prime forms). -- -- > length sc_table == 224 sc_table :: [(SC_Name,[Z12])] sc_table = [("0-1",[]) ,("1-1",[0]) ,("2-1",[0,1]) ,("2-2",[0,2]) ,("2-3",[0,3]) ,("2-4",[0,4]) ,("2-5",[0,5]) ,("2-6",[0,6]) ,("3-1",[0,1,2]) ,("3-2",[0,1,3]) ,("3-3",[0,1,4]) ,("3-4",[0,1,5]) ,("3-5",[0,1,6]) ,("3-6",[0,2,4]) ,("3-7",[0,2,5]) ,("3-8",[0,2,6]) ,("3-9",[0,2,7]) ,("3-10",[0,3,6]) ,("3-11",[0,3,7]) ,("3-12",[0,4,8]) ,("4-1",[0,1,2,3]) ,("4-2",[0,1,2,4]) ,("4-3",[0,1,3,4]) ,("4-4",[0,1,2,5]) ,("4-5",[0,1,2,6]) ,("4-6",[0,1,2,7]) ,("4-7",[0,1,4,5]) ,("4-8",[0,1,5,6]) ,("4-9",[0,1,6,7]) ,("4-10",[0,2,3,5]) ,("4-11",[0,1,3,5]) ,("4-12",[0,2,3,6]) ,("4-13",[0,1,3,6]) ,("4-14",[0,2,3,7]) ,("4-Z15",[0,1,4,6]) ,("4-16",[0,1,5,7]) ,("4-17",[0,3,4,7]) ,("4-18",[0,1,4,7]) ,("4-19",[0,1,4,8]) ,("4-20",[0,1,5,8]) ,("4-21",[0,2,4,6]) ,("4-22",[0,2,4,7]) ,("4-23",[0,2,5,7]) ,("4-24",[0,2,4,8]) ,("4-25",[0,2,6,8]) ,("4-26",[0,3,5,8]) ,("4-27",[0,2,5,8]) ,("4-28",[0,3,6,9]) ,("4-Z29",[0,1,3,7]) ,("5-1",[0,1,2,3,4]) ,("5-2",[0,1,2,3,5]) ,("5-3",[0,1,2,4,5]) ,("5-4",[0,1,2,3,6]) ,("5-5",[0,1,2,3,7]) ,("5-6",[0,1,2,5,6]) ,("5-7",[0,1,2,6,7]) ,("5-8",[0,2,3,4,6]) ,("5-9",[0,1,2,4,6]) ,("5-10",[0,1,3,4,6]) ,("5-11",[0,2,3,4,7]) ,("5-Z12",[0,1,3,5,6]) ,("5-13",[0,1,2,4,8]) ,("5-14",[0,1,2,5,7]) ,("5-15",[0,1,2,6,8]) ,("5-16",[0,1,3,4,7]) ,("5-Z17",[0,1,3,4,8]) ,("5-Z18",[0,1,4,5,7]) ,("5-19",[0,1,3,6,7]) ,("5-20",[0,1,3,7,8]) ,("5-21",[0,1,4,5,8]) ,("5-22",[0,1,4,7,8]) ,("5-23",[0,2,3,5,7]) ,("5-24",[0,1,3,5,7]) ,("5-25",[0,2,3,5,8]) ,("5-26",[0,2,4,5,8]) ,("5-27",[0,1,3,5,8]) ,("5-28",[0,2,3,6,8]) ,("5-29",[0,1,3,6,8]) ,("5-30",[0,1,4,6,8]) ,("5-31",[0,1,3,6,9]) ,("5-32",[0,1,4,6,9]) ,("5-33",[0,2,4,6,8]) ,("5-34",[0,2,4,6,9]) ,("5-35",[0,2,4,7,9]) ,("5-Z36",[0,1,2,4,7]) ,("5-Z37",[0,3,4,5,8]) ,("5-Z38",[0,1,2,5,8]) ,("6-1",[0,1,2,3,4,5]) ,("6-2",[0,1,2,3,4,6]) ,("6-Z3",[0,1,2,3,5,6]) ,("6-Z4",[0,1,2,4,5,6]) ,("6-5",[0,1,2,3,6,7]) ,("6-Z6",[0,1,2,5,6,7]) ,("6-7",[0,1,2,6,7,8]) ,("6-8",[0,2,3,4,5,7]) ,("6-9",[0,1,2,3,5,7]) ,("6-Z10",[0,1,3,4,5,7]) ,("6-Z11",[0,1,2,4,5,7]) ,("6-Z12",[0,1,2,4,6,7]) ,("6-Z13",[0,1,3,4,6,7]) ,("6-14",[0,1,3,4,5,8]) ,("6-15",[0,1,2,4,5,8]) ,("6-16",[0,1,4,5,6,8]) ,("6-Z17",[0,1,2,4,7,8]) ,("6-18",[0,1,2,5,7,8]) ,("6-Z19",[0,1,3,4,7,8]) ,("6-20",[0,1,4,5,8,9]) ,("6-21",[0,2,3,4,6,8]) ,("6-22",[0,1,2,4,6,8]) ,("6-Z23",[0,2,3,5,6,8]) ,("6-Z24",[0,1,3,4,6,8]) ,("6-Z25",[0,1,3,5,6,8]) ,("6-Z26",[0,1,3,5,7,8]) ,("6-27",[0,1,3,4,6,9]) ,("6-Z28",[0,1,3,5,6,9]) ,("6-Z29",[0,1,3,6,8,9]) ,("6-30",[0,1,3,6,7,9]) ,("6-31",[0,1,3,5,8,9]) ,("6-32",[0,2,4,5,7,9]) ,("6-33",[0,2,3,5,7,9]) ,("6-34",[0,1,3,5,7,9]) ,("6-35",[0,2,4,6,8,10]) ,("6-Z36",[0,1,2,3,4,7]) ,("6-Z37",[0,1,2,3,4,8]) ,("6-Z38",[0,1,2,3,7,8]) ,("6-Z39",[0,2,3,4,5,8]) ,("6-Z40",[0,1,2,3,5,8]) ,("6-Z41",[0,1,2,3,6,8]) ,("6-Z42",[0,1,2,3,6,9]) ,("6-Z43",[0,1,2,5,6,8]) ,("6-Z44",[0,1,2,5,6,9]) ,("6-Z45",[0,2,3,4,6,9]) ,("6-Z46",[0,1,2,4,6,9]) ,("6-Z47",[0,1,2,4,7,9]) ,("6-Z48",[0,1,2,5,7,9]) ,("6-Z49",[0,1,3,4,7,9]) ,("6-Z50",[0,1,4,6,7,9]) ,("7-1",[0,1,2,3,4,5,6]) ,("7-2",[0,1,2,3,4,5,7]) ,("7-3",[0,1,2,3,4,5,8]) ,("7-4",[0,1,2,3,4,6,7]) ,("7-5",[0,1,2,3,5,6,7]) ,("7-6",[0,1,2,3,4,7,8]) ,("7-7",[0,1,2,3,6,7,8]) ,("7-8",[0,2,3,4,5,6,8]) ,("7-9",[0,1,2,3,4,6,8]) ,("7-10",[0,1,2,3,4,6,9]) ,("7-11",[0,1,3,4,5,6,8]) ,("7-Z12",[0,1,2,3,4,7,9]) ,("7-13",[0,1,2,4,5,6,8]) ,("7-14",[0,1,2,3,5,7,8]) ,("7-15",[0,1,2,4,6,7,8]) ,("7-16",[0,1,2,3,5,6,9]) ,("7-Z17",[0,1,2,4,5,6,9]) ,("7-Z18",[0,1,2,3,5,8,9]) ,("7-19",[0,1,2,3,6,7,9]) ,("7-20",[0,1,2,4,7,8,9]) ,("7-21",[0,1,2,4,5,8,9]) ,("7-22",[0,1,2,5,6,8,9]) ,("7-23",[0,2,3,4,5,7,9]) ,("7-24",[0,1,2,3,5,7,9]) ,("7-25",[0,2,3,4,6,7,9]) ,("7-26",[0,1,3,4,5,7,9]) ,("7-27",[0,1,2,4,5,7,9]) ,("7-28",[0,1,3,5,6,7,9]) ,("7-29",[0,1,2,4,6,7,9]) ,("7-30",[0,1,2,4,6,8,9]) ,("7-31",[0,1,3,4,6,7,9]) ,("7-32",[0,1,3,4,6,8,9]) ,("7-33",[0,1,2,4,6,8,10]) ,("7-34",[0,1,3,4,6,8,10]) ,("7-35",[0,1,3,5,6,8,10]) ,("7-Z36",[0,1,2,3,5,6,8]) ,("7-Z37",[0,1,3,4,5,7,8]) ,("7-Z38",[0,1,2,4,5,7,8]) ,("8-1",[0,1,2,3,4,5,6,7]) ,("8-2",[0,1,2,3,4,5,6,8]) ,("8-3",[0,1,2,3,4,5,6,9]) ,("8-4",[0,1,2,3,4,5,7,8]) ,("8-5",[0,1,2,3,4,6,7,8]) ,("8-6",[0,1,2,3,5,6,7,8]) ,("8-7",[0,1,2,3,4,5,8,9]) ,("8-8",[0,1,2,3,4,7,8,9]) ,("8-9",[0,1,2,3,6,7,8,9]) ,("8-10",[0,2,3,4,5,6,7,9]) ,("8-11",[0,1,2,3,4,5,7,9]) ,("8-12",[0,1,3,4,5,6,7,9]) ,("8-13",[0,1,2,3,4,6,7,9]) ,("8-14",[0,1,2,4,5,6,7,9]) ,("8-Z15",[0,1,2,3,4,6,8,9]) ,("8-16",[0,1,2,3,5,7,8,9]) ,("8-17",[0,1,3,4,5,6,8,9]) ,("8-18",[0,1,2,3,5,6,8,9]) ,("8-19",[0,1,2,4,5,6,8,9]) ,("8-20",[0,1,2,4,5,7,8,9]) ,("8-21",[0,1,2,3,4,6,8,10]) ,("8-22",[0,1,2,3,5,6,8,10]) ,("8-23",[0,1,2,3,5,7,8,10]) ,("8-24",[0,1,2,4,5,6,8,10]) ,("8-25",[0,1,2,4,6,7,8,10]) ,("8-26",[0,1,2,4,5,7,9,10]) ,("8-27",[0,1,2,4,5,7,8,10]) ,("8-28",[0,1,3,4,6,7,9,10]) ,("8-Z29",[0,1,2,3,5,6,7,9]) ,("9-1",[0,1,2,3,4,5,6,7,8]) ,("9-2",[0,1,2,3,4,5,6,7,9]) ,("9-3",[0,1,2,3,4,5,6,8,9]) ,("9-4",[0,1,2,3,4,5,7,8,9]) ,("9-5",[0,1,2,3,4,6,7,8,9]) ,("9-6",[0,1,2,3,4,5,6,8,10]) ,("9-7",[0,1,2,3,4,5,7,8,10]) ,("9-8",[0,1,2,3,4,6,7,8,10]) ,("9-9",[0,1,2,3,5,6,7,8,10]) ,("9-10",[0,1,2,3,4,6,7,9,10]) ,("9-11",[0,1,2,3,5,6,7,9,10]) ,("9-12",[0,1,2,4,5,6,8,9,10]) ,("10-1",[0,1,2,3,4,5,6,7,8,9]) ,("10-2",[0,1,2,3,4,5,6,7,8,10]) ,("10-3",[0,1,2,3,4,5,6,7,9,10]) ,("10-4",[0,1,2,3,4,5,6,8,9,10]) ,("10-5",[0,1,2,3,4,5,7,8,9,10]) ,("10-6",[0,1,2,3,4,6,7,8,9,10]) ,("11-1",[0,1,2,3,4,5,6,7,8,9,10]) ,("12-1",[0,1,2,3,4,5,6,7,8,9,10,11])] -- | Lookup a set-class name. The input set is subject to -- 'forte_prime' before lookup. -- -- > sc_name [0,2,3,6,7] == "5-Z18" -- > sc_name [0,1,4,6,7,8] == "6-Z17" sc_name :: [Z12] -> SC_Name sc_name p = let n = find (\(_,q) -> forte_prime p == q) sc_table in fst (fromMaybe (error "sc_name") n) -- | Lookup a set-class given a set-class name. -- -- > sc "6-Z17" == [0,1,2,4,7,8] sc :: SC_Name -> [Z12] sc n = snd (fromMaybe (error "sc") (find (\(m,_) -> n == m) sc_table)) {- | List of set classes (the set class universe). > let r = [("0-1",[0,0,0,0,0,0]) > ,("1-1",[0,0,0,0,0,0]) > ,("2-1",[1,0,0,0,0,0]) > ,("2-2",[0,1,0,0,0,0]) > ,("2-3",[0,0,1,0,0,0]) > ,("2-4",[0,0,0,1,0,0]) > ,("2-5",[0,0,0,0,1,0]) > ,("2-6",[0,0,0,0,0,1]) > ,("3-1",[2,1,0,0,0,0]) > ,("3-2",[1,1,1,0,0,0]) > ,("3-3",[1,0,1,1,0,0]) > ,("3-4",[1,0,0,1,1,0]) > ,("3-5",[1,0,0,0,1,1]) > ,("3-6",[0,2,0,1,0,0]) > ,("3-7",[0,1,1,0,1,0]) > ,("3-8",[0,1,0,1,0,1]) > ,("3-9",[0,1,0,0,2,0]) > ,("3-10",[0,0,2,0,0,1]) > ,("3-11",[0,0,1,1,1,0]) > ,("3-12",[0,0,0,3,0,0]) > ,("4-1",[3,2,1,0,0,0]) > ,("4-2",[2,2,1,1,0,0]) > ,("4-3",[2,1,2,1,0,0]) > ,("4-4",[2,1,1,1,1,0]) > ,("4-5",[2,1,0,1,1,1]) > ,("4-6",[2,1,0,0,2,1]) > ,("4-7",[2,0,1,2,1,0]) > ,("4-8",[2,0,0,1,2,1]) > ,("4-9",[2,0,0,0,2,2]) > ,("4-10",[1,2,2,0,1,0]) > ,("4-11",[1,2,1,1,1,0]) > ,("4-12",[1,1,2,1,0,1]) > ,("4-13",[1,1,2,0,1,1]) > ,("4-14",[1,1,1,1,2,0]) > ,("4-Z15",[1,1,1,1,1,1]) > ,("4-16",[1,1,0,1,2,1]) > ,("4-17",[1,0,2,2,1,0]) > ,("4-18",[1,0,2,1,1,1]) > ,("4-19",[1,0,1,3,1,0]) > ,("4-20",[1,0,1,2,2,0]) > ,("4-21",[0,3,0,2,0,1]) > ,("4-22",[0,2,1,1,2,0]) > ,("4-23",[0,2,1,0,3,0]) > ,("4-24",[0,2,0,3,0,1]) > ,("4-25",[0,2,0,2,0,2]) > ,("4-26",[0,1,2,1,2,0]) > ,("4-27",[0,1,2,1,1,1]) > ,("4-28",[0,0,4,0,0,2]) > ,("4-Z29",[1,1,1,1,1,1]) > ,("5-1",[4,3,2,1,0,0]) > ,("5-2",[3,3,2,1,1,0]) > ,("5-3",[3,2,2,2,1,0]) > ,("5-4",[3,2,2,1,1,1]) > ,("5-5",[3,2,1,1,2,1]) > ,("5-6",[3,1,1,2,2,1]) > ,("5-7",[3,1,0,1,3,2]) > ,("5-8",[2,3,2,2,0,1]) > ,("5-9",[2,3,1,2,1,1]) > ,("5-10",[2,2,3,1,1,1]) > ,("5-11",[2,2,2,2,2,0]) > ,("5-Z12",[2,2,2,1,2,1]) > ,("5-13",[2,2,1,3,1,1]) > ,("5-14",[2,2,1,1,3,1]) > ,("5-15",[2,2,0,2,2,2]) > ,("5-16",[2,1,3,2,1,1]) > ,("5-Z17",[2,1,2,3,2,0]) > ,("5-Z18",[2,1,2,2,2,1]) > ,("5-19",[2,1,2,1,2,2]) > ,("5-20",[2,1,1,2,3,1]) > ,("5-21",[2,0,2,4,2,0]) > ,("5-22",[2,0,2,3,2,1]) > ,("5-23",[1,3,2,1,3,0]) > ,("5-24",[1,3,1,2,2,1]) > ,("5-25",[1,2,3,1,2,1]) > ,("5-26",[1,2,2,3,1,1]) > ,("5-27",[1,2,2,2,3,0]) > ,("5-28",[1,2,2,2,1,2]) > ,("5-29",[1,2,2,1,3,1]) > ,("5-30",[1,2,1,3,2,1]) > ,("5-31",[1,1,4,1,1,2]) > ,("5-32",[1,1,3,2,2,1]) > ,("5-33",[0,4,0,4,0,2]) > ,("5-34",[0,3,2,2,2,1]) > ,("5-35",[0,3,2,1,4,0]) > ,("5-Z36",[2,2,2,1,2,1]) > ,("5-Z37",[2,1,2,3,2,0]) > ,("5-Z38",[2,1,2,2,2,1]) > ,("6-1",[5,4,3,2,1,0]) > ,("6-2",[4,4,3,2,1,1]) > ,("6-Z3",[4,3,3,2,2,1]) > ,("6-Z4",[4,3,2,3,2,1]) > ,("6-5",[4,2,2,2,3,2]) > ,("6-Z6",[4,2,1,2,4,2]) > ,("6-7",[4,2,0,2,4,3]) > ,("6-8",[3,4,3,2,3,0]) > ,("6-9",[3,4,2,2,3,1]) > ,("6-Z10",[3,3,3,3,2,1]) > ,("6-Z11",[3,3,3,2,3,1]) > ,("6-Z12",[3,3,2,2,3,2]) > ,("6-Z13",[3,2,4,2,2,2]) > ,("6-14",[3,2,3,4,3,0]) > ,("6-15",[3,2,3,4,2,1]) > ,("6-16",[3,2,2,4,3,1]) > ,("6-Z17",[3,2,2,3,3,2]) > ,("6-18",[3,2,2,2,4,2]) > ,("6-Z19",[3,1,3,4,3,1]) > ,("6-20",[3,0,3,6,3,0]) > ,("6-21",[2,4,2,4,1,2]) > ,("6-22",[2,4,1,4,2,2]) > ,("6-Z23",[2,3,4,2,2,2]) > ,("6-Z24",[2,3,3,3,3,1]) > ,("6-Z25",[2,3,3,2,4,1]) > ,("6-Z26",[2,3,2,3,4,1]) > ,("6-27",[2,2,5,2,2,2]) > ,("6-Z28",[2,2,4,3,2,2]) > ,("6-Z29",[2,2,4,2,3,2]) > ,("6-30",[2,2,4,2,2,3]) > ,("6-31",[2,2,3,4,3,1]) > ,("6-32",[1,4,3,2,5,0]) > ,("6-33",[1,4,3,2,4,1]) > ,("6-34",[1,4,2,4,2,2]) > ,("6-35",[0,6,0,6,0,3]) > ,("6-Z36",[4,3,3,2,2,1]) > ,("6-Z37",[4,3,2,3,2,1]) > ,("6-Z38",[4,2,1,2,4,2]) > ,("6-Z39",[3,3,3,3,2,1]) > ,("6-Z40",[3,3,3,2,3,1]) > ,("6-Z41",[3,3,2,2,3,2]) > ,("6-Z42",[3,2,4,2,2,2]) > ,("6-Z43",[3,2,2,3,3,2]) > ,("6-Z44",[3,1,3,4,3,1]) > ,("6-Z45",[2,3,4,2,2,2]) > ,("6-Z46",[2,3,3,3,3,1]) > ,("6-Z47",[2,3,3,2,4,1]) > ,("6-Z48",[2,3,2,3,4,1]) > ,("6-Z49",[2,2,4,3,2,2]) > ,("6-Z50",[2,2,4,2,3,2]) > ,("7-1",[6,5,4,3,2,1]) > ,("7-2",[5,5,4,3,3,1]) > ,("7-3",[5,4,4,4,3,1]) > ,("7-4",[5,4,4,3,3,2]) > ,("7-5",[5,4,3,3,4,2]) > ,("7-6",[5,3,3,4,4,2]) > ,("7-7",[5,3,2,3,5,3]) > ,("7-8",[4,5,4,4,2,2]) > ,("7-9",[4,5,3,4,3,2]) > ,("7-10",[4,4,5,3,3,2]) > ,("7-11",[4,4,4,4,4,1]) > ,("7-Z12",[4,4,4,3,4,2]) > ,("7-13",[4,4,3,5,3,2]) > ,("7-14",[4,4,3,3,5,2]) > ,("7-15",[4,4,2,4,4,3]) > ,("7-16",[4,3,5,4,3,2]) > ,("7-Z17",[4,3,4,5,4,1]) > ,("7-Z18",[4,3,4,4,4,2]) > ,("7-19",[4,3,4,3,4,3]) > ,("7-20",[4,3,3,4,5,2]) > ,("7-21",[4,2,4,6,4,1]) > ,("7-22",[4,2,4,5,4,2]) > ,("7-23",[3,5,4,3,5,1]) > ,("7-24",[3,5,3,4,4,2]) > ,("7-25",[3,4,5,3,4,2]) > ,("7-26",[3,4,4,5,3,2]) > ,("7-27",[3,4,4,4,5,1]) > ,("7-28",[3,4,4,4,3,3]) > ,("7-29",[3,4,4,3,5,2]) > ,("7-30",[3,4,3,5,4,2]) > ,("7-31",[3,3,6,3,3,3]) > ,("7-32",[3,3,5,4,4,2]) > ,("7-33",[2,6,2,6,2,3]) > ,("7-34",[2,5,4,4,4,2]) > ,("7-35",[2,5,4,3,6,1]) > ,("7-Z36",[4,4,4,3,4,2]) > ,("7-Z37",[4,3,4,5,4,1]) > ,("7-Z38",[4,3,4,4,4,2]) > ,("8-1",[7,6,5,4,4,2]) > ,("8-2",[6,6,5,5,4,2]) > ,("8-3",[6,5,6,5,4,2]) > ,("8-4",[6,5,5,5,5,2]) > ,("8-5",[6,5,4,5,5,3]) > ,("8-6",[6,5,4,4,6,3]) > ,("8-7",[6,4,5,6,5,2]) > ,("8-8",[6,4,4,5,6,3]) > ,("8-9",[6,4,4,4,6,4]) > ,("8-10",[5,6,6,4,5,2]) > ,("8-11",[5,6,5,5,5,2]) > ,("8-12",[5,5,6,5,4,3]) > ,("8-13",[5,5,6,4,5,3]) > ,("8-14",[5,5,5,5,6,2]) > ,("8-Z15",[5,5,5,5,5,3]) > ,("8-16",[5,5,4,5,6,3]) > ,("8-17",[5,4,6,6,5,2]) > ,("8-18",[5,4,6,5,5,3]) > ,("8-19",[5,4,5,7,5,2]) > ,("8-20",[5,4,5,6,6,2]) > ,("8-21",[4,7,4,6,4,3]) > ,("8-22",[4,6,5,5,6,2]) > ,("8-23",[4,6,5,4,7,2]) > ,("8-24",[4,6,4,7,4,3]) > ,("8-25",[4,6,4,6,4,4]) > ,("8-26",[4,5,6,5,6,2]) > ,("8-27",[4,5,6,5,5,3]) > ,("8-28",[4,4,8,4,4,4]) > ,("8-Z29",[5,5,5,5,5,3]) > ,("9-1",[8,7,6,6,6,3]) > ,("9-2",[7,7,7,6,6,3]) > ,("9-3",[7,6,7,7,6,3]) > ,("9-4",[7,6,6,7,7,3]) > ,("9-5",[7,6,6,6,7,4]) > ,("9-6",[6,8,6,7,6,3]) > ,("9-7",[6,7,7,6,7,3]) > ,("9-8",[6,7,6,7,6,4]) > ,("9-9",[6,7,6,6,8,3]) > ,("9-10",[6,6,8,6,6,4]) > ,("9-11",[6,6,7,7,7,3]) > ,("9-12",[6,6,6,9,6,3]) > ,("10-1",[9,8,8,8,8,4]) > ,("10-2",[8,9,8,8,8,4]) > ,("10-3",[8,8,9,8,8,4]) > ,("10-4",[8,8,8,9,8,4]) > ,("10-5",[8,8,8,8,9,4]) > ,("10-6",[8,8,8,8,8,5]) > ,("11-1",[10,10,10,10,10,5]) > ,("12-1",[12,12,12,12,12,6])] > in let icvs = map icv scs in zip (map sc_name scs) icvs == r -} scs :: [[Z12]] scs = map snd sc_table -- | Cardinality /n/ subset of 'scs'. -- -- > map (length . scs_n) [1..11] == [1,6,12,29,38,50,38,29,12,6,1] scs_n :: Integral i => i -> [[Z12]] scs_n n = filter ((== n) . genericLength) scs -- * BIP Metric -- | Basic interval pattern, see Allen Forte \"The Basic Interval Patterns\" -- /JMT/ 17/2 (1973):234-272 -- -- >>> bip 0t95728e3416 -- 11223344556 -- -- > bip [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6] -- > bip (pco "0t95728e3416") == [1,1,2,2,3,3,4,4,5,5,6] bip :: [Z12] -> [Z12] bip = Z.bip z12_modulo -- * ICV Metric -- | Interval class of Z12 interval /i/. -- -- > map ic [5,6,7] == [5,6,5] -- > map ic [-13,-1,0,1,13] == [1,1,0,1,1] ic :: Z12 -> Z12 ic = Z.ic z12_modulo -- | Forte notation for interval class vector. -- -- > icv [0,1,2,4,7,8] == [3,2,2,3,3,2] icv :: Integral i => [Z12] -> [i] icv = Z.icv z12_modulo hmt-0.15/Music/Theory/Z12/Rahn_1980.hs0000644000000000000000000000143612416136065015240 0ustar0000000000000000-- | John Rahn. /Basic Atonal Theory/. Longman, New York, 1980. module Music.Theory.Z12.Rahn_1980 where import Music.Theory.Z12 import qualified Music.Theory.Z.Forte_1973 as Z -- | Rahn prime form (comparison is rightmost inwards). -- -- > rahn_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == GT rahn_cmp :: Ord a => [a] -> [a] -> Ordering rahn_cmp p q = compare (reverse p) (reverse q) -- | Rahn prime form, ie. 'ti_cmp_prime' of 'rahn_cmp'. -- -- > rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] -- -- > import Music.Theory.Z12.Forte_1973 -- -- > let s = [[0,1,3,7,8] -- > ,[0,1,3,6,8,9],[0,1,3,5,8,9] -- > ,[0,1,2,4,7,8,9] -- > ,[0,1,2,4,5,7,9,10]] -- > in all (\p -> forte_prime p /= rahn_prime p) s == True rahn_prime :: [Z12] -> [Z12] rahn_prime = Z.ti_cmp_prime z12_modulo rahn_cmp hmt-0.15/Music/Theory/Z12/Read_1978.hs0000644000000000000000000000147212416136065015232 0ustar0000000000000000-- | Ronald C. Read. \"Every one a winner or how to avoid isomorphism -- search when cataloguing combinatorial configurations.\" /Annals of -- Discrete Mathematics/ 2:107–20, 1978. module Music.Theory.Z12.Read_1978 where import Music.Theory.Z12 {- hmt -} import qualified Music.Theory.Z.Read_1978 as Z {- hmt -} type Code = Z.Code -- | Encoder for 'encode_prime'. -- -- > encode [0,1,3,6,8,9] == 843 encode :: [Z12] -> Code encode = Z.encode -- | Decoder for 'encode_prime'. -- -- > decode 843 == [0,1,3,6,8,9] decode :: Code -> [Z12] decode = Z.decode 12 -- | Binary encoding prime form algorithm, equalivalent to Rahn. -- -- > encode_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] -- > Music.Theory.Z12.Rahn_1980.rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] encode_prime :: [Z12] -> [Z12] encode_prime = Z.encode_prime z12_modulo hmt-0.15/Music/Theory/Z12/Drape_1999.hs0000644000000000000000000001757512416136065015430 0ustar0000000000000000-- | Haskell implementations of @pct@ operations. -- See . module Music.Theory.Z12.Drape_1999 where import Data.Function {- base -} import Data.List {- base -} import Data.Maybe {- base -} import qualified Music.Theory.List as T import qualified Music.Theory.Set.List as T import Music.Theory.Z12 import qualified Music.Theory.Z12.Forte_1973 as T import qualified Music.Theory.Z12.Morris_1987 as T import qualified Music.Theory.Z12.TTO as TTO import qualified Music.Theory.Z12.SRO as SRO -- | Cardinality filter -- -- > cf [0,3] (cg [1..4]) == [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[]] cf :: (Integral n) => [n] -> [[a]] -> [[a]] cf ns = filter (\p -> genericLength p `elem` ns) -- | Combinatorial sets formed by considering each set as possible -- values for slot. -- -- > cgg [[0,1],[5,7],[3]] == [[0,5,3],[0,7,3],[1,5,3],[1,7,3]] cgg :: [[a]] -> [[a]] cgg l = case l of x:xs -> [ y:z | y <- x, z <- cgg xs ] _ -> [[]] -- | Combinations generator, ie. synonym for 'T.powerset'. -- -- > sort (cg [0,1,3]) == [[],[0],[0,1],[0,1,3],[0,3],[1],[1,3],[3]] cg :: [a] -> [[a]] cg = T.powerset -- | Powerset filtered by cardinality. -- -- >>> cg -r3 0159 -- 015 -- 019 -- 059 -- 159 -- -- > cg_r 3 [0,1,5,9] == [[0,1,5],[0,1,9],[0,5,9],[1,5,9]] cg_r :: (Integral n) => n -> [a] -> [[a]] cg_r n = cf [n] . cg -- | Cyclic interval segment. ciseg :: [Z12] -> [Z12] ciseg = T.int . cyc -- | Synonynm for 'complement'. -- -- >>> cmpl 02468t -- 13579B -- -- > cmpl [0,2,4,6,8,10] == [1,3,5,7,9,11] cmpl :: [Z12] -> [Z12] cmpl = complement -- | Form cycle. -- -- >>> cyc 056 -- 0560 -- -- > cyc [0,5,6] == [0,5,6,0] cyc :: [a] -> [a] cyc l = case l of [] -> [] x:xs -> (x:xs) ++ [x] -- | Diatonic set name. 'd' for diatonic set, 'm' for melodic minor -- set, 'o' for octotonic set. d_nm :: (Integral a) => [a] -> Maybe Char d_nm x = case x of [0,2,4,5,7,9,11] -> Just 'd' [0,2,3,5,7,9,11] -> Just 'm' [0,1,3,4,6,7,9,10] -> Just 'o' _ -> Nothing -- | Diatonic implications. dim :: [Z12] -> [(Z12,[Z12])] dim p = let g (i,q) = T.is_subset p (TTO.tn i q) f = filter g . zip [0..11] . repeat d = [0,2,4,5,7,9,11] m = [0,2,3,5,7,9,11] o = [0,1,3,4,6,7,9,10] in f d ++ f m ++ f o -- | Variant of 'dim' that is closer to the 'pct' form. -- -- >>> dim 016 -- T1d -- T1m -- T0o -- -- > dim_nm [0,1,6] == [(1,'d'),(1,'m'),(0,'o')] dim_nm :: [Z12] -> [(Z12,Char)] dim_nm = let pk f (i,j) = (i,f j) in nubBy ((==) `on` snd) . map (pk (fromMaybe (error "dim_mn") . 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 (T.sc "7-35") [0,1,2,3,4] == [[1,3,5,6,8,10,11]] doi :: Int -> [Z12] -> [Z12] -> [[Z12]] doi n p q = let f j = [TTO.tn j p,TTO.tni j p] xs = concatMap f [0..11] in T.set (filter (\x -> length (x `intersect` q) == n) xs) -- | Forte name. fn :: [Z12] -> String fn = T.sc_name -- | p `has_ess` q is true iff p can embed q in sequence. has_ess :: [Z12] -> [Z12] -> Bool has_ess _ [] = True has_ess [] _ = False has_ess (p:ps) (q:qs) = if p == q then has_ess ps qs else has_ess ps (q:qs) -- | Embedded segment search. -- -- >>> echo 23a | ess 0164325 -- 2B013A9 -- 923507A -- -- > ess [2,3,10] [0,1,6,4,3,2,5] == [[9,2,3,5,0,7,10],[2,11,0,1,3,10,9]] ess :: [Z12] -> [Z12] -> [[Z12]] ess p = filter (`has_ess` p) . SRO.rtmi_related -- | Can the set-class q (under prime form algorithm pf) be -- drawn from the pcset p. has_sc_pf :: (Integral a) => ([a] -> [a]) -> [a] -> [a] -> Bool has_sc_pf pf p q = let n = length q in q `elem` map pf (cf [n] (cg p)) -- | Can the set-class q be drawn from the pcset p. has_sc :: [Z12] -> [Z12] -> Bool has_sc = has_sc_pf T.forte_prime -- | Interval cycle filter. -- -- >>> echo 22341 | icf -- 22341 -- -- > icf [[2,2,3,4,1]] == [[2,2,3,4,1]] icf :: (Num a,Eq a) => [[a]] -> [[a]] icf = filter ((== 12) . sum) -- | Interval class set to interval sets. -- -- >>> ici -c 123 -- 123 -- 129 -- 1A3 -- 1A9 -- -- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]] ici :: (Num t) => [Int] -> [[t]] ici xs = let is j = [[0], [1,11], [2,10], [3,9], [4,8], [5,7], [6]] !! j ys = map is xs in cgg ys -- | Interval class set to interval sets, concise variant. -- -- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]] ici_c :: [Int] -> [[Int]] ici_c [] = [] ici_c (x:xs) = map (x:) (ici xs) -- | Interval-class segment. -- -- >>> icseg 013265e497t8 -- 12141655232 -- -- > icseg [0,1,3,2,6,5,11,4,9,7,10,8] == [1,2,1,4,1,6,5,5,2,3,2] icseg :: [Z12] -> [Z12] icseg = map T.ic . iseg -- | Interval segment (INT). iseg :: [Z12] -> [Z12] iseg = T.int -- | Imbrications. imb :: (Integral n) => [n] -> [a] -> [[a]] imb cs p = let g n = (== n) . genericLength f ps n = filter (g n) (map (genericTake n) ps) in concatMap (f (tails p)) cs -- | 'issb' gives the set-classes that can append to 'p' to give 'q'. -- -- >>> issb 3-7 6-32 -- 3-7 -- 3-2 -- 3-11 -- -- > issb (T.sc "3-7") (T.sc "6-32") == ["3-2","3-7","3-11"] issb :: [Z12] -> [Z12] -> [String] issb p q = let k = length q - length p f = any id . map (\x -> T.forte_prime (p ++ x) == q) . TTO.ti_related in map T.sc_name (filter f (cf [k] T.scs)) -- | Matrix search. -- -- >>> mxs 024579 642 | sort -u -- 6421B9 -- B97642 -- -- > T.set (mxs [0,2,4,5,7,9] [6,4,2]) == [[6,4,2,1,11,9],[11,9,7,6,4,2]] mxs :: [Z12] -> [Z12] -> [[Z12]] mxs p q = filter (q `isInfixOf`) (SRO.rti_related p) -- | Normalize. -- -- >>> nrm 0123456543210 -- 0123456 -- -- > nrm [0,1,2,3,4,5,6,5,4,3,2,1,0] == [0,1,2,3,4,5,6] nrm :: (Ord a) => [a] -> [a] nrm = T.set -- | Normalize, retain duplicate elements. nrm_r :: (Ord a) => [a] -> [a] nrm_r = sort -- | Pitch-class invariances (called @pi@ at @pct@). -- -- >>> pi 0236 12 -- 0236 -- 6320 -- 532B -- B235 -- -- > pci [0,2,3,6] [1,2] == [[0,2,3,6],[5,3,2,11],[6,3,2,0],[11,2,3,5]] pci :: [Z12] -> [Z12] -> [[Z12]] pci p i = let f q = T.set (map (q `genericIndex`) i) in filter (\q -> f q == f p) (SRO.rti_related p) -- | Relate sets. -- -- >>> rs 0123 641e -- T1M -- -- > import Music.Theory.Z12.Morris_1987.Parse -- > rs [0,1,2,3] [6,4,1,11] == [(rnrtnmi "T1M",[1,6,11,4]) -- > ,(rnrtnmi "T4MI",[4,11,6,1])] rs :: [Z12] -> [Z12] -> [(T.SRO, [Z12])] rs x y = let xs = map (\o -> (o, o `T.sro` x)) T.sro_TnMI q = T.set y in filter (\(_,p) -> T.set p == q) xs -- | Relate segments. -- -- >>> rsg 156 3BA -- T4I -- -- > rsg [1,5,6] [3,11,10] == [rnrtnmi "T4I",rnrtnmi "r1RT4MI"] -- -- >>> rsg 0123 05t3 -- T0M -- -- > rsg [0,1,2,3] [0,5,10,3] == [rnrtnmi "T0M",rnrtnmi "RT3MI"] -- -- >>> rsg 0123 4e61 -- RT1M -- -- > rsg [0,1,2,3] [4,11,6,1] == [rnrtnmi "T4MI",rnrtnmi "RT1M"] -- -- >>> echo e614 | rsg 0123 -- r3RT1M -- -- > rsg [0,1,2,3] [11,6,1,4] == [rnrtnmi "r1T4MI",rnrtnmi "r1RT1M"] -- rsg :: [Z12] -> [Z12] -> [T.SRO] rsg x y = map fst (filter (\(_,x') -> x' == y) (T.sros x)) -- | Subsets. sb :: [[Z12]] -> [[Z12]] sb xs = let f p = all id (map (`has_sc` p) xs) in filter f T.scs -- | Super set-class. -- -- >>> spsc 4-11 4-12 -- 5-26[02458] -- -- > spsc [T.sc "4-11",T.sc "4-12"] == ["5-26"] -- -- >>> spsc 3-11 3-8 -- 4-27[0258] -- 4-Z29[0137] -- -- > spsc [T.sc "3-11",T.sc "3-8"] == ["4-27","4-Z29"] -- -- >>> spsc `fl 3` -- 6-Z17[012478] -- -- > spsc (cf [3] T.scs) == ["6-Z17"] spsc :: [[Z12]] -> [String] spsc xs = let f y = all (y `has_sc`) xs g = (==) `on` length in (map T.sc_name . head . groupBy g . filter f) T.scs hmt-0.15/Music/Theory/Z12/Literature.hs0000644000000000000000000000427012416136065016006 0ustar0000000000000000-- | Z12 set class database. module Music.Theory.Z12.Literature where -- | Set class database with descriptors for historically and -- theoretically significant set classes, indexed by Forte name. -- -- > lookup "6-Z17" sc_db == Just "All-Trichord Hexachord" -- > lookup "7-35" sc_db == Just "diatonic collection (d)" sc_db :: [(String,String)] sc_db = [("4-Z15","All-Interval Tetrachord (see also 4-Z29)") ,("4-Z29","All-Interval Tetrachord (see also 4-Z15)") ,("6-Z17","All-Trichord Hexachord") ,("8-Z15","All-Tetrachord Octochord (see also 8-Z29)") ,("8-Z29","All-Tetrachord Octochord (see also 8-Z15)") ,("6-1","A-Type All-Combinatorial Hexachord") ,("6-8","B-Type All-Combinatorial Hexachord") ,("6-32","C-Type All-Combinatorial Hexachord") ,("6-7","D-Type All-Combinatorial Hexachord") ,("6-20","E-Type All-Combinatorial Hexachord") ,("6-35","F-Type All-Combinatorial Hexachord") ,("7-35","diatonic collection (d)") ,("7-34","ascending melodic minor collection") ,("8-28","octotonic collection (Messiaen Mode II)") ,("6-35","wholetone collection") ,("3-10","diminished triad") ,("3-11","major/minor triad") ,("3-12","augmented triad") ,("4-19","minor major-seventh chord") ,("4-20","major-seventh chord") ,("4-25","french augmented sixth chord") ,("4-28","dimished-seventh chord") ,("4-26","minor-seventh chord") ,("4-27","half-dimished seventh(P)/dominant-seventh(I) chord") ,("6-30","Petrushka Chord {0476a1},3-11 at T6") ,("6-34","Mystic Chord {06a492}") ,("6-Z44","Schoenberg Signature Set,3-3 at T5 or T7") ,("6-Z19","complement of 6-Z44,3-11 at T1 or TB") ,("9-12","Messiaen Mode III (nontonic collection)") ,("8-9","Messian Mode IV") ,("7-31","The only seven-element subset of 8-28. ") ,("5-31","The only five-element superset of 4-28.") ,("5-33","The only five-element subset of 6-35.") ,("7-33","The only seven-element superset of 6-35.") ,("5-21","The only five-element subset of 6-20.") ,("7-21","The only seven-element superset of 6-20.") ,("5-25","The only five-element subset of both 7-35 and 8-28.") ,("6-14","Any non-intersecting union of 3-6 and 3-12.") ] hmt-0.15/Music/Theory/Z12/TTO.hs0000644000000000000000000000257412416136065014341 0ustar0000000000000000-- | Pitch-class set (unordered) operations on 'Z12'. module Music.Theory.Z12.TTO where import Data.List import Music.Theory.Z12 -- | Map to pitch-class and reduce to set. -- -- > pcset [1,13] == [1] pcset :: (Integral a) => [a] -> [Z12] pcset = nub . sort . map fromIntegral -- | Transpose by n. -- -- > tn 4 [1,5,6] == [5,9,10] -- > tn 4 [0,4,8] == [0,4,8] tn :: Z12 -> [Z12] -> [Z12] tn n = sort . map (+ n) -- | Invert about n. -- -- > invert 6 [4,5,6] == [6,7,8] -- > invert 0 [0,1,3] == [0,9,11] invert :: Z12 -> [Z12] -> [Z12] invert n = sort . map (\p -> n - (p - n)) -- | Composition of 'invert' about @0@ and 'tn'. -- -- > tni 4 [1,5,6] == [3,10,11] -- > (invert 0 . tn 4) [1,5,6] == [2,3,7] tni :: Z12 -> [Z12] -> [Z12] tni n = tn n . invert 0 -- | Modulo 12 multiplication -- -- > mn 11 [0,1,4,9] == invert 0 [0,1,4,9] mn :: Z12 -> [Z12] -> [Z12] mn n = sort . map (* n) -- | M5, ie. 'mn' @5@. -- -- > m5 [0,1,3] == [0,3,5] m5 :: [Z12] -> [Z12] m5 = mn 5 -- | T-related sets of /p/. -- -- > length (t_related [0,1,3]) == 12 -- > t_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]] t_related :: [Z12] -> [[Z12]] t_related p = nub (map (`tn` p) [0..11]) -- | T\/I-related set of /p/. -- -- > length (ti_related [0,1,3]) == 24 -- > ti_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]] ti_related :: [Z12] -> [[Z12]] ti_related p = nub (t_related p ++ t_related (invert 0 p)) hmt-0.15/Music/Theory/Z12/Lewin_1980.hs0000644000000000000000000000266412416136065015432 0ustar0000000000000000-- | David Lewin. \"A Response to a Response: On PC Set -- Relatedness\". /Perspectives of New Music/, 18(1-2):498-502, 1980. module Music.Theory.Z12.Lewin_1980 where import Data.List import Music.Theory.Z12 import qualified Music.Theory.Z12.Castren_1994 as C -- | REL function with given /ncv/ function (see 't_rel' and 'ti_rel'). rel :: Floating n => (Int -> [a] -> [n]) -> [a] -> [a] -> n rel ncv x y = let n = min (genericLength x) (genericLength y) p = map (`ncv` x) [2..n] q = map (`ncv` y) [2..n] f = zipWith (\i j -> sqrt (i * j)) pt = sum (map sum p) qt = sum (map sum q) in sum (map sum (zipWith f p q)) / sqrt (pt * qt) -- | T-equivalence REL function. -- -- Kuusi 2001, 7.5.2 -- -- > let (~=) p q = abs (p - q) < 1e-2 -- > t_rel [0,1,2,3,4] [0,2,3,6,7] ~= 0.44 -- > t_rel [0,1,2,3,4] [0,2,4,6,8] ~= 0.28 -- > t_rel [0,2,3,6,7] [0,2,4,6,8] ~= 0.31 t_rel :: Floating n => [Z12] -> [Z12] -> n t_rel = rel C.t_n_class_vector -- | T/I-equivalence REL function. -- -- Buchler 1998, Fig. 3.38 -- -- > let (~=) p q = abs (p - q) < 1e-3 -- > let a = [0,2,3,5,7]::[Z12] -- > let b = [0,2,3,4,5,8]::[Z12] -- > let g = [0,1,2,3,5,6,8,10]::[Z12] -- > let j = [0,2,3,4,5,6,8]::[Z12] -- > ti_rel a b ~= 0.593 -- > ti_rel a g ~= 0.648 -- > ti_rel a j ~= 0.509 -- > ti_rel b g ~= 0.712 -- > ti_rel b j ~= 0.892 -- > ti_rel g j ~= 0.707 ti_rel :: Floating n => [Z12] -> [Z12] -> n ti_rel = rel C.ti_n_class_vector hmt-0.15/Music/Theory/Z12/Morris_1987/0000755000000000000000000000000012416136065015272 5ustar0000000000000000hmt-0.15/Music/Theory/Z12/Morris_1987/Parse.hs0000644000000000000000000000312012416136065016674 0ustar0000000000000000-- | Parsers for pitch class sets and sequences, and for 'SRO's. module Music.Theory.Z12.Morris_1987.Parse (rnrtnmi,pco) where import Control.Monad {- base -} import Data.Char {- base -} import Text.ParserCombinators.Parsec {- parsec -} import Music.Theory.Z12 import Music.Theory.Z12.Morris_1987 -- | A 'Char' parser. type P a = GenParser Char () a -- | Boolean 'P' for given 'Char'. is_char :: Char -> P Bool is_char c = let f '_' = False f _ = True in liftM f (option '_' (char c)) -- | Parse 'Int'. get_int :: P Z12 get_int = liftM (fromInteger . read) (many1 digit) -- | Parse a Morris format serial operator descriptor. -- -- > rnrtnmi "r2RT3MI" == SRO 2 True 3 True True rnrtnmi :: String -> SRO rnrtnmi s = let p = do r <- rot r' <- is_char 'R' _ <- char 'T' t <- get_int m <- is_char 'M' i <- is_char 'I' eof return (SRO r r' t m i) rot = option 0 (char 'r' >> get_int) in either (\e -> error ("rnRTnMI parse failed\n" ++ show e)) id (parse p "" s) -- | Parse a /pitch class object/ string. Each 'Char' is either a -- number, a space which is ignored, or a letter name for the numbers -- 10 ('t' or 'a' or 'A') or 11 ('e' or 'B' or 'b'). -- -- > pco "13te" == [1,3,10,11] -- > pco "13te" == pco "13ab" pco :: String -> [Z12] pco s = let s' = dropWhile isSpace s s'' = takeWhile (`elem` "0123456789taAebB") s' f c | c `elem` "taA" = 10 | c `elem` "ebB" = 11 | otherwise = fromInteger (read [c]) in map f s'' hmt-0.15/Music/Theory/Tiling/0000755000000000000000000000000012416136065014201 5ustar0000000000000000hmt-0.15/Music/Theory/Tiling/Canon.hs0000644000000000000000000001437112416136065015601 0ustar0000000000000000module Music.Theory.Tiling.Canon where import Control.Monad.Logic {- logict -} import Data.Function {- base -} import Data.List {- base -} import Data.List.Split {- split -} import Text.Printf {- base -} -- | Sequence. type S = [Int] -- | Canon of /(period,sequence,multipliers,displacements)/. type R = (Int,S,[Int],[Int]) -- | Voice. type V = [Int] -- | Tiling (sequence) type T = [[Int]] -- | Cycle at /period/. -- -- > take 9 (p_cycle 18 [0,2,5]) == [0,2,5,18,20,23,36,38,41] p_cycle :: Int -> [Int] -> [Int] p_cycle n s = s ++ p_cycle n (map (+ n) s) -- | Element of /(sequence,multiplier,displacement)/. type E = (S,Int,Int) -- | Resolve sequence from 'E'. -- -- > e_to_seq ([0,2,5],2,1) == [1,5,11] -- > e_to_seq ([0,1],3,4) == [4,7] -- > e_to_seq ([0],1,2) == [2] e_to_seq :: E -> [Int] e_to_seq (s,m,o) = map ((+ o) . (* m)) s -- | Infer 'E' from sequence. -- -- > e_from_seq [1,5,11] == ([0,2,5],2,1) -- > e_from_seq [4,7] == ([0,1],3,4) -- > e_from_seq [2] == ([0],1,2) e_from_seq :: [Int] -> E e_from_seq p = let i:_ = p q = map (+ negate i) p _:r = q n = if null r then 1 else foldl1 gcd r in (map (`div` n) q,n,i) -- | Set of 'V' from 'R'. r_voices :: R -> [V] r_voices (p,s,m,o) = let f i j = p_cycle p (e_to_seq (s,i,j)) in zipWith f m o -- | 'concatMap' of 'r_voices'. rr_voices :: [R] -> [V] rr_voices = concatMap r_voices -- | Retrograde of 'T', the result 'T' is sorted. -- -- > let r = [[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]] -- > in t_retrograde [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r t_retrograde :: T -> T t_retrograde t = let n = maximum (concat t) in sort (map (reverse . map (n -)) t) -- | The normal form of 'T' is the 'min' of /t/ and it's 't_retrograde'. -- -- > let r = [[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]] -- > in t_normal [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r t_normal :: T -> T t_normal t = min t (t_retrograde t) -- | Derive set of 'R' from 'T'. -- -- > let {r = [(21,[0,1,2],[10,8,2,4,7,5,1],[0,1,2,3,5,8,14])] -- > ;t = [[0,10,20],[1,9,17],[2,4,6],[3,7,11],[5,12,19],[8,13,18],[14,15,16]]} -- > in r_from_t t == r r_from_t :: T -> [R] r_from_t t = let e = map e_from_seq t n = maximum (concat t) + 1 t3_1 (i,_,_) = i f z = let (s:_,m,o) = unzip3 z in (n,s,m,o) in map f (groupBy ((==) `on` t3_1) e) -- * Construction -- | 'msum' '.' 'map' 'return'. -- -- > observeAll (fromList [1..7]) == [1..7] fromList :: MonadPlus m => [a] -> m a fromList = msum . map return -- | Search for /perfect/ tilings of the sequence 'S' using -- multipliers from /m/ to degree /n/ with /k/ parts. perfect_tilings_m :: MonadPlus m => [S] -> [Int] -> Int -> Int -> m T perfect_tilings_m s m n k = let rec p q = if length q == k then return (sort q) else do m' <- fromList m guard (m' `notElem` p) s' <- fromList s let i = n - (maximum s' * m') - 1 o <- fromList [0..i] let s'' = e_to_seq (s',m',o) q' = concat q guard (all (`notElem` q') s'') rec (m':p) (s'':q) in rec [] [] -- | 't_normal' of 'observeAll' of 'perfect_tilings_m'. -- -- > perfect_tilings [[0,1]] [1..3] 6 3 == [] -- -- > let r = [[[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]] -- > in perfect_tilings [[0,1,2]] [1,2,4,5,7] 15 5 == r -- -- > length (perfect_tilings [[0,1,2]] [1..12] 15 5) == 1 -- -- > let r = [[[0,1],[2,5],[3,7],[4,6]] -- > ,[[0,1],[2,6],[3,5],[4,7]] -- > ,[[0,2],[1,4],[3,7],[5,6]]] -- > in perfect_tilings [[0,1]] [1..4] 8 4 == r -- -- > let r = [[[0,1],[2,5],[3,7],[4,9],[6,8]] -- > ,[[0,1],[2,7],[3,5],[4,8],[6,9]] -- > ,[[0,2],[1,4],[3,8],[5,9],[6,7]] -- > ,[[0,2],[1,5],[3,6],[4,9],[7,8]] -- > ,[[0,3],[1,6],[2,4],[5,9],[7,8]]] -- > in perfect_tilings [[0,1]] [1..5] 10 5 == r -- -- Johnson 2004, p.2 -- -- > let r = [[0,6,12],[1,8,15],[2,11,20],[3,5,7],[4,9,14],[10,13,16],[17,18,19]] -- > in perfect_tilings [[0,1,2]] [1,2,3,5,6,7,9] 21 7 == [r] -- -- > let r = [[0,10,20],[1,9,17],[2,4,6],[3,7,11],[5,12,19],[8,13,18],[14,15,16]] -- > in perfect_tilings [[0,1,2]] [1,2,4,5,7,8,10] 21 7 == [t_retrograde r] perfect_tilings :: [S] -> [Int] -> Int -> Int -> [T] perfect_tilings s m n = nub . sort . map t_normal . observeAll . perfect_tilings_m s m n -- * Display -- | Variant of 'elem' for ordered sequences, which can therefore -- return 'False' when searching infinite sequences. -- -- > 5 `elemOrd` [0,2..] == False && 10 `elemOrd` [0,2..] == True elemOrd :: Ord a => a -> [a] -> Bool elemOrd i p = case p of [] -> False j:p' -> case compare j i of LT -> elemOrd i p' EQ -> True GT -> False -- | A @.*@ diagram of /n/ places of 'V'. -- -- > v_dot_star 18 [0,2..] == "*.*.*.*.*.*.*.*.*." v_dot_star :: Int -> V -> String v_dot_star n v = let f p i = if i `elemOrd` p then '*' else '.' in map (f v) [0..n-1] -- | A white space and index diagram of /n/ places of 'V'. -- -- >>> mapM_ (putStrLn . v_space_ix 9) [[0,2..],[1,3..]] -- > -- > 0 2 4 6 8 -- > 1 3 5 7 v_space_ix :: Int -> V -> String v_space_ix n v = let w = length (show n) nil = replicate w ' ' f p i = if i `elemOrd` p then printf "%*d" w i else nil in unwords (map (f v) [0..n-1]) -- | Insert @|@ every /n/ places. -- -- > with_bars 6 (v_dot_star 18 [0,2..]) == "*.*.*.|*.*.*.|*.*.*." with_bars :: Int -> String -> String with_bars m = intercalate "|" . chunksOf m -- | Variant with measure length /m/ and number of measures /n/. -- -- > v_dot_star_m 6 3 [0,2..] == "*.*.*.|*.*.*.|*.*.*." v_dot_star_m :: Int -> Int -> V -> String v_dot_star_m m n = with_bars m . v_dot_star (n * m) -- | Print @.*@ diagram. v_print :: Int -> [V] -> IO () v_print n = putStrLn . unlines . ("" :) . map (v_dot_star n) -- | Variant to print @|@ at measures. v_print_m :: Int -> Int -> [V] -> IO () v_print_m m n = putStrLn . unlines . ("" :) . map (v_dot_star_m m n) -- | Variant that discards first /k/ measures. v_print_m_from :: Int -> Int -> Int -> [V] -> IO () v_print_m_from k m n = let k' = k * m f = with_bars m . drop k' . v_dot_star (n * m + k') in putStrLn . unlines . ("" :) . map f hmt-0.15/Music/Theory/Tiling/Johnson_2004.hs0000644000000000000000000000316512416136065016625 0ustar0000000000000000-- | Tom Johnson. \"Perfect Rhythmic Tilings\". -- Technical report, IRCAM, 24 January 2004. MaMuX Lecture. module Music.Theory.Tiling.Johnson_2004 where import Music.Theory.Tiling.Canon -- | @{0,1,2}@ order 5, p.1 -- -- >>> v_print 15 (r_voices p1) -- > -- > ..***.......... -- > ........*.*.*.. -- > .....*...*...*. -- > .*....*....*... -- > *......*......* p1 :: R p1 = (15,[0,1,2],[1,2,4,5,7],[2,8,5,1,0]) -- | @{0,1,2}@ order 7, p.2 -- -- >>> v_print 21 (r_voices p2) -- > -- > ..............***.... -- > ..*.*.*.............. -- > ...*...*...*......... -- > ........*....*....*.. -- > .....*......*......*. -- > .*.......*.......*... -- > *.........*.........* p2 :: R p2 = (21,[0,1,2],[1,2,4,5,7,8,10],[14,2,3,8,5,1,0]) -- | @{0,1}@ order 4, p.3 -- -- >>> v_print 8 (r_voices p3) -- > -- > *...*... -- > .**..... -- > ...*..*. -- > .....*.* p3 :: R p3 = (8,[0,1],[4,1,3,2],[0,1,3,5]) -- | @{0,1}@ order 5, p.4 -- -- >>> mapM_ (v_print 10 . r_voices) p4 -- > -- > *...*..... -- > .**....... -- > ...*....*. -- > .....*.*.. -- > ......*..* -- > -- > *....*.... -- > .**....... -- > ...*..*... -- > ....*...*. -- > .......*.* -- > -- > *...*..... -- > .*....*... -- > ..**...... -- > .....*..*. -- > .......*.* p4 :: [R] p4 = [(10,[0,1],[4,1,5,2,3],[0,1,3,5,6]) ,(10,[0,1],[5,1,3,4,2],[0,1,3,4,7]) ,(10,[0,1],[4,5,1,3,2],[0,1,2,5,7])] -- | Open @{1,2,3}@ order 5, p.4 -- -- >>> v_print 18 (r_voices p4_b) -- > -- > ...***............ -- > ........*.*.*..... -- > .........*...*...* -- > .*....*....*...... -- > *......*......*... p4_b :: R p4_b = (21,[0,1,2],[1,2,4,5,7],[3,8,9,1,0]) -- Local Variables: -- truncate-lines:t -- End: hmt-0.15/Music/Theory/Tiling/Johnson_2009.hs0000644000000000000000000000456212416136065016634 0ustar0000000000000000-- | Tom Johnson. \"Tiling in my Music\". -- /The Experimental Music Yearbook/, 1, 2009. module Music.Theory.Tiling.Johnson_2009 where import Music.Theory.Tiling.Canon -- | Tilework for Clarinet, p.3 -- -- >>> v_print 36 (rr_voices p3) -- > -- > *.*..*............*.*..*............ -- > .*.*..*............*.*..*........... -- > ........*.*..*............*.*..*.... -- > ....*..*.*............*..*.*........ -- > ...........*..*.*............*..*.*. -- > ............*..*.*............*..*.* p3 :: [R] p3 = [(18,[0,2,5],[1,1,1],[0,1,8]) ,(18,[0,3,5],[1,1,1],[4,11,12])] -- | Tilework for String Quartet, p.5 -- -- >>> mapM_ (v_print 24 . r_voices) p5 -- > -- > ******......******...... -- > ......******......****** -- > -- > *.****.*....*.****.*.... -- > ......*.****.*....*.**** -- > -- > **.***..*...**.***..*... -- > ......**.***..*...**.*** -- > -- > *..***.**...*..***.**... -- > ......*..***.**...*..*** p5 :: [R] p5 = [(12,[0..5],[1,1],[0,6]) ,(12,[0,2,3,4,5,7],[1,1],[0,6]) ,(12,[0,1,3,4,5,8],[1,1],[0,6]) ,(12,[0,3,4,5,7,8],[1,1],[0,6])] -- | Extra Perfect (p.7) -- -- >>> v_print_m_from 18 6 6 (r_voices p7) -- > -- > **.*..|......|......|......|......|...... -- > ......|.*.*..|.*....|......|......|...... -- > ......|......|......|......|.*..*.|....*. -- > ......|......|...*..|.*....|...*..|...... -- > ......|......|....*.|...*..|......|.*.... -- > ......|*.....|*.....|......|*.....|...... -- > ....*.|......|......|*.....|......|...*.. -- > ......|......|......|....*.|......|*..... p7 :: R p7 = (36,[0,1,3],[1,2,3,4,5,6,7,8],[0,7,25,51,52,78,105,130]) -- | Tilework for Log Drums (2005), p.10 -- -- >>> v_print 18 (r_voices p10) -- > -- > *.*.*............. -- > .*...*...*........ -- > ...*...*...*...... -- > ......*...*...*... -- > ........*...*...*. -- > .............*.*.* p10 :: R p10 = (18,[0,1,2],[2,4,4,4,4,2],[0,1,3,6,8,13]) -- | Self-Similar Melodies (1996), p.11 -- -- >>> v_print_m 20 5 (r_voices p11) -- > -- > *.....*.....*..*..*.|....*.....*.....*...|..*..*..*.....*.....|*.....*.....*..*..*.|....*.....*.....*... -- > ....................|*.....*.....*..*..*.|....*.....*.....*...|..*..*..*.....*.....|*.....*.....*..*..*. -- > ....................|....................|*.....*.....*..*..*.|....*.....*.....*...|..*..*..*.....*..... p11 :: R p11 = (30,[0,6,12,15,18,24,30,36,42,45,48,54],[1,1,1],[0,20,40]) -- Local Variables: -- truncate-lines:t -- End: hmt-0.15/Music/Theory/Time/0000755000000000000000000000000012416136065013651 5ustar0000000000000000hmt-0.15/Music/Theory/Time/Duration.hs0000644000000000000000000001205012416136065015770 0ustar0000000000000000module Music.Theory.Time.Duration where import qualified Data.List.Split as S {- split -} import Text.Printf {- base -} -- | Duration stored as /hours/, /minutes/, /seconds/ and /milliseconds/. data Duration = Duration {hours :: Int ,minutes :: Int ,seconds :: Int ,milliseconds :: Int} deriving (Eq) -- | Convert fractional /seconds/ to integral /(seconds,milliseconds)/. -- -- > s_sms 1.75 == (1,750) s_sms :: (RealFrac n,Integral i) => n -> (i,i) s_sms s = let s' = floor s ms = round ((s - fromIntegral s') * 1000) in (s',ms) -- | Inverse of 's_sms'. -- -- > sms_s (1,750) == 1.75 sms_s :: (Integral i) => (i,i) -> Double sms_s (s,ms) = fromIntegral s + fromIntegral ms / 1000 -- | 'Read' function for 'Duration' tuple. read_duration_tuple :: String -> (Int,Int,Int,Int) read_duration_tuple x = let f :: (Int,Int,Double) -> (Int,Int,Int,Int) f (h,m,s) = let (s',ms) = s_sms s in (h,m,s',ms) in case S.splitOneOf ":" x of [h,m,s] -> f (read h,read m,read s) [m,s] -> f (0,read m,read s) [s] -> f (0,0,read s) _ -> error "read_duration_tuple" -- | 'Read' function for 'Duration'. Allows either @H:M:S.MS@ or -- @M:S.MS@ or @S.MS@. -- -- > read_duration "01:35:05.250" == Duration 1 35 5 250 -- > read_duration "35:05.250" == Duration 0 35 5 250 -- > read_duration "05.250" == Duration 0 0 5 250 read_duration :: String -> Duration read_duration = tuple_to_duration id . read_duration_tuple instance Read Duration where readsPrec _ x = [(read_duration x,"")] -- | 'Show' function for 'Duration'. -- -- > show_duration (Duration 1 35 5 250) == "01:35:05.250" -- > show (Duration 1 15 0 000) == "01:15:00.000" show_duration :: Duration -> String show_duration (Duration h m s ms) = let f :: Int -> String f = printf "%02d" g = f . fromIntegral s' = sms_s (s,ms) in concat [g h,":",g m,":",printf "%06.3f" s'] instance Show Duration where show = show_duration normalise_minutes :: Duration -> Duration normalise_minutes (Duration h m s ms) = let (h',m') = m `divMod` 60 in Duration (h + h') m' s ms normalise_seconds :: Duration -> Duration normalise_seconds (Duration h m s ms) = let (m',s') = s `divMod` 60 in Duration h (m + m') s' ms normalise_milliseconds :: Duration -> Duration normalise_milliseconds (Duration h m s ms) = let (s',ms') = ms `divMod` 1000 in Duration h m (s + s') ms' normalise_duration :: Duration -> Duration normalise_duration = normalise_minutes . normalise_seconds . normalise_milliseconds -- | Extract 'Duration' tuple applying filter function at each element -- -- > duration_tuple id (Duration 1 35 5 250) == (1,35,5,250) duration_to_tuple :: (Int -> a) -> Duration -> (a,a,a,a) duration_to_tuple f (Duration h m s ms) = (f h,f m,f s,f ms) -- | Inverse of 'duration_to_tuple'. tuple_to_duration :: (a -> Int) -> (a,a,a,a) -> Duration tuple_to_duration f (h,m,s,ms) = Duration (f h) (f m) (f s) (f ms) -- > duration_to_hours (read "01:35:05.250") == 1.5847916666666668 duration_to_hours :: Fractional n => Duration -> n duration_to_hours d = let (h,m,s,ms) = duration_to_tuple fromIntegral d in h + (m / 60) + (s / (60 * 60)) + (ms / (60 * 60 * 1000)) -- > duration_to_minutes (read "01:35:05.250") == 95.0875 duration_to_minutes :: Fractional n => Duration -> n duration_to_minutes = (* 60) . duration_to_hours -- > duration_to_seconds (read "01:35:05.250") == 5705.25 duration_to_seconds :: Fractional n => Duration -> n duration_to_seconds = (* 60) . duration_to_minutes -- > hours_to_duration 1.5847916 == Duration 1 35 5 250 hours_to_duration :: RealFrac a => a -> Duration hours_to_duration n = let r = fromIntegral :: RealFrac a => Int -> a h = (r . floor) n m = (n - h) * 60 (s,ms) = s_sms ((m - (r . floor) m) * 60) in Duration (floor h) (floor m) s ms minutes_to_duration :: RealFrac a => a -> Duration minutes_to_duration n = hours_to_duration (n / 60) seconds_to_duration :: RealFrac a => a -> Duration seconds_to_duration n = minutes_to_duration (n / 60) nil_duration :: Duration nil_duration = Duration 0 0 0 0 negate_duration :: Duration -> Duration negate_duration (Duration h m s ms) = let h' = if h > 0 then -h else h m' = if h == 0 && m > 0 then -m else m s' = if h == 0 && m == 0 && s > 0 then -s else s ms' = if h == 0 && m == 0 && s == 0 then -ms else ms in Duration h' m' s' ms' -- > duration_diff (Duration 1 35 5 250) (Duration 0 25 1 125) == Duration 1 10 4 125 -- > duration_diff (Duration 0 25 1 125) (Duration 1 35 5 250) == Duration (-1) 10 4 125 -- > duration_diff (Duration 0 25 1 125) (Duration 0 25 1 250) == Duration 0 0 0 (-125) duration_diff :: Duration -> Duration -> Duration duration_diff p q = let f = duration_to_hours :: Duration -> Double (p',q') = (f p,f q) g = normalise_duration . hours_to_duration in case compare p' q' of LT -> negate_duration (g (q' - p')) EQ -> nil_duration GT -> g (p' - q') hmt-0.15/Music/Theory/Time/Seq.hs0000644000000000000000000006076512416136065014753 0ustar0000000000000000-- | Basic temporal sequence functions. module Music.Theory.Time.Seq where import Data.Function {- base -} import Data.List {- base -} import qualified Data.List.Ordered as O {- data-ordlist -} import qualified Data.Map as M {- containers -} import Data.Maybe {- base -} import Data.Monoid {- base -} import Data.Ratio {- base -} import Safe {- safe -} import Music.Theory.Function {- hmt -} import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Math as T {- hmt -} import qualified Music.Theory.Tuple as T {- hmt -} -- * Types -- | Sequence of elements with uniform duration. type Useq t a = (t,[a]) -- | Duration sequence. The duration is the /forward/ duration of the -- value, if it has other durations they must be encoded at /a/. type Dseq t a = [(t,a)] -- | Inter-offset sequence. The duration is the interval /before/ the -- value. To indicate the duration of the final value /a/ must have -- an /nil/ (end of sequence) value. type Iseq t a = [(t,a)] -- | Pattern sequence. The duration is a triple of /logical/, -- /sounding/ and /forward/ durations. type Pseq t a = [((t,t,t),a)] -- | Time-point sequence. To express holes /a/ must have a /empty/ -- value. To indicate the duration of the final value /a/ must have -- an /nil/ (end of sequence) value. type Tseq t a = [(t,a)] -- | Window sequence. The temporal field is (/time/,/duration/). -- Holes exist where @t(n) + d(n)@ '<' @t(n+1)@. Overlaps exist where -- the same relation is '>'. type Wseq t a = [((t,t),a)] -- * Zip pseq_zip :: [t] -> [t] -> [t] -> [a] -> Pseq t a pseq_zip l o f a = (zip (zip3 l o f) a) wseq_zip :: [t] -> [t] -> [a] -> Wseq t a wseq_zip t d a = (zip (zip t d) a) -- * Time span -- | Given functions for deriving start and end times calculate time -- span of sequence. -- -- > seq_tspan id id [] == (0,0) -- > seq_tspan id id (zip [0..9] ['a'..]) == (0,9) seq_tspan :: Num n => (t -> n) -> (t -> n) -> [(t,a)] -> (n,n) seq_tspan st et sq = (maybe 0 (st . fst) (headMay sq) ,maybe 0 (et . fst) (lastMay sq)) tseq_tspan :: Num t => Tseq t a -> (t,t) tseq_tspan = seq_tspan id id wseq_tspan :: Num t => Wseq t a -> (t,t) wseq_tspan = seq_tspan fst (uncurry (+)) -- * Duration dseq_dur :: Num t => Dseq t a -> t dseq_dur = sum . map fst iseq_dur :: Num t => Iseq t a -> t iseq_dur = sum . map fst pseq_dur :: Num t => Pseq t a -> t pseq_dur = sum . map (T.t3_third . fst) -- | The interval of 'tseq_tspan'. -- -- > tseq_dur (zip [0..] "abcde|") == 5 tseq_dur :: Num t => Tseq t a -> t tseq_dur = uncurry subtract . tseq_tspan -- | The interval of 'wseq_tspan'. -- -- > wseq_dur (zip (zip [0..] (repeat 2)) "abcde") == 6 wseq_dur :: Num t => Wseq t a -> t wseq_dur = uncurry subtract . wseq_tspan -- * Window -- | Keep only elements in the indicated temporal window. -- -- > let r = [((5,1),'e'),((6,1),'f'),((7,1),'g'),((8,1),'h')] -- > in wseq_twindow (5,9) (zip (zip [1..10] (repeat 1)) ['a'..]) == r wseq_twindow :: (Num t, Ord t) => (t,t) -> Wseq t a -> Wseq t a wseq_twindow (w0,w1) = let f (st,du) = w0 <= st && (st + du) <= w1 in wseq_tfilter f -- * Append dseq_append :: Dseq t a -> Dseq t a -> Dseq t a dseq_append = (++) iseq_append :: Iseq t a -> Iseq t a -> Iseq t a iseq_append = (++) pseq_append :: Pseq t a -> Pseq t a -> Pseq t a pseq_append = (++) -- * Merge -- | Merge comparing only on time. tseq_merge :: Ord t => Tseq t a -> Tseq t a -> Tseq t a tseq_merge = O.mergeBy (compare `on` fst) -- | Merge, where times are equal compare values. tseq_merge_by :: Ord t => T.Compare_F a -> Tseq t a -> Tseq t a -> Tseq t a tseq_merge_by cmp = T.merge_by_two_stage fst cmp snd {- | Merge, where times are equal apply /f/ to form a single value. > let {p = zip [1,3,5] "abc" > ;q = zip [1,2,3] "ABC" > ;left_r = [(1,'a'),(2,'B'),(3,'b'),(5,'c')] > ;right_r = [(1,'A'),(2,'B'),(3,'C'),(5,'c')]} > in tseq_merge_resolve (\x _ -> x) p q == left_r && > tseq_merge_resolve (\_ x -> x) p q == right_r -} tseq_merge_resolve :: Ord t => (a -> a -> a) -> Tseq t a -> Tseq t a -> Tseq t a tseq_merge_resolve f = let cmp = compare `on` fst g (t,p) (_,q) = (t,f p q) in T.merge_by_resolve g cmp wseq_merge :: Ord t => Wseq t a -> Wseq t a -> Wseq t a wseq_merge = O.mergeBy (compare `on` (fst . fst)) -- * Lookup tseq_lookup_window_by :: (t -> t -> Ordering) -> Tseq t e -> t -> (Maybe (t,e),Maybe (t,e)) tseq_lookup_window_by cmp = let recur l sq t = case sq of [] -> (l,Nothing) (t',e):sq' -> case cmp t t' of LT -> (l,Just (t',e)) _ -> case sq' of [] -> (Just (t',e),Nothing) (t'',e'):_ -> case cmp t t'' of LT -> (Just (t',e),Just (t'',e')) _ -> recur (Just (t',e)) sq' t in recur Nothing tseq_lookup_active_by :: (t -> t -> Ordering) -> Tseq t e -> t -> Maybe e tseq_lookup_active_by cmp sq = fmap snd . fst . tseq_lookup_window_by cmp sq tseq_lookup_active :: Ord t => Tseq t e -> t -> Maybe e tseq_lookup_active = tseq_lookup_active_by compare tseq_lookup_active_by_def :: e -> (t -> t -> Ordering) -> Tseq t e -> t -> e tseq_lookup_active_by_def def cmp sq = fromMaybe def . tseq_lookup_active_by cmp sq tseq_lookup_active_def :: Ord t => e -> Tseq t e -> t -> e tseq_lookup_active_def def = tseq_lookup_active_by_def def compare -- * Lseq data Interpolation_T = None | Linear deriving (Eq,Enum,Show) -- | Variant of 'Tseq' where nodes have an 'Intepolation_T' value. type Lseq t a = Tseq (t,Interpolation_T) a -- | Linear interpolation. lerp :: (Fractional t,Real t,Fractional e) => (t,e) -> (t,e) -> t -> e lerp (t0,e0) (t1,e1) t = let n = t1 - t0 m = t - t0 l = m / n in realToFrac l * (e1 - e0) + e0 -- | Temporal map. lseq_tmap :: (t -> t') -> Lseq t a -> Lseq t' a lseq_tmap f = let g ((t,i),e) = ((f t,i),e) in map g -- | This can give 'Nothing' if /t/ precedes the 'Lseq' or if /t/ is -- after the final element of 'Lseq' and that element has an -- interpolation type other than 'None'. lseq_lookup :: (Fractional t,Real t,Fractional e) => (t -> t -> Ordering) -> Lseq t e -> t -> Maybe e lseq_lookup cmp sq t = case tseq_lookup_window_by (cmp `on` fst) sq (t,undefined) of (Nothing,_) -> Nothing (Just ((_,None),e),_) -> Just e (Just ((t0,Linear),e0),Just ((t1,_),e1)) -> Just (lerp (t0,e0) (t1,e1) t) _ -> Nothing -- | 'error'ing variant. lseq_lookup_err :: (Fractional t,Real t,Fractional e) => (t -> t -> Ordering) -> Lseq t e -> t -> e lseq_lookup_err cmp sq = fromMaybe (error "lseq_lookup") . lseq_lookup cmp sq -- * Map, Filter, Find seq_tmap :: (t -> t') -> [(t,a)] -> [(t',a)] seq_tmap f = map (\(p,q) -> (f p,q)) seq_map :: (b -> c) -> [(a,b)] -> [(a,c)] seq_map f = map (\(p,q) -> (p,f q)) -- | Map /t/ and /e/ simultaneously. seq_bimap :: (t -> t') -> (e -> e') -> [(t,e)] -> [(t',e')] seq_bimap f g = map (\(p,q) -> (f p,g q)) seq_tfilter :: (t -> Bool) -> [(t,a)] -> [(t,a)] seq_tfilter f = filter (f . fst) seq_filter :: (b -> Bool) -> [(a,b)] -> [(a,b)] seq_filter f = filter (f . snd) seq_find :: (a -> Bool) -> [(t,a)] -> Maybe (t,a) seq_find f = let f' (_,a) = f a in find f' -- * Maybe -- | 'mapMaybe' variant. seq_map_maybe :: (p -> Maybe q) -> [(t,p)] -> [(t,q)] seq_map_maybe f = let g (t,e) = maybe Nothing (\e' -> Just (t,e')) (f e) in mapMaybe g -- | Variant of 'catMaybes'. seq_cat_maybes :: [(t,Maybe q)] -> [(t,q)] seq_cat_maybes = seq_map_maybe id -- | If value is unchanged, according to /f/, replace with 'Nothing'. -- -- > let r = [(1,'s'),(2,'t'),(4,'r'),(6,'i'),(7,'n'),(9,'g')] -- > in seq_cat_maybes (seq_changed_by (==) (zip [1..] "sttrrinng")) == r seq_changed_by :: (a -> a -> Bool) -> [(t,a)] -> [(t,Maybe a)] seq_changed_by f l = let recur z sq = case sq of [] -> [] (t,e):sq' -> if f e z then (t,Nothing) : recur z sq' else (t,Just e) : recur e sq' in case l of [] -> [] (t,e) : l' -> (t,Just e) : recur e l' -- | 'seq_changed_by' '=='. seq_changed :: Eq a => [(t,a)] -> [(t,Maybe a)] seq_changed = seq_changed_by (==) -- * Specialised temporal maps. -- | Apply /f/ at time points of 'Wseq'. wseq_tmap_st :: (t -> t) -> Wseq t a -> Wseq t a wseq_tmap_st f = let g (t,d) = (f t,d) in seq_tmap g -- | Apply /f/ at durations of elements of 'Wseq'. wseq_tmap_dur :: (t -> t) -> Wseq t a -> Wseq t a wseq_tmap_dur f = let g (t,d) = (t,f d) in seq_tmap g -- * Partition -- | Given a function that determines a /voice/ for a value, partition -- a sequence into voices. seq_partition :: Ord v => (a -> v) -> [(t,a)] -> [(v,[(t,a)])] seq_partition voice sq = let assign m (t,a) = M.insertWith (++) (voice a) [(t,a)] m from_map = sortBy (compare `on` fst) . map (\(v,l) -> (v,reverse l)) . M.toList in from_map (foldl assign M.empty sq) -- | Type specialised 'seq_partition'. -- -- > let {p = zip [0,1,3,5] (zip (repeat 0) "abcd") -- > ;q = zip [2,4,6,7] (zip (repeat 1) "ABCD") -- > ;sq = tseq_merge p q} -- > in tseq_partition fst sq == [(0,p),(1,q)] tseq_partition :: Ord v => (a -> v) -> Tseq t a -> [(v,Tseq t a)] tseq_partition = seq_partition wseq_partition :: Ord v => (a -> v) -> Wseq t a -> [(v,Wseq t a)] wseq_partition = seq_partition -- * Coalesce -- | Given a decision predicate and a join function, recursively join -- adjacent elements. -- -- > coalesce_f undefined undefined [] == [] -- > coalesce_f (==) const "abbcccbba" == "abcba" -- > coalesce_f (==) (+) [1,2,2,3,3,3] == [1,4,6,3] coalesce_f :: (t -> t -> Bool) -> (t -> t -> t) -> [t] -> [t] coalesce_f dec_f jn_f z = let recur p l = case l of [] -> [p] c:l' -> if dec_f p c then recur (jn_f p c) l' else p : recur c l' in case z of [] -> [] e0:z' -> recur e0 z' -- | 'coalesce_f' using 'mappend' for the join function. coalesce_m :: Monoid t => (t -> t -> Bool) -> [t] -> [t] coalesce_m dec_f = coalesce_f dec_f mappend -- | Form of 'coalesce_f' where the decision predicate is on the -- /element/, and a join function sums the /times/. -- -- > let r = [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')] -- > in seq_coalesce (==) const (useq_to_dseq (1,"abbcccdde")) == r seq_coalesce :: Num t => (a -> a -> Bool) -> (a -> a -> a) -> [(t,a)] -> [(t,a)] seq_coalesce dec_f jn_f = let dec_f' = dec_f `on` snd jn_f' (t1,a1) (t2,a2) = (t1 + t2,jn_f a1 a2) in coalesce_f dec_f' jn_f' dseq_coalesce :: Num t => (a -> a -> Bool) -> (a -> a -> a) -> Dseq t a -> Dseq t a dseq_coalesce = seq_coalesce -- | Given /equality/ predicate, simplify sequence by summing -- durations of adjacent /equal/ elements. This is a special case of -- 'dseq_coalesce' where the /join/ function is 'const'. The -- implementation is simpler and non-recursive. -- -- > let {d = useq_to_dseq (1,"abbcccdde") -- > ;r = dseq_coalesce (==) const d} -- > in dseq_coalesce' (==) d == r dseq_coalesce' :: Num t => (a -> a -> Bool) -> Dseq t a -> Dseq t a dseq_coalesce' eq = let f l = let (t,e:_) = unzip l in (sum t,e) in map f . groupBy (eq `on` snd) iseq_coalesce :: Num t => (a -> a -> Bool) -> (a -> a -> a) -> Iseq t a -> Iseq t a iseq_coalesce = seq_coalesce -- * T-coalesce seq_tcoalesce :: (t -> t -> Bool) -> (a -> a -> a) -> [(t,a)] -> [(t,a)] seq_tcoalesce eq_f jn_f = let dec_f = eq_f `on` fst jn_f' (t,a1) (_,a2) = (t,jn_f a1 a2) in coalesce_f dec_f jn_f' tseq_tcoalesce :: Eq t => (a -> a -> a) -> Tseq t a -> Tseq t a tseq_tcoalesce = seq_tcoalesce (==) wseq_tcoalesce :: ((t,t) -> (t,t) -> Bool) -> (a -> a -> a) -> Wseq t a -> Wseq t a wseq_tcoalesce = seq_tcoalesce -- * Group -- | Post-process 'groupBy' of /cmp/ 'on' 'fst'. -- -- > let r = [(0,"a"),(1,"bc"),(2,"de"),(3,"f")] -- > in group_f (==) (zip [0,1,1,2,2,3] ['a'..]) == r group_f :: (Eq t,Num t) => (t -> t -> Bool) -> [(t,a)] -> [(t,[a])] group_f cmp = let f l = let (t,a) = unzip l in case t of [] -> error "group_f: []?" t0:_ -> (t0,a) in map f . groupBy (cmp `on` fst) -- | Group values at equal time points. -- -- > let r = [(0,"a"),(1,"bc"),(2,"de"),(3,"f")] -- > in tseq_group (zip [0,1,1,2,2,3] ['a'..]) == r tseq_group :: (Eq t,Num t) => Tseq t a -> Tseq t [a] tseq_group = group_f (==) -- | Group values where the inter-offset time is @0@ to the left. -- -- > let r = [(0,"a"),(1,"bcd"),(1,"ef")] -- > in iseq_group (zip [0,1,0,0,1,0] ['a'..]) == r iseq_group :: (Eq t,Num t) => Iseq t a -> Iseq t [a] iseq_group = group_f (\_ d -> d == 0) -- * Fill -- | Set durations so that there are no gaps or overlaps. -- -- > let r = wseq_zip [0,3,5] [3,2,1] "abc" -- > in wseq_fill_dur (wseq_zip [0,3,5] [2,1,1] "abc") == r wseq_fill_dur :: Num t => Wseq t a -> Wseq t a wseq_fill_dur l = let f (((t1,_),e),((t2,_),_)) = ((t1,t2-t1),e) in map f (T.adj2 1 l) ++ [last l] -- * Dseq dseq_lcm :: Dseq Rational e -> Integer dseq_lcm = foldl1 lcm . map (denominator . fst) -- | Scale by lcm so that all durations are integral. dseq_set_whole :: [Dseq Rational e] -> [Dseq Integer e] dseq_set_whole sq = let m = maximum (map dseq_lcm sq) t_f n = T.rational_whole_err (n * fromIntegral m) in map (dseq_tmap t_f) sq -- * Tseq -- | Given a a default value, a 'Tseq' /sq/ and a list of time-points -- /t/, generate a Tseq that is a union of the timepoints at /sq/ and -- /t/ where times in /t/ not at /sq/ are given the /current/ value, -- or /def/ if there is no value. -- -- > tseq_latch 'a' [(2,'b'),(4,'c')] [1..5] == zip [1..5] "abbcc" tseq_latch :: Ord t => a -> Tseq t a -> [t] -> Tseq t a tseq_latch def sq t = case (sq,t) of ([],_) -> zip t (repeat def) (_,[]) -> [] ((sq_t,sq_e):sq',t0:t') -> case compare sq_t t0 of LT -> (sq_t,sq_e) : tseq_latch sq_e sq' t EQ -> (sq_t,sq_e) : tseq_latch sq_e sq' t' GT -> (t0,def) : tseq_latch def sq t' -- * Wseq -- | Transform 'Wseq' to 'Tseq' by discaring durations. wseq_discard_dur :: Wseq t a -> Tseq t a wseq_discard_dur = let f ((t,_),e) = (t,e) in map f -- | Edit durations to ensure that notes don't overlap. If the same -- note is played simultaneously delete shorter note. If a note -- extends into a later note shorten duration (apply /d_fn/ to iot). wseq_remove_overlaps :: (Eq e,Ord t,Num t) => (e -> e -> Bool) -> (t -> t) -> Wseq t e -> Wseq t e wseq_remove_overlaps eq_fn d_fn = let go sq = case sq of [] -> [] ((t,d),a):sq' -> case find (eq_fn a . snd) sq' of Nothing -> ((t,d),a) : go sq' Just ((t',d'),a') -> if t == t' then if d <= d' then -- delete LHS go sq' else -- delete RHS ((t,d),a) : go (delete ((t',d'),a') sq') else if t' < t + d then ((t,d_fn (t' - t)),a) : go sq' else ((t,d),a) : go sq' in go -- | Unjoin elements (assign equal time stamps to all elements). seq_unjoin :: [(t,[e])] -> [(t,e)] seq_unjoin = let f (t,e) = zip (repeat t) e in concatMap f -- | Type specialised. wseq_unjoin :: Wseq t [e] -> Wseq t e wseq_unjoin = seq_unjoin -- * On/Off -- | Container for values that have /on/ and /off/ modes. data On_Off a = On a | Off a deriving (Eq,Show) -- | Structural comparison at 'On_Off', 'On' compares less than 'Off'. cmp_on_off :: On_Off a -> On_Off b -> Ordering cmp_on_off p q = case (p,q) of (On _,Off _) -> LT (On _,On _) -> EQ (Off _,Off _) -> EQ (Off _,On _) -> GT -- | Translate container types. either_to_on_off :: Either a a -> On_Off a either_to_on_off p = case p of Left a -> On a Right a -> Off a -- | Translate container types. on_off_to_either :: On_Off a -> Either a a on_off_to_either p = case p of On a -> Left a Off a -> Right a -- | Convert 'Wseq' to 'Tseq' transforming elements to 'On' and 'Off' -- parts. When merging, /off/ elements precede /on/ elements at equal -- times. -- -- > let {sq = [((0,5),'a'),((2,2),'b')] -- > ;r = [(0,On 'a'),(2,On 'b'),(4,Off 'b'),(5,Off 'a')]} -- > in wseq_on_off sq == r -- -- > let {sq = [((0,1),'a'),((1,1),'b'),((2,1),'c')] -- > ;r = [(0,On 'a'),(1,Off 'a') -- > ,(1,On 'b'),(2,Off 'b') -- > ,(2,On 'c'),(3,Off 'c')]} -- > in wseq_on_off sq == r wseq_on_off :: (Num t, Ord t) => Wseq t a -> Tseq t (On_Off a) wseq_on_off sq = let f ((t,d),a) = [(t,On a),(t + d,Off a)] g l = case l of [] -> [] e:l' -> tseq_merge_by (T.ordering_invert .: cmp_on_off) e (g l') in g (map f sq) -- | 'on_off_to_either' of 'wseq_on_off'. wseq_on_off_either :: (Num t, Ord t) => Wseq t a -> Tseq t (Either a a) wseq_on_off_either = tseq_map on_off_to_either . wseq_on_off -- | Variant that applies /on/ and /off/ functions to nodes. -- -- > let {sq = [((0,5),'a'),((2,2),'b')] -- > ;r = [(0,'A'),(2,'B'),(4,'b'),(5,'a')]} -- > in wseq_on_off_f Data.Char.toUpper id sq == r wseq_on_off_f :: (Ord t,Num t) => (a -> b) -> (a -> b) -> Wseq t a -> Tseq t b wseq_on_off_f f g = tseq_map (either f g) . wseq_on_off_either -- | Inverse of 'wseq_on_off' given a predicate function for locating -- the /off/ node of an /on/ node. -- -- > let {sq = [(0,On 'a'),(2,On 'b'),(4,Off 'b'),(5,Off 'a')] -- > ;r = [((0,5),'a'),((2,2),'b')]} -- > in tseq_on_off_to_wseq (==) sq == r tseq_on_off_to_wseq :: Num t => (a -> a -> Bool) -> Tseq t (On_Off a) -> Wseq t a tseq_on_off_to_wseq cmp = let cmp' x e = case e of Off x' -> cmp x x' _ -> False f e r = case seq_find (cmp' e) r of Nothing -> error "tseq_on_off_to_wseq: no matching off?" Just (t,_) -> t go sq = case sq of [] -> [] (_,Off _) : sq' -> go sq' (t,On e) : sq' -> let t' = f e sq' in ((t,t' - t),e) : go sq' in go -- * Interop useq_to_dseq :: Useq t a -> Dseq t a useq_to_dseq (t,e) = zip (repeat t) e -- | The conversion requires a start time and a /nil/ value used as an -- /eof/ marker. Productive given indefinite input sequence. -- -- > let r = zip [0,1,3,6,8,9] "abcde|" -- > in dseq_to_tseq 0 '|' (zip [1,2,3,2,1] "abcde") == r -- -- > let {d = zip [1,2,3,2,1] "abcde" -- > ;r = zip [0,1,3,6,8,9,10] "abcdeab"} -- > in take 7 (dseq_to_tseq 0 undefined (cycle d)) == r dseq_to_tseq :: Num t => t -> a -> Dseq t a -> Tseq t a dseq_to_tseq t0 nil sq = let (d,a) = unzip sq t = T.dx_d t0 d a' = a ++ [nil] in zip t a' -- | Variant where the /nil/ is take as the last element of the -- sequence. -- -- > let r = zip [0,1,3,6,8,9] "abcdee" -- > in dseq_to_tseq_last 0 (zip [1,2,3,2,1] "abcde") == r dseq_to_tseq_last :: Num t => t -> Dseq t a -> Tseq t a dseq_to_tseq_last t0 sq = dseq_to_tseq t0 (snd (last sq)) sq -- | The conversion requires a start time and does not consult the -- /logical/ duration. -- -- > let p = pseq_zip (repeat undefined) (cycle [1,2]) (cycle [1,1,2]) "abcdef" -- > in pseq_to_wseq 0 p == wseq_zip [0,1,2,4,5,6] (cycle [1,2]) "abcdef" pseq_to_wseq :: Num t => t -> Pseq t a -> Wseq t a pseq_to_wseq t0 sq = let (p,a) = unzip sq (_,d,f) = unzip3 p t = T.dx_d t0 f in wseq_zip t d a -- | The last element of 'Tseq' is required to be an /eof/ marker that -- has no duration and is not represented in the 'Dseq'. -- -- > let r = zip [1,2,3,2,1] "abcde" -- > in tseq_to_dseq undefined (zip [0,1,3,6,8,9] "abcde|") == r -- -- > let r = zip [1,2,3,2,1] "-abcd" -- > in tseq_to_dseq '-' (zip [1,3,6,8,9] "abcd|") == r tseq_to_dseq :: (Ord t,Num t) => a -> Tseq t a -> Dseq t a tseq_to_dseq empty sq = let (t,a) = unzip sq d = T.d_dx t in case t of [] -> [] t0:_ -> if t0 > 0 then (t0,empty) : zip d a else zip d a -- | The last element of 'Tseq' is required to be an /eof/ marker that -- has no duration and is not represented in the 'Wseq'. The duration -- of each value is either derived from the value, if an /dur/ -- function is given, or else the inter-offset time. -- -- > let r = wseq_zip [0,1,3,6,8] [1,2,3,2,1] "abcde" -- > in tseq_to_wseq Nothing (zip [0,1,3,6,8,9] "abcde|") == r -- -- > let r = wseq_zip [0,1,3,6,8] (map fromEnum "abcde") "abcde" -- > in tseq_to_wseq (Just fromEnum) (zip [0,1,3,6,8,9] "abcde|") == r tseq_to_wseq :: Num t => Maybe (a -> t) -> Tseq t a -> Wseq t a tseq_to_wseq dur_f sq = let (t,a) = unzip sq d = case dur_f of Just f -> map f (fst (T.separate_last a)) Nothing -> T.d_dx t in wseq_zip t d a tseq_to_iseq :: Num t => Tseq t a -> Dseq t a tseq_to_iseq = let recur n p = case p of [] -> [] (t,e):p' -> (t - n,e) : recur t p' in recur 0 -- | Requires start time. -- -- > let r = zip (zip [0,1,3,6,8,9] [1,2,3,2,1]) "abcde" -- > in dseq_to_wseq 0 (zip [1,2,3,2,1] "abcde") == r dseq_to_wseq :: Num t => t -> Dseq t a -> Wseq t a dseq_to_wseq t0 sq = let (d,a) = unzip sq t = T.dx_d t0 d in zip (zip t d) a -- | Inverse of 'dseq_to_wseq'. The /empty/ value is used to fill -- holes in 'Wseq'. If values overlap at 'Wseq' durations are -- truncated. -- -- > let w = wseq_zip [0,1,3,6,8,9] [1,2,3,2,1] "abcde" -- > in wseq_to_dseq '-' w == zip [1,2,3,2,1] "abcde" -- -- > let w = wseq_zip [3,10] [6,2] "ab" -- > in wseq_to_dseq '-' w == zip [3,6,1,2] "-a-b" -- -- > let w = wseq_zip [0,1] [2,2] "ab" -- > in wseq_to_dseq '-' w == zip [1,2] "ab" -- -- > let w = wseq_zip [0,0,0] [2,2,2] "abc" -- > in wseq_to_dseq '-' w == zip [0,0,2] "abc" wseq_to_dseq :: (Num t,Ord t) => a -> Wseq t a -> Dseq t a wseq_to_dseq empty sq = let f (((st0,d),e),((st1,_),_)) = let d' = st1 - st0 in case compare d d' of LT -> [(d,e),(d'-d,empty)] EQ -> [(d,e)] GT -> [(d',e)] ((_,dN),eN) = last sq r = concatMap f (T.adj2 1 sq) ++ [(dN,eN)] in case sq of ((st,_),_):_ -> if st > 0 then (st,empty) : r else r [] -> error "wseq_to_dseq" -- * Measures -- | Given a list of 'Dseq' (measures) convert to a list of 'Tseq' and -- the end time of the overall sequence. -- -- > let r = [[(0,'a'),(1,'b'),(3,'c')],[(4,'d'),(7,'e'),(9,'f')]] -- > in dseql_to_tseql 0 [zip [1,2,1] "abc",zip [3,2,1] "def"] == (10,r) dseql_to_tseql :: Num t => t -> [Dseq t a] -> (t,[Tseq t a]) dseql_to_tseql = let f z dv = let (tm,el) = unzip dv (z',r) = T.dx_d' z tm in (z',zip r el) in mapAccumL f -- * Type specialised map dseq_tmap :: (t -> t') -> Dseq t a -> Dseq t' a dseq_tmap = seq_tmap pseq_tmap :: ((t,t,t) -> (t',t',t')) -> Pseq t a -> Pseq t' a pseq_tmap = seq_tmap tseq_tmap :: (t -> t') -> Dseq t a -> Dseq t' a tseq_tmap = seq_tmap tseq_bimap :: (t -> t') -> (e -> e') -> Tseq t e -> Tseq t' e' tseq_bimap = seq_bimap wseq_tmap :: ((t,t) -> (t',t')) -> Wseq t a -> Wseq t' a wseq_tmap = seq_tmap dseq_map :: (a -> b) -> Dseq t a -> Dseq t b dseq_map = seq_map pseq_map :: (a -> b) -> Pseq t a -> Pseq t b pseq_map = seq_map tseq_map :: (a -> b) -> Tseq t a -> Tseq t b tseq_map = seq_map wseq_map :: (a -> b) -> Wseq t a -> Wseq t b wseq_map = seq_map -- * Type specialised filter dseq_tfilter :: (t -> Bool) -> Dseq t a -> Dseq t a dseq_tfilter = seq_tfilter iseq_tfilter :: (t -> Bool) -> Iseq t a -> Iseq t a iseq_tfilter = seq_tfilter pseq_tfilter :: ((t,t,t) -> Bool) -> Pseq t a -> Pseq t a pseq_tfilter = seq_tfilter tseq_tfilter :: (t -> Bool) -> Tseq t a -> Tseq t a tseq_tfilter = seq_tfilter wseq_tfilter :: ((t,t) -> Bool) -> Wseq t a -> Wseq t a wseq_tfilter = seq_tfilter dseq_filter :: (a -> Bool) -> Dseq t a -> Dseq t a dseq_filter = seq_filter iseq_filter :: (a -> Bool) -> Iseq t a -> Iseq t a iseq_filter = seq_filter pseq_filter :: (a -> Bool) -> Pseq t a -> Pseq t a pseq_filter = seq_filter tseq_filter :: (a -> Bool) -> Tseq t a -> Tseq t a tseq_filter = seq_filter wseq_filter :: (a -> Bool) -> Wseq t a -> Wseq t a wseq_filter = seq_filter -- * Type specialised maybe wseq_map_maybe :: (a -> Maybe b) -> Wseq t a -> Wseq t b wseq_map_maybe = seq_map_maybe wseq_cat_maybes :: Wseq t (Maybe a) -> Wseq t a wseq_cat_maybes = seq_cat_maybes hmt-0.15/Music/Theory/Time/Notation.hs0000644000000000000000000000226012416136065016000 0ustar0000000000000000module Music.Theory.Time.Notation where import Text.Printf {- base -} -- | Fractional seconds. type FSEC = Double -- | Minutes, seconds as @(min,sec)@ type MINSEC = (Int,Int) -- | Minutes, seconds, centi-seconds as @(min,sec,csec)@ type MINCSEC = (Int,Int,Int) -- | Fractional seconds to @(min,sec)@. -- -- > map fsec_to_minsec [59.49,60,60.51] == [(0,59),(1,0),(1,1)] fsec_to_minsec :: FSEC -> MINSEC fsec_to_minsec tm = round tm `divMod` 60 -- | 'MINSEC' pretty printer. -- -- > map (minsec_pp . fsec_to_minsec) [59,61] == ["00:59","01:01"] minsec_pp :: MINSEC -> String minsec_pp (m,s) = printf "%02d:%02d" m s -- | Fractional seconds to @(min,sec,csec)@. -- -- > map fsec_to_mincsec [1,1.5,4/3] == [(0,1,0),(0,1,50),(0,1,33)] fsec_to_mincsec :: FSEC -> MINCSEC fsec_to_mincsec tm = let tm' = floor tm (m,s) = tm' `divMod` 60 cs = round ((tm - fromIntegral tm') * 100) in (m,s,cs) -- | 'MINCSEC' pretty printer. -- -- > map (mincsec_pp . fsec_to_mincsec) [1,4/3] == ["00:01.00","00:01.33"] mincsec_pp :: MINCSEC -> String mincsec_pp (m,s,cs) = printf "%02d:%02d.%02d" m s cs span_pp :: (t -> String) -> (t,t) -> String span_pp f (t1,t2) = concat [f t1," - ",f t2] hmt-0.15/Music/Theory/Time/Bel1990/0000755000000000000000000000000012416136065014676 5ustar0000000000000000hmt-0.15/Music/Theory/Time/Bel1990/R.hs0000644000000000000000000004574512416136065015452 0ustar0000000000000000{- | /Bel(R)/ is a simplified form of the /Bel/ notation described in: - Bernard Bel. \"Time and musical structures\". /Interface (Journal of New Music Research)/ Volume 19, Issue 2-3, 1990. () - Bernard Bel. \"Two algorithms for the instantiation of structures of musical objects\". Centre National de la Recherche Scientifique, 1992. /GRTC 458/ () For patterns without tempo indications, the two notations should give equivalent phase diagrams, for instance (Bel 1990, §11, p.24): > > bel_ascii_pp "ab{ab,cde}cd" > > Bel(R): "ab{ab,cde}cd", Dur: 7 > > a _ b _ a _ _ b _ _ c _ d _ > c _ d _ e _ and: > > bel_ascii_pp "{a{bc,def},ghijk}" > > Bel(R): "{a{bc,def},ghijk}", Dur: 5 > > a _ _ _ _ _ _ _ _ _ b _ _ _ _ _ _ _ _ _ _ _ _ _ _ c _ _ _ _ _ _ _ _ _ _ _ _ _ _ > d _ _ _ _ _ _ _ _ _ e _ _ _ _ _ _ _ _ _ f _ _ _ _ _ _ _ _ _ > g _ _ _ _ _ _ _ h _ _ _ _ _ _ _ i _ _ _ _ _ _ _ j _ _ _ _ _ _ _ k _ _ _ _ _ _ _ The /Bel/ notation allows /n/-ary parallel structures, ie. @{a_bcd_e,a_f_gh_,ji_a_i_}@ (Bel 1992, p.29), however /Bel(R)/ allows only binary structures. The parallel interpretation rules are associative: > > bel_ascii_pp "{a_bcd_e,{a_f_gh_,ji_a_i_}}" > > Bel(R): "{a_bcd_e,{a_f_gh_,ji_a_i_}}", Dur: 7 > > a _ b c d _ e > a _ f _ g h _ > j i _ a _ i _ /Bel(R)/ does allow unary parallel structures (see 'Iso'), which can be used to /isolate/ tempo changes: > > bel_ascii_pp "ab{*2cd}ef{*2/3gh}ij" > > Bel(R): "ab{*2cd}ef{*2/3gh}ij", Dur: 10 > > a _ b _ c d e _ f _ g _ _ h _ _ i _ j _ Patterns with tempo indications have completely different meanings in /Bel/ and /Bel(R)/, though in both cases parallel nodes delimit the scope of tempo markings. /Bel(R)/ replaces the @\/n@ notation for explicit tempo marks with a @*n@ notation to indicate a tempo multiplier, and a set of bracketing notations to specify interpretation rules for parallel (concurrent) temporal structures. The tempo indication @\/1@ in the expression @ab{\/1ab,cde}cd@ (Bel 1990, p.24) requires that the inner @ab@ have the same tempo as the outer @ab@, which is implicitly @\/1@. Setting the tempo of one part of a parallel structure requires assigning a tempo to the other part in order that the two parts have equal duration. Here the tempo assigned to @cde@ is @\/1.5@, but since fractional tempi are not allowed the expression is re-written as @\/2ab{\/2ab,\/3cde}\/2cd@. Importantly the explicit tempo indications make it possible to write syntactically correct expressions in /Bel/ that do not have a coherent interpretation, ie. @{\/1ab,\/1cde}@. Determining if a coherent set of tempos can be assigned, and assigning these tempos, is the object of the interpretation system. In comparison, all syntactically valid /Bel(R)/ strings have an interpretation. The expression @{*1ab,*1cde}@ is trivially equal to @{ab,cde}@, and tempo marks in parallel parts do not interact: > > bel_ascii_pp "{a*2b,*3c/2d/3e}" > > Bel(R): "{a*2b,*3c*1/2d*1/3e}", Dur: 3 > > a _ _ _ _ _ b _ _ > c d _ e _ _ _ _ _ Here @a@ is twice the duration of @b@, and @e@ is three times the duration of @d@, which is twice the duration of @c@ (in /Bel(R)/ @\/n@ is equivalent to @*1\/n@). The duration of any /Bel(R)/ expression can be calculated directly, given an initial 'Tempo': > bel_dur 1 (bel_char_parse "a*2b") == 3/2 > bel_dur 1 (bel_char_parse "*3c/2d/3e") == 3 Therefore in the composite expression the left part is slowed by a factor of two to align with the right part. The /Bel/ string @ab{\/1ab,cde}cd@ can be re-written in /Bel(R)/ as either @ab~{ab,cde}cd@ or @ab(ab,cde)cd@. The absolute tempo indication is replaced by notations giving alternate modes of interpretation for the parallel structure. In the first case the @~@ indicates the /opposite/ of the normal rule for parallel nodes. The normal rule is the same as for /Bel/ and is that the duration of the whole is equal to duration of the longer of the two parts. The @~@ inverts this so that the whole has the duration of the shorter of the two parts, and the longer part is scaled to have equal duration. In the second case the parentheses @()@ replacing the braces @{}@ indicates that the duration of the whole is equal to the duration of the left side, and that the right is to be scaled. Similarly, a @~@ preceding parentheses indicates the duration of the whole should be the duration of the right side, and the left scaled. > > bel_ascii_pp "ab~{ab,cde}cd" > > Bel(R): "ab~{ab,cde}cd", Dur: 6 > > a _ _ b _ _ a _ _ b _ _ c _ _ d _ _ > c _ d _ e _ There is one other parallel mode that has no equivalent in /Bel/ notation. It is a mode that does not scale either part, leaving a /hole/ at the end of the shorter part, and is indicated by square brackets: > > bel_ascii_pp "ab[ab,cde]cd" > > Bel(R): "ab[ab,cde]cd", Dur: 7 > > a b a b c d > c d e The /Bel/ string @\/2abc\/3de@ (Bel 1992, p.53) can be written as @*2abc*1/2*3de@, or equivalently as @*2abc*3/2de@: > > bel_ascii_pp "*2abc*3/2de" > > Bel(R): "*2abc*3/2de", Dur: 13/6 > > a _ _ b _ _ c _ _ d _ e _ It can also be written using the shorthand notation for rest sequences, where an integer /n/ indicates a sequence of /n/ rests, as: > > bel_ascii_pp "(9,abc)(4,de)" > > Bel(R): "(---------,abc)(----,de)", Dur: 13 > > - - - - - - - - - - - - - > a _ _ b _ _ c _ _ d _ e _ In the /Bel/ string @{ab{/3abc,de},fghijk}@ (Bel 1992, p.20) the tempo indication does not change the inter-relation of the parts but rather scales the parallel node altogether, and can be re-written in /Bel(R)/ notation as: > > bel_ascii_pp "{ab*3{abc,de},fghijk}" > > Bel(R): "{ab*3{abc,de},fghijk}", Dur: 6 > > a _ _ _ _ _ b _ _ _ _ _ a _ b _ c _ > d _ _ e _ _ > f _ _ g _ _ h _ _ i _ _ j _ _ k _ _ Curiously the following example (Bel 1990, p. 24) does not correspond to the phase diagram given: > > bel_ascii_pp "{i{ab,cde},jk}" > > Bel(R): "{i{ab,cde},jk}", Dur: 4 > > i _ a _ _ b _ _ > c _ d _ e _ > j _ _ _ k _ _ _ The paper assigns tempi of @\/6@ to both @i@ and @ab@, which in /Bel(R)/ could be written: > > bel_ascii_pp "{i~{ab,cde},jk}" > > Bel(R): "{i~{ab,cde},jk}", Dur: 3 > > i _ _ _ _ _ a _ _ _ _ _ b _ _ _ _ _ > c _ _ _ d _ _ _ e _ _ _ > j _ _ _ _ _ _ _ _ k _ _ _ _ _ _ _ _ -} module Music.Theory.Time.Bel1990.R where import Control.Monad {- base -} import Data.Function {- base -} import Data.List {- base -} import Data.Ratio {- base -} import qualified Text.ParserCombinators.Parsec as P {- parsec -} import qualified Music.Theory.List as T import qualified Music.Theory.Math as T -- * Bel -- | Types of 'Par' nodes. data Par_Mode = Par_Left | Par_Right | Par_Min | Par_Max | Par_None deriving (Eq,Show) -- | The different 'Par' modes are indicated by bracket types. par_mode_brackets :: Par_Mode -> (String,String) par_mode_brackets m = case m of Par_Left -> ("(",")") Par_Right -> ("~(",")") Par_Min -> ("~{","}") Par_Max -> ("{","}") Par_None -> ("[","]") bel_brackets_match :: (Char,Char) -> Bool bel_brackets_match (open,close) = case (open,close) of ('{','}') -> True ('(',')') -> True ('[',']') -> True _ -> False -- | Tempo is rational. The duration of a 'Term' is the reciprocal of -- the 'Tempo' that is in place at the 'Term'. type Tempo = Rational -- | Terms are the leaf nodes of the temporal structure. data Term a = Value a | Rest | Continue deriving (Eq,Show) -- | Recursive temporal structure. data Bel a = Node (Term a) -- ^ Leaf node | Iso (Bel a) -- ^ Isolate | Seq (Bel a) (Bel a) -- ^ Sequence | Par Par_Mode (Bel a) (Bel a) -- ^ Parallel | Mul Tempo -- ^ Tempo multiplier deriving (Eq,Show) -- | Pretty printer for 'Bel', given pretty printer for the term type. bel_pp :: (a -> String) -> Bel a -> String bel_pp f b = case b of Node Rest -> "-" Node Continue -> "_" Node (Value c) -> f c Iso b' -> T.bracket_l ("{","}") (bel_pp f b') Seq p q -> concat [bel_pp f p,bel_pp f q] Par m p q -> let pq = concat [bel_pp f p,",",bel_pp f q] in T.bracket_l (par_mode_brackets m) pq Mul n -> concat ["*",T.rational_pp n] -- | 'bel_pp' of 'return'. bel_char_pp :: Bel Char -> String bel_char_pp = bel_pp return -- | Analyse a Par node giving (duration,LHS-tempo-*,RHS-tempo-*). -- -- > par_analyse 1 Par_Left (nseq "cd") (nseq "efg") == (2,1,3/2) -- > par_analyse 1 Par_Right (nseq "cd") (nseq "efg") == (3,2/3,1) -- > par_analyse 1 Par_Min (nseq "cd") (nseq "efg") == (2,1,3/2) -- > par_analyse 1 Par_Max (nseq "cd") (nseq "efg") == (3,2/3,1) -- > par_analyse 1 Par_None (nseq "cd") (nseq "efg") == (3,1,1) par_analyse :: Tempo -> Par_Mode -> Bel a -> Bel a -> (Rational,Rational,Rational) par_analyse t m p q = let (_,d_p) = bel_tdur t p (_,d_q) = bel_tdur t q in case m of Par_Left -> (d_p,1,d_q / d_p) Par_Right -> (d_q,d_p / d_q,1) Par_Min -> let r = min d_p d_q in (r,d_p / r,d_q / r) Par_Max -> let r = max d_p d_q in (r,d_p / r,d_q / r) Par_None -> (max d_p d_q,1,1) -- | Duration element of 'par_analyse'. par_dur :: Tempo -> Par_Mode -> Bel a -> Bel a -> Rational par_dur t m p q = let (d,_,_) = par_analyse t m p q in d -- | Calculate final tempo and duration of 'Bel'. bel_tdur :: Tempo -> Bel a -> (Tempo,Rational) bel_tdur t b = case b of Node _ -> (t,1 / t) Iso b' -> (t,snd (bel_tdur t b')) Seq p q -> let (t_p,d_p) = bel_tdur t p (t_q,d_q) = bel_tdur t_p q in (t_q,d_p + d_q) Par m p q -> (t,par_dur t m p q) Mul n -> (t * n,0) -- | 'snd' of 'bel_tdur'. bel_dur :: Tempo -> Bel a -> Rational bel_dur t = snd . bel_tdur t -- * Linearisation -- | Time point. type Time = Rational -- | Voices are named as a sequence of left and right directions -- within nested 'Par' structures. type Voice = [Char] -- | Linear state. 'Time' is the start time of the term, 'Tempo' is -- the active tempo & therefore the reciprocal of the duration, -- 'Voice' is the part label. type L_St = (Time,Tempo,Voice) -- | Linear term. type L_Term a = (L_St,Term a) -- | Start time of 'L_Term'. lterm_time :: L_Term a -> Time lterm_time ((st,_,_),_) = st -- | Duration of 'L_Term' (reciprocal of tempo). lterm_duration :: L_Term a -> Time lterm_duration ((_,tm,_),_) = 1 / tm -- | End time of 'L_Term'. lterm_end_time :: L_Term a -> Time lterm_end_time e = lterm_time e + lterm_duration e -- | Linear form of 'Bel', an ascending sequence of 'L_Term'. type L_Bel a = [L_Term a] -- | Linearise 'Bel' given initial 'L_St', ascending by construction. bel_linearise :: L_St -> Bel a -> (L_Bel a,L_St) bel_linearise l_st b = let (st,tm,vc) = l_st in case b of Node e -> ([(l_st,e)],(st + 1/tm,tm,vc)) Iso p -> let (p',(st',_,_)) = bel_linearise l_st p in (p',(st',tm,vc)) Seq p q -> let (p',l_st') = bel_linearise l_st p (q',l_st'') = bel_linearise l_st' q in (p' ++ q',l_st'') Par m p q -> let (du,p_m,q_m) = par_analyse tm m p q (p',_) = bel_linearise (st,tm * p_m,'l':vc) p (q',_) = bel_linearise (st,tm * q_m,'r':vc) q in (p' `lbel_merge` q',(st + du,tm,vc)) Mul n -> ([],(st,tm * n,vc)) -- | Merge two ascending 'L_Bel'. lbel_merge :: L_Bel a -> L_Bel a -> L_Bel a lbel_merge = T.merge_by (compare `on` lterm_time) -- | Set of unique 'Tempo' at 'L_Bel'. lbel_tempi :: L_Bel a -> [Tempo] lbel_tempi = nub . sort . map (\((_,t,_),_) -> t) -- | Multiply 'Tempo' by /n/, and divide 'Time' by /n/. lbel_tempo_mul :: Rational -> L_Bel a -> L_Bel a lbel_tempo_mul n = map (\((st,tm,vc),e) -> ((st / n,tm * n,vc),e)) -- | After normalisation all start times and durations are integral. lbel_normalise :: L_Bel a -> L_Bel a lbel_normalise b = let t = lbel_tempi b n = foldl1 lcm (map denominator t) % 1 m = foldl1 lcm (map numerator (map (* n) t)) % 1 in lbel_tempo_mul (n / m) b -- | All leftmost voices are re-written to the last non-left turning point. -- -- > map voice_normalise ["","l","ll","lll"] == replicate 4 "" -- > voice_normalise "lllrlrl" == "rlrl" voice_normalise :: Voice -> Voice voice_normalise = dropWhile (== 'l') -- | '==' 'on' 'voice_normalise' voice_eq :: Voice -> Voice -> Bool voice_eq = (==) `on` voice_normalise -- | Unique 'Voice's at 'L_Bel'. lbel_voices :: L_Bel a -> [Voice] lbel_voices = sortBy (compare `on` reverse) . nub . map (\((_,_,v),_) -> voice_normalise v) -- | The duration of 'L_Bel'. lbel_duration :: L_Bel a -> Time lbel_duration b = let l = last (groupBy ((==) `on` lterm_time) b) in maximum (map (\((st,tm,_),_) -> st + recip tm) l) -- | Locate an 'L_Term' that is active at the indicated 'Time' and in -- the indicated 'Voice'. lbel_lookup :: (Time,Voice) -> L_Bel a -> Maybe (L_Term a) lbel_lookup (st,vc) = let f ((st',tm,vc'),_) = (st >= st' && st < st' + (1 / tm)) && vc `voice_eq` vc' in find f -- | Calculate grid (phase diagram) for 'L_Bel'. lbel_grid :: L_Bel a -> [[Maybe (Term a)]] lbel_grid l = let n = lbel_normalise l v = lbel_voices n d = lbel_duration n trs st ((st',_,_),e) = if st == st' then e else Continue get vc st = fmap (trs st) (lbel_lookup (st,vc) n) f vc = map (get vc) [0 .. d - 1] in map f v -- | 'lbel_grid' of 'bel_linearise'. bel_grid :: Bel a -> [[Maybe (Term a)]] bel_grid b = let (l,_) = bel_linearise (0,1,[]) b in lbel_grid l -- | /Bel/ type phase diagram for 'Bel' of 'Char'. Optionally print -- whitespace between columns. bel_ascii :: Bool -> Bel Char -> String bel_ascii opt = let f e = case e of Nothing -> ' ' Just Rest -> '-' Just Continue -> '_' Just (Value c) -> c g = if opt then intersperse ' ' else id in unlines . map (g . map f) . bel_grid -- | 'putStrLn' of 'bel_ascii'. bel_ascii_pr :: Bel Char -> IO () bel_ascii_pr = putStrLn . ('\n' :) . bel_ascii True -- * Combinators -- | Infix form for 'Seq'. (~>) :: Bel a -> Bel a -> Bel a p ~> q = Seq p q -- | 'foldl1' of 'Seq'. -- -- > lseq [Node Rest] == Node Rest -- > lseq [Node Rest,Node Continue] == Seq (Node Rest) (Node Continue) lseq :: [Bel a] -> Bel a lseq = foldl1 Seq -- | 'Node' of 'Value'. node :: a -> Bel a node = Node . Value -- | 'lseq' of 'Node' nseq :: [a] -> Bel a nseq = lseq . map node -- | Variant of 'nseq' where @_@ is read as 'Continue' and @-@ as 'Rest'. cseq :: String -> Bel Char cseq = let f c = case c of '_' -> Continue '-' -> Rest _ -> Value c in foldl1 Seq . map (Node . f) -- | 'Par' of 'Par_Max', this is the default 'Par_Mode'. par :: Bel a -> Bel a -> Bel a par = Par Par_Max -- | 'Node' of 'Rest'. rest :: Bel a rest = Node Rest -- | 'lseq' of 'replicate' of 'rest'. nrests :: Integral n => n -> Bel a nrests n = lseq (genericReplicate n rest) -- | Verify that 'bel_char_pp' of 'bel_char_parse' is 'id'. bel_parse_pp_ident :: String -> Bool bel_parse_pp_ident s = bel_char_pp (bel_char_parse s) == s -- | Run 'bel_char_parse', and print both 'bel_char_pp' and 'bel_ascii'. -- -- > bel_ascii_pp "{i{ab,{c[d,oh]e,sr{p,qr}}},{jk,ghjkj}}" bel_ascii_pp :: String -> IO () bel_ascii_pp s = do let p = bel_char_parse s putStrLn (concat ["\nBel(R): \"",bel_char_pp p,"\", Dur: ",T.rational_pp (bel_dur 1 p),""]) bel_ascii_pr p -- * Parsing -- | A 'Char' parser. type P a = P.GenParser Char () a -- | Parse 'Rest' 'Term'. -- -- > P.parse p_rest "" "-" p_rest :: P (Term a) p_rest = liftM (const Rest) (P.char '-') -- | Parse 'Rest' 'Term'. -- -- > P.parse p_nrests "" "3" p_nrests :: P (Bel a) p_nrests = liftM nrests p_integer -- | Parse 'Continue' 'Term'. -- -- > P.parse p_continue "" "_" p_continue :: P (Term a) p_continue = liftM (const Continue) (P.char '_') -- | Parse 'Char' 'Value' 'Term'. -- -- > P.parse p_char_value "" "a" p_char_value :: P (Term Char) p_char_value = liftM Value P.lower -- | Parse 'Char' 'Term'. -- -- > P.parse (P.many1 p_char_term) "" "-_a" p_char_term :: P (Term Char) p_char_term = P.choice [p_rest,p_continue,p_char_value] -- | Parse 'Char' 'Node'. -- -- > P.parse (P.many1 p_char_node) "" "-_a" p_char_node :: P (Bel Char) p_char_node = liftM Node p_char_term -- | Parse positive 'Integer'. -- -- > P.parse p_integer "" "3" p_integer :: P Integer p_integer = liftM read (P.many1 P.digit) -- | Parse positive 'Rational'. -- -- > P.parse (p_rational `P.sepBy` (P.char ',')) "" "3%5,2/3" p_rational :: P Rational p_rational = do n <- p_integer _ <- P.oneOf "%/" d <- p_integer return (n % d) -- | Parse positive 'Double'. -- -- > P.parse p_double "" "3.5" -- > P.parse (p_double `P.sepBy` (P.char ',')) "" "3.5,7.2,1.0" p_double :: P Double p_double = do a <- P.many1 P.digit _ <- P.char '.' b <- P.many1 P.digit return (read (a ++ "." ++ b)) -- | Parse positive number as 'Rational'. -- -- > P.parse (p_number `P.sepBy` (P.char ',')) "" "7%2,3.5,3" p_number :: P Rational p_number = P.choice [P.try p_rational ,P.try (liftM toRational p_double) ,P.try (liftM toRational p_integer)] -- | Parse 'Mul'. -- -- > P.parse (P.many1 p_mul) "" "/3*3/2" p_mul :: P (Bel a) p_mul = do op <- P.oneOf "*/" n <- p_number let n' = case op of '*' -> n '/' -> recip n _ -> error "p_mul" return (Mul n') -- | Given parser for 'Bel' /a/, generate 'Iso' parser. p_iso :: P (Bel a) -> P (Bel a) p_iso f = do open <- P.oneOf "{([" iso <- P.many1 f close <- P.oneOf "})]" if bel_brackets_match (open,close) then return (Iso (lseq iso)) else error "p_iso: open/close mismatch" -- | 'p_iso' of 'p_char_bel'. -- -- > P.parse p_char_iso "" "{abcde}" p_char_iso :: P (Bel Char) p_char_iso = p_iso p_char_bel -- | Given parser for 'Bel' /a/, generate 'Par' parser. p_par :: P (Bel a) -> P (Bel a) p_par f = do tilde <- P.optionMaybe (P.char '~') open <- P.oneOf "{([" lhs <- P.many1 f _ <- P.char ',' rhs <- P.many1 f close <- P.oneOf "})]" let m = case (tilde,open,close) of (Nothing,'{','}') -> Par_Max (Just '~','{','}') -> Par_Min (Nothing,'(',')') -> Par_Left (Just '~','(',')') -> Par_Right (Nothing,'[',']') -> Par_None _ -> error "p_par: incoherent par" return (Par m (lseq lhs) (lseq rhs)) -- | 'p_par' of 'p_char_bel'. -- -- > P.parse p_char_par "" "{ab,{c,de}}" -- > P.parse p_char_par "" "{ab,~(c,de)}" p_char_par :: P (Bel Char) p_char_par = p_par p_char_bel -- | Parse 'Bel' 'Char'. -- -- > P.parse (P.many1 p_char_bel) "" "-_a*3" p_char_bel :: P (Bel Char) p_char_bel = P.choice [P.try p_char_par,p_char_iso,p_mul,p_nrests,p_char_node] -- | Run parser for 'Bel' of 'Char'. bel_char_parse :: String -> Bel Char bel_char_parse s = either (\e -> error ("bel_parse failed\n" ++ show e)) lseq (P.parse (P.many1 p_char_bel) "" s) hmt-0.15/Music/Theory/Duration/0000755000000000000000000000000012416136065014540 5ustar0000000000000000hmt-0.15/Music/Theory/Duration/Name.hs0000644000000000000000000000247412416136065015763 0ustar0000000000000000-- | Names for common music notation durations. module Music.Theory.Duration.Name where import Music.Theory.Duration -- * 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 hmt-0.15/Music/Theory/Duration/CT.hs0000644000000000000000000001562212416136065015410 0ustar0000000000000000-- | Functions to generate a click track from a metric structure. module Music.Theory.Duration.CT where import Data.Function {- base -} import Data.List {- base -} import Data.Maybe {- base -} import qualified Music.Theory.Duration.RQ as T {- hmt -} import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Time_Signature as T {- hmt -} import qualified Music.Theory.Time.Seq as T {- hmt -} -- | 1-indexed. type Measure = Int -- | 1-indexed. type Pulse = Int -- | Transform measures given as 'T.RQ' divisions to absolute 'T.RQ' -- locations. /mdv/ abbreviates measure divisions. -- -- > mdv_to_mrq [[1,2,1],[3,2,1]] == [[0,1,3],[4,7,9]] mdv_to_mrq :: [[T.RQ]] -> [[T.RQ]] mdv_to_mrq = snd . mapAccumL T.dx_d' 0 -- | Lookup function for ('Measure','Pulse') indexed structure. mp_lookup_err :: [[a]] -> (Measure,Pulse) -> a mp_lookup_err sq (m,p) = if m < 1 || p < 1 then error (show ("mp_lookup_err: one indexed?",m,p)) else (sq !! (m - 1)) !! (p - 1) -- | Comparison for ('Measure','Pulse') indices. mp_compare :: (Measure,Pulse) -> (Measure,Pulse) -> Ordering mp_compare = T.two_stage_compare (compare `on` fst) (compare `on` snd) -- * CT -- | Latch measures (ie. make measures contiguous, hold previous value). -- -- > unzip (ct_ext 10 'a' [(3,'b'),(8,'c')]) == ([1..10],"aabbbbbccc") ct_ext :: Int -> a -> [(Measure,a)] -> [(Measure,a)] ct_ext n def sq = T.tseq_latch def sq [1 .. n] -- | Variant that requires a value at measure one (first measure). ct_ext1 :: Int -> [(Measure,a)] -> [(Measure,a)] ct_ext1 n sq = case sq of (1,e) : sq' -> ct_ext n e sq' _ -> error "ct_ext1" -- | 'T.rts_divisions' of 'ct_ext1'. ct_dv_seq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [(Measure,[[T.RQ]])] ct_dv_seq n ts = map (fmap T.rts_divisions) (ct_ext1 n ts) -- | 'ct_dv_seq' without measures numbers. ct_mdv_seq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [[T.RQ]] ct_mdv_seq n = map (concat . snd) . ct_dv_seq n -- | 'mdv_to_mrq' of 'ct_mdv_seq'. ct_rq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [[T.RQ]] ct_rq n ts = mdv_to_mrq (ct_mdv_seq n ts) ct_mp_lookup :: [[T.RQ]] -> (Measure,Pulse) -> T.RQ ct_mp_lookup = mp_lookup_err . mdv_to_mrq ct_m_to_rq :: [[T.RQ]] -> [(Measure,t)] -> [(T.RQ,t)] ct_m_to_rq sq = map (\(m,c) -> (ct_mp_lookup sq (m,1),c)) -- | Latch rehearsal mark sequence, only indicating marks. Initial mark is @.@. -- -- > ct_mark_seq 2 [] == [(1,Just '.'),(2,Nothing)] -- -- > let r = [(1,Just '.'),(3,Just 'A'),(8,Just 'B')] -- > in filter (isJust . snd) (ct_mark_seq 10 [(3,'A'),(8,'B')]) == r ct_mark_seq :: Int -> T.Tseq Measure Char -> T.Tseq Measure (Maybe Char) ct_mark_seq n mk = T.seq_changed (ct_ext n '.' mk) -- | Indicate measures prior to marks. -- -- > ct_pre_mark [] == [] -- > ct_pre_mark [(1,'A')] == [] -- > ct_pre_mark [(3,'A'),(8,'B')] == [(2,Just ()),(7,Just ())] ct_pre_mark :: [(Measure,a)] -> [(Measure,Maybe ())] ct_pre_mark = mapMaybe (\(m,_) -> if m <= 1 then Nothing else Just (m - 1,Just ())) -- | Contiguous pre-mark sequence. -- -- > ct_pre_mark_seq 1 [(1,'A')] == [(1,Nothing)] -- > ct_pre_mark_seq 10 [(3,'A'),(8,'B')] ct_pre_mark_seq :: Measure -> T.Tseq Measure Char -> T.Tseq Measure (Maybe ()) ct_pre_mark_seq n mk = let pre = ct_pre_mark mk in T.tseq_merge_resolve const pre (zip [1 .. n] (repeat Nothing)) ct_tempo_lseq_rq :: [[T.RQ]] -> T.Lseq (Measure,Pulse) T.RQ -> T.Lseq T.RQ T.RQ ct_tempo_lseq_rq sq = T.lseq_tmap (ct_mp_lookup sq) -- | Interpolating lookup of tempo sequence ('T.lseq_lookup_err'). ct_tempo_at :: T.Lseq T.RQ T.RQ -> T.RQ -> Rational ct_tempo_at = T.lseq_lookup_err compare -- | Types of nodes. data CT_Node = CT_Mark T.RQ -- ^ The start of a measure with a rehearsal mark. | CT_Start T.RQ -- ^ The start of a regular measure. | CT_Normal T.RQ -- ^ A regular pulse. | CT_Edge T.RQ -- ^ The start of a pulse group within a measure. | CT_Pre T.RQ -- ^ A regular pulse in a measure prior to a rehearsal mark. | CT_End -- ^ The end of the track. deriving (Eq,Show) -- | Lead-in of @(pulse,tempo,count)@. ct_leadin :: (T.RQ,Double,Int) -> T.Dseq Double CT_Node ct_leadin (du,tm,n) = replicate n (realToFrac du * (60 / tm),CT_Normal du) -- | Prepend initial element to start of list. -- -- > delay1 "abc" == "aabc" delay1 :: [a] -> [a] delay1 l = case l of [] -> error "delay1: []" e:_ -> e : l ct_measure:: T.Lseq T.RQ T.RQ -> ([T.RQ],Maybe Char,Maybe (),[[T.RQ]]) -> [(Rational,CT_Node)] ct_measure sq (mrq,mk,pr,dv) = let dv' = concatMap (zip [1..]) dv f (p,rq,(g,du)) = let nm = if p == 1 then case mk of Nothing -> CT_Start du Just _ -> CT_Mark du else if pr == Just () then CT_Pre du else if g == 1 then CT_Edge du else CT_Normal du in (du * (60 / ct_tempo_at sq rq),nm) in map f (zip3 [1..] mrq dv') -- | Click track definition. data CT = CT {ct_len :: Int ,ct_ts :: [(Measure,T.Rational_Time_Signature)] ,ct_mark :: [(Measure,Char)] ,ct_tempo :: T.Lseq (Measure,Pulse) T.RQ ,ct_count :: (T.RQ,Int)} deriving Show -- | Initial tempo, if given. ct_tempo0 :: CT -> Maybe T.RQ ct_tempo0 ct = case ct_tempo ct of (((1,1),_),n):_ -> Just n _ -> Nothing -- | Erroring variant. ct_tempo0_err :: CT -> T.RQ ct_tempo0_err = fromMaybe (error "ct_tempo0") . ct_tempo0 -- > import Music.Theory.Duration.CT -- > import Music.Theory.Time.Seq -- > let ct = CT 2 [(1,[(3,8),(2,4)])] [(1,'a')] [(((1,0),T.None),60)] undefined -- > ct_measures ct ct_measures :: CT -> [T.Dseq Rational CT_Node] ct_measures (CT n ts mk tm _) = let f msg sq = let (m,v) = unzip sq in if m == [1 .. n] then v else error (show ("ct_measures",msg,sq,m,v,n)) msr = zip4 (f "ts" (zip [1..] (ct_rq n ts))) (f "mk" (ct_mark_seq n mk)) (f "pre-mk" (ct_pre_mark_seq n mk)) (f "dv" (ct_dv_seq n ts)) in map (ct_measure (ct_tempo_lseq_rq (ct_mdv_seq n ts) tm)) msr ct_dseq' :: CT -> T.Dseq Rational CT_Node ct_dseq' = concat . ct_measures ct_dseq :: CT -> T.Dseq Double CT_Node ct_dseq = T.dseq_tmap fromRational . ct_dseq' -- * Indirect ct_rq_measure :: [[T.RQ]] -> T.RQ -> Maybe Measure ct_rq_measure sq rq = fmap fst (find ((rq `elem`) . snd) (zip [1..] sq)) ct_rq_mp :: [[T.RQ]] -> T.RQ -> Maybe (Measure,Pulse) ct_rq_mp sq rq = let f (m,l) = (m,fromMaybe (error "ct_rq_mp: ix") (findIndex (== rq) l) + 1) in fmap f (find ((rq `elem`) . snd) (zip [1..] sq)) ct_rq_mp_err :: [[T.RQ]] -> T.RQ -> (Measure, Pulse) ct_rq_mp_err sq = fromMaybe (error "ct_rq_mp") . ct_rq_mp sq ct_mp_to_rq :: [[T.RQ]] -> [((Measure,Pulse),t)] -> [(T.RQ,t)] ct_mp_to_rq sq = map (\(mp,c) -> (ct_mp_lookup sq mp,c)) hmt-0.15/Music/Theory/Duration/Annotation.hs0000644000000000000000000001766212416136065017222 0ustar0000000000000000-- | Duration annotations. module Music.Theory.Duration.Annotation where import Data.Maybe {- base -} import Data.Ratio {- base -} import qualified Data.Traversable as T {- base -} import Data.Tree {- containers -} import Music.Theory.Duration import Music.Theory.Duration.RQ -- | Standard music notation durational model annotations data D_Annotation = Tie_Right | Tie_Left | Begin_Tuplet (Integer,Integer,Duration) | End_Tuplet deriving (Eq,Show) -- | Annotated 'Duration'. type Duration_A = (Duration,[D_Annotation]) begin_tuplet :: D_Annotation -> Maybe (Integer,Integer,Duration) begin_tuplet a = case a of Begin_Tuplet t -> Just t _ -> Nothing da_begin_tuplet :: Duration_A -> Maybe (Integer,Integer,Duration) da_begin_tuplet (_,a) = case mapMaybe begin_tuplet a of [t] -> Just t _ -> Nothing begins_tuplet :: D_Annotation -> Bool begins_tuplet a = case a of Begin_Tuplet _ -> True _ -> False -- | Does 'Duration_A' begin a tuplet? da_begins_tuplet :: Duration_A -> Bool da_begins_tuplet (_,a) = any begins_tuplet a -- | Does 'Duration_A' end a tuplet? da_ends_tuplet :: Duration_A -> Bool da_ends_tuplet (_,a) = End_Tuplet `elem` a -- | Is 'Duration_A' tied to the the right? da_tied_right :: Duration_A -> Bool da_tied_right = elem Tie_Right . snd -- | Annotate a sequence of 'Duration_A' as a tuplet. -- -- > import Music.Theory.Duration.Name -- > da_tuplet (3,2) [(quarter_note,[Tie_Left]),(eighth_note,[Tie_Right])] da_tuplet :: (Integer,Integer) -> [Duration_A] -> [Duration_A] da_tuplet (d,n) x = let fn (p,q) = (p {multiplier = n%d},q) k = sum (map (duration_to_rq . fst) x) / (d%1) ty = rq_to_duration_err (show ("da_tuplet",d,n,x,k)) k t0 = [Begin_Tuplet (d,n,ty)] ts = [t0] ++ replicate (length x - 2) [] ++ [[End_Tuplet]] jn (p,q) z = (p,q++z) in zipWith jn (map fn x) ts -- | Transform predicates into 'Ordering' predicate such that if /f/ -- holds then 'LT', if /g/ holds then 'GT' else 'EQ'. -- -- > map (begin_end_cmp (== '{') (== '}')) "{a}" == [LT,EQ,GT] begin_end_cmp :: (t -> Bool) -> (t -> Bool) -> t -> Ordering begin_end_cmp f g x = if f x then LT else if g x then GT else EQ -- | Variant of 'begin_end_cmp', predicates are constructed by '=='. -- -- > map (begin_end_cmp_eq '{' '}') "{a}" == [LT,EQ,GT] begin_end_cmp_eq :: Eq t => t -> t -> t -> Ordering begin_end_cmp_eq p q = begin_end_cmp (== p) (== q) -- | Given an 'Ordering' predicate where 'LT' opens a group, 'GT' -- closes a group, and 'EQ' continues current group, construct tree -- from list. -- -- > let {l = "a {b {c d} e f} g h i" -- > ;t = group_tree (begin_end_cmp_eq '{' '}') l} -- > in catMaybes (flatten t) == l -- -- > let d = putStrLn . drawTree . fmap show -- > in d (group_tree (begin_end_cmp_eq '(' ')') "a(b(cd)ef)ghi") group_tree :: (a -> Ordering) -> [a] -> Tree (Maybe a) group_tree f = let unit e = Node (Just e) [] nil = Node Nothing [] insert_e (Node t l) e = Node t (e:l) reverse_n (Node t l) = Node t (reverse l) push (r,z) e = case z of h:z' -> (r,insert_e h (unit e) : z') [] -> (unit e : r,[]) open (r,z) = (r,nil:z) close (r,z) = case z of h0:h1:z' -> (r,insert_e h1 (reverse_n h0) : z') h:z' -> (reverse_n h : r,z') [] -> (r,z) go st x = case x of [] -> Node Nothing (reverse (fst st)) e:x' -> case f e of LT -> go (push (open st) e) x' EQ -> go (push st e) x' GT -> go (close (push st e)) x' in go ([],[]) -- | Group tuplets into a 'Tree'. Branch nodes have label 'Nothing', -- leaf nodes label 'Just' 'Duration_A'. -- -- > import Music.Theory.Duration.Name.Abbreviation -- -- > let d = [(q,[]) -- > ,(e,[Begin_Tuplet (3,2,e)]) -- > ,(s,[Begin_Tuplet (3,2,s)]),(s,[]),(s,[End_Tuplet]) -- > ,(e,[End_Tuplet]) -- > ,(q,[])] -- > in catMaybes (flatten (da_group_tuplets d)) == d da_group_tuplets :: [Duration_A] -> Tree (Maybe Duration_A) da_group_tuplets = let f = begin_end_cmp da_begins_tuplet da_ends_tuplet in group_tree f -- | Variant of 'break' that places separator at left. -- -- > break_left (== 3) [1..6] == ([1..3],[4..6]) -- > break_left (== 3) [1..3] == ([1..3],[]) break_left :: (a -> Bool) -> [a] -> ([a], [a]) break_left f x = let (p,q) = break f x in case q of [] -> (p,q) i:j -> (p++[i],j) -- | Variant of 'break_left' that balances begin & end predicates. -- -- > break_left (== ')') "test (sep) _) balanced" -- > sep_balanced True (== '(') (== ')') "test (sep) _) balanced" -- > sep_balanced False (== '(') (== ')') "(test (sep) _) balanced" sep_balanced :: Bool -> (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a]) sep_balanced u f g = let go n x = case x of [] -> ([],[]) p:q -> let n' = if f p then n + 1 else n r = g p n'' = if r then n' - 1 else n' in if r && n'' == 0 then ([p],q) else let (i,j) = go n'' q in (p:i,j) in go (fromEnum u) -- | Group non-nested tuplets, ie. groups nested tuplets at one level. da_group_tuplets_nn :: [Duration_A] -> [Either Duration_A [Duration_A]] da_group_tuplets_nn x = case x of [] -> [] d:x' -> if da_begins_tuplet d then let f = sep_balanced True da_begins_tuplet da_ends_tuplet (t,x'') = f x' in Right (d : t) : da_group_tuplets_nn x'' else Left d : da_group_tuplets_nn x' -- | Keep right variant of 'zipWith', unused rhs values are returned. -- -- > zip_with_kr (,) [1..3] ['a'..'e'] == ([(1,'a'),(2,'b'),(3,'c')],"de") zip_with_kr :: (a -> b -> c) -> [a] -> [b] -> ([c],[b]) zip_with_kr f = let go r p q = case (p,q) of (i:p',j:q') -> go (f i j : r) p' q' _ -> (reverse r,q) in go [] -- | Keep right variant of 'zip', unused rhs values are returned. -- -- > zip_kr [1..4] ['a'..'f'] == ([(1,'a'),(2,'b'),(3,'c'),(4,'d')],"ef") zip_kr :: [a] -> [b] -> ([(a,b)],[b]) zip_kr = zip_with_kr (,) -- | 'zipWith' variant that adopts the shape of the lhs. -- -- > let {p = [Left 1,Right [2,3],Left 4] -- > ;q = "abcd"} -- > in nn_reshape (,) p q == [Left (1,'a'),Right [(2,'b'),(3,'c')],Left (4,'d')] nn_reshape :: (a -> b -> c) -> [Either a [a]] -> [b] -> [Either c [c]] nn_reshape f p q = case (p,q) of (e:p',i:q') -> case e of Left j -> Left (f j i) : nn_reshape f p' q' Right j -> let (j',q'') = zip_with_kr f j q in Right j' : nn_reshape f p' q'' _ -> [] -- | Replace elements at 'Traversable' with result of joining with -- elements from list. adopt_shape :: T.Traversable t => (a -> b -> c) -> [b] -> t a -> t c adopt_shape jn l = let f (i:j) k = (j,jn k i) f [] _ = error "adopt_shape: rhs ends" in snd . T.mapAccumL f l -- | Variant of 'adopt_shape' that considers only 'Just' elements at -- 'Traversable'. -- -- > let {s = "a(b(cd)ef)ghi" -- > ;t = group_tree (begin_end_cmp_eq '(' ')') s} -- > in adopt_shape_m (,) [1..13] t adopt_shape_m :: T.Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> t (Maybe c) adopt_shape_m jn l = let f (i:j) k = case k of Nothing -> (i:j,Nothing) Just k' -> (j,Just (jn k' i)) f [] _ = error "adopt_shape_m: rhs ends" in snd . T.mapAccumL f l -- | Does /a/ have 'Tie_Left' and 'Tie_Right'? d_annotated_tied_lr :: [D_Annotation] -> (Bool,Bool) d_annotated_tied_lr a = (Tie_Left `elem` a,Tie_Right `elem` a) -- | Does /d/ have 'Tie_Left' and 'Tie_Right'? duration_a_tied_lr :: Duration_A -> (Bool,Bool) duration_a_tied_lr (_,a) = d_annotated_tied_lr a hmt-0.15/Music/Theory/Duration/RQ.hs0000644000000000000000000001427312416136065015425 0ustar0000000000000000-- | Rational quarter-note notation for durations. module Music.Theory.Duration.RQ where import Data.Function {- base -} import Data.List {- base -} import Data.Maybe {- base -} import Data.Ratio {- base -} import Music.Theory.Duration import Music.Theory.Duration.Name -- | Rational Quarter-Note type RQ = Rational -- | Rational quarter note to duration value. It is a mistake to hope -- this could handle tuplets directly since, for instance, a @3:2@ -- dotted note will be of the same duration as a plain undotted note. -- -- > rq_to_duration (3/4) == Just dotted_eighth_note rq_to_duration :: RQ -> Maybe Duration 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 -- | Is 'RQ' a /cmn/ duration. -- -- > map rq_is_cmn [1/4,1/5,1/8,3/32] == [True,False,True,False] rq_is_cmn :: RQ -> Bool rq_is_cmn = isJust . rq_to_duration -- | Variant of 'rq_to_duration' with error message. rq_to_duration_err :: Show a => a -> RQ -> Duration rq_to_duration_err msg n = let err = error ("rq_to_duration:" ++ show (msg,n)) in fromMaybe err (rq_to_duration n) -- | Convert a whole note division integer to an 'RQ' value. -- -- > map whole_note_division_to_rq [1,2,4,8] == [4,2,1,1/2] 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. -- -- > let d = [half_note,dotted_quarter_note,dotted_whole_note] -- > in map duration_to_rq d == [2,3/2,6] 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 -- | 'RQ' modulo. -- -- > map (rq_mod (5/2)) [3/2,3/4,5/2] == [1,1/4,0] rq_mod :: RQ -> RQ -> RQ rq_mod i j | i == j = 0 | i < 0 = rq_mod (i + j) j | i > j = rq_mod (i - j) j | otherwise = i -- | Is /p/ divisible by /q/, ie. is the 'denominator' of @p/q@ '==' @1@. -- -- > map (rq_divisible_by (3%2)) [1%2,1%3] == [True,False] rq_divisible_by :: RQ -> RQ -> Bool rq_divisible_by i j = denominator (i / j) == 1 -- | Is 'RQ' a whole number (ie. is 'denominator' '==' @1@. -- -- > map rq_is_integral [1,3/2,2] == [True,False,True] rq_is_integral :: RQ -> Bool rq_is_integral = (== 1) . denominator -- | Return 'numerator' of 'RQ' if 'denominator' '==' @1@. -- -- > map rq_integral [1,3/2,2] == [Just 1,Nothing,Just 2] rq_integral :: RQ -> Maybe Integer rq_integral n = if rq_is_integral n then Just (numerator n) else Nothing -- | Derive the tuplet structure of a set of 'RQ' values. -- -- > rq_derive_tuplet_plain [1/2] == Nothing -- > rq_derive_tuplet_plain [1/2,1/2] == Nothing -- > rq_derive_tuplet_plain [1/4,1/4] == Nothing -- > rq_derive_tuplet_plain [1/3,2/3] == Just (3,2) -- > rq_derive_tuplet_plain [1/2,1/3,1/6] == Just (6,4) -- > rq_derive_tuplet_plain [1/3,1/6] == Just (6,4) -- > rq_derive_tuplet_plain [2/5,3/5] == Just (5,4) -- > rq_derive_tuplet_plain [1/3,1/6,2/5,1/10] == Just (30,16) -- -- > map rq_derive_tuplet_plain [[1/3,1/6],[2/5,1/10]] == [Just (6,4) -- > ,Just (10,8)] rq_derive_tuplet_plain :: [RQ] -> Maybe (Integer,Integer) rq_derive_tuplet_plain x = let i = foldl lcm 1 (map denominator x) j = let z = iterate (* 2) 2 in fromJust (find (>= i) z) `div` 2 in if i `rem` j == 0 then Nothing else Just (i,j) -- | Derive the tuplet structure of a set of 'RQ' values. -- -- > rq_derive_tuplet [1/4,1/8,1/8] == Nothing -- > rq_derive_tuplet [1/3,2/3] == Just (3,2) -- > rq_derive_tuplet [1/2,1/3,1/6] == Just (3,2) -- > rq_derive_tuplet [2/5,3/5] == Just (5,4) -- > rq_derive_tuplet [1/3,1/6,2/5,1/10] == Just (15,8) rq_derive_tuplet :: [RQ] -> Maybe (Integer,Integer) rq_derive_tuplet = let f (i,j) = let k = i % j in (numerator k,denominator k) in fmap f . rq_derive_tuplet_plain -- | Remove tuplet multiplier from value, ie. to give notated -- duration. This seems odd but is neccessary to avoid ambiguity. -- Ie. is @1@ a quarter note or a @3:2@ tuplet dotted-quarter-note etc. -- -- > map (rq_un_tuplet (3,2)) [1,2/3,1/2,1/3] == [3/2,1,3/4,1/2] rq_un_tuplet :: (Integer,Integer) -> RQ -> RQ rq_un_tuplet (i,j) x = x * (i % j) -- | If an 'RQ' duration is un-representable by a single /cmn/ -- duration, give tied notation. -- -- > catMaybes (map rq_to_cmn [1..9]) == [(4,1),(4,3),(8,1)] -- -- > map rq_to_cmn [5/4,5/8] == [Just (1,1/4),Just (1/2,1/8)] rq_to_cmn :: RQ -> Maybe (RQ,RQ) rq_to_cmn x = let (i,j) = (numerator x,denominator x) k = case i of 5 -> Just (4,1) 7 -> Just (4,3) 9 -> Just (8,1) _ -> Nothing f (n,m) = (n%j,m%j) in fmap f k -- | Predicate to determine if a segment can be notated either without -- a tuplet or with a single tuplet. -- -- > rq_can_notate [1/2,1/4,1/4] == True -- > rq_can_notate [1/3,1/6] == True -- > rq_can_notate [2/5,1/10] == True -- > rq_can_notate [1/3,1/6,2/5,1/10] == False -- > rq_can_notate [4/7,1/7,6/7,3/7] == True -- > rq_can_notate [4/7,1/7,2/7] == True rq_can_notate :: [RQ] -> Bool rq_can_notate x = let x' = case rq_derive_tuplet x of Nothing -> x Just t -> map (rq_un_tuplet t) x in all rq_is_cmn x' hmt-0.15/Music/Theory/Duration/Name/0000755000000000000000000000000012416136065015420 5ustar0000000000000000hmt-0.15/Music/Theory/Duration/Name/Abbreviation.hs0000644000000000000000000000302112416136065020355 0ustar0000000000000000-- | 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 hmt-0.15/Music/Theory/Duration/RQ/0000755000000000000000000000000012416136065015062 5ustar0000000000000000hmt-0.15/Music/Theory/Duration/RQ/Tied.hs0000644000000000000000000000471012416136065016305 0ustar0000000000000000-- | 'RQ' values with /tie right/ qualifier. module Music.Theory.Duration.RQ.Tied where import Data.Maybe import Music.Theory.Duration.Annotation import Music.Theory.Duration.RQ import Music.Theory.List -- | Boolean. type Tied_Right = Bool -- | 'RQ' with /tie right/. type RQ_T = (RQ,Tied_Right) -- | Construct 'RQ_T'. rqt :: Tied_Right -> RQ -> RQ_T rqt t d = (d,t) -- | 'RQ' field of 'RQ_T'. rqt_rq :: RQ_T -> RQ rqt_rq = fst -- | 'Tied' field of 'RQ_T'. rqt_tied :: RQ_T -> Tied_Right rqt_tied = snd -- | Is 'RQ_T' tied right. is_tied_right :: RQ_T -> Bool is_tied_right = snd -- | 'RQ_T' variant of 'rq_un_tuplet'. -- -- > rqt_un_tuplet (3,2) (1,T) == (3/2,T) -- -- > let f = rqt_un_tuplet (7,4) -- > in map f [(2/7,F),(4/7,T),(1/7,F)] == [(1/2,F),(1,T),(1/4,F)] rqt_un_tuplet :: (Integer,Integer) -> RQ_T -> RQ_T rqt_un_tuplet i (d,t) = (rq_un_tuplet i d,t) -- | Transform 'RQ' to untied 'RQ_T'. -- -- > rq_rqt 3 == (3,F) rq_rqt :: RQ -> RQ_T rq_rqt n = (n,False) -- | Tie last element only of list of 'RQ'. -- -- > rq_tie_last [1,2,3] == [(1,F),(2,F),(3,T)] rq_tie_last :: [RQ] -> [RQ_T] rq_tie_last = at_last rq_rqt (\d -> (d,True)) -- | Transform a list of 'RQ_T' to a list of 'Duration_A'. The flag -- indicates if the initial value is tied left. -- -- > rqt_to_duration_a False [(1,T),(1/4,T),(3/4,F)] rqt_to_duration_a :: Bool -> [RQ_T] -> [Duration_A] rqt_to_duration_a z x = let rt = map is_tied_right x lt = z : rt f p e = if p then Just e else Nothing g r l = catMaybes [f r Tie_Right,f l Tie_Left] h = rq_to_duration_err (show ("rqt_to_duration_a",z,x)) . rqt_rq in zip (map h x) (zipWith g rt lt) -- | 'RQ_T' variant of 'rq_can_notate'. rqt_can_notate :: [RQ_T] -> Bool rqt_can_notate = rq_can_notate . map rqt_rq -- | 'RQ_T' variant of 'rq_to_cmn'. -- -- > rqt_to_cmn (5,T) == Just ((4,T),(1,T)) -- > rqt_to_cmn (5/4,T) == Just ((1,T),(1/4,T)) -- > rqt_to_cmn (5/7,F) == Just ((4/7,T),(1/7,F)) rqt_to_cmn :: RQ_T -> Maybe (RQ_T,RQ_T) rqt_to_cmn (k,t) = let f (i,j) = ((i,True),(j,t)) in fmap f (rq_to_cmn k) -- | List variant of 'rqt_to_cmn'. -- -- > rqt_to_cmn_l (5,T) == [(4,T),(1,T)] rqt_to_cmn_l :: RQ_T -> [RQ_T] rqt_to_cmn_l x = maybe [x] (\(i,j) -> [i,j]) (rqt_to_cmn x) -- | 'concatMap' 'rqt_to_cmn_l'. -- -- > rqt_set_to_cmn [(1,T),(5/4,F)] == [(1,T),(1,T),(1/4,F)] -- -- > rqt_set_to_cmn [(1/5,True),(1/20,False),(1/2,False),(1/4,True)] rqt_set_to_cmn :: [RQ_T] -> [RQ_T] rqt_set_to_cmn = concatMap rqt_to_cmn_l hmt-0.15/Music/Theory/Duration/RQ/Division.hs0000644000000000000000000000633312416136065017207 0ustar0000000000000000-- | 'RQ' sub-divisions. module Music.Theory.Duration.RQ.Division where import Data.List.Split {- split -} import Data.Ratio import Music.Theory.Duration.RQ import Music.Theory.Duration.RQ.Tied import Music.Theory.List import Music.Theory.Permutations.List -- | Divisions of /n/ 'RQ' into /i/ equal parts grouped as /j/. -- A quarter and eighth note triplet is written @(1,1,[2,1],False)@. type RQ_Div = (Rational,Integer,[Integer],Tied_Right) -- | Variant of 'RQ_Div' where /n/ is @1@. type RQ1_Div = (Integer,[Integer],Tied_Right) -- | Lift 'RQ1_Div' to 'RQ_Div'. rq1_div_to_rq_div :: RQ1_Div -> RQ_Div rq1_div_to_rq_div (i,j,k) = (1,i,j,k) -- | Verify that grouping /j/ sums to the divisor /i/. rq_div_verify :: RQ_Div -> Bool rq_div_verify (_,n,m,_) = n == sum m rq_div_mm_verify :: Int -> [RQ_Div] -> [(Integer,[RQ])] rq_div_mm_verify n x = let q = map (sum . fst . rq_div_to_rq_set_t) x in zip [1..] (chunksOf n q) -- | Translate from 'RQ_Div' to a sequence of 'RQ' values. -- -- > rq_div_to_rq_set_t (1,5,[1,3,1],True) == ([1/5,3/5,1/5],True) -- > rq_div_to_rq_set_t (1/2,6,[3,1,2],False) == ([1/4,1/12,1/6],False) rq_div_to_rq_set_t :: RQ_Div -> ([RQ],Tied_Right) rq_div_to_rq_set_t (n,k,d,t) = let q = map ((* n) . (% k)) d in (q,t) -- | Translate from result of 'rq_div_to_rq_set_t' to seqeunce of 'RQ_T'. -- -- > rq_set_t_to_rqt ([1/5,3/5,1/5],True) == [(1/5,_f),(3/5,_f),(1/5,_t)] rq_set_t_to_rqt :: ([RQ],Tied_Right) -> [RQ_T] rq_set_t_to_rqt (x,t) = at_last (\i -> (i,False)) (\i -> (i,t)) x -- | Transform sequence of 'RQ_Div' into sequence of 'RQ', discarding -- any final tie. -- -- > let q = [(1,5,[1,3,1],True),(1/2,6,[3,1,2],True)] -- > in rq_div_seq_rq q == [1/5,3/5,9/20,1/12,1/6] rq_div_seq_rq :: [RQ_Div] -> [RQ] rq_div_seq_rq = let f i qq = case qq of [] -> maybe [] return i q:qq' -> let (r,t) = rq_div_to_rq_set_t q r' = maybe r (\j -> at_head (+ j) id r) i in if t then let (r'',i') = separate_last r' in r'' ++ f (Just i') qq' else r' ++ f Nothing qq' in f Nothing -- | Partitions of an 'Integral' that sum to /n/. This includes the -- two 'trivial paritions, into a set /n/ @1@, and a set of @1@ /n/. -- -- > partitions_sum 4 == [[1,1,1,1],[2,1,1],[2,2],[3,1],[4]] -- -- > map (length . partitions_sum) [9..15] == [30,42,56,77,101,135,176] partitions_sum :: Integral i => i -> [[i]] partitions_sum n = let f p = if null p then 0 else head p in case n of 0 -> [[]] _ -> [x:y | x <- [1..n], y <- partitions_sum (n - x), x >= f y] -- | The 'multiset_permutations' of 'partitions_sum'. -- -- > map (length . partitions_sum_p) [9..12] == [256,512,1024,2048] partitions_sum_p :: Integral i => i -> [[i]] partitions_sum_p = concatMap multiset_permutations . partitions_sum -- | The set of all 'RQ1_Div' that sum to /n/, a variant on -- 'partitions_sum_p'. -- -- > map (length . rq1_div_univ) [3..5] == [8,16,32] -- > map (length . rq1_div_univ) [9..12] == [512,1024,2048,4096] rq1_div_univ :: Integer -> [RQ1_Div] rq1_div_univ n = let f l = [(n,l,k) | k <- [False,True]] in concatMap f (partitions_sum_p n) hmt-0.15/Music/Theory/Duration/Sequence/0000755000000000000000000000000012416136065016310 5ustar0000000000000000hmt-0.15/Music/Theory/Duration/Sequence/Notate.hs0000644000000000000000000007543012416136065020107 0ustar0000000000000000-- | Notation of a sequence of 'RQ' values as annotated 'Duration' values. -- -- 1. Separate input sequence into measures, adding tie annotations as -- required (see 'to_measures_ts'). Ensure all 'RQ_T' values can be -- notated as /common music notation/ durations. -- -- 2. Separate each measure into pulses (see 'm_divisions_ts'). -- Further subdivides pulses to ensure /cmn/ tuplet notation. See -- 'to_divisions_ts' for a composition of 'to_measures_ts' and -- 'm_divisions_ts'. -- -- 3. Simplify each measure (see 'm_simplify' and 'default_rule'). -- Coalesces tied durations where appropriate. -- -- 4. Notate measures (see 'm_notate' or 'mm_notate'). -- -- 5. Ascribe values to notated durations, see 'ascribe'. module Music.Theory.Duration.Sequence.Notate where import Control.Applicative {- base -} import Control.Monad {- base -} import Data.List {- base -} import Data.List.Split {- split -} import Data.Maybe {- base -} import Data.Ratio {- base -} import Music.Theory.Duration {- hmt -} import Music.Theory.Duration.Annotation {- hmt -} import Music.Theory.Function {- hmt -} import Music.Theory.Duration.RQ {- hmt -} import Music.Theory.Duration.RQ.Tied {- hmt -} import Music.Theory.List {- hmt -} import Music.Theory.Time_Signature {- hmt -} -- * Lists -- | Variant of 'catMaybes'. If all elements of the list are @Just -- a@, then gives @Just [a]@ else gives 'Nothing'. -- -- > all_just (map Just [1..3]) == Just [1..3] -- > all_just [Just 1,Nothing,Just 3] == Nothing all_just :: [Maybe a] -> Maybe [a] all_just x = case x of [] -> Just [] Just i:x' -> fmap (i :) (all_just x') Nothing:_ -> Nothing -- | Variant of 'Data.Either.rights' that preserves first 'Left'. -- -- > all_right (map Right [1..3]) == Right [1..3] -- > all_right [Right 1,Left 'a',Left 'b'] == Left 'a' all_right :: [Either a b] -> Either a [b] all_right x = case x of [] -> Right [] Right i:x' -> fmap (i :) (all_right x') Left i:_ -> Left i -- | Applies a /join/ function to the first two elements of the list. -- If the /join/ function succeeds the joined element is considered -- for further coalescing. -- -- > coalesce (\p q -> Just (p + q)) [1..5] == [15] -- -- > let jn p q = if even p then Just (p + q) else Nothing -- > in coalesce jn [1..5] == map sum [[1],[2,3],[4,5]] coalesce :: (a -> a -> Maybe a) -> [a] -> [a] coalesce f x = case x of (p:q:x') -> case f p q of Nothing -> p : coalesce f (q : x') Just r -> coalesce f (r : x') _ -> x -- | Variant of 'coalesce' with accumulation parameter. -- -- > coalesce_accum (\i p q -> Left (p + q)) 0 [1..5] == [(0,15)] -- -- > let jn i p q = if even p then Left (p + q) else Right (p + i) -- > in coalesce_accum jn 0 [1..7] == [(0,1),(1,5),(6,9),(15,13)] -- -- > let jn i p q = if even p then Left (p + q) else Right [p,q] -- > in coalesce_accum jn [] [1..5] == [([],1),([1,2],5),([5,4],9)] coalesce_accum :: (b -> a -> a -> Either a b) -> b -> [a] -> [(b,a)] coalesce_accum f i x = case x of [] -> [] [p] -> [(i,p)] (p:q:x') -> case f i p q of Right j -> (i,p) : coalesce_accum f j (q : x') Left r -> coalesce_accum f i (r : x') -- | Variant of 'coalesce_accum' that accumulates running sum. -- -- > let f i p q = if i == 1 then Just (p + q) else Nothing -- > in coalesce_sum (+) 0 f [1,1/2,1/4,1/4] == [1,1] coalesce_sum :: (b -> a -> b) -> b -> (b -> a -> a -> Maybe a) -> [a] -> [a] coalesce_sum add zero f = let g i p q = case f i p q of Just r -> Left r Nothing -> Right (i `add` p) in map snd . coalesce_accum g zero -- * Either -- | Lower 'Either' to 'Maybe' by discarding 'Left'. either_to_maybe :: Either a b -> Maybe b either_to_maybe = either (const Nothing) Just -- * Separate -- | Take elements while the sum of the prefix is less than or equal -- to the indicated value. Returns also the difference between the -- prefix sum and the requested sum. Note that zero elements are kept -- left. -- -- > take_sum_by id 3 [2,1] == ([2,1],0,[]) -- > take_sum_by id 3 [2,2] == ([2],1,[2]) -- > take_sum_by id 3 [2,1,0,1] == ([2,1,0],0,[1]) -- > take_sum_by id 3 [4] == ([],3,[4]) -- > take_sum_by id 0 [1..5] == ([],0,[1..5]) take_sum_by :: (Ord n, Num n) => (a -> n) -> n -> [a] -> ([a], n, [a]) take_sum_by f m = let go r n l = let z = (reverse r,m-n,l) in case l of [] -> z i:l' -> let n' = f i + n in if n' > m then z else go (i:r) n' l' in go [] 0 -- | Variant of 'take_sum_by' with 'id' function. take_sum :: (Ord a, Num a) => a -> [a] -> ([a],a,[a]) take_sum = take_sum_by id -- | Variant of 'take_sum' that requires the prefix to sum to value. -- -- > take_sum_by_eq id 3 [2,1,0,1] == Just ([2,1,0],[1]) -- > take_sum_by_eq id 3 [2,2] == Nothing take_sum_by_eq :: (Ord n, Num n) => (a -> n) -> n -> [a] -> Maybe ([a], [a]) take_sum_by_eq f m l = case take_sum_by f m l of (p,0,q) -> Just (p,q) _ -> Nothing -- | Recursive variant of 'take_sum_by_eq'. -- -- > split_sum_by_eq id [3,3] [2,1,0,3] == Just [[2,1,0],[3]] -- > split_sum_by_eq id [3,3] [2,2,2] == Nothing split_sum_by_eq :: (Ord n, Num n) => (a -> n) -> [n] -> [a] -> Maybe [[a]] split_sum_by_eq f mm l = case (mm,l) of ([],[]) -> Just [] (m:mm',_) -> case take_sum_by_eq f m l of Just (p,l') -> fmap (p :) (split_sum_by_eq f mm' l') Nothing -> Nothing _ -> Nothing -- | Split sequence such that the prefix sums to precisely /m/. The -- third element of the result indicates if it was required to divide -- an element. Note that zero elements are kept left. If the required -- sum is non positive, or the input list does not sum to at least the -- required sum, gives nothing. -- -- > split_sum 5 [2,3,1] == Just ([2,3],[1],Nothing) -- > split_sum 5 [2,1,3] == Just ([2,1,2],[1],Just (2,1)) -- > split_sum 2 [3/2,3/2,3/2] == Just ([3/2,1/2],[1,3/2],Just (1/2,1)) -- > split_sum 6 [1..10] == Just ([1..3],[4..10],Nothing) -- > fmap (\(a,_,c)->(a,c)) (split_sum 5 [1..]) == Just ([1,2,2],Just (2,1)) -- > split_sum 0 [1..] == Nothing -- > split_sum 3 [1,1] == Nothing -- > split_sum 3 [2,1,0] == Just ([2,1,0],[],Nothing) -- > split_sum 3 [2,1,0,1] == Just ([2,1,0],[1],Nothing) split_sum :: (Ord a, Num a) => a -> [a] -> Maybe ([a],[a],Maybe (a,a)) split_sum m l = let (p,n,q) = take_sum m l in if n == 0 then if null p then Nothing else Just (p,q,Nothing) else case q of [] -> Nothing z:q' -> Just (p++[n],z-n:q',Just (n,z-n)) -- | Alias for 'True', used locally for documentation. _t :: Bool _t = True -- | Alias for 'False', used locally for documentation. _f :: Bool _f = False -- | Variant of 'split_sum' that operates at 'RQ_T' sequences. -- -- > let r = Just ([(3,_f),(2,_t)],[(1,_f)]) -- > in rqt_split_sum 5 [(3,_f),(2,_t),(1,_f)] == r -- -- > let r = Just ([(3,_f),(1,_t)],[(1,_t),(1,_f)]) -- > in rqt_split_sum 4 [(3,_f),(2,_t),(1,_f)] == r -- -- > rqt_split_sum 4 [(5/2,False)] == Nothing rqt_split_sum :: RQ -> [RQ_T] -> Maybe ([RQ_T],[RQ_T]) rqt_split_sum d x = case split_sum d (map rqt_rq x) of Just (i,_,k) -> case k of Nothing -> Just (splitAt (length i) x) Just (p,q) -> let (s,(_,z):t) = splitAt (length i - 1) x in Just (s ++ [(p,True)] ,(q,z) : t) Nothing -> Nothing -- | Separate 'RQ_T' values in sequences summing to 'RQ' values. This -- is a recursive variant of 'rqt_split_sum'. Note that is does not -- ensure /cmn/ notation of values. -- -- > let d = [(2,_f),(2,_f),(2,_f)] -- > in rqt_separate [3,3] d == Right [[(2,_f),(1,_t)] -- > ,[(1,_f),(2,_f)]] -- -- > let d = [(5/8,_f),(1,_f),(3/8,_f)] -- > in rqt_separate [1,1] d == Right [[(5/8,_f),(3/8,_t)] -- > ,[(5/8,_f),(3/8,_f)]] -- -- > let d = [(4/7,_t),(1/7,_f),(1,_f),(6/7,_f),(3/7,_f)] -- > in rqt_separate [1,1,1] d == Right [[(4/7,_t),(1/7,_f),(2/7,_t)] -- > ,[(5/7,_f),(2/7,_t)] -- > ,[(4/7,_f),(3/7,_f)]] rqt_separate :: [RQ] -> [RQ_T] -> Either String [[RQ_T]] rqt_separate m x = case (m,x) of ([],[]) -> Right [] ([],_) -> Left (show ("rqt_separate",x)) (i:m',_) -> case rqt_split_sum i x of Just (r,x') -> fmap (r :) (rqt_separate m' x') Nothing -> Left (show ("rqt_separate",i,m',x)) rqt_separate_m :: [RQ] -> [RQ_T] -> Maybe [[RQ_T]] rqt_separate_m m = either_to_maybe . rqt_separate m -- | If the input 'RQ_T' sequence cannot be notated (see -- 'rqt_can_notate') separate into equal parts, so long as each part -- is not less than /i/. -- -- > rqt_separate_tuplet undefined [(1/3,_f),(1/6,_f)] -- > rqt_separate_tuplet undefined [(4/7,_t),(1/7,_f),(2/7,_f)] -- -- > let d = map rq_rqt [1/3,1/6,2/5,1/10] -- > in rqt_separate_tuplet (1/8) d == Right [[(1/3,_f),(1/6,_f)] -- > ,[(2/5,_f),(1/10,_f)]] -- -- > let d = [(1/5,True),(1/20,False),(1/2,False),(1/4,True)] -- > in rqt_separate_tuplet (1/16) d -- -- > let d = [(2/5,_f),(1/5,_f),(1/5,_f),(1/5,_t),(1/2,_f),(1/2,_f)] -- > in rqt_separate_tuplet (1/2) d -- -- > let d = [(4/10,True),(1/10,False),(1/2,True)] -- > in rqt_separate_tuplet (1/2) d rqt_separate_tuplet :: RQ -> [RQ_T] -> Either String [[RQ_T]] rqt_separate_tuplet i x = if rqt_can_notate x then Left (show ("rqt_separate_tuplet: separation not required",x)) else let j = sum (map rqt_rq x) / 2 in if j < i then Left (show ("rqt_separate_tuplet: j < i",j,i)) else rqt_separate [j,j] x -- | Recursive variant of 'rqt_separate_tuplet'. -- -- > let d = map rq_rqt [1,1/3,1/6,2/5,1/10] -- > in rqt_tuplet_subdivide (1/8) d == [[(1/1,_f)] -- > ,[(1/3,_f),(1/6,_f)] -- > ,[(2/5,_f),(1/10,_f)]] rqt_tuplet_subdivide :: RQ -> [RQ_T] -> [[RQ_T]] rqt_tuplet_subdivide i x = case rqt_separate_tuplet i x of Left _ -> [x] Right r -> concatMap (rqt_tuplet_subdivide i) r -- | Sequence variant of 'rqt_tuplet_subdivide'. -- -- > let d = [(1/5,True),(1/20,False),(1/2,False),(1/4,True)] -- > in rqt_tuplet_subdivide_seq (1/2) [d] rqt_tuplet_subdivide_seq :: RQ -> [[RQ_T]] -> [[RQ_T]] rqt_tuplet_subdivide_seq i = concatMap (rqt_tuplet_subdivide i) -- | If a tuplet is all tied, it ought to be a plain value?! -- -- > rqt_tuplet_sanity_ [(4/10,_t),(1/10,_f)] == [(1/2,_f)] rqt_tuplet_sanity_ :: [RQ_T] -> [RQ_T] rqt_tuplet_sanity_ t = let last_tied = rqt_tied (last t) all_tied = all rqt_tied (dropRight 1 t) in if all_tied then [(sum (map rqt_rq t),last_tied)] else t rqt_tuplet_subdivide_seq_sanity_ :: RQ -> [[RQ_T]] -> [[RQ_T]] rqt_tuplet_subdivide_seq_sanity_ i = map rqt_tuplet_sanity_ . rqt_tuplet_subdivide_seq i -- * Divisions -- | Separate 'RQ' sequence into measures given by 'RQ' length. -- -- > to_measures_rq [3,3] [2,2,2] == Right [[(2,_f),(1,_t)],[(1,_f),(2,_f)]] -- > to_measures_rq [3,3] [6] == Right [[(3,_t)],[(3,_f)]] -- > to_measures_rq [1,1,1] [3] == Right [[(1,_t)],[(1,_t)],[(1,_f)]] -- > to_measures_rq [3,3] [2,2,1] -- > to_measures_rq [3,2] [2,2,2] -- -- > let d = [4/7,33/28,9/20,4/5] -- > in to_measures_rq [3] d == Right [[(4/7,_f),(33/28,_f),(9/20,_f),(4/5,_f)]] to_measures_rq :: [RQ] -> [RQ] -> Either String [[RQ_T]] to_measures_rq m = rqt_separate m . map rq_rqt -- | Variant of 'to_measures_rq' that ensures 'RQ_T' are /cmn/ -- durations. This is not a good composition. -- -- > to_measures_rq_cmn [6,6] [5,5,2] == Right [[(4,_t),(1,_f),(1,_t)] -- > ,[(4,_f),(2,_f)]] -- -- > let r = [[(4/7,_t),(1/7,_f),(1,_f),(6/7,_f),(3/7,_f)]] -- > in to_measures_rq_cmn [3] [5/7,1,6/7,3/7] == Right r -- -- > to_measures_rq_cmn [1,1,1] [5/7,1,6/7,3/7] == Right [[(4/7,_t),(1/7,_f),(2/7,_t)] -- > ,[(4/7,_t),(1/7,_f),(2/7,_t)] -- > ,[(4/7,_f),(3/7,_f)]] to_measures_rq_cmn :: [RQ] -> [RQ] -> Either String [[RQ_T]] to_measures_rq_cmn m = fmap (map rqt_set_to_cmn) . to_measures_rq m -- | Variant of 'to_measures_rq' with measures given by -- 'Time_Signature' values. Does not ensure 'RQ_T' are /cmn/ -- durations. -- -- > to_measures_ts [(1,4)] [5/8,3/8] /= Right [[(1/2,_t),(1/8,_f),(3/8,_f)]] -- > to_measures_ts [(1,4)] [5/7,2/7] /= Right [[(4/7,_t),(1/7,_f),(2/7,_f)]] -- -- > let {m = replicate 18 (1,4) -- > ;x = [3/4,2,5/4,9/4,1/4,3/2,1/2,7/4,1,5/2,11/4,3/2]} -- > in to_measures_ts m x == Right [[(3/4,_f),(1/4,_t)],[(1/1,_t)] -- > ,[(3/4,_f),(1/4,_t)],[(1/1,_f)] -- > ,[(1/1,_t)],[(1/1,_t)] -- > ,[(1/4,_f),(1/4,_f),(1/2,_t)],[(1/1,_f)] -- > ,[(1/2,_f),(1/2,_t)],[(1/1,_t)] -- > ,[(1/4,_f),(3/4,_t)],[(1/4,_f),(3/4,_t)] -- > ,[(1/1,_t)],[(3/4,_f),(1/4,_t)] -- > ,[(1/1,_t)],[(1/1,_t)] -- > ,[(1/2,_f),(1/2,_t)],[(1/1,_f)]] -- -- > to_measures_ts [(3,4)] [4/7,33/28,9/20,4/5] -- > to_measures_ts (replicate 3 (1,4)) [4/7,33/28,9/20,4/5] to_measures_ts :: [Time_Signature] -> [RQ] -> Either String [[RQ_T]] to_measures_ts m = to_measures_rq (map ts_rq m) -- | Variant of 'to_measures_ts' that allows for duration field -- operation but requires that measures be well formed. This is -- useful for re-grouping measures after notation and ascription. to_measures_ts_by_eq :: (a -> RQ) -> [Time_Signature] -> [a] -> Maybe [[a]] to_measures_ts_by_eq f m = split_sum_by_eq f (map ts_rq m) -- | Divide measure into pulses of indicated 'RQ' durations. Measure -- must be of correct length but need not contain only /cmn/ -- durations. Pulses are further subdivided if required to notate -- tuplets correctly, see 'rqt_tuplet_subdivide_seq'. -- -- > let d = [(1/4,_f),(1/4,_f),(2/3,_t),(1/6,_f),(16/15,_f),(1/5,_f) -- > ,(1/5,_f),(2/5,_t),(1/20,_f),(1/2,_f),(1/4,_t)] -- > in m_divisions_rq [1,1,1,1] d -- -- > m_divisions_rq [1,1,1] [(4/7,_f),(33/28,_f),(9/20,_f),(4/5,_f)] m_divisions_rq :: [RQ] -> [RQ_T] -> Either String [[RQ_T]] m_divisions_rq z = fmap (rqt_tuplet_subdivide_seq_sanity_ (1/16) . map rqt_set_to_cmn) . rqt_separate z -- | Variant of 'm_divisions_rq' that determines pulse divisions from -- 'Time_Signature'. -- -- > let d = [(4/7,_t),(1/7,_f),(2/7,_f)] -- > in m_divisions_ts (1,4) d == Just [d] -- -- > let d = map rq_rqt [1/3,1/6,2/5,1/10] -- > in m_divisions_ts (1,4) d == Just [[(1/3,_f),(1/6,_f)] -- > ,[(2/5,_f),(1/10,_f)]] -- -- > let d = map rq_rqt [4/7,33/28,9/20,4/5] -- > in m_divisions_ts (3,4) d == Just [[(4/7,_f),(3/7,_t)] -- > ,[(3/4,_f),(1/4,_t)] -- > ,[(1/5,_f),(4/5,_f)]] m_divisions_ts :: Time_Signature -> [RQ_T] -> Either String [[RQ_T]] m_divisions_ts ts = m_divisions_rq (ts_divisions ts) {-| Composition of 'to_measures_rq' and 'm_divisions_rq', where measures are initially given as sets of divisions. > let m = [[1,1,1],[1,1,1]] > in to_divisions_rq m [2,2,2] == Right [[[(1,_t)],[(1,_f)],[(1,_t)]] > ,[[(1,_f)],[(1,_t)],[(1,_f)]]] > let d = [2/7,1/7,4/7,5/7,8/7,1,1/7] > in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,_f),(1/7,_f),(4/7,_f)] > ,[(4/7,_t),(1/7,_f),(2/7,_t)] > ,[(6/7,_f),(1/7,_t)] > ,[(6/7,_f),(1/7,_f)]]] > let d = [5/7,1,6/7,3/7] > in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,_t),(1/7,_f),(2/7,_t)] > ,[(4/7,_t),(1/7,_f),(2/7,_t)] > ,[(4/7,_f),(3/7,_f)]]] > let d = [2/7,1/7,4/7,5/7,1,6/7,3/7] > in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,_f),(1/7,_f),(4/7,_f)] > ,[(4/7,_t),(1/7,_f),(2/7,_t)] > ,[(4/7,_t),(1/7,_f),(2/7,_t)] > ,[(4/7,_f),(3/7,_f)]]] > let d = [4/7,33/28,9/20,4/5] > in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,_f),(3/7,_t)] > ,[(3/4,_f),(1/4,_t)] > ,[(1/5,_f),(4/5,_f)]]] > let {p = [[1/2,1,1/2],[1/2,1]] > ;d = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3]} > in to_divisions_rq p d == Right [[[(1/6,_f),(1/6,_f),(1/6,_f)] > ,[(1/6,_f),(1/6,_f),(1/6,_f),(1/2,True)] > ,[(1/6,_f),(1/6,_f),(1/6,True)]] > ,[[(1/6,_f),(1/6,_f),(1/6,_f)] > ,[(1/3,_f),(1/6,_f),(1/2,_f)]]] -} to_divisions_rq :: [[RQ]] -> [RQ] -> Either String [[[RQ_T]]] to_divisions_rq m x = let m' = map sum m in case to_measures_rq m' x of Right y -> all_right (zipWith m_divisions_rq m y) Left e -> Left e -- | Variant of 'to_divisions_rq' with measures given as set of -- 'Time_Signature'. -- -- > let d = [3/5,2/5,1/3,1/6,7/10,17/15,1/2,1/6] -- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,_f),(2/5,_f)] -- > ,[(1/3,_f),(1/6,_f),(1/2,_t)] -- > ,[(1/5,_f),(4/5,_t)] -- > ,[(1/3,_f),(1/2,_f),(1/6,_f)]]] -- -- > let d = [3/5,2/5,1/3,1/6,7/10,29/30,1/2,1/3] -- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,_f),(2/5,_f)] -- > ,[(1/3,_f),(1/6,_f),(1/2,_t)] -- > ,[(1/5,_f),(4/5,_t)] -- > ,[(1/6,_f),(1/2,_f),(1/3,_f)]]] -- -- > let d = [3/5,2/5,1/3,1/6,7/10,4/5,1/2,1/2] -- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,_f),(2/5,_f)] -- > ,[(1/3,_f),(1/6,_f),(1/2,_t)] -- > ,[(1/5,_f),(4/5,_f)] -- > ,[(1/2,_f),(1/2,_f)]]] -- -- > let d = [4/7,33/28,9/20,4/5] -- > in to_divisions_ts [(3,4)] d == Just [[[(4/7,_f),(3/7,_t)] -- > ,[(3/4,_f),(1/4,_t)] -- > ,[(1/5,_f),(4/5,_f)]]] to_divisions_ts :: [Time_Signature] -> [RQ] -> Either String [[[RQ_T]]] to_divisions_ts ts = to_divisions_rq (map ts_divisions ts) -- * Durations -- | Pulse tuplet derivation. -- -- > p_tuplet_rqt [(2/3,_f),(1/3,_t)] == Just ((3,2),[(1,_f),(1/2,_t)]) -- > p_tuplet_rqt (map rq_rqt [1/3,1/6]) == Just ((3,2),[(1/2,_f),(1/4,_f)]) -- > p_tuplet_rqt (map rq_rqt [2/5,1/10]) == Just ((5,4),[(1/2,_f),(1/8,_f)]) -- > p_tuplet_rqt (map rq_rqt [1/3,1/6,2/5,1/10]) p_tuplet_rqt :: [RQ_T] -> Maybe ((Integer,Integer),[RQ_T]) p_tuplet_rqt x = let f t = (t,map (rqt_un_tuplet t) x) in fmap f (rq_derive_tuplet (map rqt_rq x)) -- | Notate pulse, ie. derive tuplet if neccesary. The flag indicates -- if the initial value is tied left. -- -- > p_notate False [(2/3,_f),(1/3,_t)] -- > p_notate False [(2/5,_f),(1/10,_t)] -- > p_notate False [(1/4,_t),(1/8,_f),(1/8,_f)] -- > p_notate False (map rq_rqt [1/3,1/6]) -- > p_notate False (map rq_rqt [2/5,1/10]) -- > p_notate False (map rq_rqt [1/3,1/6,2/5,1/10]) == Nothing p_notate :: Bool -> [RQ_T] -> Either String [Duration_A] p_notate z x = let f = p_simplify . rqt_to_duration_a z d = case p_tuplet_rqt x of Just (t,x') -> da_tuplet t (f x') Nothing -> f x in if rq_can_notate (map rqt_rq x) then Right d else Left (show ("p_notate",z,x)) -- | Notate measure. -- -- > m_notate True [[(2/3,_f),(1/3,_t)],[(1,_t)],[(1,_f)]] -- -- > let f = m_notate False . concat -- -- > fmap f (to_divisions_ts [(4,4)] [3/5,2/5,1/3,1/6,7/10,17/15,1/2,1/6]) -- > fmap f (to_divisions_ts [(4,4)] [3/5,2/5,1/3,1/6,7/10,29/30,1/2,1/3]) m_notate :: Bool -> [[RQ_T]] -> Either String [Duration_A] m_notate z m = let z' = z : map (is_tied_right . last) m in fmap concat (all_right (zipWith p_notate z' m)) {-| Multiple measure notation. > let d = [2/7,1/7,4/7,5/7,8/7,1,1/7] > in fmap mm_notate (to_divisions_ts [(4,4)] d) > let d = [2/7,1/7,4/7,5/7,1,6/7,3/7] > in fmap mm_notate (to_divisions_ts [(4,4)] d) > let d = [3/5,2/5,1/3,1/6,7/10,4/5,1/2,1/2] > in fmap mm_notate (to_divisions_ts [(4,4)] d) > let {p = [[1/2,1,1/2],[1/2,1]] > ;d = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3]} > in fmap mm_notate (to_divisions_rq p d) -} mm_notate :: [[[RQ_T]]] -> Either String [[Duration_A]] mm_notate d = let z = False : map (is_tied_right . last . last) d in all_right (zipWith m_notate z d) -- * Simplifications -- | Structure given to 'Simplify_P' to decide simplification. The -- structure is /(ts,start-rq,(left-rq,right-rq))/. type Simplify_T = (Time_Signature,RQ,(RQ,RQ)) -- | Predicate function at 'Simplify_T'. type Simplify_P = Simplify_T -> Bool -- | Variant of 'Simplify_T' allowing multiple rules. type Simplify_M = ([Time_Signature],[RQ],[(RQ,RQ)]) -- | Transform 'Simplify_M' to 'Simplify_P'. meta_table_p :: Simplify_M -> Simplify_P meta_table_p (tt,ss,pp) (t,s,p) = t `elem` tt && s `elem` ss && p `elem` pp -- | Transform 'Simplify_M' to set of 'Simplify_T'. meta_table_t :: Simplify_M -> [Simplify_T] meta_table_t (tt,ss,pp) = [(t,s,p) | t <- tt, s <- ss,p <- pp] -- | The default table of simplifiers. -- -- > default_table ((3,4),1,(1,1)) == True default_table :: Simplify_P default_table x = let t :: [Simplify_M] t = [([(3,4)],[1],[(1,1)])] p :: [Simplify_P] p = map meta_table_p t in or (p <*> pure x) -- | The default eighth-note pulse simplifier rule. -- -- > default_8_rule ((3,8),0,(1/2,1/2)) == True -- > default_8_rule ((3,8),1/2,(1/2,1/2)) == True -- > default_8_rule ((3,8),1,(1/2,1/2)) == True -- > default_8_rule ((2,8),0,(1/2,1/2)) == True -- > default_8_rule ((5,8),0,(1,1/2)) == True -- > default_8_rule ((5,8),0,(2,1/2)) == True default_8_rule :: Simplify_P default_8_rule ((i,j),t,(p,q)) = let r = p + q in j == 8 && denominator t `elem` [1,2] && (r <= 2 || r == ts_rq (i,j) || rq_is_integral r) -- | The default quarter note pulse simplifier rule. -- -- > default_4_rule ((3,4),0,(1,1/2)) == True -- > default_4_rule ((3,4),0,(1,3/4)) == True -- > default_4_rule ((4,4),1,(1,1)) == False -- > default_4_rule ((4,4),2,(1,1)) == True -- > default_4_rule ((4,4),2,(1,2)) == True -- > default_4_rule ((4,4),0,(2,1)) == True -- > default_4_rule ((3,4),1,(1,1)) == False default_4_rule :: Simplify_P default_4_rule ((_,j),t,(p,q)) = let r = p + q in j == 4 && denominator t == 1 && even (numerator t) && (r <= 2 || rq_is_integral r) {- -- | Any pulse-division aligned pair that sums to a division of the -- pulse and does not cross a pulse boundary can be simplified. -- -- > default_aligned_pulse_rule ((4,2),0,(2,1)) == True -- > default_aligned_pulse_rule ((4,2),1,(1,1)) == False -- > default_aligned_pulse_rule ((4,2),7,(4/10,1/10)) == True default_aligned_pulse_rule :: Simplify_P default_aligned_pulse_rule ((_,j),t,(p,q)) = let r = p + q w = whole_note_division_to_rq j tw = t `rq_mod` w in w `rq_mod` r == 0 && t `rq_mod` (w `min` 1) == 0 && (tw == 0 || tw + r <= w) -} -- | The default simplifier rule. To extend provide a list of -- 'Simplify_T'. default_rule :: [Simplify_T] -> Simplify_P default_rule x r = r `elem` x || {-default_aligned_pulse_rule r ||-} default_4_rule r || default_8_rule r || default_table r -- | Measure simplifier. Apply given 'Simplify_P'. m_simplify :: Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A] m_simplify p ts = let f st (d0,a0) (d1,a1) = let t = Tie_Right `elem` a0 && Tie_Left `elem` a1 e = End_Tuplet `notElem` a0 && not (any begins_tuplet a1) m = duration_meq d0 d1 d = sum_dur d0 d1 a = delete Tie_Right a0 ++ delete Tie_Left a1 r = p (ts,st,(duration_to_rq d0,duration_to_rq d1)) n_dots = 1 g i = if dots i <= n_dots && t && e && m && r then Just (i,a) else Nothing in join (fmap g d) z i (j,_) = i + duration_to_rq j in coalesce_sum z 0 f -- | Pulse simplifier predicate, which is 'const' 'True'. p_simplify_rule :: Simplify_P p_simplify_rule = const True -- | Pulse simplifier. -- -- > import Music.Theory.Duration.Name.Abbreviation -- > p_simplify [(q,[Tie_Right]),(e,[Tie_Left])] == [(q',[])] -- > p_simplify [(e,[Tie_Right]),(q,[Tie_Left])] == [(q',[])] -- > p_simplify [(q,[Tie_Right]),(e',[Tie_Left])] == [(q'',[])] -- > p_simplify [(q'',[Tie_Right]),(s,[Tie_Left])] == [(h,[])] -- > p_simplify [(e,[Tie_Right]),(s,[Tie_Left]),(e',[])] == [(e',[]),(e',[])] -- -- > let f = rqt_to_duration_a False -- > in p_simplify (f [(1/8,_t),(1/4,_t),(1/8,_f)]) == f [(1/2,_f)] p_simplify :: [Duration_A] -> [Duration_A] p_simplify = m_simplify p_simplify_rule undefined -- * Notate {-| Notate RQ duration sequence. Derive pulse divisions from 'Time_Signature' if not given directly. Composition of 'to_divisions_ts', 'mm_notate' 'm_simplify'. > let ts = [(4,8),(3,8)] > ts_p = [[1/2,1,1/2],[1/2,1]] > rq = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3] > sr x = T.default_rule [] x > in T.notate_rqp sr ts (Just ts_p) rq -} notate_rqp :: Simplify_P -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> Either String [[Duration_A]] notate_rqp r ts ts_p x = do let ts_p' = fromMaybe (map ts_divisions ts) ts_p mm <- to_divisions_rq ts_p' x dd <- mm_notate mm return (zipWith (m_simplify r) ts dd) -- | Variant of 'notate_rqp' without pulse divisions (derive). -- -- > notate (default_rule [((3,2),0,(2,2)),((3,2),0,(4,2))]) [(3,2)] [6] notate :: Simplify_P -> [Time_Signature] -> [RQ] -> Either String [[Duration_A]] notate r ts x = notate_rqp r ts Nothing x -- * Ascribe -- | Variant of 'zip' that retains elements of the right hand (rhs) -- list where elements of the left hand (lhs) list meet the given lhs -- predicate. If the right hand side is longer the remaining elements -- to be processed are given. It is an error for the right hand side -- to be short. -- -- > zip_hold_lhs even [1..5] "abc" == ([],zip [1..6] "abbcc") -- > zip_hold_lhs odd [1..6] "abc" == ([],zip [1..6] "aabbcc") -- > zip_hold_lhs even [1] "ab" == ("b",[(1,'a')]) -- > zip_hold_lhs even [1,2] "a" == undefined zip_hold_lhs :: (Show t,Show x) => (x -> Bool) -> [x] -> [t] -> ([t],[(x,t)]) zip_hold_lhs lhs_f = let f st e = case st of r:s -> let st' = if lhs_f e then st else s in (st',(e,r)) _ -> error (show ("zip_hold_lhs: rhs ends",st,e)) in flip (mapAccumL f) -- | Variant of 'zip_hold' that requires the right hand side to be -- precisely the required length. -- -- > zip_hold_lhs_err even [1..5] "abc" == zip [1..6] "abbcc" -- > zip_hold_lhs_err odd [1..6] "abc" == zip [1..6] "aabbcc" -- > zip_hold_lhs_err id [False,False] "a" == undefined -- > zip_hold_lhs_err id [False] "ab" == undefined zip_hold_lhs_err :: (Show t,Show x) => (x -> Bool) -> [x] -> [t] -> [(x,t)] zip_hold_lhs_err lhs_f p q = case zip_hold_lhs lhs_f p q of ([],r) -> r e -> error (show ("zip_hold_lhs_err: lhs ends",e)) -- | Variant of 'zip' that retains elements of the right hand (rhs) -- list where elements of the left hand (lhs) list meet the given lhs -- predicate, and elements of the lhs list where elements of the rhs -- meet the rhs predicate. If the right hand side is longer the -- remaining elements to be processed are given. It is an error for -- the right hand side to be short. -- -- > zip_hold even (const False) [1..5] "abc" == ([],zip [1..6] "abbcc") -- > zip_hold odd (const False) [1..6] "abc" == ([],zip [1..6] "aabbcc") -- > zip_hold even (const False) [1] "ab" == ("b",[(1,'a')]) -- > zip_hold even (const False) [1,2] "a" == undefined -- -- > zip_hold odd even [1,2,6] [1..5] == ([4,5],[(1,1),(2,1),(6,2),(6,3)]) zip_hold :: (Show t,Show x) => (x -> Bool) -> (t -> Bool) -> [x] -> [t] -> ([t],[(x,t)]) zip_hold lhs_f rhs_f = let f r x t = case (x,t) of ([],_) -> (t,reverse r) (_,[]) -> error "zip_hold: rhs ends" (x0:x',t0:t') -> let x'' = if rhs_f t0 then x else x' t'' = if lhs_f x0 then t else t' in f ((x0,t0) : r) x'' t'' in f [] -- | Zip a list of 'Duration_A' elements duplicating elements of the -- right hand sequence for tied durations. -- -- > let {Just d = to_divisions_ts [(4,4),(4,4)] [3,3,2] -- > ;f = map snd . snd . flip m_ascribe "xyz"} -- > in fmap f (notate d) == Just "xxxyyyzz" m_ascribe :: Show x => [Duration_A] -> [x] -> ([x],[(Duration_A,x)]) m_ascribe = zip_hold_lhs da_tied_right -- | 'snd' '.' 'm_ascribe'. ascribe :: Show x => [Duration_A] -> [x] -> [(Duration_A, x)] ascribe d = snd . m_ascribe d -- | Variant of 'm_ascribe' for a set of measures. mm_ascribe :: Show x => [[Duration_A]] -> [x] -> [[(Duration_A,x)]] mm_ascribe mm x = case mm of [] -> [] m:mm' -> let (x',r) = m_ascribe m x in r : mm_ascribe mm' x' -- | 'mm_ascribe of 'notate'. notate_mm_ascribe :: Show a => [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] -> Either String [[(Duration_A,a)]] notate_mm_ascribe r ts rqp d p = let n = notate_rqp (default_rule r) ts rqp d f = flip mm_ascribe p err str = show ("notate_ascribe",str,ts,d,p) in either (Left . err) (Right . f) n notate_mm_ascribe_err :: Show a => [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] -> [[(Duration_A,a)]] notate_mm_ascribe_err = either error id .:::: notate_mm_ascribe -- | Group elements as /chords/ where a chord element is indicated by -- the given predicate. -- -- > group_chd even [1,2,3,4,4,5,7,8] == [[1,2],[3,4,4],[5],[7,8]] group_chd :: (x -> Bool) -> [x] -> [[x]] group_chd f x = case split (keepDelimsL (whenElt (not.f))) x of []:r -> r _ -> error "group_chd: first element chd?" -- | Variant of 'ascribe' that groups the /rhs/ elements using -- 'group_chd' and with the indicated /chord/ function, then rejoins -- the resulting sequence. ascribe_chd :: Show x => (x -> Bool) -> [Duration_A] -> [x] -> [(Duration_A, x)] ascribe_chd chd_f d x = let x' = group_chd chd_f x jn (i,j) = zip (repeat i) j in concatMap jn (ascribe d x') -- | Variant of 'mm_ascribe' using 'group_chd' mm_ascribe_chd :: Show x => (x -> Bool) -> [[Duration_A]] -> [x] -> [[(Duration_A,x)]] mm_ascribe_chd chd_f d x = let x' = group_chd chd_f x jn (i,j) = zip (repeat i) j in map (concatMap jn) (mm_ascribe d x') hmt-0.15/Music/Theory/Meter/0000755000000000000000000000000012416136065014027 5ustar0000000000000000hmt-0.15/Music/Theory/Meter/Barlow_1987.hs0000644000000000000000000003126012416136065016303 0ustar0000000000000000-- | Clarence Barlow. \"Two Essays on Theory\". -- /Computer Music Journal/, 11(1):44-60, 1987. -- Translated by Henning Lohner. module Music.Theory.Meter.Barlow_1987 where import Data.List import Data.Numbers.Primes {- primes -} --import Debug.Trace import Music.Theory.Math (R) traceShow :: a -> b -> b traceShow _ x = x -- | One indexed variant of 'genericIndex'. -- -- > map (at [11..13]) [1..3] == [11,12,13] at :: (Integral n) => [a] -> n -> a at x i = x `genericIndex` (i - 1) -- | Variant of 'at' with boundary rules and specified error message. -- -- > map (at' 'x' [11..13]) [0..4] == [1,11,12,13,1] -- > at' 'x' [0] 3 == undefined at' :: (Num a,Show a,Integral n,Show n,Show m) => m -> [a] -> n -> a at' m x i = let n = genericLength x in if i == 0 || i == n + 1 then 1 -- error (show ("at':==",m,x,i)) else if i < 0 || i > n + 1 then error (show ("at'",m,x,i)) else x `genericIndex` (i - 1) -- | Variant of 'mod' with input constraints. -- -- > mod' (-1) 2 == 1 mod' :: (Integral a,Show a) => a -> a -> a mod' a b = let r = mod a b in if r < 0 || r >= b then error (show ("mod'",a,b,r)) else r -- | Specialised variant of 'fromIntegral'. to_r :: (Integral n,Show n) => n -> R to_r = fromIntegral -- | Variant on 'div' with input constraints. div' :: (Integral a,Show a) => String -> a -> a -> a div' m i j = if i < 0 || j < 0 then error (show ("div'",m,i,j)) else truncate (to_r i / to_r j) -- | A stratification is a tree of integral subdivisions. type Stratification t = [t] -- | Indispensibilities from stratification. -- -- > indispensibilities [3,2,2] == [11,0,6,3,9,1,7,4,10,2,8,5] -- > indispensibilities [2,3,2] == [11,0,6,2,8,4,10,1,7,3,9,5] -- > indispensibilities [2,2,3] == [11,0,4,8,2,6,10,1,5,9,3,7] -- > indispensibilities [3,5] == [14,0,9,3,6,12,1,10,4,7,13,2,11,5,8] indispensibilities :: (Integral n,Show n) => Stratification n -> [n] indispensibilities x = map (lower_psi x (genericLength x)) [1 .. product x] -- | The indispensibility measure (ψ). -- -- > map (lower_psi [2] 1) [1..2] == [1,0] -- > map (lower_psi [3] 1) [1..3] == [2,0,1] -- > map (lower_psi [2,2] 2) [1..4] == [3,0,2,1] -- > map (lower_psi [5] 1) [1..5] == [4,0,3,1,2] -- > map (lower_psi [3,2] 2) [1..6] == [5,0,3,1,4,2] -- > map (lower_psi [2,3] 2) [1..6] == [5,0,2,4,1,3] lower_psi :: (Integral a,Show a) => Stratification a -> a -> a -> a lower_psi q z n = let s8 r = let s1 = product q s2 = (n - 2) `mod'` s1 s3 = let f k = at' "s3" q (z + 1 - k) in product (map f [0 .. r]) s4 = 1 + div' "s4" s2 s3 c = at' "c" q (z - r) s5 = s4 `mod'` c s6 = upper_psi c (1 + s5) s7 = let f = at' "s7" q in product (map f [0 .. z - r - 1]) in traceShow ("lower_psi:s",s1,s2,s3,s4,s5,s6,s7) (s7 * s6) in traceShow ("lower_psi",q,z,n) (sum (map s8 [0 .. z - 1])) -- | The first /n/th primes, reversed. -- -- > reverse_primes 14 == [43,41,37,31,29,23,19,17,13,11,7,5,3,2] reverse_primes :: (Integral n,Show n) => n -> [n] reverse_primes n = reverse (genericTake n primes) -- | Generate prime stratification for /n/. -- -- > map prime_stratification [2,3,5,7,11] == [[2],[3],[5],[7],[11]] -- > map prime_stratification [6,8,9,12] == [[3,2],[2,2,2],[3,3],[3,2,2]] -- > map prime_stratification [22,10,4,1] == [[11,2],[5,2],[2,2],[]] -- > map prime_stratification [18,16,12] == [[3,3,2],[2,2,2,2],[3,2,2]] prime_stratification :: (Integral n,Show n) => n -> Stratification n prime_stratification = let go x k = case x of p:x' -> if k `rem` p == 0 then p : go x (div' "ps" k p) else go x' k [] -> [] in go (reverse_primes 14) -- | Fundamental indispensibilities for prime numbers (Ψ). -- -- > map (upper_psi 2) [1..2] == [1,0] -- > map (upper_psi 3) [1..3] == [2,0,1] -- > map (upper_psi 5) [1..5] == [4,0,3,1,2] -- > map (upper_psi 7) [1..7] == [6,0,4,2,5,1,3] -- > map (upper_psi 11) [1..11] == [10,0,6,4,9,1,7,3,8,2,5] -- > map (upper_psi 13) [1..13] == [12,0,7,4,10,1,8,5,11,2,9,3,6] upper_psi :: (Integral a,Show a) => a -> a -> a upper_psi p n = if p `notElem` reverse_primes 14 then error (show ("upper_psi","not prime",p,n)) else if p == 2 then p - n else if n == p - 1 then div' "upper_psi" p 4 else let n' = n - div' "n'" n p s = prime_stratification (p - 1) q = lower_psi s (genericLength s) n' q' = to_r q p' = to_r p in truncate (q' + 2 * sqrt ((q' + 1) / p')) -- | Table such that each subsequent row deletes the least -- indispensibile pulse. -- -- > thinning_table [3,2] == [[True,True,True,True,True,True] -- > ,[True,False,True,True,True,True] -- > ,[True,False,True,False,True,True] -- > ,[True,False,True,False,True,False] -- > ,[True,False,False,False,True,False] -- > ,[True,False,False,False,False,False]] thinning_table :: (Integral n,Show n) => Stratification n -> [[Bool]] thinning_table s = let x = indispensibilities s n = genericLength x true i = genericReplicate i True false i = genericReplicate i False f i = true (i + 1) ++ false (n - i - 1) in transpose (map f x) -- | Trivial pretty printer for 'thinning_table'. -- -- > putStrLn (thinning_table_pp [3,2]) -- > putStrLn (thinning_table_pp [2,3]) -- -- > ****** ****** -- > *.**** *.**** -- > *.*.** *.**.* -- > *.*.*. *..*.* -- > *...*. *..*.. -- > *..... *..... thinning_table_pp :: (Integral n,Show n) => Stratification n -> String thinning_table_pp s = let f x = if x then '*' else '.' in unlines (map (map f) (thinning_table s)) -- | Scale values against length of list minus one. -- -- > relative_to_length [0..5] == [0.0,0.2,0.4,0.6,0.8,1.0] relative_to_length :: (Real a, Fractional b) => [a] -> [b] relative_to_length x = let n = length x - 1 in map ((/ fromIntegral n) . realToFrac) x -- | Variant of 'indispensibilities' that scales value to lie in -- @(0,1)@. -- -- relative_indispensibilities [3,2] == [1,0,0.6,0.2,0.8,0.4] relative_indispensibilities :: (Integral n,Show n) => Stratification n -> [R] relative_indispensibilities = relative_to_length . indispensibilities -- | Align two meters (given as stratifications) to least common -- multiple of their degrees. The 'indispensibilities' function is -- given as an argument so that it may be relative if required. This -- generates Table 7 (p.58). -- -- > let r = [(5,5),(0,0),(2,3),(4,1),(1,4),(3,2)] -- > in align_meters indispensibilities [2,3] [3,2] == r -- -- > let r = [(1,1),(0,0),(0.4,0.6),(0.8,0.2),(0.2,0.8),(0.6,0.4)] -- > in align_meters relative_indispensibilities [2,3] [3,2] == r -- -- > align_meters indispensibilities [2,2,3] [3,5] -- > align_meters relative_indispensibilities [2,2,3] [3,5] align_meters :: (t -> [b]) -> t -> t -> [(b,b)] align_meters f s1 s2 = let i1 = f s1 i2 = f s2 n1 = length i1 n2 = length i2 n = lcm n1 n2 i1' = concat (replicate (n `div` n1) i1) i2' = concat (replicate (n `div` n2) i2) in zip i1' i2' -- | Type pairing a stratification and a tempo. type S_MM t = ([t],t) -- | Variant of 'div' that requires 'mod' be @0@. whole_div :: Integral a => a -> a -> a whole_div i j = case i `divMod` j of (k,0) -> k _ -> error "whole_div" -- | Variant of 'quot' that requires 'rem' be @0@. whole_quot :: Integral a => a -> a -> a whole_quot i j = case i `quotRem` j of (k,0) -> k _ -> error "whole_quot" -- | Rule to prolong stratification of two 'S_MM' values such that -- pulse at the deeper level are aligned. (Paragraph 2, p.58) -- -- > let x = ([2,2,2],1) -- > in prolong_stratifications x x == (fst x,fst x) -- -- > let r = ([2,5,3,3,2],[3,2,5,5]) -- > in prolong_stratifications ([2,5],50) ([3,2],60) == r -- -- > prolong_stratifications ([2,2,3],5) ([3,5],4) == ([2,2,3],[3,5]) prolong_stratifications :: (Integral n,Show n) => S_MM n -> S_MM n -> ([n],[n]) prolong_stratifications (s1,v1) (s2,v2) = let t1 = product s1 * v1 t2 = product s2 * v2 t = lcm t1 t2 s1' = s1 ++ prime_stratification (t `whole_div` t1) s2' = s2 ++ prime_stratification (t `whole_div` t2) in (s1',s2') -- | Arithmetic mean (average) of a list. -- -- > mean [0..5] == 2.5 mean :: Fractional a => [a] -> a mean x = sum x / fromIntegral (length x) -- | Square of /n/. -- -- > square 5 == 25 square :: Num a => a -> a square n = n * n -- | Composition of 'prolong_stratifications' and 'align_meters'. -- -- > align_s_mm indispensibilities ([2,2,3],5) ([3,5],4) align_s_mm :: (Integral n,Show n) => ([n] -> [t]) -> S_MM n -> S_MM n -> [(t,t)] align_s_mm f (s1,v1) (s2,v2) = let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2) in align_meters f s1' s2' -- | An attempt at Equation 5 of the /CMJ/ paper. When /n/ is /h-1/ -- the output is incorrect (it is the product of the correct values -- for /n/ at /h-1/ and /h/). -- -- > map (upper_psi' 5) [1..5] /= [4,0,3,1,2] -- > map (upper_psi' 7) [1..7] /= [6,0,4,2,5,1,3] -- > map (upper_psi' 11) [1..11] /= [10,0,6,4,9,1,7,3,8,2,5] -- > map (upper_psi' 13) [1..13] /= [12,0,7,4,10,1,8,5,11,2,9,3,6] upper_psi' :: (Integral a,Show a) => a -> a -> a upper_psi' h n = if h > 3 then let omega x = if x == 0 then 0 else 1 h4 = div' "h4" h 4 n' = n - 1 + omega (h - n) p = prime_stratification (h - 1) x0 = lower_psi p (genericLength p) n' x1 = x0 + omega (div' "z" x0 h4) x2 = omega (h - n - 1) x3 = x2 + h4 * (1 - x2) in traceShow ("upper_psi'",h,n,n',x0,x1,x2,x3) (x1 * x3) else (h + n - 2) `mod'` h -- | The /MPS/ limit equation given on p.58. -- -- > mps_limit 3 == 21 + 7/9 mps_limit :: Floating a => a -> a mps_limit n = sum [n ** 4 / 9 ,n ** 3 / 3 ,13 * (n ** 2 ) / 36 ,n / 6 ,1 / 36] -- | The square of the product of the input sequence is summed, then -- divided by the square of the sequence length. -- -- > mean_square_product [(0,0),(1,1),(2,2),(3,3)] == 6.125 -- > mean_square_product [(2,3),(4,5)] == (6^2 + 20^2) / 2^2 mean_square_product :: Fractional n => [(n,n)] -> n mean_square_product x = let f = square . uncurry (*) n = fromIntegral (length x) in sum (map f x) / square n -- | An incorrect attempt at the description in paragraph two of p.58 -- of the /CMJ/ paper. -- -- > let p ~= q = abs (p - q) < 1e-4 -- > metrical_affinity [2,3] 1 [3,2] 1 ~= 0.0324 -- > metrical_affinity [2,2,3] 20 [3,5] 16 ~= 0.0028 metrical_affinity :: (Integral n,Show n) => [n] -> n -> [n] -> n -> R metrical_affinity s1 v1 s2 v2 = let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2) i1 = relative_indispensibilities s1' i2 = relative_indispensibilities s2' v = lcm v1 v2 i1' = concat (genericReplicate (v `div` v1) i1) i2' = concat (genericReplicate (v `div` v2) i2) in mean_square_product (zip i1' i2') -- | An incorrect attempt at Equation 6 of the /CMJ/ paper, see -- omega_z. -- -- > let p ~= q = abs (p - q) < 1e-4 -- > metrical_affinity' [2,2,2] 1 [2,2,2] 1 ~= 1.06735 -- > metrical_affinity' [2,2,2] 1 [2,2,3] 1 ~= 0.57185 -- > metrical_affinity' [2,2,2] 1 [2,3,2] 1 ~= 0.48575 -- > metrical_affinity' [2,2,2] 1 [3,2,2] 1 ~= 0.45872 -- -- > metrical_affinity' [3,2,2] 3 [2,2,3] 2 ~= 0.10282 metrical_affinity' :: (Integral t,Show t) => [t] -> t -> [t] -> t -> R metrical_affinity' s1 v1 s2 v2 = let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2) ix :: (Integer -> x) -> Integer -> x ix f i = case i of 1 -> f 1 2 -> f 2 _ -> error (show ("ix",i)) s = ix (at [s1,s2]) v = ix (at [v1,v2]) u = ix (genericLength . s) s' = ix (at [s1',s2']) z = ix (genericLength . s') q i j = s i `at` j omega_u i = product (map (q i) [1::Int .. u i]) omega_z _ = lcm (v 1 * omega_u 1) (v 2 * omega_u 2) omega_0 = lcm (product (s' 1)) (product (s' 2)) x0 n i = lower_psi (s' i) (z i) (1 + ((n - 1) `mod'` omega_z i)) x1 n = square (product (map (x0 n) [1,2])) x2 = sum (map x1 [1 .. omega_0]) x3 = 18 * x2 - 2 x4 i = square (omega_z i - 1) x5 = product (map x4 [1::Integer,2]) x6 = 7 * omega_0 * x5 x7 = to_r x3 / to_r x6 x8 = 2 * log x7 x9 = negate (recip x8) in traceShow (omega_z,omega_0,x2,x3,x5,x6,x7,x8,x9) x9 hmt-0.15/Music/Theory/Permutations/0000755000000000000000000000000012416136065015445 5ustar0000000000000000hmt-0.15/Music/Theory/Permutations/List.hs0000644000000000000000000000123712416136065016717 0ustar0000000000000000-- | List permutation functions. module Music.Theory.Permutations.List where import qualified Math.Combinatorics.Multiset as C import qualified Music.Theory.Permutations as P -- | Generate all permutations. -- -- > permutations [0,3] == [[0,3],[3,0]] -- > length (permutations [1..5]) == P.n_permutations 5 permutations :: (Eq a) => [a] -> [[a]] permutations i = let f p = P.apply_permutation p i in map f (P.permutations_n (length i)) -- | Generate all distinct permutations of a multi-set. -- -- > multiset_permutations [0,1,1] == [[0,1,1],[1,1,0],[1,0,1]] multiset_permutations :: (Ord a) => [a] -> [[a]] multiset_permutations = C.permutations . C.fromList hmt-0.15/Music/Theory/Permutations/Morris_1984.hs0000644000000000000000000001547712416136065017757 0ustar0000000000000000-- | Place notation (method ringing). -- -- Morris, R. G. T. "Place Notation" -- Central Council of Church Bell Ringers (1984). -- module Music.Theory.Permutations.Morris_1984 where import Data.Char {- base -} import Data.List {- base -} import Data.List.Split {- split -} import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Permutations as T {- hmt -} -- | A change either swaps all adjacent bells, or holds a subset of bells. data Change = Swap_All | Hold [Int] deriving (Eq,Show) -- | A method is a sequence of changes, if symmetrical only have the -- changes are given and the lead end. data Method = Method [Change] (Maybe Change) deriving (Eq,Show) -- | Compete list of 'Change's at 'Method', writing out symmetries. method_changes :: Method -> [Change] method_changes (Method p q) = case q of Nothing -> p Just q' -> p ++ tail (reverse p) ++ [q'] -- | Parse a change notation. -- -- > map parse_change ["-","x","38"] == [Swap_All,Swap_All,Hold [3,8]] parse_change :: String -> Change parse_change s = if is_swap_all s then Swap_All else Hold (to_abbrev s) -- | Separate changes. -- -- > split_changes "-38-14-1258-36-14-58-16-78" -- > split_changes "345.145.5.1.345" == ["345","145","5","1","345"] split_changes :: String -> [String] split_changes = filter (/= ".") . split (dropInitBlank (oneOf "-x.")) -- | Parse 'Method' from the sequence of changes with possible lead end. -- -- > parse_method ("-38-14-1258-36-14-58-16-78",Just "12") parse_method :: (String,Maybe String) -> Method parse_method (p,q) = let c = map parse_change (split_changes p) le = fmap parse_change q in Method c le -- > map is_swap_all ["-","x","38"] == [True,True,False] is_swap_all :: String -> Bool is_swap_all s = case s of [c] -> c `elem` "-x" _ -> False -- | Swap elemets of two-tuple (pair). -- -- > swap_pair (1,2) == (2,1) swap_pair :: (s,t) -> (t,s) swap_pair (p,q) = (q,p) -- | Flatten list of pairs. -- -- > flatten_pairs [(1,2),(3,4)] == [1..4] flatten_pairs :: [(a,a)] -> [a] flatten_pairs l = case l of [] -> [] (p,q):l' -> p : q : flatten_pairs l' -- | Swap all adjacent pairs at list. -- -- > swap_all [1 .. 8] == [2,1,4,3,6,5,8,7] swap_all :: [a] -> [a] swap_all = flatten_pairs . map swap_pair . T.adj2 2 -- | Parse abbreviated 'Hold' notation, characters are hexedecimal. -- -- > to_abbrev "38A" == [3,8,10] to_abbrev :: String -> [Int] to_abbrev = map digitToInt -- | Given a 'Hold' notation, generate permutation cycles. -- -- > let r = [Right (1,2),Left 3,Right (4,5),Right (6,7),Left 8] -- > in gen_swaps 8 [3,8] == r -- -- > let r = [Left 1,Left 2,Right (3,4),Right (5,6),Right (7,8)] -- > gen_swaps 8 [1,2] == r gen_swaps :: (Num t, Ord t) => t -> [t] -> [Either t (t,t)] gen_swaps k = let close n = if n < k then Right (n,n + 1) : close (n + 2) else [] rec n l = case l of [] -> close n m:l' -> if n < m then Right (n,n+1) : rec (n + 2) l else Left n : rec (m + 1) l' in rec 1 -- | Two-tuple to two element list. pair_to_list :: (t,t) -> [t] pair_to_list (p,q) = [p,q] -- | Swap notation to plain permutation cycles notation. -- -- > let n = [Left 1,Left 2,Right (3,4),Right (5,6),Right (7,8)] -- > in swaps_to_cycles n == [[1],[2],[3,4],[5,6],[7,8]] swaps_to_cycles :: [Either t (t,t)] -> [[t]] swaps_to_cycles = map (either return pair_to_list) -- | One-indexed permutation cycles to zero-indexed. -- -- > let r = [[0],[1],[2,3],[4,5],[6,7]] -- > in to_zero_indexed [[1],[2],[3,4],[5,6],[7,8]] == r to_zero_indexed :: Enum t => [[t]] -> [[t]] to_zero_indexed = map (map pred) -- | Apply abbreviated 'Hold' notation, given cardinality. -- -- > swap_abbrev 8 [3,8] [2,1,4,3,6,5,8,7] == [1,2,4,6,3,8,5,7] swap_abbrev :: Eq a => Int -> [Int] -> [a] -> [a] swap_abbrev k a = let c = to_zero_indexed (swaps_to_cycles (gen_swaps k a)) p = T.from_cycles c in T.apply_permutation p -- | Apply a 'Change'. apply_change :: Eq a => Int -> Change -> [a] -> [a] apply_change k p l = case p of Swap_All -> swap_all l Hold q -> swap_abbrev k q l -- | Apply a 'Method', gives next starting sequence and the course of -- the method. -- -- > let r = ([1,2,4,5,3] -- > ,[[1,2,3,4,5],[2,1,3,4,5],[2,3,1,4,5],[3,2,4,1,5],[3,4,2,5,1] -- > ,[4,3,2,5,1],[4,2,3,1,5],[2,4,1,3,5],[2,1,4,3,5],[1,2,4,3,5]]) -- > in apply_method cambridgeshire_slow_course_doubles [1..5] == r apply_method :: Eq a => Method -> [a] -> ([a],[[a]]) apply_method m l = let k = length l f z e = (apply_change k e z,z) in mapAccumL f l (method_changes m) -- | Iteratively apply a 'Method' until it closes (ie. arrives back at -- the starting sequence). -- -- > length (closed_method cambridgeshire_slow_course_doubles [1..5]) == 3 closed_method :: Eq a => Method -> [a] -> [[[a]]] closed_method m l = let rec c r = let (e,z) = apply_method m c in if e == l then reverse (z : r) else rec e (z : r) in rec l [] -- | 'concat' of 'closed_method' with initial sequence appended. closed_method' :: Eq a => Method -> [a] -> [[a]] closed_method' m l = concat (closed_method m l) ++ [l] -- * Methods -- | Cambridgeshire Slow Course Doubles. -- -- -- -- > length (closed_method cambridgeshire_slow_course_doubles [1..5]) == 3 cambridgeshire_slow_course_doubles :: Method cambridgeshire_slow_course_doubles = let a = ("345.145.5.1.345",Just "123") in parse_method a -- | Double Cambridge Cyclic Bob Minor. -- -- -- -- > length (closed_method double_cambridge_cyclic_bob_minor [1..6]) == 5 double_cambridge_cyclic_bob_minor :: Method double_cambridge_cyclic_bob_minor = let a = ("-14-16-56-36-16-12",Nothing) in parse_method a -- | Hammersmith Bob Triples -- -- -- -- > length (closed_method hammersmith_bob_triples [1..7]) == 6 hammersmith_bob_triples :: Method hammersmith_bob_triples = let a = ("7.1.5.123.7.345.7",Just "127") in parse_method a -- | Cambridge Surprise Major. -- -- -- -- > length (closed_method cambridge_surprise_major [1..8]) == 7 cambridge_surprise_major :: Method cambridge_surprise_major = let a = ("-38-14-1258-36-14-58-16-78",Just "12") in parse_method a -- | Smithsonian Surprise Royal. -- -- -- -- > length (closed_method smithsonian_surprise_royal [1..10]) == 9 smithsonian_surprise_royal :: Method smithsonian_surprise_royal = let a = ("-3A-14-5A-16-347A-18-1456-5A-16-7A",Just "12") in parse_method a hmt-0.15/Music/Theory/Xenakis/0000755000000000000000000000000012416136065014355 5ustar0000000000000000hmt-0.15/Music/Theory/Xenakis/S4.hs0000644000000000000000000001707712416136065015213 0ustar0000000000000000-- | 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 {- base -} import Data.Maybe {- base -} import qualified Data.Permute as P {- permutation -} import qualified Music.Theory.Permutations as T -- * 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,T.permutation (complement p) q) else (False,T.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 = T.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) hmt-0.15/Music/Theory/Xenakis/Sieve.hs0000644000000000000000000001472112416136065015771 0ustar0000000000000000-- | \"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 import Music.Theory.List -- | 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 -- | unicode synonym for 'l'. (⋄) :: I -> I -> Sieve (⋄) = l infixl 3 ∪ infixl 4 ∩ infixl 5 ⋄ -- | In a /normal/ 'Sieve' /m/ is '>' /i/. -- -- > normalise (L (15,19)) == L (15,4) 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 -- | Construct the sequence defined by a 'Sieve'. Note that building -- a sieve that contains an intersection clause that has no elements -- gives @_|_@. -- -- > let {d = [0,2,4,5,7,9,11] -- > ;r = d ++ map (+ 12) d} -- > in take 14 (build (union (map (l 12) d))) == r 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 (build s0) (build s1)) Intersection s0 s1 -> i_f (merge (build s0) (build s1)) {- | Variant of 'build' that gives the first /n/ places of the 'reduce' of 'Sieve'. > buildn 6 (union (map (l 8) [0,3,6])) == [0,3,6,8,11,14] > buildn 12 (L (3,2)) == [2,5,8,11,14,17,20,23,26,29,32,35] > buildn 9 (L (8,0)) == [0,8,16,24,32,40,48,56,64] > buildn 3 (L (3,2) ∩ L (8,0)) == [8,32,56] > buildn 12 (L (3,1) ∪ L (4,0)) == [0,1,4,7,8,10,12,13,16,19,20,22] > buildn 14 (5⋄4 ∪ 3⋄2 ∪ 7⋄3) == [2,3,4,5,8,9,10,11,14,17,19,20,23,24] > buildn 6 (3⋄0 ∪ 4⋄0) == [0,3,4,6,8,9] > buildn 8 (5⋄2 ∩ 2⋄0 ∪ 7⋄3) == [2,3,10,12,17,22,24,31] > buildn 12 (5⋄1 ∪ 7⋄2) == [1,2,6,9,11,16,21,23,26,30,31,36] > buildn 10 (3⋄2 ∩ 4⋄7 ∪ 6⋄9 ∩ 15⋄18) == [3,11,23,33,35,47,59,63,71,83] > let {s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19 > ;s' = 24⋄23 ∪ 30⋄3 ∪ 104⋄70} > in buildn 16 s == buildn 16 s' > buildn 10 (24⋄23 ∪ 30⋄3 ∪ 104⋄70) == [3,23,33,47,63,70,71,93,95,119] > let r = [2,3,4,5,8,9,10,11,14,17,19,20,23,24,26,29,31] > in buildn 17 (5⋄4 ∪ 3⋄2 ∪ 7⋄3) == r > let r = [0,1,3,6,9,10,11,12,15,16,17,18,21,24,26,27,30] > in buildn 17 (5⋄1 ∪ 3⋄0 ∪ 7⋄3) == r > let r = [0,2,3,4,6,7,9,11,12,15,17,18,21,22,24,25,27,30,32] > in buildn 19 (5⋄2 ∪ 3⋄0 ∪ 7⋄4) == r -} buildn :: Int -> Sieve -> [I] buildn n = take n . build . reduce -- | 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) -- -- > let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19 -- > in reduce s == (24⋄23 ∪ 30⋄3 ∪ 104⋄70) -- -- > let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19 -- > in reduce s == (24⋄23 ∪ 30⋄3 ∪ 104⋄70) reduce :: Sieve -> Sieve reduce s = let f g s1 s2 = let s1' = reduce s1 s2' = reduce s2 s' = g s1' s2' in if s1 == s1' && s2 == s2' then s' else reduce s' in case s of Empty -> Empty L _ -> s Union s1 Empty -> s1 Union s1 s2 -> f Union s1 s2 Intersection s1 Empty -> s1 Intersection (L p) (L q) -> maybe Empty L (reduce_intersection p q) Intersection s1 s2 -> f Intersection s1 s2 hmt-0.15/Music/Theory/Pitch/0000755000000000000000000000000012416136065014022 5ustar0000000000000000hmt-0.15/Music/Theory/Pitch/Name.hs0000644000000000000000000003114612416136065015243 0ustar0000000000000000-- | 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 import Music.Theory.Pitch.Note a0,b0 :: Pitch a0 = Pitch A Natural 0 b0 = Pitch B Natural 0 bes0 :: Pitch bes0 = Pitch B Flat 0 ais0,bis0 :: Pitch ais0 = Pitch A Sharp 0 bis0 = Pitch B Sharp 0 c1,d1,e1,f1,g1,a1,b1 :: Pitch c1 = Pitch C Natural 1 d1 = Pitch D Natural 1 e1 = Pitch E Natural 1 f1 = Pitch F Natural 1 g1 = Pitch G Natural 1 a1 = Pitch A Natural 1 b1 = Pitch B Natural 1 ces1,des1,ees1,fes1,ges1,aes1,bes1 :: Pitch ces1 = Pitch C Flat 1 des1 = Pitch D Flat 1 ees1 = Pitch E Flat 1 fes1 = Pitch F Flat 1 ges1 = Pitch G Flat 1 aes1 = Pitch A Flat 1 bes1 = Pitch B Flat 1 cis1,dis1,eis1,fis1,gis1,ais1,bis1 :: Pitch cis1 = Pitch C Sharp 1 dis1 = Pitch D Sharp 1 eis1 = Pitch E Sharp 1 fis1 = Pitch F Sharp 1 gis1 = Pitch G Sharp 1 ais1 = Pitch A Sharp 1 bis1 = Pitch B Sharp 1 c2,d2,e2,f2,g2,a2,b2 :: Pitch c2 = Pitch C Natural 2 d2 = Pitch D Natural 2 e2 = Pitch E Natural 2 f2 = Pitch F Natural 2 g2 = Pitch G Natural 2 a2 = Pitch A Natural 2 b2 = Pitch B Natural 2 ces2,des2,ees2,fes2,ges2,aes2,bes2 :: Pitch ces2 = Pitch C Flat 2 des2 = Pitch D Flat 2 ees2 = Pitch E Flat 2 fes2 = Pitch F Flat 2 ges2 = Pitch G Flat 2 aes2 = Pitch A Flat 2 bes2 = Pitch B Flat 2 cis2,dis2,eis2,fis2,gis2,ais2,bis2 :: Pitch cis2 = Pitch C Sharp 2 dis2 = Pitch D Sharp 2 eis2 = Pitch E Sharp 2 fis2 = Pitch F Sharp 2 gis2 = Pitch G Sharp 2 ais2 = Pitch A Sharp 2 bis2 = Pitch B Sharp 2 cisis2,disis2,eisis2,fisis2,gisis2,aisis2,bisis2 :: Pitch cisis2 = Pitch C DoubleSharp 2 disis2 = Pitch D DoubleSharp 2 eisis2 = Pitch E DoubleSharp 2 fisis2 = Pitch F DoubleSharp 2 gisis2 = Pitch G DoubleSharp 2 aisis2 = Pitch A DoubleSharp 2 bisis2 = Pitch B DoubleSharp 2 ceseh2,deseh2,eeseh2,feseh2,geseh2,aeseh2,beseh2 :: Pitch ceseh2 = Pitch C ThreeQuarterToneFlat 2 deseh2 = Pitch D ThreeQuarterToneFlat 2 eeseh2 = Pitch E ThreeQuarterToneFlat 2 feseh2 = Pitch F ThreeQuarterToneFlat 2 geseh2 = Pitch G ThreeQuarterToneFlat 2 aeseh2 = Pitch A ThreeQuarterToneFlat 2 beseh2 = Pitch B ThreeQuarterToneFlat 2 ceh2,deh2,eeh2,feh2,geh2,aeh2,beh2 :: Pitch ceh2 = Pitch C QuarterToneFlat 2 deh2 = Pitch D QuarterToneFlat 2 eeh2 = Pitch E QuarterToneFlat 2 feh2 = Pitch F QuarterToneFlat 2 geh2 = Pitch G QuarterToneFlat 2 aeh2 = Pitch A QuarterToneFlat 2 beh2 = Pitch B QuarterToneFlat 2 cih2,dih2,eih2,fih2,gih2,aih2,bih2 :: Pitch cih2 = Pitch C QuarterToneSharp 2 dih2 = Pitch D QuarterToneSharp 2 eih2 = Pitch E QuarterToneSharp 2 fih2 = Pitch F QuarterToneSharp 2 gih2 = Pitch G QuarterToneSharp 2 aih2 = Pitch A QuarterToneSharp 2 bih2 = Pitch B QuarterToneSharp 2 cisih2,disih2,eisih2,fisih2,gisih2,aisih2,bisih2 :: Pitch cisih2 = Pitch C ThreeQuarterToneSharp 2 disih2 = Pitch D ThreeQuarterToneSharp 2 eisih2 = Pitch E ThreeQuarterToneSharp 2 fisih2 = Pitch F ThreeQuarterToneSharp 2 gisih2 = Pitch G ThreeQuarterToneSharp 2 aisih2 = Pitch A ThreeQuarterToneSharp 2 bisih2 = Pitch B ThreeQuarterToneSharp 2 c3,d3,e3,f3,g3,a3,b3 :: Pitch c3 = Pitch C Natural 3 d3 = Pitch D Natural 3 e3 = Pitch E Natural 3 f3 = Pitch F Natural 3 g3 = Pitch G Natural 3 a3 = Pitch A Natural 3 b3 = Pitch B Natural 3 ces3,des3,ees3,fes3,ges3,aes3,bes3 :: Pitch ces3 = Pitch C Flat 3 des3 = Pitch D Flat 3 ees3 = Pitch E Flat 3 fes3 = Pitch F Flat 3 ges3 = Pitch G Flat 3 aes3 = Pitch A Flat 3 bes3 = Pitch B Flat 3 cis3,dis3,eis3,fis3,gis3,ais3,bis3 :: Pitch cis3 = Pitch C Sharp 3 dis3 = Pitch D Sharp 3 eis3 = Pitch E Sharp 3 fis3 = Pitch F Sharp 3 gis3 = Pitch G Sharp 3 ais3 = Pitch A Sharp 3 bis3 = Pitch B Sharp 3 ceses3,deses3,eeses3,feses3,geses3,aeses3,beses3 :: Pitch ceses3 = Pitch C DoubleFlat 3 deses3 = Pitch D DoubleFlat 3 eeses3 = Pitch E DoubleFlat 3 feses3 = Pitch F DoubleFlat 3 geses3 = Pitch G DoubleFlat 3 aeses3 = Pitch A DoubleFlat 3 beses3 = Pitch B DoubleFlat 3 cisis3,disis3,eisis3,fisis3,gisis3,aisis3,bisis3 :: Pitch cisis3 = Pitch C DoubleSharp 3 disis3 = Pitch D DoubleSharp 3 eisis3 = Pitch E DoubleSharp 3 fisis3 = Pitch F DoubleSharp 3 gisis3 = Pitch G DoubleSharp 3 aisis3 = Pitch A DoubleSharp 3 bisis3 = Pitch B DoubleSharp 3 ceseh3,deseh3,eeseh3,feseh3,geseh3,aeseh3,beseh3 :: Pitch ceseh3 = Pitch C ThreeQuarterToneFlat 3 deseh3 = Pitch D ThreeQuarterToneFlat 3 eeseh3 = Pitch E ThreeQuarterToneFlat 3 feseh3 = Pitch F ThreeQuarterToneFlat 3 geseh3 = Pitch G ThreeQuarterToneFlat 3 aeseh3 = Pitch A ThreeQuarterToneFlat 3 beseh3 = Pitch B ThreeQuarterToneFlat 3 ceh3,deh3,eeh3,feh3,geh3,aeh3,beh3 :: Pitch ceh3 = Pitch C QuarterToneFlat 3 deh3 = Pitch D QuarterToneFlat 3 eeh3 = Pitch E QuarterToneFlat 3 feh3 = Pitch F QuarterToneFlat 3 geh3 = Pitch G QuarterToneFlat 3 aeh3 = Pitch A QuarterToneFlat 3 beh3 = Pitch B QuarterToneFlat 3 cih3,dih3,eih3,fih3,gih3,aih3,bih3 :: Pitch cih3 = Pitch C QuarterToneSharp 3 dih3 = Pitch D QuarterToneSharp 3 eih3 = Pitch E QuarterToneSharp 3 fih3 = Pitch F QuarterToneSharp 3 gih3 = Pitch G QuarterToneSharp 3 aih3 = Pitch A QuarterToneSharp 3 bih3 = Pitch B QuarterToneSharp 3 cisih3,disih3,eisih3,fisih3,gisih3,aisih3,bisih3 :: Pitch cisih3 = Pitch C ThreeQuarterToneSharp 3 disih3 = Pitch D ThreeQuarterToneSharp 3 eisih3 = Pitch E ThreeQuarterToneSharp 3 fisih3 = Pitch F ThreeQuarterToneSharp 3 gisih3 = Pitch G ThreeQuarterToneSharp 3 aisih3 = Pitch A ThreeQuarterToneSharp 3 bisih3 = Pitch B ThreeQuarterToneSharp 3 c4,d4,e4,f4,g4,a4,b4 :: Pitch c4 = Pitch C Natural 4 d4 = Pitch D Natural 4 e4 = Pitch E Natural 4 f4 = Pitch F Natural 4 g4 = Pitch G Natural 4 a4 = Pitch A Natural 4 b4 = Pitch B Natural 4 ces4,des4,ees4,fes4,ges4,aes4,bes4 :: Pitch ces4 = Pitch C Flat 4 des4 = Pitch D Flat 4 ees4 = Pitch E Flat 4 fes4 = Pitch F Flat 4 ges4 = Pitch G Flat 4 aes4 = Pitch A Flat 4 bes4 = Pitch B Flat 4 cis4,dis4,eis4,fis4,gis4,ais4,bis4 :: Pitch cis4 = Pitch C Sharp 4 dis4 = Pitch D Sharp 4 eis4 = Pitch E Sharp 4 fis4 = Pitch F Sharp 4 gis4 = Pitch G Sharp 4 ais4 = Pitch A Sharp 4 bis4 = Pitch B Sharp 4 ceses4,deses4,eeses4,feses4,geses4,aeses4,beses4 :: Pitch ceses4 = Pitch C DoubleFlat 4 deses4 = Pitch D DoubleFlat 4 eeses4 = Pitch E DoubleFlat 4 feses4 = Pitch F DoubleFlat 4 geses4 = Pitch G DoubleFlat 4 aeses4 = Pitch A DoubleFlat 4 beses4 = Pitch B DoubleFlat 4 cisis4,disis4,eisis4,fisis4,gisis4,aisis4,bisis4 :: Pitch cisis4 = Pitch C DoubleSharp 4 disis4 = Pitch D DoubleSharp 4 eisis4 = Pitch E DoubleSharp 4 fisis4 = Pitch F DoubleSharp 4 gisis4 = Pitch G DoubleSharp 4 aisis4 = Pitch A DoubleSharp 4 bisis4 = Pitch B DoubleSharp 4 ceseh4,deseh4,eeseh4,feseh4,geseh4,aeseh4,beseh4 :: Pitch ceseh4 = Pitch C ThreeQuarterToneFlat 4 deseh4 = Pitch D ThreeQuarterToneFlat 4 eeseh4 = Pitch E ThreeQuarterToneFlat 4 feseh4 = Pitch F ThreeQuarterToneFlat 4 geseh4 = Pitch G ThreeQuarterToneFlat 4 aeseh4 = Pitch A ThreeQuarterToneFlat 4 beseh4 = Pitch B ThreeQuarterToneFlat 4 ceh4,deh4,eeh4,feh4,geh4,aeh4,beh4 :: Pitch ceh4 = Pitch C QuarterToneFlat 4 deh4 = Pitch D QuarterToneFlat 4 eeh4 = Pitch E QuarterToneFlat 4 feh4 = Pitch F QuarterToneFlat 4 geh4 = Pitch G QuarterToneFlat 4 aeh4 = Pitch A QuarterToneFlat 4 beh4 = Pitch B QuarterToneFlat 4 cih4,dih4,eih4,fih4,gih4,aih4,bih4 :: Pitch cih4 = Pitch C QuarterToneSharp 4 dih4 = Pitch D QuarterToneSharp 4 eih4 = Pitch E QuarterToneSharp 4 fih4 = Pitch F QuarterToneSharp 4 gih4 = Pitch G QuarterToneSharp 4 aih4 = Pitch A QuarterToneSharp 4 bih4 = Pitch B QuarterToneSharp 4 cisih4,disih4,eisih4,fisih4,gisih4,aisih4,bisih4 :: Pitch cisih4 = Pitch C ThreeQuarterToneSharp 4 disih4 = Pitch D ThreeQuarterToneSharp 4 eisih4 = Pitch E ThreeQuarterToneSharp 4 fisih4 = Pitch F ThreeQuarterToneSharp 4 gisih4 = Pitch G ThreeQuarterToneSharp 4 aisih4 = Pitch A ThreeQuarterToneSharp 4 bisih4 = Pitch B ThreeQuarterToneSharp 4 c5,d5,e5,f5,g5,a5,b5 :: Pitch c5 = Pitch C Natural 5 d5 = Pitch D Natural 5 e5 = Pitch E Natural 5 f5 = Pitch F Natural 5 g5 = Pitch G Natural 5 a5 = Pitch A Natural 5 b5 = Pitch B Natural 5 ces5,des5,ees5,fes5,ges5,aes5,bes5 :: Pitch ces5 = Pitch C Flat 5 des5 = Pitch D Flat 5 ees5 = Pitch E Flat 5 fes5 = Pitch F Flat 5 ges5 = Pitch G Flat 5 aes5 = Pitch A Flat 5 bes5 = Pitch B Flat 5 cis5,dis5,eis5,fis5,gis5,ais5,bis5 :: Pitch cis5 = Pitch C Sharp 5 dis5 = Pitch D Sharp 5 eis5 = Pitch E Sharp 5 fis5 = Pitch F Sharp 5 gis5 = Pitch G Sharp 5 ais5 = Pitch A Sharp 5 bis5 = Pitch B Sharp 5 ceses5,deses5,eeses5,feses5,geses5,aeses5,beses5 :: Pitch ceses5 = Pitch C DoubleFlat 5 deses5 = Pitch D DoubleFlat 5 eeses5 = Pitch E DoubleFlat 5 feses5 = Pitch F DoubleFlat 5 geses5 = Pitch G DoubleFlat 5 aeses5 = Pitch A DoubleFlat 5 beses5 = Pitch B DoubleFlat 5 cisis5,disis5,eisis5,fisis5,gisis5,aisis5,bisis5 :: Pitch cisis5 = Pitch C DoubleSharp 5 disis5 = Pitch D DoubleSharp 5 eisis5 = Pitch E DoubleSharp 5 fisis5 = Pitch F DoubleSharp 5 gisis5 = Pitch G DoubleSharp 5 aisis5 = Pitch A DoubleSharp 5 bisis5 = Pitch B DoubleSharp 5 ceseh5,deseh5,eeseh5,feseh5,geseh5,aeseh5,beseh5 :: Pitch ceseh5 = Pitch C ThreeQuarterToneFlat 5 deseh5 = Pitch D ThreeQuarterToneFlat 5 eeseh5 = Pitch E ThreeQuarterToneFlat 5 feseh5 = Pitch F ThreeQuarterToneFlat 5 geseh5 = Pitch G ThreeQuarterToneFlat 5 aeseh5 = Pitch A ThreeQuarterToneFlat 5 beseh5 = Pitch B ThreeQuarterToneFlat 5 ceh5,deh5,eeh5,feh5,geh5,aeh5,beh5 :: Pitch ceh5 = Pitch C QuarterToneFlat 5 deh5 = Pitch D QuarterToneFlat 5 eeh5 = Pitch E QuarterToneFlat 5 feh5 = Pitch F QuarterToneFlat 5 geh5 = Pitch G QuarterToneFlat 5 aeh5 = Pitch A QuarterToneFlat 5 beh5 = Pitch B QuarterToneFlat 5 cih5,dih5,eih5,fih5,gih5,aih5,bih5 :: Pitch cih5 = Pitch C QuarterToneSharp 5 dih5 = Pitch D QuarterToneSharp 5 eih5 = Pitch E QuarterToneSharp 5 fih5 = Pitch F QuarterToneSharp 5 gih5 = Pitch G QuarterToneSharp 5 aih5 = Pitch A QuarterToneSharp 5 bih5 = Pitch B QuarterToneSharp 5 cisih5,disih5,eisih5,fisih5,gisih5,aisih5,bisih5 :: Pitch cisih5 = Pitch C ThreeQuarterToneSharp 5 disih5 = Pitch D ThreeQuarterToneSharp 5 eisih5 = Pitch E ThreeQuarterToneSharp 5 fisih5 = Pitch F ThreeQuarterToneSharp 5 gisih5 = Pitch G ThreeQuarterToneSharp 5 aisih5 = Pitch A ThreeQuarterToneSharp 5 bisih5 = Pitch B ThreeQuarterToneSharp 5 c6,d6,e6,f6,g6,a6,b6 :: Pitch c6 = Pitch C Natural 6 d6 = Pitch D Natural 6 e6 = Pitch E Natural 6 f6 = Pitch F Natural 6 g6 = Pitch G Natural 6 a6 = Pitch A Natural 6 b6 = Pitch B Natural 6 ces6,des6,ees6,fes6,ges6,aes6,bes6 :: Pitch ces6 = Pitch C Flat 6 des6 = Pitch D Flat 6 ees6 = Pitch E Flat 6 fes6 = Pitch F Flat 6 ges6 = Pitch G Flat 6 aes6 = Pitch A Flat 6 bes6 = Pitch B Flat 6 cis6,dis6,eis6,fis6,gis6,ais6,bis6 :: Pitch cis6 = Pitch C Sharp 6 dis6 = Pitch D Sharp 6 eis6 = Pitch E Sharp 6 fis6 = Pitch F Sharp 6 gis6 = Pitch G Sharp 6 ais6 = Pitch A Sharp 6 bis6 = Pitch B Sharp 6 ceseh6,deseh6,eeseh6,feseh6,geseh6,aeseh6,beseh6 :: Pitch ceseh6 = Pitch C ThreeQuarterToneFlat 6 deseh6 = Pitch D ThreeQuarterToneFlat 6 eeseh6 = Pitch E ThreeQuarterToneFlat 6 feseh6 = Pitch F ThreeQuarterToneFlat 6 geseh6 = Pitch G ThreeQuarterToneFlat 6 aeseh6 = Pitch A ThreeQuarterToneFlat 6 beseh6 = Pitch B ThreeQuarterToneFlat 6 ceh6,deh6,eeh6,feh6,geh6,aeh6,beh6 :: Pitch ceh6 = Pitch C QuarterToneFlat 6 deh6 = Pitch D QuarterToneFlat 6 eeh6 = Pitch E QuarterToneFlat 6 feh6 = Pitch F QuarterToneFlat 6 geh6 = Pitch G QuarterToneFlat 6 aeh6 = Pitch A QuarterToneFlat 6 beh6 = Pitch B QuarterToneFlat 6 cih6,dih6,eih6,fih6,gih6,aih6,bih6 :: Pitch cih6 = Pitch C QuarterToneSharp 6 dih6 = Pitch D QuarterToneSharp 6 eih6 = Pitch E QuarterToneSharp 6 fih6 = Pitch F QuarterToneSharp 6 gih6 = Pitch G QuarterToneSharp 6 aih6 = Pitch A QuarterToneSharp 6 bih6 = Pitch B QuarterToneSharp 6 cisih6,disih6,eisih6,fisih6,gisih6,aisih6,bisih6 :: Pitch cisih6 = Pitch C ThreeQuarterToneSharp 6 disih6 = Pitch D ThreeQuarterToneSharp 6 eisih6 = Pitch E ThreeQuarterToneSharp 6 fisih6 = Pitch F ThreeQuarterToneSharp 6 gisih6 = Pitch G ThreeQuarterToneSharp 6 aisih6 = Pitch A ThreeQuarterToneSharp 6 bisih6 = Pitch B ThreeQuarterToneSharp 6 c7,d7,e7,f7,g7,a7,b7 :: Pitch c7 = Pitch C Natural 7 d7 = Pitch D Natural 7 e7 = Pitch E Natural 7 f7 = Pitch F Natural 7 g7 = Pitch G Natural 7 a7 = Pitch A Natural 7 b7 = Pitch B Natural 7 ces7,des7,ees7,fes7,ges7,aes7,bes7 :: Pitch ces7 = Pitch C Flat 7 des7 = Pitch D Flat 7 ees7 = Pitch E Flat 7 fes7 = Pitch F Flat 7 ges7 = Pitch G Flat 7 aes7 = Pitch A Flat 7 bes7 = Pitch B Flat 7 cis7,dis7,eis7,fis7,gis7,ais7,bis7 :: Pitch cis7 = Pitch C Sharp 7 dis7 = Pitch D Sharp 7 eis7 = Pitch E Sharp 7 fis7 = Pitch F Sharp 7 gis7 = Pitch G Sharp 7 ais7 = Pitch A Sharp 7 bis7 = Pitch B Sharp 7 c8,cis8,d8 :: Pitch c8 = Pitch C Natural 8 cis8 = Pitch C Sharp 8 d8 = Pitch D Natural 8 hmt-0.15/Music/Theory/Pitch/Spelling.hs0000644000000000000000000000432012416136065016132 0ustar0000000000000000-- | Spelling rules for common music notation. module Music.Theory.Pitch.Spelling where import Music.Theory.Pitch.Note (Note_T(..),Alteration_T(..),Spelling) -- | Variant of 'Spelling' for incomplete functions. type Spelling_M i = i -> Maybe (Note_T, Alteration_T) -- | Spelling for natural (♮) notes only. -- -- > map pc_spell_natural_m [0,1] == [Just (C,Natural),Nothing] pc_spell_natural_m :: Integral i => Spelling_M i 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 :: Integral i => Spelling i pc_spell_natural pc = case pc_spell_natural_m pc of Just p -> p _ -> error "pc_spell_natural" -- | Use spelling from simplest key-signature. Note that this is -- ambiguous for @8@, which could be either G Sharp (♯) in /A Major/ -- or A Flat (♭) in /E Flat (♭) Major/. -- -- > map pc_spell_ks [6,8] == [(F,Sharp),(A,Flat)] pc_spell_ks :: Integral i => Spelling i 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 :: Integral i => Spelling i 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 :: Integral i => Spelling i 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 hmt-0.15/Music/Theory/Pitch/Note.hs0000644000000000000000000001623512416136065015272 0ustar0000000000000000-- | Common music notation note and alteration values. module Music.Theory.Pitch.Note where import Data.Maybe {- base -} -- * Note -- | Enumeration of common music notation note names (@C@ to @B@). data Note_T = C | D | E | F | G | A | B deriving (Eq,Enum,Bounded,Ord,Show) -- | Transform 'Note_T' to pitch-class number. -- -- > map note_to_pc [C,E,G] == [0,4,7] note_to_pc :: Integral i => Note_T -> i note_to_pc n = case n of C -> 0 D -> 2 E -> 4 F -> 5 G -> 7 A -> 9 B -> 11 -- | 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 n' = fromEnum (maxBound::Note_T) + 1 in toEnum ((x' + n) `mod` n') -- * Alteration -- | Enumeration of common music notation note alterations. data Alteration_T = DoubleFlat | ThreeQuarterToneFlat | Flat | QuarterToneFlat | Natural | QuarterToneSharp | Sharp | ThreeQuarterToneSharp | DoubleSharp deriving (Eq,Enum,Bounded,Ord,Show) -- | Generic form. generic_alteration_to_diff :: Integral i => Alteration_T -> Maybe i generic_alteration_to_diff a = case a of DoubleFlat -> Just (-2) Flat -> Just (-1) Natural -> Just 0 Sharp -> Just 1 DoubleSharp -> Just 2 _ -> Nothing -- | Transform 'Alteration_T' to semitone alteration. Returns -- 'Nothing' for non-semitone alterations. -- -- > map alteration_to_diff [Flat,QuarterToneSharp] == [Just (-1),Nothing] alteration_to_diff :: Alteration_T -> Maybe Int alteration_to_diff = generic_alteration_to_diff -- | Is 'Alteration_T' 12-ET. alteration_is_12et :: Alteration_T -> Bool alteration_is_12et = isJust . alteration_to_diff -- | Transform 'Alteration_T' to semitone alteration. -- -- > map alteration_to_diff_err [Flat,Sharp] == [-1,1] alteration_to_diff_err :: Integral i => Alteration_T -> i alteration_to_diff_err = let err = error "alteration_to_diff: quarter tone" in fromMaybe err . generic_alteration_to_diff -- | Transform 'Alteration_T' to fractional semitone alteration, -- ie. allow quarter tones. -- -- > alteration_to_fdiff QuarterToneSharp == 0.5 alteration_to_fdiff :: Fractional n => Alteration_T -> n alteration_to_fdiff a = case a of ThreeQuarterToneFlat -> -1.5 QuarterToneFlat -> -0.5 QuarterToneSharp -> 0.5 ThreeQuarterToneSharp -> 1.5 _ -> fromInteger (alteration_to_diff_err a) -- | Transform fractional semitone alteration to 'Alteration_T', -- ie. allow quarter tones. -- -- > map fdiff_to_alteration [-0.5,0.5] == [Just QuarterToneFlat -- > ,Just QuarterToneSharp] fdiff_to_alteration :: (Fractional n,Eq n) => n -> Maybe Alteration_T fdiff_to_alteration d = case d of -2 -> Just DoubleFlat -1.5 -> Just ThreeQuarterToneFlat -1 -> Just Flat -0.5 -> Just QuarterToneFlat 0 -> Just Natural 0.5 -> Just QuarterToneSharp 1 -> Just Sharp 1.5 -> Just ThreeQuarterToneSharp 2 -> Just DoubleSharp _ -> undefined -- | Raise 'Alteration_T' by a quarter tone where possible. -- -- > alteration_raise_quarter_tone Flat == Just QuarterToneFlat -- > alteration_raise_quarter_tone DoubleSharp == Nothing alteration_raise_quarter_tone :: Alteration_T -> Maybe Alteration_T alteration_raise_quarter_tone a = if a == maxBound then Nothing else Just (toEnum (fromEnum a + 1)) -- | Lower 'Alteration_T' by a quarter tone where possible. -- -- > alteration_lower_quarter_tone Sharp == Just QuarterToneSharp -- > alteration_lower_quarter_tone DoubleFlat == Nothing alteration_lower_quarter_tone :: Alteration_T -> Maybe Alteration_T alteration_lower_quarter_tone a = if a == minBound then Nothing else Just (toEnum (fromEnum a - 1)) -- | Edit 'Alteration_T' by a quarter tone where possible, @-0.5@ -- lowers, @0@ retains, @0.5@ raises. -- -- > import Data.Ratio -- > alteration_edit_quarter_tone (-1 % 2) Flat == Just ThreeQuarterToneFlat alteration_edit_quarter_tone :: (Fractional n,Eq n) => n -> Alteration_T -> Maybe Alteration_T alteration_edit_quarter_tone n a = case n of -0.5 -> alteration_lower_quarter_tone a 0 -> Just a 0.5 -> alteration_raise_quarter_tone a _ -> Nothing -- | Simplify 'Alteration_T' to standard 12ET by deleting quarter tones. -- -- > Data.List.nub (map alteration_clear_quarter_tone [minBound..maxBound]) alteration_clear_quarter_tone :: Alteration_T -> Alteration_T alteration_clear_quarter_tone x = case x of ThreeQuarterToneFlat -> Flat QuarterToneFlat -> Flat QuarterToneSharp -> Sharp ThreeQuarterToneSharp -> Sharp _ -> x -- | 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 -> '𝄪' -- | The @ISO@ ASCII spellings for alterations. Naturals as written -- as the empty string. -- -- > mapMaybe alteration_iso_m [Flat .. Sharp] == ["b","","#"] alteration_iso_m :: Alteration_T -> Maybe String alteration_iso_m a = case a of DoubleFlat -> Just "bb" ThreeQuarterToneFlat -> Nothing Flat -> Just "b" QuarterToneFlat -> Nothing Natural -> Just "" QuarterToneSharp -> Nothing Sharp -> Just "#" ThreeQuarterToneSharp -> Nothing DoubleSharp -> Just "x" -- | The @ISO@ ASCII spellings for alterations. alteration_iso :: Alteration_T -> String alteration_iso = let qt = error "alteration_iso: quarter tone" in fromMaybe qt . alteration_iso_m -- | The /Tonhöhe/ ASCII spellings for alterations. -- -- See and -- -- -- > map alteration_tonh [Flat .. Sharp] == ["es","eh","","ih","is"] alteration_tonh :: Alteration_T -> String alteration_tonh a = case a of DoubleFlat -> "eses" ThreeQuarterToneFlat -> "eseh" Flat -> "es" QuarterToneFlat -> "eh" Natural -> "" QuarterToneSharp -> "ih" Sharp -> "is" ThreeQuarterToneSharp -> "isih" DoubleSharp -> "isis" -- * Generalised Alteration -- | Generalised alteration, given as a rational semitone difference -- and a string representation of the alteration. type Alteration_T' = (Rational,String) -- | Transform 'Alteration_T' to 'Alteration_T''. -- -- > let r = [(-1,"♭"),(0,"♮"),(1,"♯")] -- > in map alteration_t' [Flat,Natural,Sharp] == r alteration_t' :: Alteration_T -> Alteration_T' alteration_t' a = (alteration_to_fdiff a,[alteration_symbol a]) -- | Function to spell a 'PitchClass'. type Spelling n = n -> (Note_T,Alteration_T) hmt-0.15/Music/Theory/Pitch/Spelling/0000755000000000000000000000000012416136065015577 5ustar0000000000000000hmt-0.15/Music/Theory/Pitch/Spelling/Cluster.hs0000644000000000000000000001200012416136065017545 0ustar0000000000000000-- | Spelling for chromatic clusters. module Music.Theory.Pitch.Spelling.Cluster where import Data.List import Music.Theory.Pitch import Music.Theory.Pitch.Name -- | Spelling table for chromatic clusters. -- -- > let f (p,q) = p == sort (map (snd . pitch_to_octpc) q) -- > in all f spell_cluster_c4_table == True spell_cluster_c4_table :: [([PitchClass],[Pitch])] spell_cluster_c4_table = [([0],[c4]) ,([0,1],[c4,des4]) ,([0,1,2],[bis3,cis4,d4]) ,([0,1,2,3],[bis3,cis4,d4,ees4]) ,([0,1,2,3,10,11],[ais3,b3,c4,cis4,d4,ees4]) -- overlap... ,([0,1,2,10],[ais3,bis3,cis4,d4]) ,([0,1,2,11],[aisis3,bis3,cis4,d4]) ,([0,1,3],[c4,des4,ees4]) ,([0,1,3,10],[bes3,c4,des4,ees4]) ,([0,1,3,11],[b3,c4,des4,ees4]) ,([0,1,10],[bes3,c4,des4]) ,([0,1,10,11],[ais3,b3,c4,des4]) ,([0,1,11],[b3,c4,des4]) ,([0,2],[c4,d4]) ,([0,2,3],[c4,d4,ees4]) ,([0,2,3,10],[bes3,c4,d4,ees4]) ,([0,2,3,11],[b3,c4,d4,ees4]) ,([0,2,11],[b3,c4,d4]) ,([0,2,10],[bes3,c4,d4]) ,([0,2,10,11],[ais3,b3,c4,d4]) ,([0,3,10,11],[ais3,b3,c4,dis4]) ,([0,3,11],[b3,c4,dis4]) ,([0,10,11],[ais3,b3,c4]) ,([0,11],[b3,c4]) ,([1],[cis4]) ,([1,2],[cis4,d4]) ,([1,2,3],[cis4,d4,ees4]) ,([1,2,3,10],[bes3,cis4,d4,ees4]) ,([1,2,3,11],[b3,cis4,d4,ees4]) ,([1,2,10],[ais3,cis4,d4]) ,([1,2,10,11],[ais3,b3,cis4,d4]) ,([1,2,11],[b3,cis4,d4]) ,([1,3,11],[b3,cis4,dis4]) ,([1,3,10,11],[ais3,b3,cis4,dis4]) ,([1,10,11],[ais3,b3,cis4]) ,([1,11],[b3,cis4]) ,([2],[d4]) ,([2,3],[d4,ees4]) ,([2,3,4],[d4,ees4,fes4]) ,([2,3,5],[d4,ees4,f4]) ,([2,3,4,5],[d4,ees4,fes4,geses4]) ,([2,3,10,11],[bes3,ces4,d4,ees4]) ,([2,3,11],[b3,d4,ees4]) ,([2,4],[d4,e4]) ,([2,4,5],[d4,e4,f4]) ,([2,5],[d4,f4]) ,([2,10,11],[ais3,b3,d4]) ,([2,11],[b3,d4]) ,([3],[ees4]) ,([3,4],[dis4,e4]) ,([3,4,5],[dis4,e4,f4]) ,([3,5],[ees4,f4]) ,([4],[e4]) ,([4,5],[e4,f4]) ,([5],[f4]) ,([5,6],[f4,ges4]) ,([5,6,7],[eis4,fis4,g4]) ,([5,6,8],[f4,ges4,aes4]) ,([5,6,9],[f4,ges4,a4]) ,([5,6,7,8],[eis4,fis4,g4,aes4]) ,([5,6,7,8,9],[eis4,fis4,g4,aes4,beses4]) ,([5,6,7,9],[eis4,fis4,g4,a4]) ,([5,6,8,9],[eis4,fis4,gis4,a4]) ,([5,7],[f4,g4]) ,([5,7,8],[f4,g4,aes4]) ,([5,7,8,9],[f4,g4,aes4,beses4]) ,([5,7,9],[f4,g4,a4]) ,([5,8],[f4,aes4]) ,([5,8,9],[f4,gis4,a4]) ,([5,9],[f4,a4]) ,([6],[fis4]) ,([6,7],[fis4,g4]) ,([6,7,8],[fis4,g4,aes4]) ,([6,7,8,9],[fis4,g4,aes4,beses4]) ,([6,7,9],[fis4,g4,a4]) ,([6,8],[fis4,gis4]) ,([6,8,9],[fis4,gis4,a4]) ,([6,9],[fis4,a4]) ,([7],[g4]) ,([7,8],[g4,aes4]) ,([7,8,9],[fisis4,gis4,a4]) ,([7,9],[g4,a4]) ,([8],[aes4]) ,([8,9],[gis4,a4]) ,([8,9,10],[gis4,a4,bes4]) ,([8,10],[aes4,bes4]) ,([9],[a4]) ,([9,10],[a4,bes4]) ,([10],[bes4]) ,([10,11],[ais4,b4]) ,([11],[b4])] -- | Spelling for chromatic clusters. Sequence must be ascending. -- Pitch class @0@ maps to 'c4', if there is no @0@ then all notes are -- in octave @4@. -- -- > let f = fmap (map pitch_pp) . spell_cluster_c4 -- > in map f [[11,0],[11]] == [Just ["B3","C4"],Just ["B4"]] -- -- > fmap (map pitch_pp) (spell_cluster_c4 [10,11]) == Just ["A♯4","B4"] spell_cluster_c4 :: [PitchClass] -> Maybe [Pitch] spell_cluster_c4 p = lookup (sort p) spell_cluster_c4_table -- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave'. An -- octave of @4@ is the identitiy, @3@ an octave below, @5@ an octave -- above. -- -- > fmap (map pitch_pp) (spell_cluster_c 3 [11,0]) == Just ["B2","C3"] -- > fmap (map pitch_pp) (spell_cluster_c 3 [10,11]) == Just ["A♯3","B3"] spell_cluster_c :: Octave -> [PitchClass] -> Maybe [Pitch] spell_cluster_c o = fmap (map (pitch_edit_octave (+ (o - 4)))) . spell_cluster_c4 -- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave' so -- that the left-most note is in the octave given by /f/. -- -- > import Data.Maybe -- -- > let {f n = if n >= 11 then 3 else 4 -- > ;g = map pitch_pp .fromJust . spell_cluster_f f -- > ;r = [["B3","C4"],["B3"],["C4"],["A♯4","B4"]]} -- > in map g [[11,0],[11],[0],[10,11]] == r spell_cluster_f :: (PitchClass -> Octave) -> [PitchClass] -> Maybe [Pitch] spell_cluster_f o_f p = let fn r = case r of [] -> [] l:_ -> let (o,n) = pitch_to_octpc l f = (+ (o_f n - o)) in (map (pitch_edit_octave f) r) in fmap fn (spell_cluster_c4 p) -- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave' so -- that the left-most note is in octave /o/. -- -- > fmap (map pitch_pp) (spell_cluster_left 3 [11,0]) == Just ["B3","C4"] -- > fmap (map pitch_pp) (spell_cluster_left 3 [10,11]) == Just ["A♯3","B3"] spell_cluster_left :: Octave -> [PitchClass] -> Maybe [Pitch] spell_cluster_left o p = let fn r = case r of [] -> [] l:_ -> let f = (+ (o - octave l)) in map (pitch_edit_octave f) r in fmap fn (spell_cluster_c4 p) hmt-0.15/Music/Theory/Z/0000755000000000000000000000000012416136065013164 5ustar0000000000000000hmt-0.15/Music/Theory/Z/SRO.hs0000644000000000000000000000476412416136065014176 0ustar0000000000000000-- | Serial (ordered) pitch-class operations on 'Z'. module Music.Theory.Z.SRO where import Data.List {- base -} import Music.Theory.Z -- | Transpose /p/ by /n/. -- -- > tn 5 4 [0,1,4] == [4,0,3] -- > tn 12 4 [1,5,6] == [5,9,10] tn :: (Integral i, Functor f) => i -> i -> f i -> f i tn z n = fmap (z_add z n) -- | Invert /p/ about /n/. -- -- > invert 5 0 [0,1,4] == [0,4,1] -- > invert 12 6 [4,5,6] == [8,7,6] -- > invert 12 0 [0,1,3] == [0,11,9] invert :: (Integral i, Functor f) => i -> i -> f i -> f i invert z n = fmap (\p -> z_sub z n (z_sub z p n)) -- | Composition of 'invert' about @0@ and 'tn'. -- -- > tni 5 1 [0,1,3] == [1,0,3] -- > tni 12 4 [1,5,6] == [3,11,10] -- > (invert 12 0 . tn 12 4) [1,5,6] == [7,3,2] tni :: (Integral i, Functor f) => i -> i -> f i -> f i tni z n = tn z n . invert z 0 -- | Modulo multiplication. -- -- > mn 12 11 [0,1,4,9] == tni 12 0 [0,1,4,9] mn :: (Integral i, Functor f) => i -> i -> f i -> f i mn z n = fmap (z_mul z n) -- | T-related sequences of /p/. -- -- > length (t_related 12 [0,3,6,9]) == 12 t_related :: (Integral i, Functor f) => i -> f i -> [f i] t_related z p = fmap (\n -> tn z n p) [0..11] -- | T\/I-related sequences of /p/. -- -- > length (ti_related 12 [0,1,3]) == 24 -- > length (ti_related 12 [0,3,6,9]) == 24 -- > ti_related 12 [0] == map return [0..11] ti_related :: (Eq (f i), Integral i, Functor f) => i -> f i -> [f i] ti_related z p = nub (t_related z p ++ t_related z (invert z 0 p)) -- | R\/T\/I-related sequences of /p/. -- -- > length (rti_related 12 [0,1,3]) == 48 -- > length (rti_related 12 [0,3,6,9]) == 24 rti_related :: Integral i => i -> [i] -> [[i]] rti_related z p = let q = ti_related z p in nub (q ++ map reverse q) -- * Sequence operations -- | Variant of 'tn', transpose /p/ so first element is /n/. -- -- > tn_to 12 5 [0,1,3] == [5,6,8] -- > map (tn_to 12 0) [[0,1,3],[1,3,0],[3,0,1]] tn_to :: Integral a => a -> a -> [a] -> [a] tn_to z n p = case p of [] -> [] x:xs -> n : tn z (z_sub z n x) xs -- | Variant of 'invert', inverse about /n/th element. -- -- > map (invert_ix 12 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]] -- > map (invert_ix 12 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]] invert_ix :: Integral i => i -> Int -> [i] -> [i] invert_ix z n p = invert z (p !! n) p -- | The standard t-matrix of /p/. -- -- > tmatrix 12 [0,1,3] == [[0,1,3] -- > ,[11,0,2] -- > ,[9,10,0]] tmatrix :: Integral i => i -> [i] -> [[i]] tmatrix z p = map (\n -> tn z n p) (tn_to z 0 (invert_ix z 0 p)) hmt-0.15/Music/Theory/Z/Forte_1973.hs0000644000000000000000000000617712416136065015275 0ustar0000000000000000-- | Allen Forte. /The Structure of Atonal Music/. Yale University -- Press, New Haven, 1973. module Music.Theory.Z.Forte_1973 where import Data.List {- base -} import Data.Maybe {- base -} import Music.Theory.List import qualified Music.Theory.Set.List as S import Music.Theory.Z import Music.Theory.Z.SRO -- * Prime form -- | T-related rotations of /p/. -- -- > t_rotations 12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]] t_rotations :: Integral a => a -> [a] -> [[a]] t_rotations z p = let r = rotations (sort p) in map (tn_to z 0) r -- | T\/I-related rotations of /p/. -- -- > ti_rotations 12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10] -- > ,[0,9,11],[0,2,3],[0,1,10]] ti_rotations :: Integral a => a -> [a] -> [[a]] ti_rotations z p = let q = invert z 0 p r = rotations (sort p) ++ rotations (sort q) in map (tn_to z 0) r -- | Variant with default value for empty input list case. minimumBy_or :: a -> (a -> a -> Ordering) -> [a] -> a minimumBy_or p f q = if null q then p else minimumBy f q -- | Prime form rule requiring comparator, considering 't_rotations'. t_cmp_prime :: Integral a => a -> ([a] -> [a] -> Ordering) -> [a] -> [a] t_cmp_prime z f = minimumBy_or [] f . t_rotations z -- | Prime form rule requiring comparator, considering 'ti_rotations'. ti_cmp_prime :: Integral a => a -> ([a] -> [a] -> Ordering) -> [a] -> [a] ti_cmp_prime z f = minimumBy_or [] f . ti_rotations z -- | Forte comparison function (rightmost first then leftmost outwards). -- -- > forte_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == LT forte_cmp :: (Ord t) => [t] -> [t] -> Ordering forte_cmp [] [] = EQ forte_cmp p q = let r = compare (last p) (last q) in if r == EQ then compare p q else r -- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'. -- -- > forte_prime 12 [0,1,3,6,8,9] == [0,1,3,6,8,9] -- > forte_prime 5 [0,1,4] == [0,1,2] -- -- > S.set (map (forte_prime 5) (S.powerset [0..4])) forte_prime :: Integral a => a -> [a] -> [a] forte_prime z = ti_cmp_prime z forte_cmp -- | Transpositional equivalence prime form, ie. 't_cmp_prime' of -- 'forte_cmp'. -- -- > (forte_prime 12 [0,2,3],t_prime 12 [0,2,3]) == ([0,1,3],[0,2,3]) t_prime :: Integral a => a -> [a] -> [a] t_prime z = t_cmp_prime z forte_cmp -- * ICV Metric -- | Interval class of i interval /i/. -- -- > map (ic 5) [1,2,3,4] == [1,2,2,1] -- > map (ic 12) [5,6,7] == [5,6,5] -- > map (ic 12 . to_Z 12) [-13,-1,0,1,13] == [1,1,0,1,1] ic :: Integral a => a -> a -> a ic z i = if i <= (z `div` 2) then i else z_sub z z i -- | Forte notation for interval class vector. -- -- > icv 12 [0,1,2,4,7,8] == [3,2,2,3,3,2] icv :: (Integral i, Num n) => i -> [i] -> [n] icv z s = let i = map (ic z . uncurry (z_sub z)) (S.pairs s) j = map f (group (sort i)) k = map (`lookup` j) [1 .. z `div` 2] f l = (head l,genericLength l) in map (fromMaybe 0) k -- * BIP Metric -- | Basic interval pattern, see Allen Forte \"The Basic Interval Patterns\" -- /JMT/ 17/2 (1973):234-272 -- -- >>> bip 0t95728e3416 -- 11223344556 -- -- > bip 12 [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6] bip :: Integral a => a -> [a] -> [a] bip z = sort . map (ic z . to_Z z) . d_dx hmt-0.15/Music/Theory/Z/Read_1978.hs0000644000000000000000000001102412416136065015061 0ustar0000000000000000-- | Ronald C. Read. \"Every one a winner or how to avoid isomorphism -- search when cataloguing combinatorial configurations.\" /Annals of -- Discrete Mathematics/ 2:107–20, 1978. module Music.Theory.Z.Read_1978 where import Data.Bits {- base -} import Data.Char {- base -} import Data.Function {- base -} import Data.List {- base -} import Data.Maybe {- base -} import qualified Music.Theory.Z.SRO as T {- hmt -} -- | Coding. type Code = Int -- | Bit array. type Array = [Bool] -- | Pretty printer for 'Array'. array_pp :: Array -> String array_pp = map intToDigit . map fromEnum -- | Parse PP of 'Array'. -- -- > parse_array "01001" == [False,True,False,False,True] parse_array :: String -> Array parse_array = map (toEnum . digitToInt) -- | Generate 'Code' from 'Array', the coding is most to least significant. -- -- > array_to_code (map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0]) == 6428 array_to_code :: Array -> Code array_to_code a = let n = length a f e j = if e then 2 ^ (n - j - 1) else 0 in sum (zipWith f a [0..]) -- | Inverse of 'array_to_code'. -- -- > code_to_array 13 6428 == map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0] code_to_array :: Int -> Code -> Array code_to_array n c = map (testBit c) [n - 1, n - 2 .. 0] -- | Array to set. -- -- > array_to_set (map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0]) == [0,1,4,8,9,10] -- > T.encode [0,1,4,8,9,10] == 1811 array_to_set :: Integral i => [Bool] -> [i] array_to_set = let f (i,e) = if e then Just i else Nothing in mapMaybe f . zip [0..] -- | Inverse of 'array_to_set', /z/ is the degree of the array. set_to_array :: Integral i => i -> [i] -> Array set_to_array z p = map (`elem` p) [0 .. z - 1] -- | 'array_to_code' of 'set_to_array'. -- -- > set_to_code 12 [0,2,3,5] -- > map (set_to_code 12) (T.ti_related 12 [0,2,3,5]) set_to_code :: Integral i => i -> [i] -> Code set_to_code z = array_to_code . set_to_array z -- | Logical complement. array_complement :: Array -> Array array_complement = map not -- | The /prime/ form is the 'maximum' encoding. -- -- > array_is_prime (set_to_array 12 [0,2,3,5]) == False array_is_prime :: Array -> Bool array_is_prime a = let c = array_to_code a p = array_to_set a z = length a u = maximum (map (set_to_code z) (T.ti_related z p)) in c == u -- | The augmentation rule adds @1@ in each empty slot at end of array. -- -- > map array_pp (array_augment (parse_array "01000")) == ["01100","01010","01001"] array_augment :: Array -> [Array] array_augment a = let (z,a') = break id (reverse a) a'' = reverse a' n = length z f k = map (== k) [0 .. n - 1] x = map f [0 .. n - 1] in map (a'' ++) x -- | Enumerate first half of the set-classes under given /prime/ function. -- The second half can be derived as the complement of the first. -- -- > import Music.Theory.Z12.Forte_1973 -- > length scs == 224 -- > map (length . scs_n) [0..12] == [1,1,6,12,29,38,50,38,29,12,6,1,1] -- -- > let z12 = map (fmap (map array_to_set)) (enumerate_half array_is_prime 12) -- > map (length . snd) z12 == [1,1,6,12,29,38,50] -- -- This can become slow, edit /z/ to find out. It doesn't matter -- about /n/. This can be edited so that small /n/ would run quickly -- even for large /z/. -- -- > fmap (map array_to_set) (lookup 5 (enumerate_half array_is_prime 16)) enumerate_half :: (Array -> Bool) -> Int -> [(Int,[Array])] enumerate_half pr n = let a0 = replicate n False f k a = if k >= n `div` 2 then [] else let r = filter pr (array_augment a) in (k + 1,r) : concatMap (f (k + 1)) r jn l = case l of (x,y):l' -> (x,concat (y : map snd l')) _ -> error "" post_proc = map jn . groupBy ((==) `on` fst) . sortBy (compare `on` fst) in post_proc ((0,[a0]) : f 0 a0) -- * Alternate (reverse) form. -- | Encoder for 'encode_prime'. -- -- > encode [0,1,3,6,8,9] == 843 encode :: Integral i => [i] -> Code encode = sum . map (2 ^) -- | Decoder for 'encode_prime'. -- -- > decode 12 843 == [0,1,3,6,8,9] decode :: Integral i => i -> Code -> [i] decode z n = let f i = (i,testBit n (fromIntegral i)) in map fst (filter snd (map f [0 .. z - 1])) -- | Binary encoding prime form algorithm, equalivalent to Rahn. -- -- > encode_prime 12 [0,1,3,6,8,9] == [0,2,3,6,7,9] -- > Music.Theory.Z12.Rahn_1980.rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] encode_prime :: Integral i => i -> [i] -> [i] encode_prime z s = let t = map (\n -> T.tn z n s) [0..11] c = t ++ map (T.invert z 0) t in decode z (minimum (map encode c)) hmt-0.15/Music/Theory/Metric/0000755000000000000000000000000012416136065014176 5ustar0000000000000000hmt-0.15/Music/Theory/Metric/Polansky_1996.hs0000644000000000000000000002502412416136065017025 0ustar0000000000000000-- | Larry Polansky. \"Morphological Metrics\". Journal of New Music -- Research, 25(4):289-368, 1996. module Music.Theory.Metric.Polansky_1996 where import Data.List import Data.Maybe import Data.Ratio import qualified Music.Theory.Contour.Polansky_1992 as C import qualified Music.Theory.List as L -- | Distance function, ordinarily /n/ below is in 'Num', 'Fractional' -- or 'Real'. type Interval a n = (a -> a -> n) -- | 'fromIntegral' '.' '-'. dif_i :: (Integral a,Num b) => a -> a -> b dif_i i j = fromIntegral (i - j) -- | 'realToFrac' '.' '-'. dif_r :: (Real a,Fractional b) => a -> a -> b dif_r i j = realToFrac (i - j) -- | 'abs' '.' /f/. abs_dif :: Num n => Interval a n -> a -> a -> n abs_dif f i j = abs (i `f` j) -- | Square. sqr :: Num a => a -> a sqr n = n * n -- | 'sqr' '.' /f/. sqr_dif :: Num n => Interval a n -> a -> a -> n sqr_dif f i j = sqr (i `f` j) -- | 'sqr' '.' 'abs' '.' /f/. sqr_abs_dif :: Num n => Interval a n -> a -> a -> n sqr_abs_dif f i = sqr . abs_dif f i -- | 'sqrt' '.' 'abs' '.' /f/. sqrt_abs_dif :: Floating c => Interval a c -> a -> a -> c sqrt_abs_dif f i = sqrt . abs_dif f i -- | City block metric, p.296 -- -- > city_block_metric (-) (1,2) (3,5) == 2+3 city_block_metric :: Num n => Interval a n -> (a,a) -> (a,a) -> n city_block_metric f (x1,x2) (y1,y2) = abs_dif f x1 y1 + abs_dif f x2 y2 -- | Two-dimensional euclidean metric, p.297. -- -- > euclidean_metric_2 (-) (1,2) (3,5) == sqrt (4+9) euclidean_metric_2 :: Floating n => Interval a n -> (a,a) -> (a,a) -> n euclidean_metric_2 f (x1,x2) (y1,y2) = sqrt (sqr_dif f x1 y1 + sqr_dif f x2 y2) -- | /n/-dimensional euclidean metric -- -- > euclidean_metric_l (-) [1,2] [3,5] == sqrt (4+9) -- > euclidean_metric_l (-) [1,2,3] [2,4,6] == sqrt (1+4+9) euclidean_metric_l :: Floating c => Interval b c -> [b] -> [b] -> c euclidean_metric_l f p = sqrt . sum . zipWith (sqr_dif f) p -- | Cube root. -- -- > map cbrt [1,8,27] == [1,2,3] cbrt :: Floating a => a -> a cbrt n = n ** (1/3) -- | /n/-th root -- -- > map (nthrt 4) [1,16,81] == [1,2,3] nthrt :: Floating a => a -> a -> a nthrt r n = n ** recip r -- | Two-dimensional Minkowski metric, p.297 -- -- > minkowski_metric_2 (-) 1 (1,2) (3,5) == 5 -- > minkowski_metric_2 (-) 2 (1,2) (3,5) == sqrt (4+9) -- > minkowski_metric_2 (-) 3 (1,2) (3,5) == cbrt (8+27) minkowski_metric_2 :: Floating a => Interval t a -> a -> (t,t) -> (t,t) -> a minkowski_metric_2 f n (x1,x2) (y1,y2) = ((abs (x1 `f` y1) ** n) + (abs (x2 `f` y2) ** n)) ** (1/n) -- | /n/-dimensional Minkowski metric -- -- > minkowski_metric_l (-) 2 [1,2,3] [2,4,6] == sqrt (1+4+9) -- > minkowski_metric_l (-) 3 [1,2,3] [2,4,6] == cbrt (1+8+27) minkowski_metric_l :: Floating a => Interval t a -> a -> [t] -> [t] -> a minkowski_metric_l f n p q = let g i j = abs (i `f` j) ** n in nthrt n (sum (zipWith g p q)) -- | Integration with /f/. -- -- > d_dx (-) [0,2,4,1,0] == [2,2,-3,-1] -- > d_dx (-) [2,3,0,4,1] == [1,-3,4,-3] d_dx :: Interval a n -> [a] -> [n] d_dx f l = zipWith f (tail l) l -- | 'map' 'abs' '.' 'd_dx'. -- -- > d_dx_abs (-) [0,2,4,1,0] == [2,2,3,1] -- > d_dx_abs (-) [2,3,0,4,1] == [1,3,4,3] d_dx_abs :: Num n => Interval a n -> [a] -> [n] d_dx_abs f = map abs . d_dx f -- | Ordered linear magnitude (no delta), p.300 -- -- > olm_no_delta' [0,2,4,1,0] [2,3,0,4,1] == 1.25 olm_no_delta' :: Fractional a => [a] -> [a] -> a olm_no_delta' p q = let r = zipWith (-) (d_dx_abs (-) p) (d_dx_abs (-) q) z = sum (map abs r) in z / (fromIntegral (length p) - 1) -- | Ordered linear magintude (general form) p.302 -- -- > olm_general (abs_dif (-)) [0,2,4,1,0] [2,3,0,4,1] == 1.25 -- > olm_general (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6 olm_general :: (Fractional a,Enum a,Fractional n) => Interval a n -> [a] -> [a] -> n olm_general f p q = let r = zipWith (-) (d_dx f p) (d_dx f q) z = sum (map abs r) in z / (fromIntegral (length p) - 1) -- | 'Delta' (Δ) determines an interval given a sequence and an index. type Delta n a = ([n] -> Int -> a) -- | /f/ at indices /i/ and /i+1/ of /x/. -- -- > map (ix_dif (-) [0,1,3,6,10]) [0..3] == [-1,-2,-3,-4] ix_dif :: Interval a t -> Delta a t ix_dif f x i = (x !! i) `f` (x !! (i + 1)) -- | 'abs' '.' 'ix_dif' -- -- > map (abs_ix_dif (-) [0,2,4,1,0]) [0..3] == [2,2,3,1] abs_ix_dif :: Num n => Interval a n -> Delta a n abs_ix_dif f x i = abs (ix_dif f x i) -- | 'sqr' '.' 'abs_ix_dif' -- -- > map (sqr_abs_ix_dif (-) [0,2,4,1,0]) [0..3] == [4,4,9,1] -- > map (sqr_abs_ix_dif (-) [2,3,0,4,1]) [0..3] == [1,9,16,9] sqr_abs_ix_dif :: Num n => Interval a n -> Delta a n sqr_abs_ix_dif f x i = sqr (abs_ix_dif f x i) -- | 'Psi' (Ψ) joins 'Delta' equivalent intervals from morphologies /m/ and /n/. type Psi a = (a -> a -> a) -- | Ordered linear magintude (generalised-interval form) p.305 -- -- > olm (abs_dif dif_r) (abs_ix_dif dif_r) (const 1) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6 -- > olm (abs_dif dif_r) (abs_ix_dif dif_r) maximum [1,5,12,2,9,6] [7,6,4,9,8,1] == 0.46 olm :: (Fractional a,Enum a) => Psi a -> Delta n a -> ([a] -> a) -> [n] -> [n] -> a olm psi delta maxint m n = let l = length m l' = fromIntegral l - 1 k = [0..l-2] m' = map (delta m) k n' = map (delta n) k in sum (zipWith psi m' n') / (l' * maxint (m' ++ n')) -- > olm_no_delta [0,2,4,1,0] [2,3,0,4,1] == 1.25 -- > olm_no_delta [1,6,2,5,11] [3,15,13,2,9] == 4.5 olm_no_delta :: (Real a,Real n,Enum n,Fractional n) => [a] -> [a] -> n olm_no_delta = olm (abs_dif dif_r) (abs_ix_dif dif_r) (const 1) -- > olm_no_delta_squared [0,2,4,1,0] [2,3,0,4,1] == sum (map sqrt [3,5,7,8]) / 4 olm_no_delta_squared :: (Enum a,Floating a) => [a] -> [a] -> a olm_no_delta_squared = olm (sqrt_abs_dif (-)) (sqr_abs_ix_dif (-)) (const 1) second_order :: (Num n) => ([n] -> [n] -> t) -> [n] -> [n] -> t second_order f p q = f (d_dx_abs (-) p) (d_dx_abs (-) q) -- > olm_no_delta_second_order [0,2,4,1,0] [2,3,0,4,1] == 1.0 olm_no_delta_second_order :: (Real a,Enum a,Fractional a) => [a] -> [a] -> a olm_no_delta_second_order = second_order olm_no_delta -- p.301 erroneously gives this as sum (map sqrt [2,0,1]) / 3 -- > olm_no_delta_squared_second_order [0,2,4,1,0] [2,3,0,4,1] == sum (map sqrt [4,0,3]) / 3 olm_no_delta_squared_second_order :: (Enum a,Floating a) => [a] -> [a] -> a olm_no_delta_squared_second_order = second_order olm_no_delta_squared -- | Second order binomial coefficient, p.307 -- -- > map second_order_binonial_coefficient [2..10] == [1,3,6,10,15,21,28,36,45] second_order_binonial_coefficient :: Fractional a => a -> a second_order_binonial_coefficient n = ((n * n) - n) / 2 -- | 'd_dx' of 'flip' 'compare'. -- -- > direction_interval [5,9,3,2] == [LT,GT,GT] -- > direction_interval [2,5,6,6] == [LT,LT,EQ] direction_interval :: Ord i => [i] -> [Ordering] direction_interval = d_dx (flip compare) -- | Histogram of list of 'Ordering's. -- -- > ord_hist [LT,GT,GT] == (1,0,2) ord_hist :: Integral t => [Ordering] -> (t,t,t) ord_hist x = let h = L.histogram x f n = fromMaybe 0 (lookup n h) in (f LT,f EQ,f GT) -- | Histogram of /directions/ of adjacent elements, p.312. -- -- > direction_vector [5,9,3,2] == (1,0,2) -- > direction_vector [2,5,6,6] == (2,1,0) direction_vector :: Integral i => (Ord a) => [a] -> (i,i,i) direction_vector = ord_hist . direction_interval -- | Unordered linear direction, p.311 (Fig. 5) -- -- > uld [5,9,3,2] [2,5,6,6] == 2/3 -- > uld [5,3,6,1,4] [3,6,1,4,2] == 0 uld :: (Integral n,Ord a) => [a] -> [a] -> Ratio n uld m n = let (i,j,k) = direction_vector m (p,q,r) = direction_vector n z = (i + j + k) * 2 in (abs_dif (-) i p + abs_dif (-) j q + abs_dif (-) k r) % z -- | Ordered linear direction, p.312 -- -- > direction_interval [5,3,6,1,4] == [GT,LT,GT,LT] -- > direction_interval [3,6,1,4,2] == [LT,GT,LT,GT] -- > old [5,3,6,1,4] [3,6,1,4,2] == 1 old :: (Ord i, Integral a) => [i] -> [i] -> Ratio a old m n = let p = direction_interval m q = direction_interval n f i j = if i == j then 0 else 1 in sum (zipWith f p q) % (genericLength m - 1) -- | Ordered combinatorial direction, p.314 -- -- > ocd [5,9,3,2] [2,5,6,6] == 5/6 -- > ocd [5,3,6,1,4] [3,6,1,4,2] == 4/5 ocd :: (Ord a,Integral i) => [a] -> [a] -> Ratio i ocd m n = let p = concat (C.half_matrix_f compare m) q = concat (C.half_matrix_f compare n) f i j = if i == j then 0 else 1 in sum (zipWith f p q) % genericLength p -- | Unordered combinatorial direction, p.314 -- -- > ucd [5,9,3,2] [2,5,6,6] == 5/6 -- > ucd [5,3,6,1,4] [3,6,1,4,2] == 0 -- > ucd [5,3,7,6] [2,1,2,1] == 1/2 -- > ucd [2,1,2,1] [8,3,5,4] == 1/3 -- > ucd [5,3,7,6] [8,3,5,4] == 1/3 ucd :: (Integral n,Ord a) => [a] -> [a] -> Ratio n ucd m n = let (i,j,k) = ord_hist (concat (C.half_matrix_f compare m)) (p,q,r) = ord_hist (concat (C.half_matrix_f compare n)) z = (i + j + k) * 2 in (abs_dif (-) i p + abs_dif (-) j q + abs_dif (-) k r) % z -- | 'C.half_matrix_f', Fig.9, p.318 -- -- > let r = [[2,3,1,4] -- > ,[1,3,6] -- > ,[4,7] -- > ,[3]] -- > in combinatorial_magnitude_matrix (abs_dif (-)) [5,3,2,6,9] == r combinatorial_magnitude_matrix :: Interval a n -> [a] -> [[n]] combinatorial_magnitude_matrix = C.half_matrix_f -- | Unordered linear magnitude (simplified), p.320-321 -- -- > let r = abs (sum [5,4,3,6] - sum [12,2,11,7]) / 4 -- > in ulm_simplified (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == r -- -- > ulm_simplified (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3 ulm_simplified :: Fractional n => Interval a n -> [a] -> [a] -> n ulm_simplified f p q = let g = abs . sum . d_dx f in abs (g p - g q) / fromIntegral (length p - 1) ocm_zcm :: (Fractional n, Num a) => Interval a n -> [a] -> [a] -> (n, n, [n]) ocm_zcm f p q = let p' = concat (C.half_matrix_f f p) q' = concat (C.half_matrix_f f q) r = zipWith (-) p' q' z = sum (map abs r) c = second_order_binonial_coefficient (fromIntegral (length p)) m = p' ++ q' in (z,c,m) -- | Ordered combinatorial magnitude (OCM), p.323 -- -- > ocm (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == 5.2 -- > ocm (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3.6 ocm :: (Fractional a,Enum a,Fractional n) => Interval a n -> [a] -> [a] -> n ocm f p q = let (z,c,_) = ocm_zcm f p q in z / c -- | Ordered combinatorial magnitude (OCM), p.323 -- -- > ocm_absolute_scaled (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == 0.4 -- > ocm_absolute_scaled (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 54/(15*11) ocm_absolute_scaled :: (Ord a,Fractional a,Enum a,Ord n,Fractional n) => Interval a n -> [a] -> [a] -> n ocm_absolute_scaled f p q = let (z,c,m) = ocm_zcm f p q in z / (c * maximum m) hmt-0.15/Music/Theory/Metric/Morris_1980.hs0000644000000000000000000000156712416136065016477 0ustar0000000000000000-- | Robert Morris. \"A Similarity Index for Pitch-Class -- Sets\". Perspectives of New Music, 18(2):445-460, 1980. module Music.Theory.Metric.Morris_1980 where import Data.Ratio import Music.Theory.Z12 import Music.Theory.Z12.Forte_1973 -- | SIM -- -- > icv [0,1,3,6] == [1,1,2,0,1,1] && icv [0,2,4,7] == [0,2,1,1,2,0] -- > sim [0,1,3,6] [0,2,4,7] == 6 -- > sim [0,1,2,4,5,8] [0,1,3,7] == 9 sim :: Integral a => [Z12] -> [Z12] -> a sim r s = let r' = icv r s' = icv s t = zipWith (-) r' s' in sum (map abs t) -- | ASIM -- -- > asim [0,1,3,6] [0,2,4,7] == 6/12 -- > asim [0,1,2,4,5,8] [0,1,3,7] == 9/21 -- > asim [0,1,2,3,4] [0,1,4,5,7] == 2/5 -- > asim [0,1,2,3,4] [0,2,4,6,8] == 3/5 -- > asim [0,1,4,5,7] [0,2,4,6,8] == 3/5 asim :: (Integral n) => [Z12] -> [Z12] -> Ratio n asim r s = let r' = icv r s' = icv s in sim r s % (sum r' + sum s') hmt-0.15/Music/Theory/Metric/Buchler_1998.hs0000644000000000000000000001753412416136065016622 0ustar0000000000000000-- | Michael Buchler. \"Relative Saturation of Subsets and Interval -- Cycles as a Means for Determining Set-Class Similarity\". PhD -- thesis, University of Rochester, 1998 module Music.Theory.Metric.Buchler_1998 where import Data.List {- base -} import Data.Ratio {- base -} import qualified Music.Theory.List as T import qualified Music.Theory.Z12.Forte_1973 as T import qualified Music.Theory.Set.List as T import Music.Theory.Z12 (Z12) -- | Predicate for list with cardinality /n/. of_c :: Integral n => n -> [a] -> Bool of_c n = (== n) . genericLength -- | Set classes of cardinality /n/. -- -- > sc_table_n 2 == [[0,1],[0,2],[0,3],[0,4],[0,5],[0,6]] sc_table_n :: (Integral n) => n -> [[Z12]] sc_table_n n = filter (of_c n) (map snd T.sc_table) -- | Minima and maxima of ICV of SCs of cardinality /n/. -- -- > icv_minmax 5 == ([0,0,0,1,0,0],[4,4,4,4,4,2]) icv_minmax :: (Integral n, Integral b) => n -> ([b], [b]) icv_minmax n = let t = sc_table_n n i = transpose (map T.icv t) in (map minimum i,map maximum i) data R = MIN | MAX deriving (Eq,Show) type D n = (R,n) -- | Pretty printer for 'R'. -- -- > map r_pp [MIN,MAX] == ["+","-"] r_pp :: R -> String r_pp r = case r of MIN -> "+" MAX -> "-" -- | 'SATV' element measure with given funtion. satv_f :: (Integral n) => ((n,n,n) -> D n) -> [Z12] -> [D n] satv_f f p = let n = length p i = T.icv p (l,r) = icv_minmax n in map f (zip3 l i r) -- | Pretty printer for SATV element. -- -- > satv_e_pp (satv_a [0,1,2,6,7,8]) == "<-1,+2,+0,+0,-1,-0>" satv_e_pp :: Show i => [D i] -> String satv_e_pp = let f (i,j) = r_pp i ++ show j in T.bracket ('<','>') . intercalate "," . map f type SATV i = ([D i],[D i]) -- | Pretty printer for 'SATV'. satv_pp :: Show i => SATV i -> String satv_pp (i,j) = T.bracket ('(',')') (satv_e_pp i ++ "," ++ satv_e_pp j) -- | @SATVa@ measure. -- -- > satv_e_pp (satv_a [0,1,2,6,7,8]) == "<-1,+2,+0,+0,-1,-0>" -- > satv_e_pp (satv_a [0,1,2,3,4]) == "<-0,-1,-2,+0,+0,+0>" satv_a :: Integral i => [Z12] -> [D i] satv_a = let f (l,i,r) = let l' = abs (i - l) r' = abs (i - r) in case compare l' r' of LT -> (MIN,l') _ -> (MAX,r') in satv_f f -- | @SATVb@ measure. -- -- > satv_e_pp (satv_b [0,1,2,6,7,8]) == "<+4,-4,-5,-4,+4,+3>" -- > satv_e_pp (satv_b [0,1,2,3,4]) == "<+4,+3,+2,-3,-4,-2>" satv_b :: Integral i => [Z12] -> [D i] satv_b = let f (l,i,r) = let l' = abs (i - l) r' = abs (i - r) in case compare l' r' of LT -> (MAX,r') _ -> (MIN,l') in satv_f f -- | 'SATV' measure. -- -- > satv_pp (satv [0,3,6,9]) == "(<+0,+0,-0,+0,+0,-0>,<-3,-3,+4,-3,-3,+2>)" -- > satv_pp (satv [0,1,3,4,8]) == "(<-2,+1,-2,-1,-2,+0>,<+2,-3,+2,+2,+2,-2>)" -- > satv_pp (satv [0,1,2,6,7,8]) == "(<-1,+2,+0,+0,-1,-0>,<+4,-4,-5,-4,+4,+3>)" -- > satv_pp (satv [0,4]) == "(<+0,+0,+0,-0,+0,+0>,<-1,-1,-1,+1,-1,-1>)" -- > satv_pp (satv [0,1,3,4,6,9]) == "(<+2,+2,-0,+0,+2,-1>,<-3,-4,+5,-4,-3,+2>)" -- > satv_pp (satv [0,1,3,6,7,9]) == "(<+2,+2,-1,+0,+2,-0>,<-3,-4,+4,-4,-3,+3>)" -- > satv_pp (satv [0,1,2,3,6]) == "(<-1,-2,-2,+0,+1,-1>,<+3,+2,+2,-3,-3,+1>)" -- > satv_pp (satv [0,1,2,3,4,6]) == "(<-1,-2,-2,+0,+1,+1>,<+4,+4,+3,-4,-4,-2>)" -- > satv_pp (satv [0,1,3,6,8]) == "(<+1,-2,-2,+0,-1,-1>,<-3,+2,+2,-3,+3,+1>)" -- > satv_pp (satv [0,2,3,5,7,9]) == "(<+1,-2,-2,+0,-1,+1>,<-4,+4,+3,-4,+4,-2>)" satv :: Integral i => [Z12] -> SATV i satv p = (satv_a p,satv_b p) -- | 'SATV' reorganised by 'R'. -- -- > satv_minmax (satv [0,1,2,6,7,8]) == ([4,2,0,0,4,3],[1,4,5,4,1,0]) satv_minmax :: SATV i -> ([i],[i]) satv_minmax (p,q) = let f (i,j) (_,k) = if i == MIN then (j,k) else (k,j) in unzip (zipWith f p q) -- | Absolute difference. abs_dif :: Num a => a -> a -> a abs_dif i j = abs (i - j) -- | Sum of numerical components of @a@ and @b@ parts of 'SATV'. -- -- > satv_n_sum (satv [0,1,2,6,7,8]) == [5,6,5,4,5,3] -- > satv_n_sum (satv [0,3,6,9]) = [3,3,4,3,3,2] satv_n_sum :: Num c => SATV c -> [c] satv_n_sum (i,j) = zipWith (+) (map snd i) (map snd j) -- > two_part_difference_vector (satv_a [0,1,2,6,7,8]) (satv [0,3,6,9]) == [2,2,4,0,2,0] two_part_difference_vector :: (Integral i) => [D i] -> SATV i -> [i] two_part_difference_vector i j = let (p,q) = satv_minmax j f (r,_) k = if r == MIN then p!!k else q!!k z = zipWith f i [0..] in zipWith abs_dif (map snd i) z -- > two_part_difference_vector_set (satv [0,4]) (satv [0,1,3,4,6,9]) == ([2,2,5,4,2,2],[2,2,1,1,2,0]) two_part_difference_vector_set :: (Integral i) => SATV i -> SATV i -> ([i],[i]) two_part_difference_vector_set i j = (two_part_difference_vector (fst i) j ,two_part_difference_vector (fst j) i) -- | @SATSIM@ metric. -- -- > satsim [0,1,2,6,7,8] [0,3,6,9] == 25/46 -- > satsim [0,4] [0,1,3,4,6,9] == 25/34 -- > satsim [0,4] [0,1,3,6,7,9] == 25/34 -- > satsim [0,1,2,3,6] [0,1,2,3,4,6] == 1/49 -- > satsim [0,1,3,6,8] [0,2,3,5,7,9] == 1/49 -- > satsim [0,1,2,3,4] [0,1,4,5,7] == 8/21 -- > satsim [0,1,2,3,4] [0,2,4,6,8] == 4/7 -- > satsim [0,1,4,5,7] [0,2,4,6,8] == 4/7 satsim :: Integral a => [Z12] -> [Z12] -> Ratio a satsim p q = let i = satv p j = satv q (d1,d2) = two_part_difference_vector_set i j d = sum d1 + sum d2 (n1,n2) = (satv_n_sum i,satv_n_sum j) n = sum n1 + sum n2 in if n == 0 then error (show ("satsim",p,q)) else d % n -- | Table of 'satsim' measures for all @SC@ pairs. -- -- > length satsim_table == 24310 satsim_table :: Integral i => [(([Z12],[Z12]),Ratio i)] satsim_table = let f (i,j) = ((i,j),satsim i j) t = filter ((`notElem` [0,1,12]) . length) (map snd T.sc_table) in map f (T.pairs t) -- | Histogram of values at 'satsim_table'. -- -- > satsim_table_histogram == T.histogram (map snd satsim_table) satsim_table_histogram :: Integral i => [(Ratio i,i)] satsim_table_histogram = [(0,132),(1/49,4),(1/30,4),(2/49,16),(2/39,16),(18,8),(2/33,12),(3/49,30),(15,12),(14,144),(13,56),(4/49,72),(2/23,14),(2/21,304),(10,6),(5/49,132),(4/39,160),(1/9,264),(4/33,16),(6/49,152),(1/8,12),(5/39,108),(3/23,4),(25,44),(1/7,487),(7/46,6),(23,132),(8/49,304),(1/6,116),(4/23,86),(7/40,6),(7/39,444),(21,48),(9/49,208),(4/21,1116),(9/46,84),(1/5,68),(10/49,298),(8/39,472),(5/24,4),(7/33,88),(34,394),(5/23,176),(2/9,516),(11/49,378),(9/40,8),(33,176),(7/30,116),(11/46,172),(8/33,64),(12/49,314),(1/4,10),(10/39,336),(7/27,4),(6/23,276),(9/34,2),(13/49,374),(45,124),(31,192),(11/40,4),(58,56),(11/39,376),(13/46,298),(2/7,1297),(7/24,48),(8/27,8),(30,226),(10/33,148),(7/23,204),(15/49,228),(43,384),(11/34,6),(13/40,50),(15/46,272),(16/49,196),(1/3,1528),(17/49,132),(8/23,230),(7/20,128),(67,6),(54,82),(14/39,144),(41,160),(11/30,168),(18/49,74),(17/46,228),(10/27,32),(3/8,238),(8/21,412),(53,160),(19/49,84),(78,76),(9/23,94),(13/33,284),(2/5,310),(11/27,44),(20/49,76),(16/39,376),(77,14),(19/46,150),(52,128),(14/33,156),(17/40,154),(3/7,81),(13/30,108),(10/23,114),(17/39,236),(15/34,4),(4/9,460),(22/49,10),(9/20,96),(51,172),(21/46,124),(11/24,144),(63,112),(75,84),(23/49,6),(87,28),(19/40,96),(10/21,84),(11/23,28),(13/27,188),(16/33,52),(19/39,160),(24/49,8),(1/2,545),(25/49,2),(20/39,144),(17/33,100),(14/27,296),(12/23,64),(21/40,42),(97,48),(85,56),(15/28,1),(73,64),(13/24,32),(25/46,66),(61,36),(11/20,18),(27/49,24),(5/9,192),(19/34,132),(22/39,24),(13/23,18),(17/30,40),(4/7,176),(23/40,32),(19/33,16),(72,28),(27/46,56),(107,84),(23/39,20),(29/49,26),(16/27,72),(3/5,14),(20/33,4),(14/23,10),(30/49,24),(21/34,120),(5/8,28),(17/27,36),(31/49,22),(71,16),(94,22),(117,72),(13/20,4),(32/49,14),(2/3,14),(27/40,6),(23/34,14),(19/28,1),(70,4),(19/27,4),(127,24),(5/7,10),(25/34,4),(3/4,7),(7/9,12),(114,4),(17/21,4),(23/28,7),(5/6,20),(6/7,11),(8/9,12),(25/28,16),(19/21,38),(112,4),(134,7),(178,18),(20/21,12),(1,32)] -- Local Variables: -- truncate-lines:t -- End: hmt-0.15/Music/Theory/Block_Design/0000755000000000000000000000000012416136065015276 5ustar0000000000000000hmt-0.15/Music/Theory/Block_Design/Johnson_2007.hs0000644000000000000000000000734512416136065017731 0ustar0000000000000000-- | Tom Johnson. \"Networks\". In Conference on Mathematics and -- Computation in Music, Berlin, May 2007. module Music.Theory.Block_Design.Johnson_2007 where import Control.Arrow {- base -} import Data.List {- base -} import qualified Music.Theory.List as T -- * Designs data Design i = Design [i] [[i]] -- * Johnson (7,3,1), (13,4,1) and (12,4,3) -- > c_7_3_1 == [1,3,4,2,7,6,5] c_7_3_1 :: (Num i) => [i] c_7_3_1 = [1,3,4,2,7,6,5] -- > b_7_3_1 == ([[1,2,3],[3,4,7],[2,4,6],[2,5,7],[1,6,7],[3,5,6],[1,4,5]] -- > ,[[1,2,4],[2,3,7],[4,6,7],[2,5,6],[1,5,7],[1,3,6],[3,4,5]]) b_7_3_1 :: (Ord i,Num i) => ([[i]], [[i]]) b_7_3_1 = let c = c_7_3_1 f i (j1,j2) = sort [i,j1,j2] in (zipWith f (T.rotate_left 3 c) (T.adj2_cyclic 1 c) ,zipWith f c (T.adj2_cyclic 1 (T.rotate_left 2 c))) d_7_3_1 :: (Enum n,Ord n,Num n) => (Design n,Design n) d_7_3_1 = let d = Design [1..7] in (d *** d) b_7_3_1 -- > length n_7_3_1 == 7 && sort n_7_3_1 == n_7_3_1 n_7_3_1 :: Num i => [(i,i)] n_7_3_1 = [(3,4),(3,11),(4,1),(4,3),(4,5),(4,7),(5,2)] -- > Music.Theory.List.histogram (concat p_9_3_1) == [(1,4),(2,4),(3,4),(4,4),(5,4),(6,4),(7,4),(8,4),(9,4)] p_9_3_1 :: Num i => [[i]] p_9_3_1 = [[1,8,9],[2,3,5],[4,6,7],[1,4,5],[2,6,8],[3,7,9],[1,2,7],[3,4,8],[5,6,9],[1,3,6],[2,4,9],[5,7,8]] -- > b_13_4_1 == ([[1,2,4,10],[2,3,5,11],[3,4,6,12],[4,5,7,13],[1,5,6,8],[2,6,7,9],[3,7,8,10],[4,8,9,11],[5,9,10,12],[6,10,11,13],[1,7,11,12],[2,8,12,13]] -- > ,[[4,8,9,11],[5,9,10,12],[6,10,11,13],[1,7,11,12],[2,8,12,13],[1,3,9,13],[1,2,4,10],[2,3,5,11],[3,4,6,12],[4,5,7,13],[1,5,6,8],[2,6,7,9]]) b_13_4_1 :: (Enum i,Num i,Ord i) => ([[i]], [[i]]) b_13_4_1 = let c = [1..13] c' = T.rotate_left 7 c d = T.interleave_rotations 9 3 c e = T.interleave_rotations 3 10 c f (i1,i2) (j1,j2) = sort [i1,i2,j1,j2] in (zipWith f (T.adj2 1 c) (T.adj2 2 d) ,zipWith f (T.adj2 1 c') (T.adj2 2 e)) d_13_4_1 :: (Enum n,Ord n,Num n) => (Design n,Design n) d_13_4_1 = let d = Design [1..13] in (d *** d) b_13_4_1 -- > length n_13_4_1 == 13 && sort n_13_4_1 == n_13_4_1 n_13_4_1 :: Num i => [(i,i)] n_13_4_1 = [(3,0),(3,2),(3,5),(3,7),(3,10),(4,0),(4,3),(4,5),(4,8),(4,10),(5,1),(5,3),(5,6)] -- > histogram (concat b_12_4_3) == [(1,11),(2,11),(3,11),(4,11),(5,11),(6,11),(7,11),(8,11),(9,11),(10,11),(11,11),(12,11)] -- > histogram (map (sort.concat) (chunksOf 3 b_12_4_3)) == [([1,2,3,4,5,6,7,8,9,10,11,12],11)] -- > map length (adj_intersect 1 b_12_4_3) == [0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0,3,0,0] -- > map (map length . adj_intersect 1) (cycles 3 b_12_4_3) == [[1,1,1,1,1,1,1,1,1,1],[2,2,2,2,2,2,2,2,2,2],[1,1,1,1,1,1,1,1,1,1]] -- > map adj_intersect 1 (cycles 3 b_12_4_3) == [[[12],[12],[12],[12],[12],[12],[12],[12],[12],[12]] -- > ,[[8,9],[7,8],[6,7],[5,6],[4,5],[3,4],[2,3],[1,2],[1,11],[10,11]] -- > ,[[3],[2],[1],[11],[10],[9],[8],[7],[6],[5]]] b_12_4_3 :: Integral i => [[i]] b_12_4_3 = [[1,5,7,12] ,[2,8,9,10] ,[3,4,6,11] ,[4,6,11,12] ,[1,7,8,9] ,[2,3,5,10] ,[3,5,10,12] ,[6,7,8,11] ,[1,2,4,9] ,[2,4,9,12] ,[5,6,7,10] ,[1,3,8,11] ,[1,3,8,12] ,[4,5,6,9] ,[2,7,10,11] ,[2,7,11,12] ,[3,4,5,8] ,[1,6,9,10] ,[1,6,10,12] ,[2,3,4,7] ,[5,8,9,11] ,[5,9,11,12] ,[1,2,3,6] ,[4,7,8,10] ,[4,8,10,12] ,[1,2,5,11] ,[3,6,7,9] ,[3,7,9,12] ,[1,4,10,11] ,[2,5,6,8] ,[2,6,8,12] ,[3,9,10,11] ,[1,4,5,7]] -- > length n_12_4_3 == 12 && sort n_12_4_3 == n_12_4_3 n_12_4_3 :: Num i => [(i,i)] n_12_4_3 = [(3,2),(3,5),(3,6),(3,9),(3,10),(4,1),(4,4),(4,7),(4,8),(4,11),(5,0),(5,3)] -- Local Variables: -- truncate-lines:t -- End: hmt-0.15/Music/Theory/Tuning/0000755000000000000000000000000012416136065014217 5ustar0000000000000000hmt-0.15/Music/Theory/Tuning/ET.hs0000644000000000000000000002057412416136065015073 0ustar0000000000000000-- | Equal temperament tuning tables. module Music.Theory.Tuning.ET where import Data.List {- base -} import Data.List.Split {- split -} import Data.Ratio {- base -} import Text.Printf {- base -} import Music.Theory.List {- hmt -} import Music.Theory.Pitch {- hmt -} import Music.Theory.Pitch.Note {- hmt -} import Music.Theory.Pitch.Spelling {- hmt -} import Music.Theory.Tuning {- hmt -} -- | 'octpc_to_pitch' and 'octpc_to_cps'. octpc_to_pitch_cps :: (Floating n) => OctPC -> (Pitch,n) octpc_to_pitch_cps x = (octpc_to_pitch pc_spell_ks x,octpc_to_cps x) -- | 12-tone equal temperament table equating 'Pitch' and frequency -- over range of human hearing, where @A4@ = @440@hz. -- -- > length tbl_12et == 132 -- > let min_max l = (minimum l,maximum l) -- > min_max (map (round . snd) tbl_12et) == (16,31609) tbl_12et :: [(Pitch,Double)] tbl_12et = let z = [(o,pc) | o <- [0..10], pc <- [0..11]] in map octpc_to_pitch_cps z -- | 24-tone equal temperament variant of 'tbl_12et'. -- -- > length tbl_24et == 264 -- > min_max (map (round . snd) tbl_24et) == (16,32535) tbl_24et :: [(Pitch,Double)] tbl_24et = let f x = let p = fmidi_to_pitch pc_spell_ks x p' = pitch_rewrite_threequarter_alteration p in (p',fmidi_to_cps x) in map f [12,12.5 .. 143.5] -- | Given an @ET@ table (or like) find bounds of frequency. -- -- > let r = Just (at_pair octpc_to_pitch_cps ((3,11),(4,0))) -- > in bounds_et_table tbl_12et 256 == r bounds_et_table :: Ord s => [(t,s)] -> s -> Maybe ((t,s),(t,s)) bounds_et_table tbl = let f (_,p) = compare p in find_bounds True f tbl -- | 'bounds_et_table' of 'tbl_12et'. -- -- > map bounds_12et_tone (hsn 17 55) bounds_12et_tone :: Double -> Maybe ((Pitch,Double),(Pitch,Double)) bounds_12et_tone = bounds_et_table tbl_12et -- | Tuple indicating nearest 'Pitch' to /frequency/ with @ET@ -- frequency, and deviation in hertz and 'Cents'. type HS_R p = (Double,p,Double,Double,Cents) -- | /n/-decimal places. -- -- > ndp 3 (1/3) == "0.333" ndp :: Int -> Double -> String ndp = printf "%.*f" -- | Pretty print 'HS_R'. hs_r_pp :: (p -> String) -> Int -> HS_R p -> [String] hs_r_pp pp n (f,p,pf,fd,c) = let dp = ndp n in [dp f ,pp p ,dp pf ,dp fd ,dp c] hs_r_pitch_pp :: Int -> HS_R Pitch -> [String] hs_r_pitch_pp = hs_r_pp pitch_pp -- | Form 'HS_R' for /frequency/ by consulting table. -- -- > let {f = 256 -- > ;f' = octpc_to_cps (4,0) -- > ;r = (f,Pitch C Natural 4,f',f-f',fratio_to_cents (f/f'))} -- > in nearest_et_table_tone tbl_12et 256 == r nearest_et_table_tone :: [(p,Double)] -> Double -> HS_R p nearest_et_table_tone tbl f = case bounds_et_table tbl f of Nothing -> error "nearest_et_table_tone: no bounds?" Just ((lp,lf),(rp,rf)) -> let ld = f - lf rd = f - rf in if abs ld < abs rd then (f,lp,lf,ld,fratio_to_cents (f/lf)) else (f,rp,rf,rd,fratio_to_cents (f/rf)) -- | 'nearest_et_table_tone' for 'tbl_12et'. nearest_12et_tone :: Double -> HS_R Pitch nearest_12et_tone = nearest_et_table_tone tbl_12et -- | 'nearest_et_table_tone' for 'tbl_24et'. -- -- > let r = "55.0 A1 55.0 0.0 0.0" -- > in unwords (hs_r_pitch_pp 1 (nearest_24et_tone 55)) == r nearest_24et_tone :: Double -> HS_R Pitch nearest_24et_tone = nearest_et_table_tone tbl_24et -- * 72ET -- | Monzo 72-edo HEWM notation. The domain is (-9,9). -- -- -- > let r = ["+",">","^","#<","#-","#","#+","#>","#^"] -- > in map alteration_72et_monzo [1 .. 9] == r -- -- > let r = ["-","<","v","b>","b+","b","b-","b<","bv"] -- > in map alteration_72et_monzo [-1,-2 .. -9] == r alteration_72et_monzo :: Integral n => n -> String alteration_72et_monzo n = let spl = splitOn "," asc = spl ",+,>,^,#<,#-,#,#+,#>,#^" dsc = spl ",-,<,v,b>,b+,b,b-,b<,bv" in case compare n 0 of LT -> genericIndex dsc (- n) EQ -> "" GT -> genericIndex asc n -- | Given a midi note number and @1/6@ deviation determine 'Pitch'' -- and frequency. -- -- > let {f = pitch'_pp . fst . pitch_72et -- > ;r = "C4 C+4 C>4 C^4 C#<4 C#-4 C#4 C#+4 C#>4 C#^4"} -- > in unwords (map f (zip (repeat 60) [0..9])) == r -- -- > let {f = pitch'_pp . fst . pitch_72et -- > ;r = "A4 A+4 A>4 A^4 Bb<4 Bb-4 Bb4 Bb+4 Bb>4 Bv4"} -- > in unwords (map f (zip (repeat 69) [0..9])) -- -- > let {f = pitch'_pp . fst . pitch_72et -- > ;r = "Bb4 Bb+4 Bb>4 Bv4 B<4 B-4 B4 B+4 B>4 B^4"} -- > in unwords (map f (zip (repeat 70) [0..9])) == r pitch_72et :: (Int,Int) -> (Pitch',Double) pitch_72et (x,n) = let p = midi_to_pitch pc_spell_ks x t = note p a = alteration p (t',n') = case a of Flat -> if n < (-3) then (pred t,n + 6) else (t,n - 6) Natural -> (t,n) Sharp -> if n > 3 then (succ t,n - 6) else (t,n + 6) _ -> error "pitch_72et: alteration?" a' = alteration_72et_monzo n' x' = fromIntegral x + (fromIntegral n / 6) r = (Pitch' t' (fromIntegral n' % 12,a') (octave p),fmidi_to_cps x') r' = if n > 3 then pitch_72et (x + 1,n - 6) else if n < (-3) then pitch_72et (x - 1,n + 6) else r in case a of Natural -> r' _ -> r -- | 72-tone equal temperament table equating 'Pitch'' and frequency -- over range of human hearing, where @A4@ = @440@hz. -- -- > length tbl_72et == 792 -- > min_max (map (round . snd) tbl_72et) == (16,33167) tbl_72et :: [(Pitch',Double)] tbl_72et = let f n = map pitch_72et (zip (replicate 6 n) [0..5]) in concatMap f [12 .. 143] -- | 'nearest_et_table_tone' for 'tbl_72et'. -- -- > let r = "324.0 E<4 323.3 0.7 3.5" -- > in unwords (hs_r_pp pitch'_pp 1 (nearest_72et_tone 324)) -- -- > let {f = take 2 . hs_r_pp pitch'_pp 1 . nearest_72et_tone . snd} -- > in mapM_ (print . unwords . f) tbl_72et nearest_72et_tone :: Double -> HS_R Pitch' nearest_72et_tone = nearest_et_table_tone tbl_72et -- * Detune -- | 'Pitch' with 12-ET/24-ET tuning deviation given in 'Cents'. type Pitch_Detune = (Pitch,Cents) -- | Exract 'Pitch_Detune' from 'HS_R'. hsr_to_pitch_detune :: HS_R Pitch -> Pitch_Detune hsr_to_pitch_detune (_,p,_,_,c) = (p,c) -- | Nearest 12-ET 'Pitch_Detune' to indicated frequency (hz). -- -- > nearest_pitch_detune_12et 452.8929841231365 nearest_pitch_detune_12et :: Double -> Pitch_Detune nearest_pitch_detune_12et = hsr_to_pitch_detune . nearest_12et_tone -- | Nearest 24-ET 'Pitch_Detune' to indicated frequency (hz). -- -- > nearest_pitch_detune_24et 452.8929841231365 nearest_pitch_detune_24et :: Double -> Pitch_Detune nearest_pitch_detune_24et = hsr_to_pitch_detune . nearest_24et_tone -- | Given /near/ function, /f0/ and ratio derive 'Pitch_Detune'. ratio_to_pitch_detune :: (Double -> HS_R Pitch) -> OctPC -> Rational -> Pitch_Detune ratio_to_pitch_detune near_f f0 r = let f = octpc_to_cps f0 * realToFrac r (_,p,_,_,c) = near_f f in (p,c) -- | Frequency (hz) of 'Pitch_Detune'. -- -- > pitch_detune_to_cps (octpc_to_pitch pc_spell_ks (4,9),50) pitch_detune_to_cps :: Floating n => Pitch_Detune -> n pitch_detune_to_cps (p,d) = cps_shift_cents (pitch_to_cps p) (realToFrac d) -- | 'ratio_to_pitch_detune' of 'nearest_12et_tone' ratio_to_pitch_detune_12et :: OctPC -> Rational -> Pitch_Detune ratio_to_pitch_detune_12et = ratio_to_pitch_detune nearest_12et_tone -- | 'ratio_to_pitch_detune' of 'nearest_24et_tone' ratio_to_pitch_detune_24et :: OctPC -> Rational -> Pitch_Detune ratio_to_pitch_detune_24et = ratio_to_pitch_detune nearest_24et_tone pitch_detune_in_octave_nearest :: Pitch -> Pitch_Detune -> Pitch_Detune pitch_detune_in_octave_nearest p1 (p2,d2) = let p2' = pitch_in_octave_nearest p1 p2 in (p2',d2) -- | Markdown pretty-printer for 'Pitch_Detune'. pitch_detune_md :: Pitch_Detune -> String pitch_detune_md (p,c) = pitch_pp p ++ cents_diff_md (round c :: Integer) -- | HTML pretty-printer for 'Pitch_Detune'. pitch_detune_html :: Pitch_Detune -> String pitch_detune_html (p,c) = pitch_pp p ++ cents_diff_html (round c :: Integer) -- | No-octave variant of 'pitch_detune_md'. pitch_class_detune_md :: Pitch_Detune -> String pitch_class_detune_md (p,c) = pitch_class_pp p ++ cents_diff_md (round c :: Integer) -- | No-octave variant of 'pitch_detune_html'. pitch_class_detune_html :: Pitch_Detune -> String pitch_class_detune_html (p,c) = pitch_class_pp p ++ cents_diff_html (round c :: Integer) hmt-0.15/Music/Theory/Tuning/Polansky_1990.hs0000644000000000000000000000403412416136065017036 0ustar0000000000000000-- | Larry Polansky. \"Notes on the Tunings of Three Central Javanese -- Slendro\/Pelog Pairs\". /Experimental Musical Instruments/, -- 6(2):12-13,16-17, 1990. module Music.Theory.Tuning.Polansky_1990 where import Data.Ratio import qualified Music.Theory.List as L import qualified Music.Theory.Tuning as T -- | Kanjutmesem Slendro (S1,S2,S3,S5,S6,S1') -- -- > L.d_dx kanjutmesem_s == [252,238,241,236,253] kanjutmesem_s :: Num n => [n] kanjutmesem_s = [0,252,490,731,967,1220] -- | Kanjutmesem Pelog (P1,P2,P3,P4,P5,P6,P7,P1') -- -- > L.d_dx kanjutmesem_p == [141,141,272,140,115,172,246] kanjutmesem_p :: Num n => [n] kanjutmesem_p = [37,178,319,591,731,846,1018,1264] -- | Darius Slendro (S1,S2,S3,S5,S6,S1') -- -- > L.d_dx darius_s == [204,231,267,231,267] -- > ax_r darius_s == [9/8,8/7,7/6,8/7,7/6] darius_s :: Num n => [n] darius_s = [0,204,435,702,933,1200] -- | Madeleine Pelog (P1,P2,P3,P4,P5,P6,P7,P1') -- -- > L.d_dx madeleine_p == [139,128,336,99,94,173,231] -- > ax_r madeleine_p == [13/12,14/13,17/14,18/17,19/18,21/19,8/7] madeleine_p :: Num n => [n] madeleine_p = [137,276,404,740,839,933,1106,1337] -- | Lipur Sih Slendro (S1,S2,S3,S5,S6,S1') -- -- > L.d_dx lipur_sih_s == [273,236,224,258,256] lipur_sih_s :: Num n => [n] lipur_sih_s = [0,273,509,733,991,1247] -- | Lipur Sih Pelog (P1,P2,P3,P4,P5,P6,P7,P1') -- -- > L.d_dx lipur_sih_p == [110,153,253,146,113,179] lipur_sih_p :: Num n => [n] lipur_sih_p = [216,326,479,732,878,991,1170] -- | Idealized ET Slendro, 5-tone equal temperament (p.17) -- -- > L.d_dx idealized_et_s == [240,240,240,240,240] idealized_et_s :: Num n => [n] idealized_et_s = [0,240,480,720,960,1200] -- | Idealized ET Pelog, subset of 9-tone equal temperament (p.17) -- -- > L.d_dx idealized_et_p == [400/3,800/3,400/3,400/3,400/3,400/3,800/3] idealized_et_p :: Integral n => [Ratio n] idealized_et_p = [160,293+1/3,560,693+1/3,826+2/3,960,1093+1/3,1360] -- | Reconstruct approximate ratios to within @1e-3@ from intervals. ax_r :: Real n => [n] -> [Rational] ax_r = map (T.reconstructed_ratio 1e-3 . realToFrac) . L.d_dx hmt-0.15/Music/Theory/Tuning/Polansky_1985c.hs0000644000000000000000000000261512416136065017210 0ustar0000000000000000-- | Larry Polansky. "Notes on Piano Study #5". -- _1/1, The Journal of the Just Intonation Newtork_, 1(4), Autumn 1985. module Music.Theory.Tuning.Polansky_1985c where import Music.Theory.Tuning {- hmt -} -- | The tuning has four octaves, these ratios are per-octave. ps5_jpr_r :: [[Rational]] ps5_jpr_r = [[1/1, 21/20, 9/8, 6/5, 5/4, 4/3, 7/5, 3/2, 8/5, 5/3, 7/4, 15/8] ,[1/1, 21/20, 9/8, 6/5, 5/4, 4/3, 7/5, 3/2, 8/5, 5/3, 7/4, 15/8] ,[1/1, 33/32, 9/8, 6/5, 5/4, 21/16, 11/8, 3/2, 8/5, 13/8, 7/4, 15/8] ,[1/1, 21/20, 9/8, 7/6, 5/4, 4/3, 11/8, 3/2, 8/5, 27/16, 7/4, 15/8]] {- | Four-octave tuning. > import Data.List.Split > let r = [[ 0, 84, 204, 316, 386, 498, 583, 702, 814, 884, 969,1088] > ,[1200,1284,1404,1516,1586,1698,1783,1902,2014,2084,2169,2288] > ,[2400,2453,2604,2716,2786,2871,2951,3102,3214,3241,3369,3488] > ,[3600,3684,3804,3867,3986,4098,4151,4302,4414,4506,4569,4688]] > in chunksOf 12 (cents_i ps5_jpr) == r > let r = [[0,84,204,316,386,498,583,702,814,884,969,1088] > ,[0,84,204,316,386,498,583,702,814,884,969,1088] > ,[0,53,204,316,386,471,551,702,814,841,969,1088] > ,[0,84,204,267,386,498,551,702,814,906,969,1088]] > chunksOf 12 (map (`mod` 1200) (cents_i ps5_jpr)) -} ps5_jpr :: Tuning ps5_jpr = let f (m,n) = map (* m) n r = concat (map f (zip [1,2,4,8] ps5_jpr_r)) in Tuning (Left r) 16 hmt-0.15/Music/Theory/Tuning/Alves_1997.hs0000644000000000000000000000306012416136065016315 0ustar0000000000000000-- | Bill Alves. \"Pleng: Composing for a Justly Tuned Gender -- Barung\". 1/1: Journal of the Just Intonation Network, 1:4-11, Spring -- 1997. module Music.Theory.Tuning.Alves_1997 where import Music.Theory.Tuning -- > let c = [0,231,498,765,996] -- > in map (round.to_cents_r) alves_slendro_r == c alves_slendro_r :: [Rational] alves_slendro_r = [1,8/7,4/3,14/9,16/9] -- | HMC /slendro/ tuning. -- -- > cents_i alves_slendro == [0,231,498,765,996] alves_slendro :: Tuning alves_slendro = Tuning (Left alves_slendro_r) 2 -- > let c = [0,231,316,702,814] -- > in map (round.to_cents_r) alves_pelog_bem_r == c alves_pelog_bem_r :: [Rational] alves_pelog_bem_r = [1,8/7,6/5,3/2,8/5] -- | HMC /pelog bem/ tuning. -- -- > cents_i alves_pelog_bem == [0,231,316,702,814] alves_pelog_bem :: Tuning alves_pelog_bem = Tuning (Left alves_pelog_bem_r) 2 -- > let c = [0,386,471,857,969] -- > in map (round.to_cents_r) alves_pelog_barang_r == c alves_pelog_barang_r :: [Rational] alves_pelog_barang_r = [1,5/4,21/16,105/64,7/4] -- | HMC /pelog 2,3,4,6,7/ tuning. -- -- > cents_i alves_pelog_barang == [0,386,471,857,969] alves_pelog_barang :: Tuning alves_pelog_barang = Tuning (Left alves_pelog_barang_r) 2 -- > let c = [0,386,471,702,969] -- > in map (round.to_cents_r) alves_pelog_23467 == c alves_pelog_23467_r :: [Rational] alves_pelog_23467_r = [1,5/4,21/16,3/2,7/4] -- | HMC /pelog barang/ tuning. -- -- > cents_i alves_pelog_23467 == [0,386,471,702,969] alves_pelog_23467 :: Tuning alves_pelog_23467 = Tuning (Left alves_pelog_23467_r) 2 hmt-0.15/Music/Theory/Tuning/Syntonic.hs0000644000000000000000000000413312416136065016362 0ustar0000000000000000-- | Syntonic tuning. module Music.Theory.Tuning.Syntonic where import Data.List {- base -} import Music.Theory.Tuning {- hmt -} -- | 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 (mk_seq n_col (-1,2)) left -- | A minimal isomorphic note layout. -- -- > let [i,j,k] = mk_isomorphic_layout 3 5 (3,-4) -- > in [i,take 4 j,(2,-4):take 4 k] == minimal_isomorphic_note_layout minimal_isomorphic_note_layout :: [[(Int,Int)]] minimal_isomorphic_note_layout = [[(3,-4),(2,-2),(1,0),(0,2),(-1,4)] ,[(2,-3),(1,-1),(0,1),(-1,3)] ,[(2,-4),(1,-2),(0,0),(-1,2),(-2,4)]] -- | Make a rank two regular temperament from a list of /(i,j)/ -- positions by applying the scalars /a/ and /b/. rank_two_regular_temperament :: Integral a => a -> a -> [(a,a)] -> [a] 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@. -- -- > divisions syntonic_697 == 17 -- -- > let c = [0,79,194,273,309,388,467,503,582,697,776,812,891,970,1006,1085,1164] -- > in cents_i syntonic_697 == c syntonic_697 :: Tuning syntonic_697 = Tuning (Right (mk_syntonic_tuning 697)) 2 -- | 'mk_syntonic_tuning' of @702@. -- -- > divisions syntonic_702 == 17 -- -- > let c = [0,24,114,204,294,318,408,498,522,612,702,792,816,906,996,1020,1110] -- > in cents_i syntonic_702 == c syntonic_702 :: Tuning syntonic_702 = Tuning (Right (mk_syntonic_tuning 702)) 2 hmt-0.15/Music/Theory/Tuning/Scala.hs0000644000000000000000000001456512416136065015611 0ustar0000000000000000-- | Parser for the Scala scale file format. See -- for details. -- This module succesfully parses all 4496 scales in v.81 of the scale -- library. module Music.Theory.Tuning.Scala where import qualified Codec.Binary.UTF8.String as U {- utf8-string -} import qualified Data.ByteString as B {- bytestring -} import Data.List import Data.Ratio import qualified Music.Theory.Tuning as T import System.Directory {- directory -} import System.FilePath {- filepath -} -- | A @.scl@ pitch is either in 'Cents' or is a 'Ratio'. type Pitch i = Either T.Cents (Ratio i) -- | A scale has a description, a degree, and a list of 'Pitch'es. type Scale i = (String,i,[Pitch i]) -- | Text description of scale. scale_description :: Scale i -> String scale_description (d,_,_) = d -- | The degree of the scale (number of 'Pitch'es). scale_degree :: Scale i -> i scale_degree (_,n,_) = n -- | The 'Pitch'es at 'Scale'. scale_pitches :: Scale i -> [Pitch i] scale_pitches (_,_,p) = p -- | The last 'Pitch' element of the scale (ie. the /ocatve/). scale_octave :: Scale i -> Maybe (Pitch i) scale_octave (_,_,s) = case s of [] -> Nothing _ -> Just (last s) -- | Is 'scale_octave' perfect, ie. 'Ratio' of @2@ or 'Cents' of -- @1200@. perfect_octave :: Integral i => Scale i -> Bool perfect_octave s = scale_octave s `elem` [Just (Right 2),Just (Left 1200)] -- | A pair giving the number of 'Cents' and number of 'Ratio' pitches -- at 'Scale'. scale_pitch_representations :: (Integral t) => Scale i -> (t,t) scale_pitch_representations s = let f (l,r) p = case p of Left _ -> (l + 1,r) Right _ -> (l,r + 1) in foldl f (0,0) (scale_pitches s) -- | Pitch as 'T.Cents', conversion by 'T.to_cents_r' if necessary. pitch_cents :: Pitch Integer -> T.Cents pitch_cents p = case p of Left c -> c Right r -> T.ratio_to_cents r type Epsilon = Double -- | Pitch as 'Rational', conversion by 'T.reconstructed_ratio' if -- necessary, hence /epsilon/. pitch_ratio :: Epsilon -> Pitch Integer -> Rational pitch_ratio epsilon p = case p of Left c -> T.reconstructed_ratio epsilon c Right r -> r -- | Make scale pitches uniform, conforming to the most promininent -- pitch type. scale_uniform :: Epsilon -> Scale Integer -> Scale Integer scale_uniform epsilon s = let (d,n,p) = s (c,r) = scale_pitch_representations s :: (Int,Int) in if c >= r then (d,n,map (Left . pitch_cents) p) else (d,n,map (Right . pitch_ratio epsilon) p) -- | Scale as list of 'T.Cents' (ie. 'pitch_cents') with @0@ prefix. scale_cents :: Scale Integer -> [T.Cents] scale_cents s = 0 : map pitch_cents (scale_pitches s) -- | Scale as list of 'Rational' (ie. 'pitch_ratio') with @1@ prefix. scale_ratios :: Epsilon -> Scale Integer -> [Rational] scale_ratios epsilon s = 1 : map (pitch_ratio epsilon) (scale_pitches s) -- | Comment lines being with @!@. comment_p :: String -> Bool comment_p x = case x of '!':_ -> True _ -> False -- | Remove @\r@. filter_cr :: String -> String filter_cr = filter (not . (==) '\r') -- | Logical /or/ of list of predicates. p_or :: [a -> Bool] -> a -> Bool p_or p x = case p of [] -> False f:p' -> f x || p_or p' x -- | Remove to end of line @!@ comments. remove_eol_comments :: String -> String remove_eol_comments = takeWhile (/= '!') -- | Remove comments and null lines. -- -- > filter_comments ["!a","b","","c"] == ["b","c"] filter_comments :: [String] -> [String] filter_comments = map remove_eol_comments . filter (not . p_or [comment_p,null]) -- | Delete trailing @.@, 'read' fails for @700.@. delete_trailing_point :: String -> String delete_trailing_point s = case reverse s of '.':s' -> reverse s' _ -> s -- | Pitches are either cents (with decimal point) or ratios (with @/@). -- -- > map pitch ["700.0","3/2","2"] == [Left 700,Right (3/2),Right 2] pitch :: (Read i,Integral i) => String -> Pitch i pitch p = if '.' `elem` p then Left (read (delete_trailing_point p)) else case break (== '/') p of (n,'/':d) -> Right (read n % read d) _ -> Right (read p % 1) -- | Pitch lines may contain commentary. pitch_ln :: (Read i, Integral i) => String -> Pitch i pitch_ln x = case words x of p:_ -> pitch p _ -> error (show ("pitch",words x)) -- | Parse @.scl@ file. parse :: (Read i, Integral i) => String -> Scale i parse s = case filter_comments (lines (filter_cr s)) of t:n:p -> (t,read n,map pitch_ln p) _ -> error "parse" -- | Load @.scl@ file. -- -- > s <- load "/home/rohan/data/scala/81/scl/xenakis_chrom.scl" -- > scale_pitch_representations s == (6,1) -- > scale_ratios 1e-3 s == [1,21/20,29/23,179/134,280/187,11/7,100/53,2] load :: (Read i, Integral i) => FilePath -> IO (Scale i) load fn = do b <- B.readFile fn let s = U.decode (B.unpack b) return (parse s) -- | Subset of files in /dir/ with an extension in /ext/. dir_subset :: [String] -> FilePath -> IO [FilePath] dir_subset ext dir = do let f nm = takeExtension nm `elem` ext c <- getDirectoryContents dir return (map (dir ) (sort (filter f c))) -- | Load all @.scl@ files at /dir/. -- -- > db <- load_dir "/home/rohan/data/scala/81/scl" -- > length db == 4496 -- > length (filter ((== 0) . scale_degree) db) == 0 -- > length (filter (== Just (Right 2)) (map scale_octave db)) == 3855 -- -- > let r = [2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24 -- > ,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44 -- > ,45,46,47,48,49,50,51,53,54,55,56,57,58,59,60,61,62,63,64 -- > ,65,66,67,68,69,70,71,72,74,75,77,78,79,80,81,84,87,88 -- > ,90,91,92,95,96,99,100,101,105,110,112,117,118,130,140,171 -- > ,180,271,311,342,366,441,612] -- > in nub (sort (map scale_degree db)) == r -- -- > let r = ["Xenakis's Byzantine Liturgical mode, 5 + 19 + 6 parts" -- > ,"Xenakis's Byzantine Liturgical mode, 12 + 11 + 7 parts" -- > ,"Xenakis's Byzantine Liturgical mode, 7 + 16 + 7 parts"] -- > in filter (isInfixOf "Xenakis") (map scale_description db) == r -- -- > length (filter (not . perfect_octave) db) == 544 -- -- > mapM_ (putStrLn.scale_description) (filter (not . perfect_octave) db) load_dir :: (Read i, Integral i) => FilePath -> IO [Scale i] load_dir d = dir_subset [".scl"] d >>= mapM load -- Local Variables: -- truncate-lines:t -- End: hmt-0.15/Music/Theory/Tuning/Gann.hs0000644000000000000000000001001512416136065015433 0ustar0000000000000000-- | Kyle Gann. module Music.Theory.Tuning.Gann where import Music.Theory.Tuning {- hmt -} -- * Historical -- | Cents for 'pietro_aaron_1523'. -- -- > let c = [0,76,193,310,386,503,580,697,773,890,1007,1083] -- > in map round pietro_aaron_1523_c == c pietro_aaron_1523_c :: [Cents] pietro_aaron_1523_c = [0,76.0 ,193.2,310.3 ,386.3 ,503.4,579.5 ,696.8,772.6 ,889.7,1006.8 ,1082.9] -- | Pietro Aaron (1523) meantone temperament, see -- -- -- > cents_i pietro_aaron_1523 == [0,76,193,310,386,503,580,697,773,890,1007,1083] pietro_aaron_1523 :: Tuning pietro_aaron_1523 = Tuning (Right pietro_aaron_1523_c) 2 -- | Andreas Werckmeister (1645-1706), . werckmeister_iii_c :: [Cents] werckmeister_iii_c = [0,90.225 ,192.18,294.135 ,390.225 ,498.045,588.27 ,696.09,792.18 ,888.27,996.09 ,1092.18] -- | Cents for 'thomas_young_1799'. -- -- > let c = [0,94,196,298,392,500,592,698,796,894,1000,1092] -- > in map round thomas_young_1799_c == c thomas_young_1799_c :: [Cents] thomas_young_1799_c = [0,93.9 ,195.8,297.8 ,391.7 ,499.9,591.9 ,697.9,795.8 ,893.8,999.8 ,1091.8] -- | Thomas Young (1799), Well Temperament, . -- -- > cents_i thomas_young_1799 == [0,94,196,298,392,500,592,698,796,894,1000,1092] thomas_young_1799 :: Tuning thomas_young_1799 = Tuning (Right thomas_young_1799_c) 2 -- | Ratios for 'zarlino'. zarlino_r :: [Rational] zarlino_r = [1/1,25/24,10/9,9/8,32/27,6/5,5/4,4/3,25/18,45/32,3/2,25/16,5/3,16/9,9/5,15/8] -- | Gioseffo Zarlino, 1588, see . -- -- > divisions zarlino == 16 -- > cents_i zarlino == [0,71,182,204,294,316,386,498,569,590,702,773,884,996,1018,1088] zarlino :: Tuning zarlino = Tuning (Left zarlino_r) 2 -- * 20th Century -- | Ratios for 'la_monte_young'. -- -- > let c = [0,177,204,240,471,444,675,702,738,969,942,1173] -- > in map (round . ratio_to_cents) la_monte_young_r == c la_monte_young_r :: [Rational] la_monte_young_r = [1,567/512 ,9/8,147/128 ,21/16 ,1323/1024,189/128 ,3/2,49/32 ,7/4,441/256 ,63/32] -- | La Monte Young's \"The Well-Tuned Piano\", see -- . -- -- > cents_i la_monte_young == [0,177,204,240,471,444,675,702,738,969,942,1173] la_monte_young :: Tuning la_monte_young = Tuning (Left la_monte_young_r) 2 -- | Ratios for 'ben_johnston'. -- -- > let c = [0,105,204,298,386,471,551,702,841,906,969,1088] -- > in map (round . ratio_to_cents) ben_johnston_r == c ben_johnston_r :: [Rational] ben_johnston_r = [1,17/16 ,9/8,19/16 ,5/4 ,21/16,11/8 ,3/2,13/8 ,27/16,7/4 ,15/8] -- | Ben Johnston's \"Suite for Microtonal Piano\" (1977), see -- -- -- > cents_i ben_johnston == [0,105,204,298,386,471,551,702,841,906,969,1088] ben_johnston :: Tuning ben_johnston = Tuning (Left ben_johnston_r) 2 -- * Gann -- | Ratios for 'gann_arcana_xvi'. gann_arcana_xvi_r :: [Rational] gann_arcana_xvi_r = [1/1,21/20,16/15,9/8,7/6,6/5,11/9,5/4,21/16,4/3,27/20,7/5 ,22/15,3/2,55/36,8/5,44/27,5/3,42/25,7/4,9/5,11/6,15/8,88/45] -- | Kyle Gann, _Arcana XVI_, see . -- -- > let r = [0,84,112,204,267,316,347,386,471,498,520,583,663,702,734,814,845,884,898,969,1018,1049,1088,1161] -- > in cents_i gann_arcana_xvi == r gann_arcana_xvi :: Tuning gann_arcana_xvi = Tuning (Left gann_arcana_xvi_r) 2 -- | Ratios for 'gann_superparticular'. gann_superparticular_r :: [Rational] gann_superparticular_r = [1/1,11/10,10/9,9/8,8/7,7/6,6/5,5/4,9/7,4/3,11/8,7/5,10/7,3/2,11/7,14/9,8/5,5/3,12/7,7/4,16/9,9/5] -- | Kyle Gann, _Superparticular_, see . -- -- > divisions gann_superparticular == 22 -- -- > let r = [0,165,182,204,231,267,316,386,435,498,551,583,617,702,782,765,814,884,933,969,996,1018] -- > in cents_i gann_superparticular == r gann_superparticular :: Tuning gann_superparticular = Tuning (Left gann_superparticular_r) 2 hmt-0.15/Music/Theory/Tuning/Alves.hs0000644000000000000000000000127712416136065015634 0ustar0000000000000000-- | Bill Alves. module Music.Theory.Tuning.Alves where import Music.Theory.Tuning {- hmt -} -- | Ratios for 'harrison_ditone'. -- -- > let c = [0,114,204,294,408,498,612,702,816,906,996,1110] -- > in map (round . ratio_to_cents) harrison_ditone_r == c harrison_ditone_r :: [Rational] harrison_ditone_r = [1,2187/2048 {- 256/243 -} ,9/8,32/27 ,81/64 ,4/3,729/512 ,3/2,6561/4096 {- 128/81 -} ,27/16,16/9 ,243/128] -- | Ditone/pythagorean tuning, -- see -- -- > cents_i harrison_ditone == [0,114,204,294,408,498,612,702,816,906,996,1110] harrison_ditone :: Tuning harrison_ditone = Tuning (Left harrison_ditone_r) 2 hmt-0.15/Music/Theory/Tuning/Riley.hs0000644000000000000000000000116712416136065015644 0ustar0000000000000000-- | Terry Riley. module Music.Theory.Tuning.Riley where import Music.Theory.Tuning {- hmt -} -- | Ratios for 'riley_albion'. -- -- > let r = [0,112,204,316,386,498,610,702,814,884,996,1088] -- > in map (round . ratio_to_cents) riley_albion_r == r riley_albion_r :: [Rational] riley_albion_r = [1/1,16/15,9/8,6/5,5/4,4/3,64/45,3/2,8/5,5/3,16/9,15/8] -- | Riley's five-limit tuning as used in _The Harp of New Albion_, -- see . -- -- > cents_i riley_albion == [0,112,204,316,386,498,610,702,814,884,996,1088] riley_albion :: Tuning riley_albion = Tuning (Left riley_albion_r) 2 hmt-0.15/Music/Theory/Tuning/Microtonal_Synthesis.hs0000644000000000000000000001411312416136065020733 0ustar0000000000000000-- | module Music.Theory.Tuning.Microtonal_Synthesis where import Music.Theory.Tuning {- hmt -} -- | Ratios for 'pythagorean'. -- -- > let c = [0,90,204,294,408,498,612,702,792,906,996,1110] -- > in map (round . ratio_to_cents) pythagorean_r == c pythagorean_r :: [Rational] pythagorean_r = [1,256/243 {- 2187/2048 -} ,9/8,32/27 ,81/64 ,4/3,729/512 ,3/2,128/81 {- 6561/4096 -} ,27/16,16/9 ,243/128] -- | Pythagorean tuning, . -- -- > divisions pythagorean == 12 -- > cents_i pythagorean == [0,90,204,294,408,498,612,702,792,906,996,1110] pythagorean :: Tuning pythagorean = Tuning (Left pythagorean_r) 2 -- | Ratios for 'five_limit_tuning'. -- -- > let c = [0,112,204,316,386,498,590,702,814,884,996,1088] -- > in map (round . ratio_to_cents) five_limit_tuning_r == c five_limit_tuning_r :: [Rational] five_limit_tuning_r = [1,16/15 ,9/8,6/5 ,5/4 ,4/3,45/32 {- 64/45 -} ,3/2,8/5 ,5/3,16/9 {- 9/5 -} ,15/8] -- | Five-limit tuning (five limit just intonation). -- -- > cents_i five_limit_tuning == [0,112,204,316,386,498,590,702,814,884,996,1088] five_limit_tuning :: Tuning five_limit_tuning = Tuning (Left five_limit_tuning_r) 2 -- | Ratios for 'septimal_tritone_just_intonation'. -- -- > let c = [0,112,204,316,386,498,583,702,814,884,1018,1088] -- > in map (round . ratio_to_cents) septimal_tritone_just_intonation == c septimal_tritone_just_intonation_r :: [Rational] septimal_tritone_just_intonation_r = [1,16/15 ,9/8,6/5 ,5/4 ,4/3,7/5 ,3/2,8/5 ,5/3,9/5 ,15/8] -- | Septimal tritone Just Intonation, see -- -- -- > cents_i septimal_tritone_just_intonation == [0,112,204,316,386,498,583,702,814,884,1018,1088] septimal_tritone_just_intonation :: Tuning septimal_tritone_just_intonation = Tuning (Left septimal_tritone_just_intonation_r) 2 -- | Ratios for 'seven_limit_just_intonation'. -- -- > let c = [0,112,204,316,386,498,583,702,814,884,969,1088] -- > in map (round . ratio_to_cents) seven_limit_just_intonation == c seven_limit_just_intonation_r :: [Rational] seven_limit_just_intonation_r = [1,16/15 ,9/8,6/5 ,5/4 ,4/3,7/5 ,3/2,8/5 ,5/3,7/4 ,15/8] -- | Seven limit Just Intonation. -- -- > cents_i seven_limit_just_intonation == [0,112,204,316,386,498,583,702,814,884,969,1088] seven_limit_just_intonation :: Tuning seven_limit_just_intonation = Tuning (Left seven_limit_just_intonation_r) 2 -- | Approximate ratios for 'kirnberger_iii'. -- -- > let c = [0,90,193,294,386,498,590,697,792,890,996,1088] -- > in map (round.to_cents) kirnberger_iii_ar == c kirnberger_iii_ar :: [Approximate_Ratio] kirnberger_iii_ar = [1,256/243 ,sqrt 5 / 2,32/27 ,5/4 ,4/3,45/32 ,5 ** 0.25,128/81 ,(5 ** 0.75)/2,16/9 ,15/8] -- | . -- -- > cents_i kirnberger_iii == [0,90,193,294,386,498,590,697,792,890,996,1088] kirnberger_iii :: Tuning kirnberger_iii = Tuning (Right (map approximate_ratio_to_cents kirnberger_iii_ar)) 2 -- > let c = [0,94,196,298,392,502,592,698,796,894,1000,1090] -- > in map round vallotti_c == c vallotti_c :: [Cents] vallotti_c = [0.0,94.135 ,196.09,298.045 ,392.18 ,501.955,592.18 ,698.045,796.09 ,894.135,1000.0 ,1090.225] -- | Vallotti & Young scale (Vallotti version), see -- . -- -- > cents_i vallotti == [0,94,196,298,392,502,592,698,796,894,1000,1090] vallotti :: Tuning vallotti = Tuning (Right vallotti_c) 2 -- > let c = [0,128,139,359,454,563,637,746,841,911,1072,1183] -- > in map (round . ratio_to_cents) mayumi_reinhard == c mayumi_reinhard_r :: [Rational] mayumi_reinhard_r = [1,14/13 ,13/12,16/13 ,13/10 ,18/13,13/9 ,20/13,13/8 ,22/13,13/7 ,208/105] -- | Mayumi Reinhard 13-limit Just Intonation scale, -- . -- -- > cents_i mayumi_reinhard == [0,128,139,359,454,563,637,746,841,911,1072,1183] mayumi_reinhard :: Tuning mayumi_reinhard = Tuning (Left mayumi_reinhard_r) 2 -- | Ratios for 'lou_harrison_16'. -- -- > length lou_harrison_16_r == 16 -- -- > let c = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088] -- > in map (round . ratio_to_cents) lou_harrison_16_r == c lou_harrison_16_r :: [Rational] lou_harrison_16_r = [1,16/15 ,10/9,8/7 ,7/6,6/5,5/4 ,4/3 ,17/12 ,3/2 ,8/5,5/3,12/7 ,7/4,9/5,15/8] -- | Lou Harrison 16 tone Just Intonation scale, see -- -- -- > let r = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088] -- > in cents_i lou_harrison_16 == r lou_harrison_16 :: Tuning lou_harrison_16 = Tuning (Left lou_harrison_16_r) 2 -- | Ratios for 'partch_43'. partch_43_r :: [Rational] partch_43_r = [1,81/80,33/32,21/20,16/15,12/11,11/10,10/9,9/8,8/7 ,7/6,32/27,6/5,11/9,5/4,14/11,9/7 ,21/16,4/3,27/20 ,11/8,7/5,10/7,16/11 ,40/27,3/2,32/21,14/9,11/7,8/5,18/11,5/3,27/16,12/7 ,7/4,16/9,9/5,20/11,11/6,15/8,40/21,64/33,160/81] -- | Harry Partch 43 tone scale, see -- -- -- > cents_i partch_43 == [0,22,53,84,112,151,165 -- > ,182,204,231,267,294,316 -- > ,347,386,418,435 -- > ,471,498,520,551,583,617,649 -- > ,680,702,729,765,782,814,853,884,906,933 -- > ,969,996,1018,1035,1049,1088,1116,1147,1178] partch_43 :: Tuning partch_43 = Tuning (Left partch_43_r) 2 -- | Ratios for 'ben_johnston_25'. ben_johnston_25_r :: [Rational] ben_johnston_25_r = [1/1,25/24,135/128,16/15,10/9 ,9/8,75/64,6/5,5/4,81/64 ,32/25,4/3,27/20,45/32,36/25 ,3/2,25/16,8/5,5/3,27/16 ,225/128,16/9,9/5,15/8,48/25] -- | Ben Johnston 25 note just enharmonic scale, see -- ben_johnston_25 :: Tuning ben_johnston_25 = Tuning (Left ben_johnston_25_r) 2 hmt-0.15/Music/Theory/Tuning/Polansky_1984.hs0000644000000000000000000001063412416136065017044 0ustar0000000000000000-- | Larry Polansky. \"Tuning Systems in American Gamelan, Part I: -- Interval Sizes in Javanese Slendro\". /Balungan/, 1(2):9-11, 1984 module Music.Theory.Tuning.Polansky_1984 where import Data.List import Music.Theory.Tuning k_manisrenga :: Fractional n => [n] k_manisrenga = [219.5,266.5,227,233.5,258.5] k_kanjutmesem :: Fractional n => [n] k_kanjutmesem = [224,253.5,237.5,232.5,264] k_udanriris :: Fractional n => [n] k_udanriris = [255.5,256.5,223.5,235.5,234] k_pengawesari :: Fractional n => [n] k_pengawesari = [251.5,233.5,233.5,236,250] k_rarasrum :: Fractional n => [n] k_rarasrum = [229.5,227.5,253,232,261.5] k_hardjanagara :: Fractional n => [n] k_hardjanagara = [216,249.5,216,262,261.5] k_madukentir :: Fractional n => [n] k_madukentir = [268.5,242,243,230,221] k_surak :: Fractional n => [n] k_surak = [206,231.5,238.5,265,264.5] -- | The set of /K/ slendro tunings. -- -- > map length k_set == replicate (length k_set) 5 -- > minimum (concat k_set) == 206 -- > maximum (concat k_set) == 268.5 k_set :: Fractional n => [[n]] k_set = [k_manisrenga ,k_kanjutmesem ,k_udanriris ,k_pengawesari ,k_rarasrum ,k_hardjanagara ,k_madukentir ,k_surak] -- | Given a set of equal length lists calculate the average value of -- each position. -- -- > calculate_averages [[1,2,3],[3,2,1]] == [2,2,2] calculate_averages :: Fractional n => [[n]] -> [n] calculate_averages set = let n = fromIntegral (length set) z = map sum (transpose set) in map (/ n) z -- | Averages of /K/ set, p. 10. -- -- > k_averages == [233.8125,245.0625,234.0,240.8125,251.875] k_averages :: Fractional n => [n] k_averages = calculate_averages k_set gm_1,gm_2,gm_3,gm_4,gm_5,gm_6,gm_7,gm_8 :: Fractional n => [n] gm_1 = [237,251,248,242,258] gm_2 = [252,239,242,236.5,253.5] gm_3 = [237,238.5,232.5,262,238] gm_4 = [226,252,260,234,256] gm_5 = [232,239,248,232,259.5] gm_6 = [218,238.5,244.5,244.5,260] gm_7 = [238,230,257,243,250.5] gm_8 = [232,234,249,251,257] -- | The set of /GM/ (Gadja Mada University) slendro tunings. -- -- > map length gm_set == replicate (length gm_set) 5 -- > minimum (concat gm_set) == 218 -- > maximum (concat gm_set) == 262 gm_set :: Fractional n => [[n]] gm_set = [gm_1,gm_2,gm_3,gm_4,gm_5,gm_6,gm_7,gm_8] -- | Averages of /GM/ set, p. 10. -- -- > gm_averages == [234.0,240.25,247.625,243.125,254.0625] gm_averages :: Fractional n => [n] gm_averages = calculate_averages gm_set -- | Association list giving interval boundaries for interval class -- categories (pp.10-11). i_categories :: Num n => [((n,n),String)] i_categories = [((206,238),"S") ,((238,240),"S-E") ,((240,248),"E") ,((248,250),"E-L") ,((250,269),"L")] -- | Categorise an interval. i_category :: (Ord a, Num a) => a -> String i_category x = let f n (i,j) = i <= n && n < j in maybe "U" snd (find (f x . fst) i_categories) -- | Pad 'String' to right with spaces until at least /n/ characters. -- -- > map (pad 3) ["S","E-L"] == ["S ","E-L"] pad :: Int -> String -> String pad n s = s ++ replicate (n - length s) ' ' -- | Pretty interval category table (pp. 10-11). -- -- > i_category_table k_set == -- > ["S L S S L " -- > ,"S L S S L " -- > ,"L L S S S " -- > ,"L S S S L " -- > ,"S S L S L " -- > ,"S E-L S L L " -- > ,"L E E S S " -- > ,"S S S-E L L "] -- -- > i_category_table gm_set == -- > ["S L E-L E L " -- > ,"L S-E E S L " -- > ,"S S-E S L S-E" -- > ,"S L L S L " -- > ,"S S-E E-L S L " -- > ,"S S-E E E L " -- > ,"S-E S L E L " -- > ,"S S E-L L L "] i_category_table :: (Ord a, Num a) => [[a]] -> [String] i_category_table = map (intercalate " " . map (pad 3 . i_category)) -- | Rational tuning derived from 'gm_averages', p.11. -- -- > polansky_1984_r == sort polansky_1984_r -- > polansky_1984_r == [1/1,8/7,21/16,512/343,12/7,96/49] -- -- > import Music.Theory.List -- > d_dx polansky_1984_r == [1/7,19/112,989/5488,76/343,12/49] polansky_1984_r :: [Rational] polansky_1984_r = let vi = 12/7 v = 128/147 * vi i' = 21/16 * v in [1,8/7,21/16,v,vi,i'] -- | 'ratio_to_cents' of 'polansky_1984_r'. -- -- > import Music.Theory.List -- > map round (d_dx polansky_1984_c) == [231,240,223,240,231] polansky_1984_c :: [Cents] polansky_1984_c = map ratio_to_cents polansky_1984_r hmt-0.15/Music/Theory/Tuning/Werckmeister.hs0000644000000000000000000000602012416136065017215 0ustar0000000000000000-- | Andreas Werckmeister (1645-1706). module Music.Theory.Tuning.Werckmeister where import Music.Theory.Tuning {- hmt -} -- | Approximate ratios for 'werckmeister_iii'. -- -- > let c = [0,90,192,294,390,498,588,696,792,888,996,1092] -- > in map (round . ratio_to_cents) werckmeister_iii_ar == c werckmeister_iii_ar :: [Approximate_Ratio] werckmeister_iii_ar = let c0 = 2 ** (1/2) c1 = 2 ** (1/4) c2 = 8 ** (1/4) in [1,256/243 ,64/81 * c0,32/27 ,256/243 * c1 ,4/3,1024/729 ,8/9 * c2,128/81 ,1024/729 * c1,16/9 ,128/81 * c1] -- | Cents for 'werckmeister_iii'. werckmeister_iii_ar_c :: [Cents] werckmeister_iii_ar_c = map approximate_ratio_to_cents werckmeister_iii_ar -- | Werckmeister III, Andreas Werckmeister (1645-1706) -- -- > cents_i werckmeister_iii == [0,90,192,294,390,498,588,696,792,888,996,1092] werckmeister_iii :: Tuning werckmeister_iii = Tuning (Right werckmeister_iii_ar_c) 2 -- | Approximate ratios for 'werckmeister_iv'. -- -- > let c = [0,82,196,294,392,498,588,694,784,890,1004,1086] -- > in map (round . ratio_to_cents) werckmeister_iv_ar == c werckmeister_iv_ar :: [Approximate_Ratio] werckmeister_iv_ar = let c0 = 2 ** (1/3) c1 = 4 ** (1/3) in [1,16384/19683 * c0 ,8/9 * c0,32/27 ,64/81 * c1 ,4/3,1024/729 ,32/27 * c0,8192/6561 * c0 ,256/243 * c1,9/(4*c0) ,4096/2187] -- | Cents for 'werckmeister_iv'. werckmeister_iv_c :: [Cents] werckmeister_iv_c = map approximate_ratio_to_cents werckmeister_iv_ar -- | Werckmeister IV, Andreas Werckmeister (1645-1706) -- -- > cents_i werckmeister_iv == [0,82,196,294,392,498,588,694,784,890,1004,1086] werckmeister_iv :: Tuning werckmeister_iv = Tuning (Right werckmeister_iv_c) 2 -- | Approximate ratios for 'werckmeister_v'. -- -- > let c = [0,96,204,300,396,504,600,702,792,900,1002,1098] -- > in map (round . ratio_to_cents) werckmeister_v_ar == c werckmeister_v_ar :: [Approximate_Ratio] werckmeister_v_ar = let c0 = 2 ** (1/4) c1 = 2 ** (1/2) c2 = 8 ** (1/4) in [1,8/9 * c0 ,9/8,c0 ,8/9 * c1 ,9/8 * c0,c1 ,3/2,128/81 ,c2,3/c2 ,4/3 * c1] -- | Cents for 'werckmeister_v'. werckmeister_v_c :: [Cents] werckmeister_v_c = map approximate_ratio_to_cents werckmeister_v_ar -- | Werckmeister V, Andreas Werckmeister (1645-1706) -- -- > cents_i werckmeister_v == [0,96,204,300,396,504,600,702,792,900,1002,1098] werckmeister_v :: Tuning werckmeister_v = Tuning (Right werckmeister_v_c) 2 -- | Ratios for 'werckmeister_vi'. -- -- > let c = [0,91,196,298,395,498,595,698,793,893,1000,1097] -- > in map (round . ratio_to_cents) werckmeister_vi_r == c werckmeister_vi_r :: [Rational] werckmeister_vi_r = [1,98/93 ,28/25,196/165 ,49/39 ,4/3,196/139 ,196/131,49/31 ,196/117,98/55 ,49/26] -- | Werckmeister VI, Andreas Werckmeister (1645-1706) -- -- > cents_i werckmeister_vi == [0,91,196,298,395,498,595,698,793,893,1000,1097] werckmeister_vi :: Tuning werckmeister_vi = Tuning (Left werckmeister_vi_r) 2 hmt-0.15/Music/Theory/Tuning/Meyer_1929.hs0000644000000000000000000000733012416136065016323 0ustar0000000000000000-- | Max Meyer. \"The musician's arithmetic: drill problems for an -- introduction to the scientific study of musical composition.\" The -- University of Missouri, 1929. p.22 module Music.Theory.Tuning.Meyer_1929 where import Data.List import Data.Ratio import qualified Music.Theory.Tuning as T -- | Odd numbers to /n/. -- -- > odd_to 7 == [1,3,5,7] odd_to :: (Num t, Enum t) => t -> [t] odd_to n = [1,3 .. n] -- | Generate initial row for /n/. -- -- > row 7 == [1,5/4,3/2,7/4] row :: Integral i => i -> [Ratio i] row = sort . map T.fold_ratio_to_octave . odd_to . (% 1) -- | Generate initial column for /n/. -- -- > column 7 == [1,8/5,4/3,8/7] column :: Integral i => i -> [Ratio i] column = map (T.fold_ratio_to_octave . recip) . row -- | 'T.fold_to_octave' '.' '*'. in_oct_mul :: Integral i => Ratio i -> Ratio i -> Ratio i in_oct_mul i j = T.fold_ratio_to_octave (i * j) -- | Given /row/ and /column/ generate matrix value at /(i,j)/. -- -- > inner (row 7,column 7) (1,2) == 6/5 inner :: Integral i => ([Ratio i],[Ratio i]) -> (i,i) -> Ratio i inner (r,c) (i,j) = in_oct_mul (r `genericIndex` j) (c `genericIndex` i) meyer_table_rck :: Integral i => i -> ([Ratio i],[Ratio i],i) meyer_table_rck n = let r = row n c = column n k = n `div` 2 in (r,c,k) -- | Meyer table in form /(r,c,n)/. -- -- > meyer_table_indices 7 == [(0,0,1/1),(0,1,5/4),(0,2,3/2),(0,3,7/4) -- > ,(1,0,8/5),(1,1,1/1),(1,2,6/5),(1,3,7/5) -- > ,(2,0,4/3),(2,1,5/3),(2,2,1/1),(2,3,7/6) -- > ,(3,0,8/7),(3,1,10/7),(3,2,12/7),(3,3,1/1)] meyer_table_indices :: Integral i => i -> [(i,i,Ratio i)] meyer_table_indices n = let (r,c,k) = meyer_table_rck n in [(i,j,inner (r,c) (i,j)) | i <- [0..k], j <- [0..k]] -- | Meyer table as set of rows. -- -- > meyer_table_rows 7 == [[1/1, 5/4, 3/2,7/4] -- > ,[8/5, 1/1, 6/5,7/5] -- > ,[4/3, 5/3, 1/1,7/6] -- > ,[8/7,10/7,12/7,1/1]] -- -- > let r = [[ 1/1, 9/8, 5/4, 11/8, 3/2, 13/8, 7/4, 15/8] -- > ,[16/9, 1/1, 10/9, 11/9, 4/3, 13/9, 14/9, 5/3] -- > ,[ 8/5, 9/5, 1/1, 11/10, 6/5, 13/10, 7/5, 3/2] -- > ,[16/11, 18/11, 20/11, 1/1, 12/11, 13/11, 14/11, 15/11] -- > ,[ 4/3, 3/2, 5/3, 11/6, 1/1, 13/12, 7/6, 5/4] -- > ,[16/13, 18/13, 20/13, 22/13, 24/13, 1/1, 14/13, 15/13] -- > ,[ 8/7, 9/7, 10/7, 11/7, 12/7, 13/7, 1/1, 15/14] -- > ,[16/15, 6/5, 4/3, 22/15, 8/5, 26/15, 28/15, 1/1]] -- > in meyer_table_rows 15 == r meyer_table_rows :: Integral a => a -> [[Ratio a]] meyer_table_rows n = let (r,c,k) = meyer_table_rck n rn i = [inner (r,c) (i,j) | j <- [0..k]] in map rn [0..k] -- | Third element of three-tuple. t3_3 :: (t1,t2,t3) -> t3 t3_3 (_,_,i) = i -- | Set of unique ratios in /n/ table. -- -- > elements 7 == [1,8/7,7/6,6/5,5/4,4/3,7/5,10/7,3/2,8/5,5/3,12/7,7/4] -- -- > elements 9 == [1,10/9,9/8,8/7,7/6,6/5,5/4,9/7,4/3,7/5,10/7 -- > ,3/2,14/9,8/5,5/3,12/7,7/4,16/9,9/5] elements :: Integral i => i -> [Ratio i] elements = nub . sort . concat . meyer_table_rows -- | Number of unique elements at /n/ table. -- -- > map degree [7,9,11,13,15] == [13,19,29,41,49] degree :: Integral i => i -> i degree = genericLength . elements -- | -- -- > let r = [[0,1/2,1] -- > ,[0,1/3,1/2,2/3,1] -- > ,[0,1/4,1/3,1/2,2/3,3/4,1] -- > ,[0,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,1] -- > ,[0,1/6,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,5/6,1]] -- > in map farey_sequence [2..6] == r farey_sequence :: Integral a => a -> [Ratio a] farey_sequence k = 0 : nub (sort [n%d | d <- [1..k], n <- [1..d]]) hmt-0.15/Music/Theory/Tuning/Polansky_1978.hs0000644000000000000000000000217012416136065017043 0ustar0000000000000000-- | Larry Polansky. \"Psaltery (for Lou Harrison)\". Frog Peak Music, -- 1978. module Music.Theory.Tuning.Polansky_1978 where import Data.List import qualified Music.Theory.Tuning as T -- | Three interlocking harmonic series on 1:5:3, by Larry Polansky in -- \"Psaltery\". -- -- > import qualified Music.Theory.Tuning.Scala as T -- > let fn = "/home/rohan/opt/scala/scl/polansky_ps.scl" -- > s <- T.load fn -- > T.scale_pitch_representations s == (0,50) -- > 1 : Data.Either.rights (T.scale_pitches s) == psaltery psaltery :: [Rational] psaltery = [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,5/4,5/2,15/4,5,25/4,15/2,35/4,10,45/4,25/2,55/4,15,65/4,35/2,75/4,20,85/4,3/2,3,9/2,6,15/2,9,21/2,12,27/2,15,33/2,18,39/2,21,45/2,24,51/2] -- | 'T.fold_ratio_to_octave' of 'psaltery'. -- -- > length psaltery == 51 && length psaltery_o == 21 -- > psaltery_o == [1,65/64,33/32,17/16,35/32,9/8,75/64,39/32 -- > ,5/4,21/16,85/64,11/8,45/32 -- > ,3/2,25/16,51/32,13/8,27/16,55/32,7/4,15/8] psaltery_o :: [Rational] psaltery_o = nub (sort (map T.fold_ratio_to_octave psaltery)) -- Local Variables: -- truncate-lines:t -- End: hmt-0.15/Music/Theory/Set/0000755000000000000000000000000012416136065013506 5ustar0000000000000000hmt-0.15/Music/Theory/Set/Set.hs0000644000000000000000000000064412416136065014601 0ustar0000000000000000-- | Set operations on 'Set's. module Music.Theory.Set.Set where import qualified Data.Set as S {- containers -} import qualified Music.Theory.Set.List as L set :: (Ord a) => [a] -> S.Set a set = S.fromList -- > powerset (set [1,2]) powerset :: Ord a => S.Set a -> S.Set (S.Set a) powerset = S.fromList . map S.fromList . L.powerset . S.elems pairs :: Ord a => S.Set a -> S.Set (a,a) pairs = set . L.pairs . S.elems hmt-0.15/Music/Theory/Set/List.hs0000644000000000000000000000407612416136065014764 0ustar0000000000000000-- | Set operations on lists. module Music.Theory.Set.List where import Control.Monad import Data.List import qualified Math.Combinatorics.Multiset as M {- multiset-comb -} -- | Remove duplicate elements with 'nub' and then 'sort'. -- -- > set_l [3,3,3,2,2,1] == [1,2,3] set :: (Ord a) => [a] -> [a] set = sort . nub -- | Size of powerset of set of cardinality /n/, ie. @2@ '^' /n/. -- -- > map n_powerset [6..9] == [64,128,256,512] n_powerset :: Integral n => n -> n n_powerset = (^) 2 -- | Powerset, ie. set of all subsets. -- -- > sort (powerset [1,2]) == [[],[1],[1,2],[2]] -- > map length (map (\n -> powerset [1..n]) [6..9]) == [64,128,256,512] powerset :: [a] -> [[a]] powerset = filterM (const [True,False]) -- | Two element subsets. -- -- > pairs [1,2,3] == [(1,2),(1,3),(2,3)] pairs :: [a] -> [(a,a)] pairs s = case s of [] -> [] x:s' -> [(x,y) | y <- s'] ++ pairs s' -- | Three element subsets. -- -- > triples [1..4] == [(1,2,3),(1,2,4),(1,3,4),(2,3,4)] -- -- > let f n = genericLength (triples [1..n]) == nk_combinations n 3 -- > in all f [1..15] triples :: [a] -> [(a,a,a)] triples s = case s of [] -> [] x:s' -> [(x,y,z) | (y,z) <- pairs s'] ++ triples s' -- | Set expansion (ie. to multiset of degree /n/). -- -- > expand_set 4 [1,2,3] == [[1,1,2,3],[1,2,2,3],[1,2,3,3]] expand_set :: (Ord a) => Int -> [a] -> [[a]] expand_set n xs = if length xs >= n then [xs] else nub (concatMap (expand_set n) [sort (y : xs) | y <- xs]) -- | All distinct multiset partitions, see 'M.partitions'. -- -- > partitions "aab" == [["aab"],["a","ab"],["b","aa"],["b","a","a"]] -- -- > partitions "abc" == [["abc"] -- > ,["bc","a"],["b","ac"],["c","ab"] -- > ,["c","b","a"]] partitions :: Eq a => [a] -> [[[a]]] partitions = map (map M.toList . M.toList) . M.partitions . M.fromListEq -- | Cartesian product of two sets. -- -- > let r = [('a',1),('a',2),('b',1),('b',2),('c',1),('c',2)] -- > in cartesian_product "abc" [1,2] == r cartesian_product :: [a] -> [b] -> [(a,b)] cartesian_product p q = [(i,j) | i <- p, j <- q] hmt-0.15/Music/Theory/Interval/0000755000000000000000000000000012416136065014537 5ustar0000000000000000hmt-0.15/Music/Theory/Interval/Name.hs0000644000000000000000000000047212416136065015756 0ustar0000000000000000-- | 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 hmt-0.15/Music/Theory/Interval/Spelling.hs0000644000000000000000000000353412416136065016655 0ustar0000000000000000-- | 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 Seventh Augmented GT 0) == Interval Unison Perfect GT 1 interval_simplify :: Interval -> Interval interval_simplify x = let (Interval ty qu d o) = x (qu',ty',o') = case (qu,ty) of (Diminished,Second) -> (Perfect,Unison,o) (Diminished,Third) -> (Major,Second,o) (Augmented,Second) -> (Minor,Third,o) (Augmented,Third) -> (Perfect,Fourth,o) (Diminished,Sixth) -> (Perfect,Fifth,o) (Diminished,Seventh) -> (Major,Sixth,o) (Augmented,Sixth) -> (Minor,Seventh,o) (Augmented,Seventh) -> (Perfect,Unison,o + 1) _ -> (qu,ty,o) in Interval ty' qu' d o' hmt-0.15/Music/Theory/Interval/Barlow_1987.hs0000644000000000000000000001450012416136065017011 0ustar0000000000000000-- | Clarence Barlow. \"Two Essays on Theory\". -- /Computer Music Journal/, 11(1):44-60, 1987. -- Translated by Henning Lohner. module Music.Theory.Interval.Barlow_1987 where import Data.List {- base -} import Data.Maybe {- base -} import Data.Numbers.Primes {- primes -} import Data.Ratio {- base -} import Text.Printf {- base -} import Music.Theory.Tuning -- | Barlow's /indigestibility/ function for prime numbers. -- -- > map barlow [1,2,3,5,7,11,13] == [0,1,8/3,32/5,72/7,200/11,288/13] barlow :: (Integral a,Fractional b) => a -> b barlow p = let p' = fromIntegral p square n = n * n in 2 * (square (p' - 1) / p') -- | Generate list of factors of /n/ from /x/. -- -- > factor primes 315 == [3,3,5,7] factor :: Integral a => [a] -> a -> [a] factor x n = case x of [] -> undefined i:x' -> if i * i > n then [n] else if rem n i == 0 then i : factor x (quot n i) else factor x' n -- | 'factor' /n/ from 'primes'. -- -- > prime_factors 315 == [3,3,5,7] prime_factors :: Integral a => a -> [a] prime_factors = factor primes -- | Collect number of occurences of each element of a sorted list. -- -- > multiplicities [1,1,1,2,2,3] == [(1,3),(2,2),(3,1)] multiplicities :: (Eq a,Integral n) => [a] -> [(a,n)] multiplicities = let f x = case x of [] -> undefined e:_ -> (e,genericLength x) in map f . group -- | 'multiplicities' '.' 'prime_factors'. -- -- > prime_factors_m 315 == [(3,2),(5,1),(7,1)] prime_factors_m :: Integral a => a -> [(a,a)] prime_factors_m = multiplicities . prime_factors -- | Merging function for 'rational_prime_factors_m'. merge :: (Ord a,Num b,Eq b) => [(a,b)] -> [(a,b)] -> [(a,b)] merge p q = case (p,q) of (_,[]) -> p ([],_) -> map (\(i,j) -> (i,-j)) q ((a,b):p',(c,d):q') -> if a < c then (a,b) : merge p' q else if a > c then (c,-d) : merge p q' else if b /= d then (a,b-d) : merge p' q' else merge p' q' -- | Collect the prime factors in a rational number given as a -- numerator/ denominator pair (n,m). Prime factors are listed in -- ascending order with their positive or negative multiplicities, -- depending on whether the prime factor occurs in the numerator or -- the denominator (after cancelling out common factors). -- -- > rational_prime_factors_m (16,15) == [(2,4),(3,-1),(5,-1)] -- > rational_prime_factors_m (10,9) == [(2,1),(3,-2),(5,1)] -- > rational_prime_factors_m (81,64) == [(2,-6),(3,4)] -- > rational_prime_factors_m (27,16) == [(2,-4),(3,3)] -- > rational_prime_factors_m (12,7) == [(2,2),(3,1),(7,-1)] rational_prime_factors_m :: Integral b => (b,b) -> [(b,b)] rational_prime_factors_m (n,m) = let n' = prime_factors_m n m' = prime_factors_m m in merge n' m' -- | Variant of 'rational_prime_factors_m' giving results in a table -- up to the /n/th prime. -- -- > rational_prime_factors_t 6 (12,7) == [2,1,0,-1,0,0] rational_prime_factors_t :: Integral b => Int -> (b,b) -> [b] rational_prime_factors_t n x = let r = rational_prime_factors_m x in map (\i -> fromMaybe 0 (lookup i r)) (take n primes) -- | Compute the disharmonicity of the interval /(p,q)/ using the -- prime valuation function /pv/. -- -- > map (disharmonicity barlow) [(9,10),(8,9)] ~= [12.733333,8.333333] disharmonicity :: (Integral a,Num b) => (a -> b) -> (a,a) -> b disharmonicity pv (p,q) = let n = rational_prime_factors_m (p,q) in sum [abs (fromIntegral j) * pv i | (i,j) <- n] -- | The reciprocal of 'disharmonicity'. -- -- > map (harmonicity barlow) [(9,10),(8,9)] ~= [0.078534,0.120000] harmonicity :: (Integral a,Fractional b) => (a -> b) -> (a,a) -> b harmonicity pv = recip . disharmonicity pv -- | Variant of 'harmonicity' with 'Ratio' input. harmonicity_r :: (Integral a,Fractional b) => (a -> b) -> Ratio a -> b harmonicity_r pv = harmonicity pv . from_rational -- | 'uncurry' ('%'). to_rational :: Integral a => (a,a) -> Ratio a to_rational = uncurry (%) -- | Make 'numerator' 'denominator' pair of /n/. from_rational :: Integral t => Ratio t -> (t, t) from_rational n = (numerator n,denominator n) -- | Set of 1. interval size (cents), 2. intervals as product of -- powers of primes, 3. frequency ratio and 4. harmonicity value. type Table_2_Row = (Double,[Integer],Rational,Double) -- | Table 2 (p.45) -- -- > length (table_2 0.06) == 24 table_2 :: Double -> [Table_2_Row] table_2 z = let g n = n <= 2 && n >= 1 r = nub (sort (filter g [p % q | p <- [1..81],q <- [1..81]])) h = map (harmonicity_r barlow) r f = (> z) . snd k (i,j) = (fratio_to_cents i,rational_prime_factors_t 6 (from_rational i),i,j) in map k (filter f (zip r h)) -- | Pretty printer for 'Table_2_Row' values. -- -- > mapM_ (putStrLn . table_2_pp) (table_2 0.06) -- -- > 0.000 | 0 0 0 0 0 0 | 1:1 | Infinity -- > 111.731 | 4 -1 -1 0 0 0 | 15:16 | 0.076531 -- > 182.404 | 1 -2 1 0 0 0 | 9:10 | 0.078534 -- > 203.910 | -3 2 0 0 0 0 | 8:9 | 0.120000 -- > 231.174 | 3 0 0 -1 0 0 | 7:8 | 0.075269 -- > 266.871 | -1 -1 0 1 0 0 | 6:7 | 0.071672 -- > 294.135 | 5 -3 0 0 0 0 | 27:32 | 0.076923 -- > 315.641 | 1 1 -1 0 0 0 | 5:6 | 0.099338 -- > 386.314 | -2 0 1 0 0 0 | 4:5 | 0.119048 -- > 407.820 | -6 4 0 0 0 0 | 64:81 | 0.060000 -- > 435.084 | 0 2 0 -1 0 0 | 7:9 | 0.064024 -- > 498.045 | 2 -1 0 0 0 0 | 3:4 | 0.214286 -- > 519.551 | -2 3 -1 0 0 0 | 20:27 | 0.060976 -- > 701.955 | -1 1 0 0 0 0 | 2:3 | 0.272727 -- > 764.916 | 1 -2 0 1 0 0 | 9:14 | 0.060172 -- > 813.686 | 3 0 -1 0 0 0 | 5:8 | 0.106383 -- > 884.359 | 0 -1 1 0 0 0 | 3:5 | 0.110294 -- > 905.865 | -4 3 0 0 0 0 | 16:27 | 0.083333 -- > 933.129 | 2 1 0 -1 0 0 | 7:12 | 0.066879 -- > 968.826 | -2 0 0 1 0 0 | 4:7 | 0.081395 -- > 996.090 | 4 -2 0 0 0 0 | 9:16 | 0.107143 -- > 1017.596 | 0 2 -1 0 0 0 | 5:9 | 0.085227 -- > 1088.269 | -3 1 1 0 0 0 | 8:15 | 0.082873 -- > 1200.000 | 1 0 0 0 0 0 | 1:2 | 1.000000 table_2_pp :: Table_2_Row -> String table_2_pp (i,j,k,l) = let i' = printf "%8.3f" i j' = unwords (map (printf "%2d") j) k' = let (p,q) = from_rational k in printf "%2d:%-2d" q p l' = printf "%1.6f" l in intercalate " | " [i',j',k',l']